Annotation of freem/src/xecline.c, revision 1.26
1.1 snw 1: /*
1.26 ! snw 2: * $Id: xecline.c,v 1.25 2025/05/18 18:15:38 snw Exp $
1.1 snw 3: * freem interpreter proper
4: *
5: *
1.4 snw 6: * Author: Serena Willis <snw@coherent-logic.com>
1.1 snw 7: * Copyright (C) 1998 MUG Deutschland
1.5 snw 8: * Copyright (C) 2020, 2025 Coherent Logic Development LLC
1.1 snw 9: *
10: *
11: * This file is part of FreeM.
12: *
13: * FreeM is free software: you can redistribute it and/or modify
14: * it under the terms of the GNU Affero Public License as published by
15: * the Free Software Foundation, either version 3 of the License, or
16: * (at your option) any later version.
17: *
18: * FreeM is distributed in the hope that it will be useful,
19: * but WITHOUT ANY WARRANTY; without even the implied warranty of
20: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21: * GNU Affero Public License for more details.
22: *
23: * You should have received a copy of the GNU Affero Public License
24: * along with FreeM. If not, see <https://www.gnu.org/licenses/>.
25: *
1.6 snw 26: * $Log: xecline.c,v $
1.26 ! snw 27: * Revision 1.25 2025/05/18 18:15:38 snw
! 28: * Add ZEDIT command for editing routines
! 29: *
1.25 snw 30: * Revision 1.24 2025/05/14 12:22:04 snw
31: * Further work on shared memory
32: *
1.24 snw 33: * Revision 1.23 2025/05/06 16:10:06 snw
34: * Add extra blank before readline call on NetBSD
35: *
1.23 snw 36: * Revision 1.22 2025/05/05 14:53:17 snw
37: * Modify rpm spec to include documentation TODO
38: *
1.22 snw 39: * Revision 1.21 2025/05/01 17:02:30 snw
40: * Further debugging improvements
41: *
1.21 snw 42: * Revision 1.20 2025/04/30 17:19:16 snw
43: * Improve backtraces in debugger
44: *
1.20 snw 45: * Revision 1.19 2025/04/30 14:41:03 snw
46: * Further debugger work
47: *
1.19 snw 48: * Revision 1.18 2025/04/29 18:46:17 snw
49: * Begin work on interactive debugger
50: *
1.18 snw 51: * Revision 1.17 2025/04/28 19:38:55 snw
52: * Add trace mode
53: *
1.17 snw 54: * Revision 1.16 2025/04/28 14:52:54 snw
55: * Temporarily revert global handler refactor and fix reference regression in xecline
56: *
1.16 snw 57: * Revision 1.15 2025/04/15 16:49:36 snw
58: * Make use of logprintf throughout codebase
59: *
1.15 snw 60: * Revision 1.14 2025/04/13 04:22:43 snw
61: * Fix snprintf calls
62: *
1.14 snw 63: * Revision 1.13 2025/04/10 01:24:39 snw
64: * Remove C++ style comments
65: *
1.13 snw 66: * Revision 1.12 2025/04/09 19:52:02 snw
67: * Eliminate as many warnings as possible while building with -Wall
68: *
1.12 snw 69: * Revision 1.11 2025/04/02 03:02:42 snw
70: * Stop requiring users to pass -e to fmadm when -u or -g are passed
71: *
1.11 snw 72: * Revision 1.10 2025/03/27 03:27:35 snw
73: * Install init scripts to share/freem/examples/init and fix regression in method dispatch
74: *
1.10 snw 75: * Revision 1.9 2025/03/24 04:13:12 snw
76: * Replace action macro dat with fra_dat to avoid symbol conflict on OS/2
77: *
1.9 snw 78: * Revision 1.8 2025/03/24 04:05:36 snw
79: * Replace crlf with frm_crlf to avoid symbol conflict with readline on OS/2
80: *
1.8 snw 81: * Revision 1.7 2025/03/22 22:52:24 snw
82: * Add STRLEN_GBL macro to manage global string length
83: *
1.7 snw 84: * Revision 1.6 2025/03/22 21:44:32 snw
85: * Make the startup messages fewer and add environment name to direct-mode prompt
86: *
1.6 snw 87: * Revision 1.5 2025/03/09 19:50:47 snw
88: * Second phase of REUSE compliance and header reformat
89: *
1.5 snw 90: *
91: * SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
92: * SPDX-License-Identifier: AGPL-3.0-or-later
1.1 snw 93: **/
94:
95: #include <stdlib.h>
96:
97: #include "mpsdef.h"
98: #include "namespace.h"
99: #include "transact.h"
100: #include "merge.h"
101: #include "sighnd.h"
102: #include "init.h"
103: #include "events.h"
104: #include "mdebug.h"
105: #include "freem.h"
106: #include "mref.h"
107: #include "log.h"
108: #include "consttbl.h"
109: #include "shmmgr.h"
110: #include "locktab.h"
111: #include "jobtab.h"
112: #include "config.h"
113: #include "datatypes.h"
114: #include "objects.h"
115: #include "mcommand.h"
116:
117: #if defined(__linux__)
118: # include <sched.h>
119: #endif
120:
121: #if !defined(MSDOS)
122: # include "io_socket.h"
123: #endif
124:
125: #include "merr.h"
126:
127: #include <errno.h>
128: #include <unistd.h>
129: #include <string.h>
130:
131: #if !defined(MSDOS)
132: # include <syslog.h>
133: #endif
134:
135: #include <stdio.h>
136: #include <ctype.h>
137:
138: #include <time.h>
139: #include <sys/types.h>
140: #include <pwd.h>
141: #if !defined(__OpenBSD__) && !defined(__FreeBSD__)
142: # include <sys/timeb.h>
143: #endif
144: #include <sys/wait.h>
145: #include <sys/time.h>
146: #include <time.h>
147:
148: #ifdef HAVE_LIBREADLINE
149: # if defined(HAVE_READLINE_READLINE_H)
150: # include <readline/readline.h>
151: # elif defined(HAVE_READLINE_H)
152: # include <readline.h>
153: # else /* !defined(HAVE_READLINE_H) */
154: extern char *readline ();
155: # endif /* !defined(HAVE_READLINE_H) */
156: /*char *cmdline = NULL;*/
157: #else /* !defined(HAVE_READLINE_READLINE_H) */
158: /* no readline */
159: #endif /* HAVE_LIBREADLINE */
160:
161: #ifdef HAVE_READLINE_HISTORY
162: # if defined(HAVE_READLINE_HISTORY_H)
163: # include <readline/history.h>
164: # elif defined(HAVE_HISTORY_H)
165: # include <history.h>
166: # else /* !defined(HAVE_HISTORY_H) */
167: extern void add_history ();
168: extern int write_history ();
169: extern int read_history ();
170: # endif /* defined(HAVE_READLINE_HISTORY_H) */
171: /* no history */
172: #endif /* HAVE_READLINE_HISTORY */
173:
174: #include "mwapi_window.h"
175: #include "mwapi_event.h"
176:
177:
178: void on_frame_entry(void);
179: void rbuf_dump(void);
180: short rbuf_slot_from_name(char *);
181: short is_standard(void);
182:
183: /*
184: * xecline():
185: * typ (where to go on function entry): 1 = restart
186: * 2 = error
187: *
188: */
189: int xecline(int typ)
190: {
191: MACTION ra;
192: short new_and_set = FALSE;
193: short new_object = FALSE;
194: short destructor_run = FALSE;
195: short libcall = FALSE;
196: char *namold;
197: long rouoldc;
198: unsigned long jobtime;
199: char label[256], routine[256];
200:
1.17 snw 201: char tracestr[512];
202:
1.1 snw 203: char *vn;
204: char *an;
205: char *tmp;
206: char *tmp2;
207: char *tmp3;
208:
209:
210: char *deferrable_codptr;
211: char deferrable_code[512];
212:
213: char *ev_handlers;
214:
215: char *reeval_codptr;
216: char reeval_code[512];
1.21 snw 217: char entryref[256];
1.1 snw 218:
219: int i;
220: int j;
221: register int ch;
222:
223: int then_ctr = 0;
224:
225: #if defined(HAVE_MWAPI_MOTIF)
226: int syn_event_entry_nstx = 0;
227: int in_syn_event_loop = FALSE;
228: #endif
229:
230: # ifdef DEBUG_NEWSTACK
231: int loop;
232: # endif
233:
234: vn = (char *) malloc ((STRLEN + 1) * sizeof (char));
235: an = (char *) malloc ((STRLEN + 1) * sizeof (char));
236: tmp = (char *) malloc ((STRLEN + 1) * sizeof (char));
237: tmp2 = (char *) malloc ((STRLEN + 1) * sizeof (char));
238: tmp3 = (char *) malloc ((STRLEN + 1) * sizeof (char));
239:
240: NULLPTRCHK(vn,"xecline");
241: NULLPTRCHK(an,"xecline");
242: NULLPTRCHK(tmp,"xecline");
243: NULLPTRCHK(tmp2,"xecline");
244: NULLPTRCHK(tmp3,"xecline");
245:
246: deferrable_codptr = deferrable_code;
247:
248: switch (typ) {
249:
250: case 0:
251: goto next_line;
252:
253: case 1:
254: goto restart;
255:
256: case 2:
257: goto err;
258:
259: case 3:
260: libcall = TRUE;
261: goto restart;
262:
263: }
264:
265: next_line: /* entry point for next command line */
266:
1.18 snw 267: if (debug_mode) {
1.21 snw 268: debug_mode = debugger (DEBENTRY_LINE, entryref);
1.18 snw 269: }
1.24 snw 270:
1.1 snw 271: job_set_status (pid, JSTAT_INTERPRETER);
272:
273: if (then_ctr > 0) {
274: test = nestlt[nstx];
275: level--;
276: then_ctr--;
277: }
278:
279: while ((roucur < rouend) && (ch = (*roucur++)) != TAB && ch != SP); /* skip label */
280:
281: if (roucur >= rouend) goto quit0; /* end of routine implies QUIT */
282:
283: while ((ch = *roucur) == TAB || ch == SP) roucur++;
284:
285: i = 0;
286: if (ch == '.') { /* get level count */
287:
288: do {
289: i++;
290: while ((ch = (*++roucur)) == SP || ch == TAB);
291: }
292: while (ch == '.');
293:
294: }
295:
296: if (i != level) {
297:
298: if (mcmnd == GOTO) {
299: merr_raise (M45);
300: goto err;
301: }
302:
303: if (i < level) {
304: goto quit0;
305: }
306: else {
307: roucur += stlen (roucur) + 2;
308: goto next_line;
309: }
310: }
311:
312: i = stcpy (code, roucur) + 1;
313: code[i] = EOL;
314: roucur += i + 1;
315: codptr = code;
316:
317: next_cmnd: /* continue line entry point */
1.21 snw 318: getraddress (entryref, nstx);
1.19 snw 319: if (debug_mode) {
1.21 snw 320: debug_mode = debugger (DEBENTRY_CMD, entryref);
1.19 snw 321: }
322:
1.1 snw 323: if (sigint_in_for) goto for_quit;
324:
325: if (forsw && (forpost[forx][0] != '\0')) {
326:
327: stcpy (reeval_code, code);
328: reeval_codptr = codptr;
329:
330: strcpy (code, forpost[forx]);
331: stcnv_c2m (code);
332: codptr = code;
333:
334: expr (STRING);
335:
336: if (merr () > OK) {
337: stcpy (code, reeval_code);
338: codptr = reeval_codptr;
339:
340: goto err;
341: }
342:
343: if (tvexpr (argptr) == FALSE) {
344: stcpy (code, reeval_code);
345: codptr = reeval_codptr;
346:
347: goto for_quit;
348: }
349:
350: stcpy (code, reeval_code);
351: codptr = reeval_codptr;
352:
353: }
354:
355: job_set_status (pid, JSTAT_INTERPRETER);
356:
357: if (evt_async_enabled == TRUE) {
358:
359: switch (pending_signal_type) {
360:
361: case SIGWINCH:
362: evt_enqueue ("SIGWINCH", EVT_CLS_INTERRUPT, 1);
363: break;
364:
365: case SIGINT:
366: evt_enqueue ("SIGINT", EVT_CLS_INTERRUPT, 0);
367: break;
368:
369: case SIGFPE:
370: evt_enqueue ("SIGFPE", EVT_CLS_INTERRUPT, 0);
371: break;
372:
373: case SIGQUIT:
374: evt_enqueue ("SIGQUIT", EVT_CLS_INTERRUPT, 0);
375: break;
376:
377: }
378:
379: pending_signal_type = -1;
380:
381: /* process async events */
382: ev_handlers = (char *) malloc (STRLEN * sizeof (char));
383: NULLPTRCHK(ev_handlers,"xecline");
384:
385:
386: /* get a comma-delimited list of applicable handlers (e.g. ^HNDL1,^HNDL2,^HNDL3) */
387: ev_handlers[0] = NUL;
388: evt_depth = evt_get_handlers (ev_handlers);
389:
390: stcnv_c2m (ev_handlers);
391: stcpy (tmp3, ev_handlers);
392: free (ev_handlers);
393:
394: /* only execute event handlers if we have at least one such handler registered in ^$JOB($JOB,"EVENTS") */
395: if (evt_depth) {
396:
397: /* per X11-1998/28, async events are to be disabled during the execution of event handlers */
398:
399: /* TODO: this should be done by incrementing the event block counter
400: for all event types, or whatever the event extension says to do.
401:
402: In any event (rimshot here for the obvious pun), turning off all
403: event handlers this way is decidedly non-standard. Or non-what-might-
404: become the standard. Whatever. */
405:
406: evt_async_enabled = FALSE;
407: evt_async_initial = TRUE;
408: evt_async_restore = TRUE;
409:
410: goto evthandler;
411:
412: }
413:
414: }
415:
416:
417: if (merr () > OK) goto err;
418:
419: next0:
420:
421: do {
422: if ((ch = *codptr) == EOL) {
423: if (forsw) goto for_end;
424:
425: goto next_line;
426: }
427:
428: codptr++;
429: }
430: while (ch == SP);
431:
432: /* decode command word */
433:
434: if (ch < 'A') { /* Handle non-alpha first chars */
435:
436: if (ch == ';') { /* COMMENT */
437:
438: ch = *(codptr++);
439:
440: if(ch == '%') { /* DIRECTIVE */
441:
442: int dir_pos = 0;
443: int dir_wc = 0;
444: char dir_words[20][255];
445:
446: while((ch = *(codptr++)) != EOL) {
447:
448: switch (ch) {
449:
450:
451: case SP:
452:
453: dir_words[dir_wc][dir_pos] = NUL;
454:
455: dir_wc++;
456: dir_pos = 0;
457:
458: break;
459:
460:
461: default:
462:
463: dir_words[dir_wc][dir_pos++] = ch;
464:
465: }
466:
467: }
468:
469: dir_words[dir_wc][dir_pos] = NUL;
470:
471: if (strcmp (dir_words[0], "DIALECT") == 0) {
472: short rb_slot;
473:
474: rb_slot = rbuf_slot_from_name (rou_name);
475:
476: if ((strcmp (dir_words[1], "STANDARD") == 0) ||
477: (strcmp (dir_words[1], "MDS") == 0)) {
478: rbuf_flags[rb_slot].standard = TRUE;
479: rbuf_flags[rb_slot].dialect = D_MDS;
480: }
481: else if (strcmp (dir_words[1], "M77") == 0) {
482: rbuf_flags[rb_slot].standard = TRUE;
483: rbuf_flags[rb_slot].dialect = D_M77;
484: }
485: else if (strcmp (dir_words[1], "M84") == 0) {
486: rbuf_flags[rb_slot].standard = TRUE;
487: rbuf_flags[rb_slot].dialect = D_M84;
488: }
489: else if (strcmp (dir_words[1], "M90") == 0) {
490: rbuf_flags[rb_slot].standard = TRUE;
491: rbuf_flags[rb_slot].dialect = D_M90;
492: }
493: else if (strcmp (dir_words[1], "M95") == 0) {
494: rbuf_flags[rb_slot].standard = TRUE;
495: rbuf_flags[rb_slot].dialect = D_M95;
496: }
497: else if (strcmp (dir_words[1], "M5") == 0) {
498: rbuf_flags[rb_slot].standard = TRUE;
499: rbuf_flags[rb_slot].dialect = D_M5;
500: }
501: else if ((strcmp (dir_words[1], "FREEM") == 0) ||
502: (strcmp (dir_words[1], "EXTENDED") == 0)) {
503: rbuf_flags[rb_slot].standard = FALSE;
504: rbuf_flags[rb_slot].dialect = D_FREEM;
505: }
506: else {
507: merr_raise (CMMND);
508: goto err;
509: }
510: goto skip_line;
511: }
512: else {
513: goto skip_line;
514: }
515:
516: }
517:
518: goto skip_line;
519: }
520:
521: if ((!is_standard ()) && (ch == '#')) {
522: goto skip_line;
523: }
524:
525: if ((is_standard ()) && (ch == '#')) {
526: merr_raise (NOSTAND);
527: goto err;
528: }
529:
530: if (ch == '@') {
531: if (!is_standard ()) {
532: goto do_xecute;
533: }
534: else {
535: merr_raise (NOSTAND);
536: goto err;
537: }
538: }
539:
540: if (ch == '!') { /* UNIXCALL */
541:
542: if (restricted_mode) {
543: merr_raise (NOSTAND);
544: goto err;
545: }
546:
547: /* don't catch child dies signal */
548: sig_attach (SIGUSR1, SIG_IGN);
549:
550: tmp2[stcpy (tmp2, codptr)] = NUL;
551:
552: if (demomode) fputc (d1char, stdout);
553:
554: if (tmp2[0] == '!') {
555:
556: uid_t suid;
557: struct passwd *spw;
558:
559: suid = geteuid ();
560: spw = getpwuid (suid);
561:
562: set_io (UNIX);
563:
564: fprintf (stderr, "Type Ctrl-D to exit from the shell\n");
565:
566: if (strlen (spw->pw_shell)) {
567: zsystem = system (spw->pw_shell);
568: }
569: else {
570: zsystem = system ("/bin/sh");
571: }
572:
573: set_io (MUMPS);
574: sig_attach (SIGUSR1, &oncld); /* restore handler */
575:
576: }
577: else if (tmp2[0] == '<') { /* call write output to %-array */
578:
579: FILE *pipdes;
1.14 snw 580: char key[STRLEN];
581: char data[STRLEN];
1.1 snw 582: char data_kill[256];
583: data_kill[255] = EOL;
584:
1.14 snw 585: for (i = 0; i < STRLEN - 1; i++) vn[i] = EOL;
1.1 snw 586:
1.14 snw 587: snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid);
1.1 snw 588: ssvn (get_sym, key, vn);
589:
590: if (vn[0] == '^') {
591:
592: if (vn[1] == '$') {
593: merr_raise (INVREF);
594: goto err;
595: }
596: else {
597: global (kill_sym, vn, data_kill);
598: }
599:
600: }
601: else {
602: symtab (kill_sym, vn, data);
603: }
604:
1.14 snw 605: snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid);
1.1 snw 606: ssvn (get_sym, key, vn);
607:
608: data[0] = '0';
609: data[1] = EOL;
610:
611: if (vn[0] == '^') {
612:
613: if (vn[1] == '$') {
614: merr_raise (INVREF);
615: goto err;
616: }
617: else {
618: global (set_sym, vn, data);
619: }
620:
621: }
622: else {
623: symtab (set_sym, vn, data);
624: }
625:
626: set_io (UNIX);
627: if ((pipdes = popen (&tmp2[1], "r")) == NULL) {
628: zsystem = 1;
629: }
630: else {
631: int glvn_len = 0;
632:
633: while (fgets (data, STRLEN, pipdes)) {
1.14 snw 634: snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid);
1.1 snw 635: ssvn (get_sym, key, vn);
636:
637: glvn_len = stlen (vn);
638: stcpy (key, vn);
639:
640: key[glvn_len] = DELIM;
641:
642: if (vn[0] == '^') {
643:
644: if (vn[1] == '$') {
645: merr_raise (INVREF);
646: goto err;
647: }
648: else {
649: global (getinc, vn, &key[glvn_len + 1]);
650: }
651:
652: }
653: else {
654: symtab (getinc, vn, &key[glvn_len + 1]);
655: }
656:
657: i = strlen (data);
658:
659: data[i] = EOL;
660:
661: if (i > 1 && data[i - 1] == LF) data[i - 1] = EOL;
662:
663: if (vn[0] == '^') {
664:
665: if (vn[1] == '$') {
666: merr_raise (INVREF);
667: goto err;
668: }
669: else {
670: global (set_sym, key, data);
671: }
672:
673: }
674: else {
675: symtab (set_sym, key, data);
676: }
677:
678: if (merr () == STORE) break;
679: }
680:
681: pclose (pipdes);
682:
683: zsystem = 0;
684: }
685: set_io (MUMPS);
686: }
687: else if (tmp2[0] == '>') { /* call read input from %-array */
688: FILE *pipdes;
689: char key[STRLEN + 1 /*was 256 */ ];
690: char data[STRLEN + 1 /*was 256 */ ];
691: int i, k, l;
692:
693: for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL;
694:
1.14 snw 695: snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid);
1.1 snw 696: ssvn (get_sym, key, vn);
697:
698: if (vn[0] == '^') {
699:
700: if (vn[1] == '$') {
701: merr_raise (INVREF);
702: goto err;
703: }
704: else {
705: global (get_sym, vn, data);
706: }
707:
708: }
709: else {
710: symtab (get_sym, vn, data);
711: }
712:
713: merr_clear ();
714: k = intexpr (data);
715:
716: set_io (UNIX);
717: if (k < 1 || (pipdes = popen (&tmp2[1], "w")) == NULL) {
718: zsystem = 1;
719: }
720: else {
721: int glvn_len = 0;
722:
723: for (i = 1; i <= k; i++) {
1.14 snw 724: snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid);
1.1 snw 725: ssvn (get_sym, key, vn);
726:
727: glvn_len = stlen (vn);
728: stcpy (key, vn);
729:
730: key[glvn_len] = DELIM;
731:
732: intstr (&key[glvn_len + 1], i);
733:
734: if (vn[0] == '^') {
735:
736: if (vn[1] == '$') {
737: merr_raise (INVREF);
738: goto err;
739: }
740: else {
741: global (get_sym, key, data);
742: }
743:
744: }
745: else {
746: symtab (get_sym, key, data);
747: }
748:
749: l = stlen (data);
750:
751: data[l++] = LF;
752: data[l] = NUL;
753:
754: fputs (data, pipdes);
755: }
756:
757: pclose (pipdes);
758:
759: zsystem = 0;
760: merr_clear ();
761: }
762: set_io (MUMPS);
763:
764: }
765: else {
766: set_io (UNIX);
767: zsystem = system (tmp2);
768: set_io (MUMPS);
769: }
770:
771: if (demomode) fputc (d1char, stdout);
772:
773: sig_attach (SIGUSR1, &oncld); /* restore handler */
774:
775:
776: if (merr () == STORE) {
777: zsystem = 1;
778: goto err;
779: }
780:
781: goto skip_line;
782: }
783:
784: merr_raise (CMMND);
785: goto err;
786: } /* END handling of non-alpha first chars */
787:
788:
789: mcmnd = ch | 0140; /* uppercase to lower case */
790:
791: i = 1;
792:
793: while ((ch = (*codptr)) != SP && ch != ':' && ch != EOL) {
794: tmp3[++i] = ch | 0140;
795: codptr++;
796: }
797:
798: j = i;
799:
800: if (j > 1) {
801: merr_raise (mcmd_tokenize (&ra, tmp3, deferrable_codptr, deferrable_code, &j));
802: MRESCHECK(ra);
803: }
804:
805:
806: if (*codptr == ':') {
807: /* handle postconditional */
808:
809: if (mcmnd == FOR) {
810: char *savcp = codptr;
811:
812: codptr++;
813: i = 0;
814: while ((forpost[forx + 1][i++] = *(codptr++)) != SP);
815:
816: forpost[forx + 1][i - 1] = '\0';
817:
818: codptr = savcp;
819: }
820:
821:
822: /* postcond after FOR,IF,ELSE not allowed in dialects other than D_FREEM */
823:
824:
825: if ((rtn_dialect () != D_FREEM) && (mcmnd == FOR || mcmnd == IF || mcmnd == ELSE)) {
826: merr_raise (NOSTAND);
827: goto err;
828: }
829:
830: codptr++;
831:
832: expr (STRING);
833:
834: if (merr () > OK) goto err;
835:
836: ch = *codptr;
837:
838: if (ch != SP && ch != EOL) {
839: merr_raise (SPACER);
840: goto err;
841: }
842:
843: if (tvexpr (argptr) == FALSE) { /* skip arguments */
844:
845: if ((mcmnd == IF) || (mcmnd == THEN) || (mcmnd == ELSE) || (mcmnd == FOR)) {
846: mcmnd = 0;
847: goto skip_line;
848: }
849:
850: mcmnd = 0; /* avoid false LEVEL error */
851:
852: for (;;) {
853: if (ch == EOL) goto skip_line;
854: if ((ch = *++codptr) == SP) goto next_cmnd;
855: if (ch != '"') continue;
856:
857: while (*codptr++ != EOL) {
858: if (*codptr != ch) continue;
859: if (*++codptr != ch) break;
860: }
861:
862: if (--codptr == code) goto err;
863: }
864: }
865:
866: }
867:
868: if (*codptr != EOL) { /* beware argumentless cmnds at end of line */
869: codptr++; /* entry for next argument in list */
870:
871: again:
872: while (*codptr == '@') { /* handle indirection */
873:
874: stcpy (tmp, codptr++); /* save code to restore on nameind */
875: expr (ARGIND);
876:
877: if (merr () > OK) goto err;
878:
879: if (((ch = (*codptr)) != SP && ch != EOL && ch != ',' && ch != ':' && ch != '=') || (ch == '@' && *(codptr + 1) == '(')) {
880: stcpy (code, tmp); /* restore code on nameind */
881: codptr = code;
882:
883: break;
884: }
885: else {
886: stcpy (argptr + stlen (argptr), codptr);
887: stcpy (code, argptr);
888:
889: codptr = code;
890: }
891: }
892: }
893:
1.17 snw 894: if (trace_mode) tracestr[0] = '\0';
895:
1.1 snw 896: switch (mcmnd) {
897:
898: case MAP:
899: merr_raise (cmd_map (&ra));
900: MRESCHECK(ra);
901: break;
902:
903: case UNMAP:
904: merr_raise (cmd_unmap (&ra));
905: MRESCHECK(ra);
906: break;
907:
908: case THEN:
909: merr_raise (cmd_then (&ra, &then_ctr));
910: MRESCHECK(ra);
911: break;
912:
913: case THROW:
914: merr_raise (cmd_throw (&ra));
915: MRESCHECK(ra);
916: break;
917:
918: case CONST:
919: merr_raise (cmd_const (&ra));
920: MRESCHECK(ra);
921: break;
922:
923: case KVALUE:
924: merr_raise (cmd_kvalue (&ra));
925: MRESCHECK(ra);
926: break;
927:
928: case KSUBSC:
929: merr_raise (cmd_ksubscripts (&ra));
930: MRESCHECK(ra);
931: break;
932:
933: case TSTART:
934: merr_raise (cmd_tstart (&ra));
935: MRESCHECK(ra);
936: break;
937:
938: case TCOMMIT:
939: merr_raise (cmd_tcommit (&ra));
940: MRESCHECK(ra);
941: break;
942:
943: case TROLLBACK:
944: merr_raise (cmd_trollback (&ra));
945: MRESCHECK(ra);
946: break;
947:
948: case SET:
949:
950: set0:
951: if ((ch = (*codptr)) >= 'A') { /* no set$piece nor multiset */
952: short setref = FALSE;
953: short stclass = SC_UNCHANGED;
954:
955: expr (NAME);
956: if (merr () > OK) break;
957: stcpy (vn, varnam);
958:
959: if (isalpha (vn[0]) && *(codptr + 1) == ':') {
960: char sc_string[255];
1.12 snw 961:
1.1 snw 962: codptr += 2;
963: expr (NAME);
964:
965: stcpy (sc_string, varnam);
966: for (i = 0; i < stlen (sc_string); i++) {
967: sc_string[i] = toupper (sc_string[i]);
968: }
969:
970: stcnv_m2c (sc_string);
971: if (strcmp (sc_string, "PRIVATE") == 0) {
972: stclass = SC_PRIVATE;
973: }
974: else if (strcmp (sc_string, "PUBLIC") == 0) {
975: stclass = SC_PUBLIC;
976: }
977: else {
978: merr_raise (OBJACINVALID);
979: break;
980: }
981: }
982:
983: if ((*++codptr != '=') || (*(codptr + 1) == '=')) {
984: ch = *codptr;
985:
986: /* double char symbol ** (power) is encoded by ' ' */
987: if (ch == '*' && *(codptr + 1) == ch) {
988: codptr++;
989: ch = ' ';
990: }
991:
992: /* negated boolean operator */
993: else if ((ch == '\'') && (*(codptr + 2) == '=')) ch = SETBIT (*++codptr);
994:
995: if (*++codptr != '=') {
996:
1.13 snw 997: /* unary ++/-- */
1.1 snw 998: if ((ch == '+' || ch == '-') && ch == *codptr) {
999: codptr++;
1000: setop = ch;
1001: argptr[0] = '1';
1002: argptr[1] = EOL;
1003:
1004: goto set2;
1005: }
1006:
1007: merr_raise (ASSIGNER);
1008: break;
1009: }
1010:
1011: setop = ch;
1012: }
1013:
1014: codptr++;
1015:
1016: ch = *codptr;
1017:
1.16 snw 1018: if (ch == '.') {
1019: if (!isdigit (*(codptr + 1))) {
1020: setref = TRUE;
1021: codptr++;
1022: expr (NAME);
1023: }
1024: else {
1025: expr (STRING);
1026: }
1.1 snw 1027: }
1028: else {
1029: expr (STRING);
1030: }
1031:
1032:
1033: if (merr () > OK) break;
1034:
1035:
1036: set2:
1037:
1038: if (vn[0] == '^') {
1039:
1040: stcpy (an, argptr);
1041:
1042: if (setref == TRUE) {
1043: merr_raise (INVREF);
1044: goto err;
1045: }
1046:
1047: if (vn[1] == '$') {
1048: ssvn (set_sym, vn, an);
1049: }
1050: else {
1051: global (set_sym, vn, an);
1052: }
1053:
1054: }
1055: else {
1056: stcpy (an, argptr);
1057:
1058: if (setref == TRUE) {
1059: symtab (new_sym, vn, "");
1060: symtab (m_alias, vn, varnam);
1061: codptr++;
1062: }
1063: else {
1064: if (new_object == FALSE) {
1065: symtab (set_sym, vn, an);
1066: switch (stclass) {
1067:
1068: case SC_PUBLIC:
1069: obj_set_field_public (vn);
1070: break;
1071:
1072: case SC_PRIVATE:
1073: obj_set_field_private (vn);
1074: break;
1075:
1076: }
1077: }
1078: }
1079: }
1080:
1081: if (merr () > OK) {
1082: stcpy (varerr, vn);
1083: break;
1084: }
1085:
1086: if (((new_and_set == TRUE) || (new_object == TRUE)) && (*codptr != SP) && (*codptr != EOL)) {
1087: new_and_set = FALSE;
1088: new_object = FALSE;
1089:
1090: merr_raise (INEWMUL);
1091: goto err;
1092: }
1093:
1094: if (new_and_set == TRUE) new_and_set = FALSE;
1095: if (new_object == TRUE) new_object = FALSE;
1.12 snw 1096: /*
1.1 snw 1097: set1:
1.12 snw 1098: */
1.1 snw 1099: if (*codptr != ',') break;
1100:
1101: if (*++codptr == '@') goto again;
1102:
1103: goto set0;
1104: }
1105:
1106: /****** special SET syntax: multiple SET, set$piece, special variables */
1107: {
1108: char multiset, vnset[256]; /* multiset variables */
1109: long arg3, arg4; /* 3rd,4th arg in set$piece */
1110:
1111: if ((multiset = (ch == '('))) {
1112: vnset[0] = EOL;
1113: codptr++;
1114: }
1115:
1116: set:
1117: if (*codptr == '$' && (*(codptr + 1) | 0140) == 'p') { /* set$piece */
1118:
1119: if (multiset) {
1120: merr_raise (INVREF);
1121: goto err;
1122: }
1123:
1124: setpiece = 'p';
1125:
1126: while (*++codptr != '(') {
1127:
1128: if (*codptr == EOL) {
1129: merr_raise (INVREF);
1130: goto err;
1131: }
1132:
1133: }
1134:
1135: codptr++;
1136:
1137: expr (NAME);
1138:
1139: if (merr () > OK) goto err;
1140:
1141: stcpy (vn, varnam);
1142:
1143: codptr++;
1144:
1145: if (*codptr++ != ',') {
1146: merr_raise (COMMAER);
1147: goto err;
1148: }
1149:
1.7 snw 1150: expr (STRING);
1151:
1.1 snw 1152: if (merr () > OK) goto err;
1153:
1154: stcpy (tmp2, argptr);
1155:
1156: if (*codptr != ')') {
1157:
1158: codptr++;
1159:
1160: expr (STRING);
1161:
1162: if (merr () > OK) goto err;
1163:
1164: arg3 = intexpr (argptr);
1165:
1166: if (merr () == MXNUM) {
1167: arg3 = 256;
1168: merr_clear ();
1169: }
1170:
1171: }
1172: else {
1173: arg3 = 1;
1174: }
1175:
1176: if (*codptr != ')') {
1177:
1178: codptr++;
1179:
1180: expr (STRING);
1181:
1182: if (merr () > OK) goto err;
1183:
1184: if (*codptr != ')') {
1185: merr_raise (BRAER);
1186: goto err;
1187: }
1188:
1189: arg4 = intexpr (argptr);
1190:
1191: if (merr () == MXNUM) {
1192: arg4 = 256;
1193: merr_clear ();
1194: }
1195:
1196: }
1197: else {
1198: arg4 = arg3;
1199: }
1200: } /* set$piece */
1201: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'q' && (*(codptr + 2) | 0140) == 's') { /* TODO: verify this works (jpw) was (*codptr == '$q'...*/
1202: /*SET $QSUBSCRIPT */
1203:
1204: if (multiset) {
1205: merr_raise (INVREF);
1206: goto err;
1207: }
1208:
1209: setpiece = 'q';
1210:
1211: while (*++codptr != '(') {
1212:
1213: if (*codptr == EOL) {
1214: merr_raise (INVREF);
1215: goto err;
1216: }
1217:
1218: }
1219:
1220: codptr++;
1221:
1222: expr (NAME);
1223:
1224: if (merr () > OK) goto err;
1225:
1226: stcpy (vn, varnam);
1227:
1228: if (*++codptr == ',') {
1229: codptr++;
1230:
1231: expr (STRING);
1232:
1233: if (merr () > OK) goto err;
1234:
1235: stcpy (tmp2, argptr);
1236: }
1237:
1238: if (*codptr != ')') {
1239: merr_raise (BRAER);
1240: goto err;
1241: }
1242:
1243: }
1244: else if (*codptr == '$' &&
1245: (*(codptr + 1) | 0140) == 'd' &&
1246: (*(codptr + 2) | 0140) == 'i') {
1247:
1248: short rb_slot;
1249:
1250: rb_slot = rbuf_slot_from_name (rou_name);
1251:
1252: while ((*(++codptr)) != '=');
1253:
1254: codptr++;
1255:
1256: expr (STRING);
1257:
1258: stcnv_m2c (argptr);
1259:
1260: if ((strcmp (argptr, "STANDARD") == 0) ||
1261: (strcmp (argptr, "MDS") == 0)) {
1262: rbuf_flags[rb_slot].standard = TRUE;
1263: rbuf_flags[rb_slot].dialect = D_MDS;
1264: }
1265: else if (strcmp (argptr, "M77") == 0) {
1266: rbuf_flags[rb_slot].standard = TRUE;
1267: rbuf_flags[rb_slot].dialect = D_M77;
1268: }
1269: else if (strcmp (argptr, "M84") == 0) {
1270: rbuf_flags[rb_slot].standard = TRUE;
1271: rbuf_flags[rb_slot].dialect = D_M84;
1272: }
1273: else if (strcmp (argptr, "M90") == 0) {
1274: rbuf_flags[rb_slot].standard = TRUE;
1275: rbuf_flags[rb_slot].dialect = D_M90;
1276: }
1277: else if (strcmp (argptr, "M95") == 0) {
1278: rbuf_flags[rb_slot].standard = TRUE;
1279: rbuf_flags[rb_slot].dialect = D_M95;
1280: }
1281: else if (strcmp (argptr, "M5") == 0) {
1282: rbuf_flags[rb_slot].standard = TRUE;
1283: rbuf_flags[rb_slot].dialect = D_M5;
1284: }
1285: else if ((strcmp (argptr, "FREEM") == 0) ||
1286: (strcmp (argptr, "EXTENDED") == 0)) {
1287: rbuf_flags[rb_slot].standard = TRUE;
1288: rbuf_flags[rb_slot].dialect = D_FREEM;
1289: }
1290: else {
1291: merr_raise (CMMND);
1292: goto err;
1293: }
1294:
1295: goto s_end;
1296:
1297: }
1298: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) != 't' && (*(codptr + 2) | 0140) != 'c') {
1299:
1300: /* set $extract */
1301: if (multiset) {
1302: merr_raise (INVREF);
1303: goto err;
1304: }
1305:
1306: setpiece = 'e';
1307:
1308: while (*++codptr != '(') {
1309:
1310: if (*codptr == EOL) {
1311: merr_raise (INVREF);
1312: goto err;
1313: }
1314:
1315: }
1316:
1317: codptr++;
1318:
1319: expr (NAME);
1320:
1321: if (merr () > OK) goto err;
1322:
1323: stcpy (vn, varnam);
1324:
1325: codptr++;
1326:
1327: if (*codptr != ')') {
1328: codptr++;
1329:
1330: expr (STRING);
1331:
1332: if (merr () > OK) goto err;
1333:
1334: arg3 = intexpr (argptr);
1335:
1336: if (merr () == MXNUM) {
1337: arg3 = 256;
1338: merr_clear ();
1339: }
1340: }
1341: else {
1342: arg3 = 1;
1343: }
1344:
1345: if (*codptr != ')') {
1346: codptr++;
1347:
1348: expr (STRING);
1349:
1350: if (merr () > OK) goto err;
1351:
1352: if (*codptr != ')') {
1353: merr_raise (BRAER);
1354: goto err;
1355: }
1356:
1357: arg4 = intexpr (argptr);
1358:
1359: if (merr () == MXNUM) {
1360: arg4 = 256;
1361: merr_clear ();
1362: }
1363:
1364: }
1365: else {
1366: arg4 = arg3;
1367: }
1368:
1369: }
1370: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) == 'c') {
1371: /* set $ecode */
1372:
1373: if (multiset) {
1374: merr_raise (INVREF);
1375: goto err;
1376: }
1377:
1378: while ((*(++codptr)) != '=');
1379:
1380: codptr++;
1381:
1382: expr (STRING);
1383:
1384: if (merr () > OK) goto err;
1385:
1386: switch (argptr[0]) {
1387:
1388: case ',':
1389:
1390: switch (argptr[1]) {
1391:
1392: case ',':
1393: merr_raise (M101);
1394: goto err;
1395:
1396: }
1397:
1398: break;
1399:
1400: }
1401:
1402: merr_raise (merr_set_ecode (argptr));
1403:
1404: #if 0
1405: set_io (UNIX);
1406: stcnv_m2c (ecode);
1407: stcnv_m2c (etrap);
1408: printf ("\n\n*** IN SET $ECODE: ecode = '%s' etrap = '%s'\n", ecode, etrap);
1409: stcnv_c2m (etrap);
1410: stcnv_c2m (ecode);
1411: set_io (MUMPS);
1412: #endif
1413:
1414: if (merr () > OK) goto err;
1415:
1416: goto s_end;
1417:
1418: }
1419: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) == 't') {
1420: /* set $etrap */
1421:
1422: if (multiset) {
1423: merr_raise (INVREF);
1424: goto err;
1425: }
1426:
1427: while ((*(++codptr)) != '=');
1428:
1429: codptr++;
1430:
1431: expr (STRING);
1432:
1433: if (merr () > OK) goto err;
1434:
1435: stcpy (etrap, argptr);
1436:
1437: #if 0
1438: set_io (UNIX);
1439: stcnv_m2c (ecode);
1440: stcnv_m2c (etrap);
1441: printf ("\n\n***IN SET $ETRAP: ecode = '%s' etrap = '%s'\n", ecode, etrap);
1442: stcnv_c2m (etrap);
1443: stcnv_c2m (ecode);
1444: set_io (MUMPS);
1445: #endif
1446:
1447: goto s_end;
1448:
1449: }
1450: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'g' && cset) { /* set$get */
1451:
1452: if (multiset) {
1453: merr_raise (INVREF);
1454: goto err;
1455: }
1456:
1457: setpiece = 'g';
1458:
1459: while (*++codptr != '(') {
1460:
1461: if (*codptr == EOL) {
1462: merr_raise (INVREF);
1463: goto err;
1464: }
1465: }
1466:
1467: codptr++;
1468:
1469: expr (NAME);
1470:
1471: if (merr () > OK) goto err;
1472:
1473: stcpy (vn, varnam);
1474:
1475: if (*++codptr == ',') {
1476: codptr++;
1477:
1478: expr (STRING);
1479:
1480: if (merr () > OK) goto err;
1481:
1482: stcpy (tmp2, argptr);
1483: }
1484: else {
1485: tmp2[0] = EOL;
1486: }
1487:
1488: if (*codptr != ')') {
1489: merr_raise (BRAER);
1490: goto err;
1491: }
1492: }
1493: else {
1494: if (*codptr == '$') {
1495: codptr++;
1496:
1497: expr (NAME);
1498:
1499: if (merr () > OK) goto err;
1500:
1501: stcpy (tmp, varnam);
1502:
1503: varnam[0] = '$';
1504:
1505: stcpy (&varnam[1], tmp);
1506:
1507: i = 0;
1508: while ((ch = varnam[++i]) != EOL) {
1509: if (ch >= 'A' && ch <= 'Z') {
1510: varnam[i] |= 0140; /*to lowercase */
1511: }
1512: }
1513: }
1514: else {
1515: expr (NAME);
1516:
1517: if (merr () > OK) goto err;
1518: }
1519:
1520: stcpy (vn, varnam);
1521: }
1522:
1523: if (multiset) {
1524: vnset[i = stlen (vnset)] = SOH;
1525:
1526: stcpy (&vnset[++i], vn);
1527:
1528: if (*++codptr == ',') {
1529: codptr++;
1530: goto set;
1531: }
1532:
1533: if (*codptr != ')') {
1534: merr_raise (COMMAER);
1535: goto err;
1536: }
1537: }
1538:
1539: if (*++codptr != '=') {
1540: ch = *codptr;
1541:
1542: if (!cset || *++codptr != '=' || multiset || setpiece || varnam[0] == '$') {
1543: merr_raise (ASSIGNER);
1544: break;
1545: }
1546:
1547: setop = ch;
1548: }
1549:
1550: codptr++;
1551:
1552: expr (STRING);
1553:
1554: if (merr () > OK) goto err;
1555:
1556: if (multiset)
1557: multi:
1558: {
1559: i = 0;
1560: while (vnset[i] == SOH) i++;
1561:
1562: j = 0;
1563: while ((vn[j] = vnset[i]) != SOH && vnset[i] != EOL) {
1564: vnset[i++] = SOH;
1565: j++;
1566: }
1567:
1568: vn[j] = EOL;
1569:
1570: if (j == 0) goto s_end;
1571: }
1572:
1573: if (setpiece == 'p') {
1574: long m, n;
1575:
1576: if (arg4 < arg3 || arg4 < 1) {
1577: setpiece = FALSE;
1578: break;
1579: }
1580:
1581: if (arg3 <= 0) arg3 = 1;
1582:
1583: if (vn[0] == '^') {
1584: if (vn[1] == '$') {
1585: ssvn (get_sym, vn, tmp3);
1586: }
1587: else {
1588: global (get_sym, vn, tmp3);
1589: }
1590: }
1591: else {
1592: symtab (get_sym, vn, tmp3);
1593: }
1594:
1595:
1596: if (merr () == UNDEF || merr () == M6 || merr () == M7) {
1597: tmp3[0] = EOL;
1598: merr_clear ();
1599: }
1600: else if (merr () != OK) {
1601: stcpy (varerr, vn);
1602: }
1603:
1604: ch = 0;
1605: m = 0;
1606: n = 0;
1607:
1608: j = stlen (tmp2);
1609:
1610: while (n < arg3 - 1) {
1611:
1612: if ((ch = find (&tmp3[m], tmp2)) <= 0) {
1613:
1614: while (++n < arg3) {
1615: if (stcat (tmp3, tmp2) == 0) {
1616: merr_raise (M75);
1617: goto err;
1618: }
1619: }
1620:
1621: arg3 = arg4 = stlen (tmp3);
1622:
1623: goto set10;
1624: }
1625:
1626: n++;
1627: m += j + ch - 1;
1628: }
1629:
1630: if (arg3 > 1) {
1631: arg3 = m;
1632: }
1633: else {
1634: arg3 = 0;
1635: }
1636:
1637: while (n++ < arg4) {
1638:
1639: if ((ch = find (&tmp3[m], tmp2)) <= 0) {
1640: arg4 = stlen (tmp3);
1641:
1642: goto set10;
1643: }
1644:
1645: m += j + ch - 1;
1646: }
1647:
1648: arg4 = m - j;
1649:
1650: set10:
1651:
1652: stcpy0 (tmp2, tmp3, (long) arg3);
1653:
1654: tmp2[arg3] = EOL;
1655:
1656: if (stcat (tmp2, argptr) == 0) {
1657: merr_raise (M75);
1658: goto err;
1659: }
1660:
1661: if (stcat (tmp2, &tmp3[arg4]) == 0) {
1.13 snw 1662: merr_raise (M56); /* snw */
1.1 snw 1663: goto err;
1664: }
1665:
1666: stcpy (argptr, tmp2);
1667:
1668: setpiece = FALSE;
1669: }
1670: else if (setpiece == 'q') { /* SET$QSUBSCRIPT */
1671:
1672: setpiece = FALSE;
1673:
1674: if (vn[0] == '^') {
1675: if (vn[1] == '$') {
1676: ssvn (get_sym, vn, tmp3);
1677: }
1678: else {
1679: global (get_sym, vn, tmp3);
1680: }
1681: }
1682: else {
1683: symtab (get_sym, vn, tmp3);
1684: }
1685:
1686: if (merr () == UNDEF || merr () == M6 || merr () == M7) {
1687: tmp3[0] = EOL;
1688: merr_clear ();
1689: }
1690: else if (merr () != OK) {
1691: stcpy (varerr, vn);
1692: }
1693:
1694: if (merr () == OK) {
1695: /* 2nd $QS argument */
1696: if ((arg4 = intexpr (tmp2)) < -1) merr_raise (ARGER);
1697: if (merr () != OK) break;
1698:
1699: /* special if source is empty */
1700: if (tmp3[0] != EOL || (arg4 != 0)) {
1701: /* special: Set env to empty: no |""| */
1702: if ((arg4 == -1) && (*argptr == EOL)) {
1703: tmp2[0] = EOL;
1704: }
1705: else if ((arg4 != 0) && !znamenumeric (argptr)) {
1706: /* put replacement string in tmp2 with */
1707: /* quotes around env or subscript, unless numeric */
1708: i = 0;
1709: j = -1;
1710: tmp2[0] = '"';
1711:
1712: while ((tmp2[++i] = argptr[++j]) != EOL) {
1713: if (tmp2[i] == '"') tmp2[++i] = '"';
1714:
1715: if (i >= (STRLEN - 2)) {
1716: merr_raise (M75);
1717: break;
1718: }
1719: }
1720:
1721: tmp2[i] = '"';
1722: tmp2[++i] = EOL;
1723: }
1724: else {
1725: stcpy (tmp2, argptr);
1726: }
1727:
1728: /* source is tmp3, dest is argptr, replacement is tmp2 */
1729: {
1730: int ch, cpflag, quote, piececounter;
1731:
1732: piececounter = 0;
1733: i = 0;
1734: j = 0;
1735: quote = FALSE;
1736: cpflag = FALSE;
1737:
1738: /* if source has no env, process right now */
1739: if ((arg4 == -1) && (tmp3[tmp3[0] == '^'] != '|') && tmp2[0] != EOL) {
1740:
1741: if (tmp3[0] == '^') {
1742: argptr[j++] = '^';
1743: i = 1;
1744: }
1745:
1746: argptr[j++] = '|';
1747: ch = 0;
1748:
1749: while ((argptr[j] = tmp2[ch++]) != EOL) j++;
1750:
1751: argptr[j++] = '|';
1752:
1753: }
1754: else if (arg4 == 0) { /* '^'+name may be separated by env */
1755: if (tmp2[0] == '^') argptr[j++] = '^';
1756: if (tmp3[0] == '^') i++;
1757: }
1758:
1759: while ((ch = tmp3[i++]) != EOL) {
1760: if (ch == '"') quote = !quote;
1761:
1762: if (!quote) {
1763:
1764: if (ch == ',') {
1765: piececounter++;
1766: argptr[j++] = ch;
1767:
1768: continue;
1769: }
1770:
1771: if ((ch == '(' && piececounter == 0)) {
1772: if (!cpflag && (arg4 == 0)) {
1773: i--;
1774: }
1775: else {
1776: piececounter = 1;
1777: argptr[j++] = ch;
1778:
1779: continue;
1780: }
1781: }
1782:
1783: if (ch == '|') {
1784: if (piececounter == 0) {
1785: piececounter = (-1);
1786: }
1787: else if (piececounter == (-1)) {
1788: piececounter = 0;
1789: }
1790:
1791: if (tmp2[0] != EOL || piececounter > 0) argptr[j++] = ch;
1792:
1793: continue;
1794: }
1795: }
1796:
1797: if (piececounter == arg4) {
1798: if (cpflag) continue;
1799:
1800: cpflag = TRUE;
1801: ch = 0;
1802:
1803: if (arg4 == 0 && tmp2[0] == '^') ch = 1;
1804:
1805: while ((argptr[j] = tmp2[ch++]) != EOL) j++;
1806: }
1807: else {
1808: argptr[j++] = ch;
1809: }
1810:
1811: if (j >= (STRLEN - 1)) {
1812: merr_raise (M75);
1813: break;
1814: }
1815: } /* while ((ch = tmp3[i++]) != EOL) ... */
1816:
1817: if (piececounter && (piececounter == arg4)) argptr[j++] = ')';
1818:
1819: if (piececounter < arg4) {
1820:
1821: if (piececounter == 0) {
1822: argptr[j++] = '(';
1823: }
1824: else {
1825: argptr[j - 1] = ',';
1826: }
1827:
1828: while (++piececounter < arg4) {
1829: argptr[j++] = '"';
1830: argptr[j++] = '"';
1831: argptr[j++] = ',';
1832:
1833: if (j >= STRLEN) {
1834: merr_raise (M75);
1835: break;
1836: }
1837:
1838: }
1839: }
1840:
1841: ch = 0;
1842:
1843: if (argptr[j - 1] != ')') {
1844: while ((argptr[j++] = tmp2[ch++]) != EOL);
1845: argptr[j - 1] = ')';
1846: }
1847: }
1848:
1849: argptr[j] = EOL;
1850:
1851: if (j >= STRLEN) {
1852: merr_raise (M75);
1853: break;
1854: }
1855:
1856: }
1857: }
1858: else {
1859: break;
1860: }
1861: } /* set$qsubscript */
1862: else if (setpiece == 'e') { /* SETtable $EXTRACT *//* parameters ok?? */
1863:
1864: if (arg3 > arg4 || arg4 < 1) {
1865: setpiece = FALSE;
1866: break;
1867: }
1868:
1869: if (arg3 <= 0) arg3 = 1;
1870:
1871: if (arg3 > STRLEN) {
1872: merr_raise (M75);
1873: goto err;
1874: }
1875:
1876: /* get value of glvn */
1877: if (vn[0] == '^') {
1878: if (vn[1] == '$') {
1879: ssvn (get_sym, vn, tmp3);
1880: }
1881: else {
1882: global (get_sym, vn, tmp3);
1883: }
1884: }
1885: else {
1886: symtab (get_sym, vn, tmp3);
1887: }
1888:
1889:
1890: /* if UNDEF assume null string */
1891: if (merr () == UNDEF || merr () == M6 || merr () == M7) {
1892: tmp3[0] = EOL;
1893: merr_clear ();
1894: }
1895: else if (merr () != OK) {
1896: stcpy (varerr, vn);
1897: }
1898:
1899: j = stlen (tmp3);
1900:
1901: /* pad with SPaces if source string is too short */
1902: while (j < arg3) tmp3[j++] = SP;
1903:
1904: tmp3[j] = EOL;
1905:
1906: if (stlen (tmp3) > arg4) {
1907: stcpy (tmp2, &tmp3[arg4]);
1908: }
1909: else {
1910: tmp2[0] = EOL;
1911: }
1912:
1913: tmp3[arg3 - 1] = EOL;
1914:
1915: /* compose new value of glvn */
1916: if (stcat (tmp3, argptr) == 0) {
1917: merr_raise (M75);
1918: goto err;
1919: }
1920:
1921: if (stcat (tmp3, tmp2) == 0) {
1922: merr_raise (M75);
1923: goto err;
1924: }
1925:
1926: stcpy (argptr, tmp3);
1927: setpiece = FALSE;
1928: }
1929: else if (setpiece == 'g') { /* SETtable $GET */
1930: setpiece = FALSE;
1931: ch = (stcmp (tmp2, argptr) == 0) ? killone : set_sym;
1932:
1933: if (vn[0] == '^') {
1934: stcpy (an, argptr);
1935: if (vn[1] == '$') {
1936: ssvn (ch, vn, an);
1937: }
1938: else {
1939: global (ch, vn, an);
1940: }
1941: }
1942: else {
1943: stcpy (an, argptr);
1944: symtab (ch, vn, an);
1945: }
1946:
1947: if (merr () != OK) stcpy (varerr, vn);
1948: break;
1949: }
1950:
1951: if (vn[0] == '^') { /* global variables and SSVNs */
1952: stcpy (an, argptr);
1953:
1954: if (vn[1] == '$') {
1955: ssvn (set_sym, vn, an);
1956: }
1957: else {
1958: global (set_sym, vn, an);
1959: }
1960:
1961:
1962: if (merr () > OK) {
1963: stcpy (varerr, vn);
1964: goto err;
1965: }
1966: }
1967: else if (vn[0] != '$') { /* local variables */
1968: stcpy (an, argptr);
1969: symtab (set_sym, vn, an);
1970:
1971: if (merr () > OK) {
1972: stcpy (varerr, vn);
1973: goto err;
1974: }
1975: }
1976: else { /* $-variables */
1977:
1978: if (vn[1] == 'x') { /* set $X */
1979: j = intexpr (argptr);
1980:
1981: if (merr () == MXNUM) {
1982: j = 256;
1983: merr_clear ();
1984: }
1985:
1986: if (j < 0) {
1987: merr_raise (M43);
1988: goto err;
1989: }
1990:
1991: if (io == HOME) {
1992: argptr[0] = ESC;
1993: argptr[1] = '[';
1994: argptr[2] = EOL;
1995:
1996: if (ypos[HOME] > 1) {
1997: intstr (tmp3, ypos[HOME] + 1);
1998: stcat (argptr, tmp3);
1999: }
2000:
2001: if (j > 0) {
2002: stcat (argptr, ";\201");
2003: intstr (tmp3, j + 1);
2004: stcat (argptr, tmp3);
2005: }
2006:
2007: stcat (argptr, "H\201");
2008: write_m (argptr);
2009: }
2010:
2011: xpos[io] = j;
2012: goto s_end;
2013: }
2014: else if (vn[1] == 'y') { /* set $Y */
2015:
2016: j = intexpr (argptr);
2017:
2018: if (merr () == MXNUM) {
2019: j = 256;
2020: merr_clear ();
2021: }
2022:
2023: if (j < 0) {
2024: merr_raise (M43);
2025: goto err;
2026: }
2027:
2028: if (io == HOME) {
2029:
2030: argptr[0] = ESC;
2031: argptr[1] = '[';
2032: argptr[2] = EOL;
2033:
2034: if (j > 0) {
2035: intstr (tmp3, j + 1);
2036: stcat (argptr, tmp3);
2037: }
2038:
2039: if (xpos[HOME] > 0) {
2040: stcat (argptr, ";\201");
2041: intstr (tmp3, xpos[HOME] + 1);
2042: stcat (argptr, tmp3);
2043: }
2044:
2045: stcat (argptr, "H\201");
2046: write_m (argptr);
2047: }
2048:
2049: ypos[io] = j;
2050: goto s_end;
2051: }
2052: else if (vn[1] == 't') { /* set $t */
2053: test = tvexpr (argptr);
2054: goto s_end;
2055: }
2056: else if (vn[1] == 'j') { /* set $job */
2057: pid = intexpr (argptr);
2058: lock (" \201", -1, 's');
2059: goto s_end;
2060: }
2061: #if !defined(_SCO_DS)
2062: else if (vn[1] == 'h') { /* set $horolog */
2063: long int day;
2064: long int sec;
2065: struct timespec sh_ts;
2066:
2067: if (!is_horolog (argptr)) {
2068: merr_raise (ZINVHORO);
2069: goto err;
2070: }
2071:
2072: sec = 0L;
2073:
2074: for (i = 0; argptr[i] != EOL; i++) {
2075:
2076: if (argptr[i] == ',') {
2077: sec = intexpr (&argptr[i + 1]);
2078: break;
2079: }
2080:
2081: }
2082:
2083: if (sec < 0 || sec >= 86400L) {
2084: merr_raise (ARGER);
2085: goto err;
2086: }
2087:
2088: day = intexpr (argptr) - 47117L;
2089:
2090: if (day < 0 || day > 49710L) {
2091: merr_raise (ARGER);
2092: goto err;
2093: }
2094:
1.3 snw 2095: sec += day * 86400 + FreeM_timezone;
2096: day = FreeM_timezone;
1.1 snw 2097:
2098: sh_ts.tv_sec = sec;
2099:
2100: #if defined(__linux__)
2101: if (clock_settime (CLOCK_REALTIME, &sh_ts) != 0) {
2102: merr_raise (PROTECT);
2103: goto err;
2104: }
2105: #endif
2106:
2107: #ifndef LINUX
2108: /* daylight savings time status may have changed */
2109: {
2110: struct tm *ctdata;
2111: long clock;
2112:
2113: clock = time (0L);
2114: ctdata = localtime (&clock);
2115:
1.3 snw 2116: if (day -= (FreeM_timezone = ctdata->tm_tzadj)) {
1.1 snw 2117: sec -= day;
2118: tzoffset += day;
2119: stime (&sec);
2120: }
2121: }
2122: #endif /* LINUX */
2123: goto s_end;
2124:
2125:
2126: }
2127: #endif /* _SCO_DS */
2128: else if ((vn[1] == 'r') || ((vn[1] == 'z') && (vn[2] == 'r') && vn[3] == EOL)) { /* set $reference */
2129:
2130: if (argptr[0] == EOL) {
2131: zref[0] = EOL;
2132: break;
2133: }
2134:
2135: stcpy (tmp4, codptr);
2136: stcpy (code, argptr);
2137:
2138: codptr = code;
2139:
2140: expr (NAME);
2141: stcpy (code, tmp4);
2142:
2143: codptr = code;
2144:
2145: if (argptr[0] != '^') merr_raise (INVREF);
2146: if (ierr <= OK) nakoffs = stcpy (zref, argptr); /* save reference */ /* SMW - TODO */
2147:
2148: goto s_end;
2149: }
2150: else if (vn[1] == 'z') { /* $Z.. variables *//* if not intrinsic: make it user defined */
2151:
2152: i = stcpy (&tmp[1], &vn[1]) + 1;
2153:
2154: if (vn[3] == DELIM) i = 3; /* set $zf() function keys */
2155:
2156: tmp[0] = SP;
2157: tmp[i] = SP;
2158: tmp[++i] = EOL;
2159:
2160: if (find (zsvn, tmp) == FALSE) {
2161:
2162: i = 2;
2163: while (vn[i] != EOL) {
2164:
2165: if (vn[i++] == DELIM) {
2166: merr_raise (INVREF);
2167: goto err;
2168: }
2169:
2170: }
2171:
2172: udfsvn (set_sym, &vn[2], argptr);
2173: break;
2174: }
2175:
2176: if ((!stcmp (&vn[2], "l\201")) || (!stcmp (&vn[2], "local\201"))) { /* set $zlocal */
2177:
2178: if (argptr[0] == EOL) {
2179: zloc[0] = EOL;
2180: break;
2181: }
2182:
2183: stcpy (tmp4, codptr);
2184: stcpy (code, argptr);
2185:
2186: codptr = code;
2187:
2188: expr (NAME);
2189: stcpy (code, tmp4);
2190:
2191: codptr = code;
2192:
2193: if (argptr[0] == '^') merr_raise (INVREF);
2194: if (ierr <= OK) stcpy (zloc, argptr); /* save reference */
2195:
2196: break;
2197: }
2198: if ((!stcmp (&vn[2], "t\201")) || (!stcmp (&vn[2], "tr\201")) || (!stcmp (&vn[2], "trap\201"))) { /* set $ztrap */
2199:
2200: if (stlen (argptr) > ZTLEN) {
2201: merr_raise (M75);
2202: goto err;
2203: }
2204:
2205: /* DSM V.2 error trapping */
2206: #ifdef DEBUG_NEWSTACK
2207: printf ("Setting Ztrap, DSM2err [%d]\r\n", DSM2err);
2208: #endif
2209:
2210:
2211: if (DSM2err) {
2212: stcpy (ztrap[NESTLEVLS + 1], argptr);
2213: }
2214: else {
2215: stcpy (ztrap[nstx], argptr);
2216: }
2217:
2218: }
2219: else if (!stcmp (&vn[2], "p\201") || !stcmp (&vn[2], "precision\201")) { /* set $zprecision */
2220:
2221: short tmp_zprecise;
2222:
2223: if ((tmp_zprecise = intexpr (argptr)) < 0) {
2224: merr_raise (MXNUM);
2225: goto err;
2226: }
2227:
2228: if (!fp_mode) {
2229:
2230: if (merr () == MXNUM) goto err;
2231:
2232: if (tmp_zprecise > 20000) {
2233: merr_raise (MXNUM);
2234: goto err;
2235: }
2236:
2237: }
2238: #if !defined(_AIX)
2239: else {
2240:
2241: if (tmp_zprecise > DBL_DIG) {
2242: merr_raise (MXNUM);
2243: goto err;
2244: }
2245:
2246: sprintf (fp_conversion, "%%.%df\201", tmp_zprecise);
2247:
2248: }
2249: #endif
2250:
2251: zprecise = tmp_zprecise;
2252:
2253:
2254: }
2255: else if (vn[2] == 'f' && vn[3] == DELIM) { /* set $zf() function keys */
2256:
2257: i = intexpr (&vn[4]) - 1;
2258:
2259: if (i < 0 || i > 43) {
2260: merr_raise (FUNARG);
2261: goto err;
2262: }
2263:
2264: if (stlen (argptr) > FUNLEN) {
2265: merr_raise (M75);
2266: goto err;
2267: }
2268:
2269: stcpy (zfunkey[i], argptr);
2270:
2271: }
2272: else if (vn[2] == 'm' && vn[4] == EOL && (vn[3] == 'c' || vn[3] == 'n' || vn[3] == 'p' || vn[3] == 'l' || vn[3] == 'u')) { /* set $zm_ loadable match; sort match code */
2273:
2274: short k;
2275:
2276: i = 0;
2277:
2278: for (ch = 0; ch <= 255; ch++) {
2279: j = argptr - partition;
2280:
2281: while ((k = partition[j++]) != EOL) {
2282:
2283: if (UNSIGN (k) == ch) {
2284: tmp[i++] = k;
2285: break;
2286: }
2287:
2288: }
2289:
2290: }
2291:
2292: tmp[i] = EOL;
2293:
2294: switch (vn[3]) {
2295:
2296: case 'c':
2297: stcpy (zmc, tmp);
2298: break;
2299:
2300: case 'n':
2301: stcpy (zmn, tmp);
2302: break;
2303:
2304: case 'p':
2305: stcpy (zmp, tmp);
2306: break;
2307: /* 'a': always union of zml+zmu */
2308:
2309: case 'l':
2310: stcpy (zml, tmp);
2311: break;
2312:
2313: case 'u':
2314: stcpy (zmu, tmp);
2315: break;
2316: /* 'e': always 'everything' */
2317: }
2318:
2319: }
2320: else {
2321: merr_raise (INVREF);
2322: break;
2323: }
2324: }
2325: else {
2326: merr_raise (INVREF);
2327: goto err;
2328: } /* end of processing for $Z.. intrinsic special variables */
2329: } /* svns=$vars */
2330:
2331: if (multiset) goto multi;
2332: } /* end of scope for special SET syntaxes */
2333:
2334: s_end:
2335: if (*codptr != ',') break;
2336: if (*++codptr == '@') goto again;
2337:
2338: goto set0;
2339:
2340: case IF:
2341: merr_raise (cmd_if (&ra));
2342: MRESCHECK(ra);
2343: break;
2344:
2345:
2346: case OO_USING:
2347: merr_raise (cmd_using (&ra));
2348: MRESCHECK(ra);
2349: break;
2350:
2351: case OO_WITH:
2352: merr_raise (cmd_with (&ra));
2353: MRESCHECK(ra);
2354: break;
2355:
2356: case WRITE:
2357: merr_raise (cmd_write(&ra, &i));
2358: MRESCHECK(ra);
2359: break;
2360:
2361: case READ:
2362: merr_raise (cmd_read (&ra));
2363: MRESCHECK(ra);
2364: break;
2365:
2366: case ELSE:
2367: merr_raise (cmd_else (&ra));
2368: MRESCHECK(ra);
2369: break;
2370:
2371: case ZQUIT:
2372:
2373: {
2374: int zq_lvlct;
2375:
2376: if (rtn_dialect () != D_FREEM) {
2377: merr_raise (NOSTAND);
2378: goto err;
2379: }
2380:
2381: if (*codptr == EOL) {
2382: zq_lvlct = nstx;
2383: }
2384: else {
2385: expr (STRING);
2386:
2387: zq_lvlct = intexpr (argptr);
2388:
2389: if (merr () > OK) goto err;
2390:
2391: if (zq_lvlct < 0 || zq_lvlct > nstx) {
2392: merr_raise (LVLERR);
2393: goto err;
2394: }
2395: else if (zq_lvlct != nstx) {
2396: repQUIT = nstx - zq_lvlct;
2397: }
2398: else {
2399: merr_raise (LVLERR);
2400: goto err;
2401: }
2402: }
2403:
2404: break;
2405: }
2406:
2407: case QUIT:
2408:
1.17 snw 2409: if (trace_mode) {
2410: fprintf (stderr, ">> TRACE: $STACK = %d QUIT CMD = %c\r\n", nstx, nestc[nstx]);
2411: }
2412:
1.1 snw 2413: if (tp_level > 0) {
2414: merr_raise (M42);
2415: goto err;
2416: }
2417:
2418: #ifdef DEBUG_NEWSTACK
2419: printf ("At QUIT command, checking stack...\r\n");
2420: #endif
2421:
2422:
2423:
2424: #ifdef DEBUG_NEWSTACK
2425: printf ("nestc[nstx] is (%d)\r\n", nestc[nstx]);
2426: #endif
2427:
2428: if (*codptr != EOL && *codptr != SP && nestc[nstx] != '$') {
2429: #ifdef DEBUG_NEWSTACK
2430: printf ("IERR\r\n");
2431: #endif
2432:
2433: merr_raise (ARGER);
2434: break;
2435: }
2436:
2437:
2438:
2439: if (nestc[nstx] == '$') { /* extrinsic function/variable */
2440:
2441:
1.17 snw 2442: if (trace_mode) {
2443: fprintf (stderr, ">> TRACE: QUIT FROM EXTRINSIC\r\n");
2444: }
2445:
1.1 snw 2446: #ifdef DEBUG_NEWSTACK
2447: printf ("EXTRINSIC\r\n");
2448: #endif
2449: if (*codptr == EOL || *codptr == SP) {
2450:
2451: #ifdef DEBUG_NEWSTACK
2452: printf ("CODPTR is [%d]\r\n", *codptr);
2453: #endif
2454:
2455: if (exfdefault[0] == EOL) {
2456: *argptr = EOL;
2457: merr_raise (NOVAL);
2458: }
2459: else { /* there is a default expression... */
2460: stcpy (&code[1], exfdefault);
2461: expr (STRING);
2462:
2463: if (ierr != OK - CTRLB && merr () != OK && merr () != INRPT) {
2464:
2465: #ifdef DEBUG_NEWSTACK
2466: printf ("Break at 1st IERR\r\n");
2467: #endif
2468: break;
2469: }
2470: }
2471: }
2472: else {
2473:
2474: expr (STRING);
1.17 snw 2475:
2476: if (trace_mode) {
2477: fprintf (stderr, ">> TRACE: QUIT FROM SUBROUTINE\r\n");
2478: }
1.1 snw 2479:
2480: if (ierr != OK - CTRLB && merr () != OK && merr () != INRPT) {
2481:
2482: #ifdef DEBUG_NEWSTACK
2483: printf ("Break at 2nd IERR\r\n");
2484: #endif
2485:
2486: break;
2487: }
2488:
2489: if (dt_check (extr_types[nstx], argptr, 0) == FALSE) {
2490: extr_types[nstx] = DT_STRING;
2491: merr_raise (TYPMISMATCH);
2492: break;
2493: }
2494:
2495:
2496: }
2497:
2498: #ifdef DEBUG_NEWSTACK
2499: printf ("CHECK 01 (Stack POP)\r\n");
2500: #endif
2501:
2502:
2503:
2504: if (nestn[nstx]) { /* reload routine */
2505: namptr = nestn[nstx];
2506:
2507: stcpy (rou_name, namptr);
2508: zload (rou_name);
2509:
2510: ssvn_job_update ();
2511:
2512: dosave[0] = 0;
2513:
2514: namptr--;
2515: }
2516:
2517: if (nestnew[nstx]) unnew (); /* un-NEW variables */
2518:
2519: /* restore old pointers */
2520: level = nestlt[nstx]; /* pop level */
2521: roucur = nestr[nstx] + rouptr;
2522:
2523: extr_types[nstx] = DT_STRING;
2524:
2525: stcpy (codptr = code, cmdptr = nestp[nstx--]);
2526: estack--;
2527:
2528: forsw = (nestc[nstx] == FOR);
2529: loadsw = TRUE;
2530:
2531: return 0;
2532:
2533:
2534: }
2535:
2536:
2537: if (nestc[nstx] == BREAK) {
2538: merr_clear ();
2539: merr_set_break ();
2540: goto zgo;
2541: } /*cont. single step */
2542:
2543:
2544: quit0:
2545:
2546: #ifdef DEBUG_NEWSTACK
2547: printf ("CHECK 02 (Stack POP)\r\n");
2548: #endif
2549:
2550: if (evt_depth) {
2551:
2552: evt_depth--;
2553:
2554: if (evt_depth == 0 && evt_async_restore == TRUE) {
2555: evt_async_enabled = TRUE;
2556: evt_async_restore = FALSE;
2557: }
2558:
2559: }
2560:
2561: if (etrap_lvl) etrap_lvl--;
2562:
2563: if (nstx == 0) goto restore; /* nothing to quit */
2564:
2565: if (nestc[nstx] == FOR) {
2566:
2567: stcpy (code, cmdptr = nestp[nstx--]);
2568:
2569: estack--;
2570:
2571: codptr = code;
2572:
2573: ftyp = fortyp[--forx];
2574: fvar = forvar[forx];
2575: finc = forinc[forx];
2576: fpost = forpost[forx];
2577: flim = forlim[forx];
2578: fi = fori[forx];
2579:
2580: if ((forsw = (nestc[nstx] == FOR))) goto for_end;
2581:
2582: goto next_line;
2583: }
2584:
2585: if (nestn[nstx]) { /* reload routine */
2586: namptr = nestn[nstx];
2587:
2588: if ((nestc[nstx] != XECUTE) || loadsw) {
2589:
2590: stcpy (rou_name, namptr);
2591: zload (rou_name);
2592:
2593: ssvn_job_update ();
2594:
2595: dosave[0] = 0;
2596: }
2597:
2598: namptr--;
2599: }
2600:
2601: if (nestnew[nstx]) unnew (); /* un-NEW variables */
2602:
2603: /* restore old pointers */
2604: if ((mcmnd = nestc[nstx]) == BREAK) goto restore; /* cont. single step */
2605:
2606: if (mcmnd == DO_BLOCK) {
2607: test = nestlt[nstx];
2608: level--;
2609: }
2610: else { /* pop $TEST */
2611: level = nestlt[nstx]; /* pop level */
2612: }
2613:
2614: if (nstx) {
2615: roucur = nestr[nstx] + rouptr;
2616: }
2617: else {
2618: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
2619: }
2620:
2621: stcpy (codptr = code, cmdptr = nestp[nstx--]);
2622: estack--;
2623: forsw = (nestc[nstx] == FOR);
2624:
2625: loadsw = TRUE;
2626:
2627: if (deferred_ierr > OK) { /* smw - TODO: how to handle deferred_ierr now */
2628: merr_raise (deferred_ierr);
2629: }
2630:
2631: #if defined(HAVE_MWAPI_MOTIF)
2632: if ((in_syn_event_loop == TRUE) && (nstx == syn_event_entry_nstx)) goto syn_evt_loop_bottom;
2633: #endif
2634:
2635: break;
2636:
2637: case FOR:
2638:
2639: if ((ch = *codptr) == EOL) goto skip_line; /* ignore empty line */
2640:
2641: #ifdef DEBUG_NEWSTACK
2642: printf ("CHECK 03 (Stack PUSH)\r\n");
2643: #endif
2644:
2645: if (++nstx > NESTLEVLS) {
2646: nstx--;
2647: merr_raise (STKOV);
2648:
2649: break;
2650: }
2651: else {
2652: estack++;
2653: }
2654:
2655: fvar = forvar[++forx];
2656: finc = forinc[forx];
2657: fpost = forpost[forx];
2658: flim = forlim[forx];
2659: fi = fori[forx];
2660: nestc[nstx] = FOR; /* stack set-up */
2661:
2662: #ifdef DEBUG_NEWSTACK
2663: if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
2664: #endif
2665:
2666: nestp[nstx] = cmdptr;
2667: nestn[nstx] = 0; /* no overring of routine */
2668: nestr[nstx] = roucur - rouptr; /* save roucur: only for $V(26) needed */
2669: ztrap[nstx][0] = EOL;
1.19 snw 2670:
1.1 snw 2671:
2672: forsw = TRUE;
2673: ftyp = 0; /* no args is FOREVER */
2674:
2675: if (ch == SP) {
2676: goto for_go;
2677: }
2678: else { /* find local variable */
2679:
2680: if (ch == '^') {
2681: merr_raise (GLOBER);
2682: break;
2683: }
2684:
2685: if (ch == '$') {
2686: merr_raise (INVREF);
2687: break;
2688: }
2689:
2690: if (*(codptr + 1) == '=') { /* single char local variable */
2691:
2692: if ((ch < 'A' && ch != '%') || (ch > 'Z' && ch < 'a') || ch > 'z') {
2693: merr_raise (INVREF);
2694: break;
2695: }
2696:
2697: fvar[0] = ch;
2698: fvar[1] = EOL;
2699:
2700: codptr += 2;
2701: }
2702: else {
2703: expr (NAME);
2704:
2705: if (*++codptr != '=') merr_raise (ASSIGNER);
2706: if (merr () != OK) break;
2707:
2708: stcpy (fvar, varnam);
2709:
2710: codptr++;
2711: }
2712:
2713: ftyp++;
2714: }
2715:
2716: for_nxt_arg:
2717:
2718: expr (STRING);
2719:
2720: if (merr () != OK) break;
2721:
2722: stcpy (tmp, argptr);
2723:
2724: if ((ch = *codptr) != ':') {
2725:
2726: if (ch == ',' || ch == SP || ch == EOL) {
2727: ftyp = 1;
2728: goto for_init;
2729: }
2730:
2731: merr_raise (ARGLIST);
2732: break;
2733: }
2734:
2735: numlit (tmp); /* numeric interpretation */
2736:
2737: codptr++;
2738: expr (STRING);
2739:
2740: if (merr () != OK) break;
2741:
2742: numlit (argptr);
2743: stcpy (finc, argptr); /* increment */
2744:
2745: if ((ch = *codptr) != ':') {
2746:
2747: if (ch == ',' || ch == EOL || ch == SP) {
2748: ftyp = 2;
2749: goto for_init;
2750: }
2751:
2752: merr_raise (ARGLIST);
2753: break;
2754:
2755: }
2756:
2757: codptr++;
2758:
2759: expr (STRING);
2760: if (merr () != OK) break;
2761:
2762: numlit (argptr);
2763: stcpy (flim, argptr); /* limit */
2764:
2765: ftyp = 3;
2766:
2767: if ((ch = *codptr) != ',' && ch != SP && ch != EOL) {
2768: merr_raise (ARGLIST);
2769: break;
2770: }
2771:
2772: if ((*finc != '-' && comp (flim, tmp)) || (*finc == '-' && comp (tmp, flim))) {
2773:
2774: symtab (set_sym, fvar, tmp);
2775:
2776: if (merr () > OK) {
2777: stcpy (varerr, vn);
2778: break;
2779: }
2780:
2781: goto for_quit;
2782: }
2783:
2784: for_init:
2785:
2786: symtab (set_sym, fvar, tmp);
2787:
2788: if (merr () > OK) {
2789: stcpy (varerr, fvar);
2790: break;
2791: }
2792:
2793: /* optimize frequent special case: */
2794: /* increment by one and no additional FOR arguments */
2795: /* if limit value it must be a positive integer */
2796: if (ftyp > 1 && finc[0] == '1' && finc[1] == EOL) {
2797: j = TRUE;
2798:
2799: if (ftyp == 3) {
2800: i = 0;
2801:
2802: while ((ch = flim[i]) != EOL) {
2803:
2804: if (ch < '0' || ch > '9') j = FALSE;
2805:
2806: i++;
2807: }
2808:
2809: fi = i;
2810: fori[forx] = i;
2811: }
2812:
2813: if (j && ((ch = *codptr) == SP || ch == EOL)) {
2814: ftyp += 2;
2815: if (ch == SP) codptr++;
2816: }
2817: }
2818:
2819: for_go:
2820:
2821: fortyp[forx] = ftyp;
2822:
2823:
2824: #ifdef DEBUG_NEWSTACK
2825: if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
2826: #endif
2827:
2828: nestp[nstx] = cmdptr;
2829:
2830: cmdptr += stcpy (cmdptr, codptr) + 1;
2831:
2832: if (ftyp > 3) goto next_cmnd;
2833:
2834: /* skip following for arguments if there are any */
2835:
2836: for10:
2837:
2838: if (*codptr == SP) goto next_cmnd;
2839:
2840: i = 0;
2841:
2842: while ((((ch = *codptr) != SP) || i) && ch != EOL) {
2843: if (ch == '"') i = !i;
2844:
2845: codptr++;
2846: } /* skip rest of FOR list */
2847:
2848: goto next_cmnd;
2849:
2850: for_end: /* end of line return */
2851:
2852: #ifdef DEBUG_NEWSTACK
2853: printf ("For_end: nstx: %d, Nestp: (%d)\r\n", nstx, nestp[nstx]);
2854: #endif
2855:
2856: stcpy (codptr = code, nestp[nstx]); /* restore old pointers */
2857:
2858:
2859:
2860: switch (ftyp) {
2861:
2862: case 5: /* frequent special case: increment 1 */
2863: symtab (getinc, fvar, tmp);
2864:
2865: /* compare fvar-value to flim-value */
2866: /* fi: i=0; while (flim[i]>='0') i++; */
2867: /* Note: EOL<'-'<'.'<'0' tmp has at least one character */
2868: ch = '0';
2869: j = 1;
2870:
2871: while (tmp[j] >= ch) j++;
2872:
2873: if (j < fi) goto next_cmnd;
2874:
2875: if (j == fi) {
2876: j = 0;
2877:
2878: while (tmp[j] == flim[j]) {
2879: if (tmp[j] == EOL) goto next_cmnd;
2880: j++;
2881: }
2882:
2883: if (tmp[j] <= flim[j]) goto next_cmnd;
2884: }
2885:
2886: if (flim[0] != '-' && tmp[0] == '-') goto next_cmnd;
2887:
2888: stcpy (tmp2, "-1\201"); /* correct last inc */
2889: add (tmp, tmp2);
2890: symtab (set_sym, fvar, tmp);
2891:
2892: goto for_quit;
2893:
2894: case 4: /* frequent special case: increment 1 without limit */
2895: symtab (getinc, fvar, tmp);
2896:
2897:
2898: case 0: /* argumentless FOR */
2899:
2900: if(argless_forsw_quit == TRUE) {
2901: /* if we have a positive QUIT condition, bail from the FOR loop */
2902: argless_forsw_quit = FALSE;
2903: goto for_quit;
2904: }
2905: else {
2906:
2907: /* otherwise, just keep on truckin' */
2908: goto next_cmnd;
2909: }
2910:
2911: case 3: /* FOR with increment and limit test */
2912: symtab (get_sym, fvar, tmp);
2913: numlit (tmp);
2914: stcpy (tmp2, finc); /* add may change forinc */
2915: add (tmp, tmp2);
2916:
2917: if (*finc != '-') {
2918: if (comp (flim, tmp)) goto for_quit;
2919: }
2920: else {
2921: if (comp (tmp, flim)) goto for_quit;
2922: }
2923:
2924: symtab (set_sym, fvar, tmp);
2925:
2926: goto for10;
2927:
2928: case 2: /* FOR with increment without limit test */
2929: symtab (get_sym, fvar, tmp);
2930: numlit (tmp);
2931: stcpy (tmp2, finc); /* add may change forinc */
2932: add (tmp, tmp2);
2933:
2934: symtab (set_sym, fvar, tmp);
2935: goto for10;
2936: } /* end switch */
2937:
2938: for_quit:
2939:
2940: cmdptr = nestp[nstx];
2941:
2942:
2943: if (*codptr++ == ',') goto for_nxt_arg;
2944:
2945: forpost[forx][0] = '\0';
2946:
2947: nstx--;
2948: estack--;
2949:
2950: forx--;
2951: ftyp = fortyp[forx];
2952: fvar = forvar[forx];
2953: finc = forinc[forx];
2954: flim = forlim[forx];
2955: fi = fori[forx];
2956:
2957:
2958: if ((forsw = (nestc[nstx] == FOR))) goto for_end;
2959:
2960: if (sigint_in_for) {
2961: merr_raise (INRPT);
2962: sigint_in_for = FALSE;
2963: }
2964:
2965: if (merr () > OK) goto err;
2966: goto next_line;
2967:
2968: case MERGE:
2969:
2970: {
2971: char lhs[256];
2972: char rhs[256];
2973:
2974: char k_buf[STRLEN];
2975:
2976: if ((rtn_dialect () != D_M95) &&
2977: (rtn_dialect () != D_MDS) &&
2978: (rtn_dialect () != D_M5) &&
2979: (rtn_dialect () != D_FREEM)) {
2980: merr_raise (NOSTAND);
2981: goto err;
2982: }
2983:
2984: expr (NAME);
2985: if (merr () > OK) break;
2986:
2987: key_to_name (lhs, varnam, 255);
2988: stcnv_c2m (lhs);
2989:
2990: if (*++codptr != '=') {
2991: merr_raise (ASSIGNER);
2992: break;
2993: }
2994:
2995: codptr++;
2996:
2997: expr (NAME);
2998: if (merr () > OK) break;
2999:
3000: codptr++;
3001:
3002: key_to_name (rhs, varnam, 255);
3003: stcnv_c2m (rhs);
3004:
3005: stcpy (k_buf, "%INTMERGELHS\201\201");
3006: symtab (set_sym, k_buf, lhs);
3007:
3008: stcpy (k_buf, "%INTMERGERHS\201\201");
3009: symtab (set_sym, k_buf, rhs);
3010:
3011: stcpy (&tmp3[1], "SYSWMERGE \201");
3012: goto private;
3013:
3014: break;
3015:
3016: }
3017:
3018:
3019: case RLOAD:
3020: if ((rtn_dialect () != D_MDS) &&
3021: (rtn_dialect () != D_FREEM)) {
3022: merr_raise (NOSTAND);
3023: goto err;
3024: }
3025: stcpy (&tmp3[1], "zrload \201");
3026: goto private;
3027:
3028:
3029: case RSAVE:
3030: if ((rtn_dialect () != D_MDS) &&
3031: (rtn_dialect () != D_FREEM)) {
3032: merr_raise (NOSTAND);
3033: goto err;
3034: }
3035:
3036: stcpy (&tmp3[1], "zrsave \201");
3037: goto private;
3038:
3039:
3040: case XECUTE:
3041:
3042:
3043: do_xecute:
3044: expr (STRING);
3045:
3046: if (merr () > OK) break;
3047:
3048: stcpy (tmp, argptr);
3049:
3050: if (*codptr == ':') { /* argument postcond */
3051: codptr++;
3052: expr (STRING);
3053:
3054: if (merr () > OK) break;
3055: if (tvexpr (argptr) == FALSE) break;
3056: }
3057:
3058: if (++nstx > NESTLEVLS) {
3059: nstx--;
3060: merr_raise (STKOV);
3061:
3062: break;
3063: }
3064: else {
3065: estack++;
3066: }
3067:
3068:
3069: #ifdef DEBUG_NEWSTACK
3070: if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
3071: #endif
3072:
3073: nestc[nstx] = XECUTE;
3074: nestp[nstx] = cmdptr; /* command stack address */
3075: nestr[nstx] = roucur - rouptr; /* save roucur */
3076: nestlt[nstx] = level;
3077:
3078: level = 0; /* save level */
3079: nestnew[nstx] = 0;
3080: ztrap[nstx][0] = EOL;
3081:
3082: while ((*(namptr++)) != EOL);
3083:
3084: stcpy ((nestn[nstx] = namptr), rou_name); /* save routine name */
3085:
3086: forsw = FALSE;
3087: loadsw = FALSE;
3088: cmdptr += stcpy (cmdptr, codptr) + 1;
3089:
3090: stcpy (code, tmp);
3091:
3092: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
3093: codptr = code;
3094:
3095: goto next_cmnd;
3096:
3097:
3098: case DO:
3099:
3100: if (evt_async_initial == TRUE) {
3101: evt_async_initial = FALSE;
3102: }
3103: else {
3104: evt_depth++;
3105: }
3106:
3107: rouoldc = roucur - rouptr;
3108: namold = 0;
3109:
3110: case GOTO:
3111:
3112: do_goto:
3113:
1.17 snw 3114: if (trace_mode) {
3115: char rn[256];
3116: stcpy (rn, rou_name);
3117: stcnv_m2c (rn);
3118:
3119: switch (mcmnd) {
3120: case DO:
3121: snprintf (tracestr, sizeof (tracestr) - 1, "rtn = %s $stack = %d do ", rn, nstx);
3122: break;
3123: case GOTO:
3124: snprintf (tracestr, sizeof (tracestr) - 1, "rtn = %s $stack = %d goto ", rn, nstx);
3125: break;
3126: }
3127: }
3128:
1.1 snw 3129: offset = 0;
3130: label[0] = routine[0] = EOL;
3131: dofram0 = 0;
3132:
3133: if (((ch = *codptr) != '+') && (ch != '^')) { /* parse label */
3134:
3135: if (ch == SP || ch == EOL) { /* no args: blockstructured DO */
3136:
3137: if (mcmnd != DO) {
3138: merr_raise (ARGLIST);
3139: break;
3140: }
3141:
3142: /* direct mode: DO +1 */
3143:
3144:
3145: if (nstx == 0 && roucur >= rouend) {
3146: roucu0 = rouptr;
3147: goto off1;
3148: }
3149:
3150: mcmnd = DO_BLOCK;
3151: roucu0 = roucur; /* continue with next line */
3152: forsw = FALSE;
3153:
3154: goto off2;
3155: }
3156:
3157: expr (LABEL);
3158:
3159: if (merr () > OK) goto err;
3160:
3161: stcpy (label, varnam);
3162:
1.17 snw 3163: if (trace_mode) {
3164: char ttt[256];
3165: stcpy (ttt, label);
3166: stcnv_m2c (ttt);
3167:
3168: strcat (tracestr, ttt);
3169: }
3170:
1.1 snw 3171: ch = *++codptr;
3172: }
3173:
3174: if (ch == '+') { /* parse offset */
3175:
3176: codptr++;
3177: expr (OFFSET);
3178:
3179: if (merr () > OK) goto err;
3180:
3181: offset = intexpr (argptr);
3182: dosave[0] = EOL;
3183:
3184: /* unless argument is numeric, expr returns wrong codptr */
3185: if ((ch = *codptr) != SP && (ch != EOL) && (ch != ',') && (ch != '^')) ch = *++codptr;
1.17 snw 3186:
3187: if (trace_mode) {
3188: char ttt[256];
3189: snprintf (ttt, 255, "+%d", offset);
3190: strcat (tracestr, ttt);
3191: }
1.1 snw 3192: }
3193:
3194: if (ch == '^') { /* parse routine */
3195: codptr++;
3196: expr (LABEL);
3197:
3198: if (merr () > OK) goto err;
3199:
3200: stcpy (routine, varnam);
1.17 snw 3201:
3202: if (trace_mode) {
3203: char ttt[256];
3204: char ttx[256];
3205:
3206: stcpy (ttt, routine);
3207: stcnv_m2c (ttt);
3208: snprintf (ttx, 255, "^%s", ttt);
3209: strcat (tracestr, ttx);
3210: }
1.1 snw 3211:
3212: dosave[0] = EOL;
3213: ch = *++codptr;
3214: loadsw = TRUE;
3215: }
3216:
1.17 snw 3217: if (trace_mode) {
3218: fprintf (stderr, ">> TRACE: %s\r\n", tracestr);
3219: }
3220:
1.1 snw 3221: if (ch == '(' && mcmnd == DO) { /* parse parameter */
3222:
3223: if (offset) {
3224: merr_raise (ARGLIST);
3225: goto err;
3226: }
3227:
3228: if (*++codptr == ')') {
3229: ch = *++codptr;
3230: }
3231: else {
3232: dofram0 = dofrmptr;
3233: i = 0;
3234:
3235: for (;;) {
3236: setpiece = TRUE; /* to avoid error on closing bracket */
3237:
3238: if (*codptr == '.' && (*(codptr + 1) < '0' || *(codptr + 1) > '9')) {
3239: codptr++;
3240:
3241: expr (NAME);
3242: codptr++;
3243:
3244: *dofrmptr++ = DELIM; /* to indicate call by name */
3245: dofrmptr += stcpy (dofrmptr, varnam) + 1;
3246: }
3247: else {
3248: expr (STRING);
3249: dofrmptr += stcpy (dofrmptr, argptr) + 1;
3250: }
3251:
3252: setpiece = FALSE;
3253: i++;
3254:
3255: if (merr () > OK) {
3256: dofrmptr = dofram0;
3257: goto err;
3258: }
3259:
3260: ch = *codptr++;
3261: if (ch == ',') continue;
3262:
3263: if (ch != ')') {
3264: merr_raise (COMMAER);
3265: dofrmptr = dofram0;
3266:
3267: goto err;
3268: }
3269:
3270: ch = *codptr;
3271: break;
3272: }
3273: }
3274: }
3275:
3276: if (ch == ':') { /* parse postcond */
3277:
3278: codptr++;
3279: expr (STRING);
3280:
3281: if (merr () > OK) {
3282: if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
3283: goto err;
3284: }
3285:
3286: if (tvexpr (argptr) == FALSE) {
3287: if (*codptr != ',') mcmnd = 0; /* avoid false LEVEL Error */
3288: if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
3289:
3290: break;
3291: }
3292: }
3293:
3294: if (mcmnd == GOTO) { /* GOTO: clear FORs from stack */
3295:
3296: #ifdef DEBUG_NEWSTACK
3297: printf ("CHECK 05 Multi-POP on FOR\r\n");
3298: #endif
3299:
3300:
3301:
3302: while (nestc[nstx] == FOR) {
3303:
3304: #ifdef DEBUG_NEWSTACK
3305: printf ("POP");
3306: #endif
3307:
3308: cmdptr = nestp[nstx--];
3309: estack--;
3310:
3311: forx--;
3312: ftyp = fortyp[forx];
3313: fvar = forvar[forx];
3314: finc = forinc[forx];
3315: flim = forlim[forx];
3316: fi = fori[forx];
3317: }
3318:
3319: #ifdef DEBUG_NEWSTACK
3320: printf ("\r\n");
3321: #endif
3322:
3323:
3324: loadsw = TRUE;
3325: }
3326:
3327: job_entry: /* entry called from successful JOB */
3328:
3329: if (routine[0] != EOL) {
3330:
3331: #ifdef DEBUG_NEWSTACK
3332: printf ("CHECK 06\r\n");
3333: #endif
3334:
3335: if (mcmnd == DO) {
3336:
3337: while ((*(namptr++)) != EOL);
3338:
3339: namold = namptr;
3340: stcpy (namptr, rou_name);
3341:
3342: ssvn_job_update ();
3343:
3344: }
3345:
3346: /* if (GOTO label^rou) under a (DO label) */
3347: /* save away old routine to restore on quit */
3348:
3349:
3350:
3351: else if (nstx > 0) {
3352:
3353: #ifdef DEBUG_NEWSTACK
3354: printf ("CHECK 06, stack is greater than 0\r\n");
3355: #endif
3356:
3357: while (nestc[nstx] == FOR) {
3358: #ifdef DEBUG_NEWSTACK
3359: printf ("POP");
3360: #endif
3361:
3362: nstx--;
3363: estack--;
3364: forx--;
3365: ftyp = fortyp[forx];
3366: fvar = forvar[forx];
3367: finc = forinc[forx];
3368: flim = forlim[forx];
3369: fi = fori[forx];
3370: }
3371:
3372: if (nestn[nstx] == 0) {
3373: while ((*(namptr++)) != EOL);
3374:
3375: stcpy ((nestn[nstx] = namptr), rou_name);
3376: }
3377: }
3378:
3379: zload (routine);
3380: if (merr () > OK) goto err; /* load file */
3381:
3382: ssvn_job_update ();
3383:
3384: } /* if (routine[0] != EOL) */
3385: {
3386: char *reg, *reg1;
3387:
3388: reg1 = rouptr;
3389: reg = reg1;
3390:
3391: if (label[0] != EOL) {
3392:
3393: if (forsw && mcmnd == DO && stcmp (label, dosave) == 0) {
3394: roucu0 = xdosave;
3395: goto off1;
3396: }
3397:
3398: while (reg < rouend) {
3399: reg++;
3400: j = 0;
3401:
3402: while (*reg == label[j]) {
3403: reg++;
3404: j++;
3405: }
3406:
3407: if (label[j] == EOL) {
3408:
3409: if (*reg == TAB || *reg == SP) goto off;
3410:
3411: /* call of procedure without specifying a parameter list */
3412: if (*reg == '(') {
3413: if (dofram0 == 0) dofram0 = dofrmptr;
3414: goto off;
3415: }
3416:
3417: }
3418:
3419: reg = (reg1 = reg1 + UNSIGN (*reg1) + 2);
3420: }
3421: {
3422: merr_raise (M13);
3423: stcpy (varerr, label); /* to be included in error message */
3424:
3425: if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
3426:
3427: zload (rou_name);
3428: ssvn_job_update ();
3429: goto err;
3430: }
3431: }
3432: off:
3433: if (label[0] == EOL && offset > 0) offset--;
3434: while (offset-- > 0) reg1 = reg1 + (UNSIGN (*reg1) + 2);
3435:
3436: if (forsw) {
3437: xdosave = reg1;
3438: stcpy (dosave, label);
3439: }
3440:
3441: roucu0 = reg1;
3442: }
3443:
3444: if (roucu0 >= rouend) {
3445: merr_raise (M13);
3446: stcpy (varerr, label); /* to be included in error message */
3447:
3448: if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
3449:
3450: zload (rou_name);
3451: ssvn_job_update ();
3452: goto err;
3453: }
3454:
3455: off1:
3456: if (routine[0] != EOL) stcpy (rou_name, routine);
3457:
3458: ssvn_job_update ();
3459:
3460: roucu0++;
3461: forsw = FALSE;
3462:
3463: if (mcmnd != DO) { /* i.e. GOTO or JOB */
3464: roucur = roucu0;
3465: goto off3;
3466: }
3467:
3468: off2:
3469:
3470: #ifdef DEBUG_NEWSTACK
3471: printf ("CHECK 07 (Stack PUSH)\r\n");
3472: #endif
3473:
3474:
3475:
3476: if (++nstx > NESTLEVLS) {
3477: nstx--;
3478: merr_raise (STKOV);
3479:
3480: goto err;
3481: }
3482: else {
3483: on_frame_entry ();
3484: estack++;
3485: }
3486:
3487: nestc[nstx] = mcmnd;
3488:
3489: #ifdef DEBUG_NEWSTACK
3490: if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
3491: #endif
3492:
3493: nestp[nstx] = cmdptr;
3494: nestn[nstx] = namold;
3495: nestr[nstx] = rouoldc;
3496: nestnew[nstx] = 0;
3497:
3498: if (mcmnd != DO_BLOCK) {
3499: nestlt[nstx] = level;
3500: level = 0;
3501: }
3502: else { /* push level ; clr level */
3503: nestlt[nstx] = test;
3504: level++;
3505: } /* push $TEST ; inc level */
3506:
3507: ztrap[nstx][0] = EOL;
3508:
3509:
3510: cmdptr += stcpy (cmdptr, codptr) + 1;
3511: roucur = roucu0;
3512:
3513: /* processing for private Z-Command: */
3514: if (privflag) {
3515:
3516:
3517:
3518: #ifdef DEBUG_NEWPTR
3519: printf ("Xecline 01 (using NEWPTR): ");
3520: printf ("[nstx] is [%d], [nestnew] is [%d]", nstx, nestnew[nstx]);
3521: printf ("- Initialized to newptr\r\n");
3522: #endif /* Debug */
3523:
3524: nestnew[nstx] = newptr;
3525:
3526:
3527: stcpy (vn, zargdefname);
3528:
3529: /*was: vn[0] = '%'; vn[1] = EOL; */
3530:
3531: symtab (new_sym, vn, "");
3532: /*djw change 'input variable for Z command' to get value of $V(202) */
3533: /*was: vn[0] = '%'; vn[1] = EOL; */
3534:
3535: stcpy (vn, zargdefname);
3536: symtab (set_sym, vn, tmp2);
3537:
3538: privflag = FALSE;
3539: }
3540:
3541: off3:
3542:
3543: if (dofram0) {
3544: char *reg, *reg1;
3545:
3546: reg = roucu0;
3547: reg1 = dofram0;
3548:
3549: while ((ch = (*reg++)) != '(') {
3550: if (ch == SP || ch == TAB || ch == EOL) break;
3551: }
3552:
3553: if (ch != '(') {
3554: merr_raise (TOOPARA);
3555: dofrmptr = dofram0;
3556:
3557: goto err;
3558: }
3559:
3560: j = 0;
3561:
3562: while ((ch = (*reg++)) != EOL) {
3563:
3564: if ((ch == ',' && j) || ch == ')') {
3565: varnam[j] = EOL;
3566:
3567:
3568:
3569: #ifdef DEBUG_NEWPTR
3570: printf ("Xecline 02: ");
3571: printf ("[nstx] is [%d], [nestnew] is [%d]\r\n", nstx, nestnew[nstx]);
3572: #endif
3573:
3574: if (nestnew[nstx] == 0) nestnew[nstx] = newptr;
3575:
3576:
3577:
3578: if (reg1 < dofrmptr) {
3579:
3580: if (*reg1 == DELIM) { /* call by reference */
3581:
3582: if (stcmp (reg1 + 1, varnam)) { /* are they different?? */
3583: symtab (new_sym, varnam, "");
3584: symtab (m_alias, varnam, reg1 + 1);
3585: }
3586:
3587: }
3588: else {
3589: symtab (new_sym, varnam, ""); /* call by value */
3590: symtab (set_sym, varnam, reg1);
3591: }
3592:
3593: reg1 += stlen (reg1) + 1;
3594: }
3595: else {
3596: symtab (new_sym, varnam, "");
3597: }
3598:
3599: if (ch == ')') break;
3600:
3601: j = 0;
3602: continue;
3603: }
3604:
3605: if ((ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9' && j) || (ch == '%' && j == 0)) {
3606: varnam[j++] = ch;
3607: continue;
3608: }
3609:
3610: merr_raise (ARGLIST);
3611: dofrmptr = dofram0; /* reset frame pointer */
3612:
3613: goto err;
3614: }
3615:
3616: if (reg1 < dofrmptr) {
3617: merr_raise (TOOPARA);
3618: dofrmptr = dofram0;
3619:
3620: goto err;
3621: }
3622:
3623: dofrmptr = dofram0;
3624: }
3625:
3626: goto next_line;
3627:
3628: /* ZJOB *//* same as JOB, but without timeout */
3629: /* not recommended; just for backward compatibility */
3630: case ZJOB:
3631: if (is_standard ()) {
3632: merr_raise (NOSTAND);
3633: goto err;
3634: }
3635:
3636: case JOB:
3637:
3638: if (rtn_dialect () == D_M77) {
3639: merr_raise (NOSTAND);
3640: goto err;
3641: }
3642:
3643: if (*codptr == SP || *codptr == EOL) {
3644: merr_raise (M13);
3645: varerr[0] = EOL; /* to be included in error message */
3646:
3647: break;
3648: }
3649:
3650: loadsw = TRUE;
3651: offset = 0;
3652: frm_timeout = (-1L);
3653: label[0] = routine[0] = EOL;
3654:
3655: if (((ch = *codptr) != '+') && (ch != '^')) { /* parse label */
3656: expr (LABEL);
3657: if (merr () > OK) goto err;
3658:
3659: stcpy (label, varnam);
3660:
3661: ch = *++codptr;
3662: }
3663:
3664: if (ch == '+') { /* parse offset */
3665: codptr++;
3666:
3667: expr (OFFSET);
3668: if (merr () > OK) goto err;
3669:
3670: offset = intexpr (argptr);
3671:
3672: /* unless argument is numeric, expr returns wrong codptr */
3673: if ((ch = *codptr) != SP && (ch != EOL) && (ch != ',') && (ch != '^')) ch = *++codptr;
3674:
3675: }
3676:
3677: if (ch == '^') { /* parse routine */
3678: codptr++;
3679:
3680: expr (LABEL);
3681: if (merr () > OK) goto err;
3682:
3683: stcpy (routine, varnam);
3684:
3685: dosave[0] = EOL;
3686: ch = *++codptr;
3687: }
3688:
3689: dofram0 = NULL;
3690: if (ch == '(') { /* parse parameter */
3691:
3692: if (offset) {
3693: merr_raise (ARGLIST);
3694: goto err;
3695: }
3696:
3697: codptr++;
3698: dofram0 = dofrmptr;
3699:
3700: i = 0;
3701: for (;;) {
3702: setpiece = TRUE; /* to avoid error on closing bracket */
3703:
3704: if (*codptr == '.' && (*(codptr + 1) < '0' || *(codptr + 1) > '9')) {
3705: codptr++;
3706:
3707: expr (NAME);
3708:
3709: codptr++;
3710:
3711: *dofrmptr++ = DELIM; /* to indicate call by name */
3712: dofrmptr += stcpy (dofrmptr, varnam) + 1;
3713: }
3714: else {
3715: expr (STRING);
3716: dofrmptr += stcpy (dofrmptr, argptr) + 1;
3717: }
3718:
3719: setpiece = FALSE;
3720: i++;
3721:
3722: if (merr () > OK) {
3723: dofrmptr = dofram0;
3724: goto err;
3725: }
3726:
3727: ch = *codptr++;
3728: if (ch == ',') continue;
3729:
3730: if (ch != ')') {
3731: merr_raise (COMMAER);
3732: dofrmptr = dofram0;
3733:
3734: goto err;
3735: }
3736:
3737: ch = *codptr;
3738: break;
3739: }
3740: }
3741:
3742: if (ch == ':' && *(codptr + 1) == ch) {
3743: codptr++; /* timeout,no jobparams */
3744: }
3745: else if (ch == ':' && *(codptr + 1) == '(') { /* parse any 'job parameters', but ignore them otherwise */
3746: codptr++;
3747: setpiece = TRUE; /* to avoid bracket error at end of jobparameters */
3748:
3749: for (;;) {
3750: if (*++codptr != ':') expr (STRING);
3751: if (*codptr == ':') continue;
3752: if (*codptr++ != ')') merr_raise (ARGER);
3753:
3754: break;
3755: }
3756:
3757: setpiece = FALSE;
3758: ch = (*codptr);
3759: }
3760:
3761: if (ch == ':') { /* timeout */
3762: codptr++;
3763: expr (STRING);
3764:
3765: if ((frm_timeout = intexpr (argptr)) < 0L) frm_timeout = 0L;
3766: if (merr () > OK) goto err;
3767:
3768: test = TRUE;
3769: }
3770:
3771: if (mcmnd == ZJOB) frm_timeout = 0L; /* ZJOB-command has timeout 0 */
3772:
3773: close_all_globals (); /* close all globals */
3774: j = getpid (); /* job number of father process */
3775:
3776: if (lonelyflag) { /* single user */
3777: if (frm_timeout < 0L) {
3778: merr_raise (PROTECT); /* error without timeout */
3779: }
3780: else {
3781: test = FALSE; /* timeout always fails */
3782: }
3783:
3784: break;
3785: }
3786:
3787: while ((i = fork ()) == -1) {
3788:
3789: if (frm_timeout == 0L) {
3790: test = FALSE;
3791: break;
3792: }
3793:
3794: if (frm_timeout > 0L) frm_timeout--;
3795:
3796: sleep (1);
3797:
3798: }
3799:
3800: if (mcmnd == ZJOB && zjobflag) {
3801:
3802: if (i == 0) { /* we are in child process */
3803: intstr (zb, j); /* $JOB of father job */
3804:
3805: father = j;
3806: pid = getpid (); /* this is our new job number */
3807:
3808: jobtime = time (0L);;
3809:
3810:
3811: nstx = 0; /* clear stack */
3812: estack = 0;
3813:
3814: forx = 0;
3815: forsw = FALSE;
3816: level = 0;
3817: cmdptr = cmdstack; /* - command stack pointer */
3818: namptr = namstck; /* - routine name stack pointer */
3819: usermode = 0; /* application mode */
3820: merr_clear ();
3821:
3822: lock (" \201", -1, 'j'); /* tell lock about JOB */
3823: goto job_entry;
3824: }
3825:
3826: /* ignore signal while here */
3827: sig_attach (SIGUSR1, SIG_IGN);
3828:
3829: while (wait (&zsystem) != i);
3830:
3831: sig_attach (SIGUSR1, &oncld); /* restore handler */
3832:
3833: merr_clear (); /* there might be a INRPT from other job */
3834:
3835: set_io (MUMPS);
3836: break;
3837: }
3838:
3839: if (i == 0) { /* we are in child process */
3840:
3841: intstr (zb, j); /* $JOB of father job */
3842: father = j;
3843:
3844: pid = getpid (); /* $J = process ID */
3845: usermode = 0; /* no programmer mode */
3846: DSW |= BIT0; /* disable echo */
3847: zbreakon = DISABLE; /* disable CTRL/B */
3848: breakon = DISABLE; /* disable CTRL/C */
3849: hardcopy = DISABLE; /* disable hardcopy function */
3850:
3851: fclose (stdin); /* close normal input */
3852:
3853: jour_flag = 0; /* no protocol */
3854:
3855:
3856: nstx = 0; /* clear stack */
3857: estack = 0;
3858:
3859: forx = 0;
3860: forsw = FALSE;
3861: level = 0;
3862:
3863: cmdptr = cmdstack; /* - command stack pointer */
3864: namptr = namstck; /* - routine name stack pointer */
3865:
3866: /* init random number */
3867: if ((nrandom = time (0L) * getpid ()) < 0) nrandom = (-nrandom);
3868:
3869: merr_clear ();
3870: lock (" \201", -1, 'j'); /* tell lock about JOB */
3871:
3872: goto job_entry;
3873: }
3874:
3875: intstr (zb, i); /* $JOB of the process just started */
3876: break;
3877:
3878: case KILL:
1.10 snw 3879:
1.1 snw 3880: /* argumentless: KILL all local variables */
3881: if (((ch = *codptr) == SP) || ch == EOL) {
3882: symtab (kill_all, "", "");
3883: break;
3884: }
3885:
3886: if (ch != '(') {
3887: char destc[255];
3888: register int cd;
3889:
3890: destc[0] = '\0';
3891:
3892: expr (NAME);
3893:
3894: /* aviod a disaster if someone types KILL ^PATDAT[TEST] ! */
3895: if (((ch = *++codptr) != SP) && ch != EOL && ch != ',') merr_raise (INVREF);
3896: if (merr () > OK) goto err;
3897:
3898: if (varnam[0] == '^') {
3899: if (varnam[1] != '$') {
3900: global (kill_sym, varnam, tmp);
3901: }
3902: else {
3903: ssvn (kill_sym, varnam, tmp);
3904: }
3905: break;
3906: }
3907:
3908: symtab (kill_sym, varnam, tmp);
3909:
3910: if (destructor_ct) {
3911:
3912: for (cd = 0; cd < destructor_ct; cd++) {
1.10 snw 3913: if (strlen (destructors[cd]) > 0) {
3914: strcat (destc, destructors[cd]);
3915: strcat (destc, ",");
3916: }
1.1 snw 3917: }
3918:
3919: destructor_ct = 0;
3920: destc[strlen(destc) - 1] = '\201';
3921:
3922: stcpy (&tmp3[1], destc);
3923: destructor_run = TRUE;
3924:
3925: goto private;
3926: }
3927:
3928:
3929: break;
3930: }
3931:
3932: /* exclusive kill */
3933: tmp[0] = SP;
3934: tmp[1] = EOL;
3935:
3936: for (;;) {
3937:
3938: codptr++;
3939: expr (NAME);
3940:
3941: if (merr () > OK) goto err;
3942:
3943: if (varnam[0] == '^') {
3944: merr_raise (GLOBER);
3945: goto err;
3946: }
3947:
3948: i = 0;
3949: while (varnam[i] != EOL) {
3950:
3951: if (varnam[i] == DELIM) {
3952: merr_raise (SBSCR);
3953: goto err;
3954: }
3955:
3956: i++;
3957: }
3958:
3959: if (stcat (tmp, varnam) == 0) {
3960: merr_raise (M75);
3961: goto err;
3962: }
3963:
3964: if (stcat (tmp, " \201") == 0) {
3965: merr_raise (M75);
3966: goto err;
3967: }
3968:
3969: if ((ch = *++codptr) == ')') {
3970: codptr++;
3971: break;
3972: }
3973:
3974: if (ch != ',') {
3975: merr_raise (COMMAER);
3976: goto err;
3977: }
3978: }
3979:
3980: symtab (killexcl, tmp, "");
3981: break;
3982:
3983: case NEWCMD:
3984: if ((rtn_dialect () == D_M77) ||
3985: (rtn_dialect () == D_M84)) {
3986: merr_raise (NOSTAND);
3987: goto err;
3988: }
3989: /*case ZNEW:*/
3990:
3991: /* argumentless: NEW all local variables */
3992: if (((ch = *codptr) == SP) || ch == EOL) {
3993: ch = nstx;
3994:
3995: while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */
3996:
3997: #ifdef DEBUG_NEWPTR
3998: printf ("Xecline 03: (TODO - NEW ALL) ");
3999: printf ("[ch] is %d, [nestnew] is %d\r\n", ch, nestnew[ch]);
4000: #endif
4001:
4002: if (nestnew[ch] == 0) nestnew[ch] = newptr;
4003:
4004: symtab (new_all, "", "");
4005: break;
4006: }
4007:
4008: if (ch != '(') {
4009: expr (NAME);
4010:
4011: if (merr () > OK) goto err;
4012:
4013: codptr++;
4014:
4015: if (varnam[0] == '^') {
4016: merr_raise (GLOBER);
4017: goto err;
4018: }
4019:
4020: if (varnam[0] == '$') {
4021: i = 0;
4022:
4023: while ((ch = varnam[++i]) != EOL) if (ch >= 'A' && ch <= 'Z') varnam[i] = ch + 32;
4024:
4025: /* set $reference */
4026: if ((stcmp (&varnam[1], "r\201")) && (stcmp (&varnam[1], "reference\201")) && (stcmp (&varnam[1], "zr\201")) && (stcmp (&varnam[1], "zreference\201")) &&
4027: (stcmp (&varnam[1], "t\201")) && (stcmp (&varnam[1], "test\201")) && (stcmp (&varnam[1], "j\201")) && (stcmp (&varnam[1], "job\201")) &&
4028: (stcmp (&varnam[1], "zi\201")) && (stcmp (&varnam[1], "zinrpt\201")) && (stcmp (&varnam[1], "et\201")) && (stcmp (&varnam[1], "etrap\201")) &&
4029: (stcmp (&varnam[1], "es\201")) && (stcmp (&varnam[1], "estack\201"))) {
4030: merr_raise (INVREF);
4031: goto err;
4032: }
4033: }
4034:
4035: /* new and set, new object */
4036: if (*codptr == '=') {
4037:
4038: if ((rtn_dialect () != D_FREEM)) {
4039: merr_raise (NOSTAND);
4040: goto err;
4041: }
4042:
4043: codptr++;
4044: stcpy (vn, varnam);
4045:
4046: if (*codptr != '$') {
4047: /* this is a new-and-set */
4048: expr (STRING);
4049: new_and_set = TRUE;
4050: }
4051: else {
4052: if ((*codptr == '$') &&
4053: (*(codptr + 1) == '#') &&
4054: (*(codptr + 2) == '^')) {
4055:
4056: char class[255];
4057: char constructor[255];
4058: char objvar[255];
4059: char datres[5];
4060: int dat_res;
4061:
4062: stcpy (objvar, vn);
4063:
1.9 snw 4064: symtab (fra_dat, objvar, datres);
1.1 snw 4065: dat_res = atoi (datres);
4066:
4067: if (dat_res > 0) {
4068: merr_raise (OBJCONFLICT);
4069: goto err;
4070: }
4071:
4072: stcnv_m2c (objvar);
4073:
4074: codptr += 2;
4075:
4076: /* this is probably an object instantiation */
4077: expr (NAME);
4078: if (merr () > OK) goto err;
4079:
4080: stcpy (class, varnam);
4081: stcnv_m2c (class);
4082: new_object = TRUE;
4083: codptr++;
4084:
4085: obj_get_constructor (constructor, class, objvar);
4086:
4087: for (dat_res = 0; dat_res < strlen (class); dat_res++) {
4088: if (class[dat_res] == '\202') {
4089: class[dat_res] = '\0';
4090: break;
4091: }
4092: }
4093:
4094: obj_create_symbols (objvar, class);
4095:
4096: if (merr () > OK) goto err;
4097:
1.14 snw 4098: /* TODO: check this snprintf for proper sizing */
1.1 snw 4099: snprintf (&tmp3[1], 255, "%s\201", &constructor[1]);
4100: goto private;
4101:
4102: }
4103: else {
4104: if (*codptr == '$') {
4105: expr (STRING);
4106: new_and_set = TRUE;
4107: }
4108: else {
4109: merr_raise (ILLFUN);
4110: goto err;
4111: }
4112: }
4113: }
4114:
4115:
4116: goto set2;
4117: }
4118:
1.12 snw 4119: /*
1.1 snw 4120: post_new:
1.12 snw 4121: */
1.1 snw 4122: ch = nstx;
4123:
4124: while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */
4125:
4126: #ifdef DEBUG_NEWPTR
4127: printf ("Xecline 04 (DANGER): ");
4128: printf ("[ch] is %d, [nestnew] is %d\r\n", ch, nestnew[ch]);
4129: #endif
4130:
4131: if (nestnew[ch] == 0) nestnew[ch] = newptr;
4132:
4133: symtab (new_sym, varnam, "");
4134: break;
4135: }
4136:
4137: /* exclusive new */
4138: tmp[0] = SP;
4139: tmp[1] = EOL;
4140:
4141: for (;;) {
4142: codptr++;
4143: expr (NAME);
4144:
4145: if (merr () > OK) goto err;
4146:
4147: if (varnam[0] == '^') {
4148: merr_raise (GLOBER);
4149: goto err;
4150: }
4151:
4152: if (varnam[0] == '$') {
4153: merr_raise (INVREF);
4154: goto err;
4155: }
4156:
4157: i = 0;
4158: while (varnam[i] != EOL) {
4159:
4160: if (varnam[i] == DELIM) {
4161: merr_raise (SBSCR);
4162: goto err;
4163: }
4164:
4165: i++;
4166: }
4167:
4168: if (stcat (tmp, varnam) == 0) {
4169: merr_raise (M75);
4170: goto err;
4171: }
4172:
4173: if (stcat (tmp, " \201") == 0) {
4174: merr_raise (M75);
4175: goto err;
4176: }
4177:
4178: if ((ch = *++codptr) == ')') {
4179: codptr++;
4180: break;
4181: }
4182:
4183: if (ch != ',') {
4184: merr_raise (COMMAER);
4185: goto err;
4186: }
4187: }
4188:
4189: ch = nstx;
4190: while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */
4191:
4192: #ifdef DEBUG_NEWPTR
4193: printf ("Xecline 05 (TODO): ");
4194: printf ("[ch] is %d, [nestnew] is %d\r\n", ch, nestnew[ch]);
4195: #endif
4196:
4197: if (nestnew[ch] == 0) nestnew[ch] = newptr;
4198:
4199: symtab (newexcl, tmp, "");
4200: break;
4201:
4202: case LOCK:
4203:
4204: /* argumentless: UNLOCK */
4205: if ((ch = *codptr) == SP || ch == EOL) {
4206: locktab_unlock_all ();
4207: break;
4208: }
4209:
4210: if (ch == '+' || ch == '-') {
4211:
4212: if ((rtn_dialect () == D_M77) ||
4213: (rtn_dialect () == D_M84)) {
4214: merr_raise (NOSTAND);
4215: goto err;
4216: }
4217:
4218: tmp[0] = ch;
4219: ch = (*++codptr);
4220: }
4221: else {
4222: tmp[0] = SP;
4223: }
4224:
4225: if (ch != '(') {
4226: expr (NAME);
4227:
4228: if (merr () > OK) goto err;
4229:
4230: stcpy (&tmp[1], varnam);
4231: stcat (tmp, "\001\201");
4232: }
4233: else { /* multiple lock */
4234: tmp[1] = EOL;
4235:
4236: for (;;) {
4237: codptr++;
4238: expr (NAME);
4239:
4240: if (merr () > OK) goto err;
4241:
4242: stcat (tmp, varnam);
4243: stcat (tmp, "\001\201");
4244:
4245: if ((ch = *++codptr) == ')') break;
4246:
4247: if (ch != ',') {
4248: merr_raise (COMMAER);
4249: goto err;
4250: }
4251: }
4252:
4253: }
4254:
4255: frm_timeout = (-1L); /* no timeout */
4256:
4257: if (*++codptr == ':') {
4258: codptr++;
4259: expr (STRING);
4260:
4261: frm_timeout = intexpr (argptr);
4262:
4263: if (merr () > OK) goto err;
4264: if (frm_timeout < 0L) frm_timeout = 0L;
4265: }
4266:
4267: lock (tmp, frm_timeout, LOCK);
4268: break;
4269:
4270: case USE:
4271:
4272: if (*codptr == SP || *codptr == EOL) {
4273: merr_raise (ARGER);
4274: goto err;
4275: }
4276:
4277: expr (STRING);
4278: j = intexpr (argptr);
4279:
4280: if (j > MAXSEQ && j < MAXDEV) {
4281: io = j;
4282: goto use_socket;
4283: }
4284:
4285: if (j < 0 || j > MAXDEV) {
4286: merr_raise (NODEVICE);
4287: }
4288: else if (j != HOME && devopen[j] == 0) {
4289: merr_raise (NOPEN);
4290: }
4291:
4292: if (merr () > OK) goto err;
4293:
4294: io = j;
4295:
4296: if (io == HOME && *codptr == ':' && *(codptr + 1) == '(') {
4297:
4298: use0: /* entry point for processing of device parameters */
4299:
4300: codptr += 2;
4301: j = 1;
4302: setpiece = TRUE; /* so a surplus closing bracket will not be an error */
4303:
4304: while (*codptr != ')') {
4305:
4306: if (*codptr == ':') {
4307: codptr++;
4308: j++;
4309:
4310: continue;
4311: }
4312:
4313: expr (STRING);
4314:
4315: if (merr () > OK) {
4316: setpiece = FALSE;
4317: goto err;
4318: }
4319:
4320: switch (j) {
4321:
4322: case 1:
4323: i = intexpr (argptr);
4324:
4325: if (i < 0) i = 0;
4326: if (i > 255) i = 255;
4327:
4328: RightMargin = i;
4329: break;
4330:
4331: case 3:
4332: i = intexpr (argptr);
4333:
4334: if (i < 0) i = 0;
4335: if (i > 255) i = 255;
4336:
4337: InFieldLen = i;
4338: break;
4339:
4340: case 5:
4341: DSW = intexpr (argptr);
4342: break;
4343:
4344: case 7:
4345: i = intexpr (argptr);
4346: ypos[HOME] = i / 256;
4347: xpos[HOME] = i % 256;
4348:
4349: if (DSW & BIT7) {
4350:
4351: i = io;
4352: io = HOME;
4353: argptr[0] = ESC;
4354: argptr[1] = '[';
4355: argptr[2] = EOL;
4356:
4357: if (ypos[HOME]) {
4358: intstr (&argptr[2], ypos[HOME] + 1);
4359: }
4360:
4361: if (xpos[HOME]) {
4362: tmp3[0] = ';';
4363:
4364: intstr (&tmp3[1], xpos[HOME] + 1);
4365: stcat (argptr, tmp3);
4366: }
4367:
4368: stcat (argptr, "H\201");
4369: write_m (argptr);
4370:
4371: io = i;
4372: }
4373: break;
4374:
4375: case 9:
4376: i = 0;
4377: j = 0;
4378:
4379: while ((ch = argptr[i++]) != EOL) LineTerm[j++] = ch;
4380:
4381: LineTerm[j] = EOL;
4382: break;
4383:
4384: case 10:
4385: BrkKey = (*argptr);
4386:
4387: /* make new break active */
4388: set_io (UNIX);
4389: set_io (MUMPS);
4390: }
4391: }
4392:
4393: setpiece = FALSE;
4394: codptr++;
4395:
4396: break;
4397: }
4398: else if (*codptr == ':') {
4399: codptr++;
4400:
4401: if (io == HOME) { /* old syntax: enable/disable echo */
4402: expr (STRING);
4403:
4404: if (merr () > OK) goto err;
4405:
4406: if (tvexpr (argptr)) {
4407: DSW &= ~BIT0;
4408: }
4409: else {
4410: DSW |= BIT0;
4411: }
4412:
4413: }
4414: else {
4415:
4416: if (*codptr == '(') {
4417: codptr++;
4418: setpiece = TRUE;
4419: }
4420:
4421: j = 1;
4422:
4423: while (*codptr != ')') {
4424:
4425: if (*codptr == ':') {
4426: codptr++;
4427: j++;
4428:
4429: continue;
4430: }
4431: else if (setpiece == FALSE) {
4432: merr_raise (SPACER);
4433: goto err;
4434: }
4435:
4436: expr (STRING);
4437:
4438: if (merr () > OK) {
4439: setpiece = FALSE;
4440: goto err;
4441: }
4442:
4443: switch (j) {
4444:
4445: case 1:
4446: fseek (opnfile[io], (long) intexpr (argptr), 0);
4447: break;
4448:
4449: case 2:
1.8 snw 4450: frm_crlf[io] = tvexpr (argptr);
1.1 snw 4451: break;
4452:
4453: case 3:
4454: fm_nodelay[io] = tvexpr (argptr);
4455: break;
4456: }
4457:
4458: if (setpiece == FALSE) break;
4459: }
4460:
4461: if (setpiece) {
4462: codptr++;
4463: setpiece = FALSE;
4464: }
4465:
4466: break;
4467: }
4468: }
4469: break;
4470:
4471:
4472: use_socket:
4473: {
4474: char use_parm[256];
4475: int upct = 0;
4476:
4477: if (*codptr == ':') {
4478: codptr++;
4479: }
4480: else {
4481: while ((ch = *(codptr++)) != SP && ch != EOL);
4482: codptr--;
4483: break;
4484: }
4485:
4486: if (*codptr != '/') {
4487: merr_raise (ARGLIST);
4488: goto err;
4489: }
4490:
4491: codptr++;
4492:
4493: while ((ch = *codptr++) != SP && ch != EOL && isalpha (ch)) {
4494: use_parm[upct++] = ch;
4495: }
4496:
4497: use_parm[upct] = NUL;
4498:
4499: for (upct = 0; upct < strlen (use_parm); upct++) {
4500: use_parm[upct] = toupper (use_parm[upct]);
4501: }
4502:
4503: if (strcmp (use_parm, "CONNECT") == 0) {
4504:
4505: msck_connect (io);
4506:
4507: if (merr () > OK) goto err;
4508:
4509: }
4510: else if (strcmp (use_parm, "BIND") == 0) {
4511: write_m("BIND\r\n\201");
4512: }
4513: else {
4514: merr_raise (ARGLIST);
4515: goto err;
4516: }
4517:
4518: break;
4519:
4520: }
4521:
4522: case OPEN:
4523:
4524: {
4525: short k;
4526:
4527: if (*codptr == SP || *codptr == EOL) {
4528: merr_raise (FILERR);
4529: goto err;
4530: }
4531:
4532: expr (STRING);
4533: k = intexpr (argptr);
4534:
4535: if (merr () > OK) goto err;
4536:
4537:
4538: if (k < 0 || k > MAXDEV) {
4539: merr_raise (NODEVICE);
4540: goto err;
4541: }
4542:
4543: if (k > MAXSEQ) goto open_socket;
4544:
4545: if (restricted_mode) {
4546: merr_raise (NOSTAND);
4547: goto err;
4548: }
4549:
4550: /* need to evaluate the following 6 lines carefully - smw 2023-10-15 */
4551: if (k != HOME) {
1.8 snw 4552: frm_crlf[k] = FALSE;
1.1 snw 4553: fm_nodelay[k] = FALSE;
4554: xpos[k] = 0;
4555: ypos[k] = 0;
4556: }
4557:
4558: /* OPEN implies a previous CLOSE on same channel */
4559: if ((k != HOME) && devopen[k]) {
4560:
4561: fclose (opnfile[k]);
4562: devopen[k] = 0;
4563:
4564: if (io == k) io = HOME;
4565: }
4566:
4567: /* process device parameters on HOME at USE command. */
4568: if (k == HOME && *codptr == ':' && *(codptr + 1) == '(') goto use0;
4569:
4570: if (*codptr != ':') {
4571:
4572: if (k == HOME) break;
4573:
4574: if (dev[k][0] == EOL) {
4575: merr_raise (FILERR);
4576: merr_set_iochan_err (k, FILERR, "file not found");
4577: goto err;
4578: }
4579:
4580: goto open10;
4581: }
4582:
4583: codptr++;
4584:
4585: if (k == HOME) {
4586:
4587: if (*codptr != ':') { /* turn echo on/off */
4588:
4589: expr (STRING);
4590:
4591: if (merr () > OK) goto err;
4592:
4593: if (tvexpr (argptr)) {
4594: DSW &= ~BIT0;
4595: }
4596: else {
4597: DSW |= BIT0;
4598: }
4599: }
4600:
4601: if (*codptr == ':') { /* dummy timeout on HOME */
4602: codptr++;
4603:
4604: if (*codptr != SP && *codptr != EOL) {
4605: expr (STRING);
4606:
4607: if (merr () > OK) goto err;
4608:
4609: test = TRUE;
4610: break;
4611: }
4612: else {
4613: merr_raise (INVEXPR);
4614: goto err;
4615: }
4616: }
4617: }
4618: else {
4619: int op_pos;
4620:
4621: expr (STRING);
4622:
4623: if (merr () > OK) goto err;
4624:
4625: stcpy (dev[k], argptr);
4626: frm_timeout = (-1L);
4627:
4628: if (*codptr == ':') {
4629:
4630: codptr++;
4631:
4632: expr (STRING);
4633: frm_timeout = intexpr (argptr);
4634:
4635: if (merr () > OK) goto err;
4636: if (frm_timeout < 0L) frm_timeout = 0L;
4637: }
4638:
4639: open10:
4640:
4641: j = stcpy (tmp, dev[k]);
4642: i = dev[k][j - 1];
4643:
4644: while (--j >= 0) {
4645: if (dev[k][j] == '/') break;
4646: }
4647:
4648: stcpy (tmp2, dev[k]);
4649:
4650: if (j <= 0) {
4651: tmp2[stlen (tmp2)] = NUL;
4652: tmp[1] = 'r';
4653: i = '+';
4654: }
4655: else { /* default is read+write */
4656: tmp2[j] = NUL;
4657:
4658: j = stcpy (&tmp[1], &tmp[j + 1]);
4659:
4660: tmp[0] = SP;
4661: tmp[j + 1] = SP;
4662: tmp[j + 2] = EOL;
4663:
4664: j = 0;
4665:
4666: while ((ch = tmp[++j]) != EOL) if (ch >= 'A' && ch <= 'Z') tmp[j] = ch + 32;
4667:
4668: if (find (" r w a r+ w+ a+ read write append read+ write+ append+ \201", tmp) == FALSE) {
4669: tmp[1] = 'r';
4670: i = '+';
4671:
4672: tmp2[strlen (tmp2)] = '/';
4673: }
4674: }
4675:
4676: tmp[0] = tmp[1];
4677: tmp[1] = NUL; /* NUL not EOL !!! */
4678:
4679: if (i == '+') {
4680: tmp[1] = i;
4681: tmp[2] = NUL;
4682: }
4683:
4684: op_pos = 0;
4685:
4686: open20:
4687:
4688: if (oucpath[op_pos] != EOL) {
4689:
4690: j = stlen (dev[k]);
4691:
4692: while (--j >= 0) if (dev[k][j] == '/') break;
4693: while (--j >= 0) if (dev[k][j] == '/') break;
4694:
4695: if (j < 0) {
4696:
4697: strcpy (tmp3, tmp2);
4698: stcpy (tmp2, &oucpath[op_pos]);
4699:
4700: j = 0;
4701: while (tmp2[j] != ':' && tmp2[j] != EOL) j++;
4702:
4703: tmp2[j] = EOL;
4704:
4705: stcpy (act_oucpath[k], tmp2);
4706: op_pos += j;
4707:
4708: if (j) tmp2[j++] = '/';
4709:
4710: strcpy (&tmp2[j], tmp3);
4711: }
4712: }
4713:
4714: /* r = READ only access;
4715: * w = WRITE new file;
4716: * a = WRITE append;
4717: * r+ = READ/WRITE access;
4718: * w+ = WRITE new file;
4719: * a+ = WRITE append;
4720: */
4721: j = tmp[0];
4722: sq_modes[k] = j;
4723:
4724: if (j == 'r' && tmp[1] == '+') {
4725: sq_modes[k] = '+';
4726: }
4727:
4728: if (j == 'r' && frm_timeout < 0L) {
4729:
4730: errno = 0;
4731:
4732: while ((opnfile[k] = fopen (tmp2, tmp)) == NULL) {
4733:
4734: if (errno == EINTR) {
4735: errno = 0;
4736: continue;
4737: } /* interrupt */
4738:
4739: if (errno == EMFILE || errno == ENFILE) {
4740: close_all_globals ();
4741: continue;
4742: }
4743:
4744: if (dev[k][0] != '/' && oucpath[op_pos++] != EOL) {
4745: strcpy (tmp2, tmp3);
4746: goto open20;
4747: }
4748:
4749: act_oucpath[k][0] = EOL;
4750: merr_raise ((errno == ENOENT ? FILERR : PROTECT));
4751:
4752: switch (merr ()) {
4753:
4754: case FILERR:
4755: merr_set_iochan_err (k, FILERR, "file not found");
4756: break;
4757:
4758: case PROTECT:
4759: merr_set_iochan_err (k, PROTECT, "file protection violation");
4760: break;
4761:
4762: }
4763:
4764: goto err;
4765: }
4766:
4767: ssvn_job_add_device (k, tmp2);
4768:
4769: devopen[k] = ((i == '+') ? i : j);
4770: break;
4771: }
4772:
4773: if (j == 'r' || j == 'w' || j == 'a') {
4774:
4775: if (frm_timeout >= 0L) {
4776:
4777: test = TRUE;
4778:
4779: if (setjmp (sjbuf)) {
4780: test = FALSE;
4781: goto endopn;
4782: }
4783:
4784: sig_attach (SIGALRM, &ontimo);
4785: alarm ((unsigned) (frm_timeout < 3 ? 3 : frm_timeout));
4786: }
4787:
4788: for (;;) {
4789: errno = 0;
4790:
4791: if ((opnfile[k] = fopen (tmp2, tmp)) != NULL) break;
4792: if (merr () == INRPT) goto err;
4793: if (errno == EINTR) continue; /* interrupt */
4794:
4795: if (errno == EMFILE || errno == ENFILE) {
4796: close_all_globals ();
4797: continue;
4798: }
4799:
4800: if (frm_timeout < 0L) {
4801:
4802: if (dev[k][0] != '/' && oucpath[op_pos++] != EOL) {
4803: strcpy (tmp2, tmp3);
4804: goto open20;
4805: }
4806:
4807: if (errno == ENOENT) continue;
4808:
4809: act_oucpath[k][0] = EOL;
4810: merr_raise (PROTECT);
4811:
4812: merr_set_iochan_err (k, PROTECT, "file protection violation");
4813:
4814: goto err;
4815: }
4816:
4817: if (frm_timeout == 0L) {
4818: test = FALSE;
4819: goto endopn;
4820: }
4821:
4822: sleep (1);
4823: frm_timeout--;
4824: }
4825:
4826: devopen[k] = ((i == '+') ? i : j);
4827: endopn:;
4828:
4829: alarm (0); /* reset alarm request */
4830: }
4831: else {
4832: merr_raise (ARGLIST);
4833: merr_set_iochan_err (k, ARGLIST, "invalid argument");
4834: goto err;
4835: }
4836: }
4837:
4838:
4839: open_socket:
4840: if (*codptr != ':') {
4841: if (j == 'w') {
4842: merr_raise (FILEXWR);
4843: merr_set_iochan_err (k, FILEXWR, "cannot open existing file for WRITE");
4844: }
4845: else {
4846: merr_raise (ARGLIST);
4847: merr_set_iochan_err (k, ARGLIST, "invalid argument");
4848: }
4849: goto err;
4850: }
4851:
4852: codptr++;
4853: expr (STRING);
4854:
4855: if (merr () > OK) goto err;
4856:
4857:
4858: stcpy (vn, argptr);
4859: stcnv_m2c (vn);
4860:
4861: msck_open (k, vn);
4862:
4863: if (merr () > OK) goto err;
4864:
4865: ssvn_job_add_device (k, vn);
4866:
4867: break;
4868: }
4869: break;
4870:
4871:
4872:
4873:
4874:
4875: case CLOSE:
4876:
4877: /* no arguments: close all exept HOME */
4878: if (*codptr == SP || *codptr == EOL) {
4879:
4880: if (rtn_dialect () != D_FREEM) {
4881: merr_raise (NOSTAND);
4882: break;
4883: }
4884:
4885: j = 1;
4886:
4887: while (j <= MAXDEV) {
4888:
4889: if (j < FIRSTSCK) {
4890: if (jour_flag && (j == 2)) {
4891: j++;
4892: continue;
4893: }
4894:
4895: if (devopen[j]) fclose (opnfile[j]);
4896:
4897: ssvn_job_remove_device (j);
4898:
4899: devopen[j++] = 0;
4900: }
4901: else {
4902: msck_close (j++);
4903: }
4904:
4905: }
4906:
4907: io = HOME;
4908: break;
4909: }
4910:
4911: expr (STRING);
4912: j = intexpr (argptr);
4913:
4914: if (merr () > OK) break;
4915:
4916: if (j >= FIRSTSCK && j < MAXDEV) {
4917: msck_close (j);
4918: ssvn_job_remove_device (j);
4919: break;
4920: }
4921:
4922: /*ignore close on illgal units */
4923: if ((j >= 0 && j <= MAXDEV && j != HOME) && (jour_flag == 0 || (j != 2))) { /*ignore close on protocol channel */
4924:
4925: if (devopen[j]) fclose (opnfile[j]);
4926:
4927: devopen[j] = 0;
4928:
4929: ssvn_job_remove_device (j);
4930:
4931: if (io == j) io = HOME;
4932:
4933: }
4934:
4935: /* parse any 'device parameters', but ignore them otherwise */
4936: if (*codptr == ':') {
4937: if (*++codptr != '(') {
4938: expr (STRING);
4939: }
4940: else {
4941: setpiece = TRUE; /* to avoid bracket error at end of deviceparameters */
4942: for (;;)
4943: {
4944: if (*++codptr != ':')
4945: expr (STRING);
4946: if (*codptr == ':')
4947: continue;
4948: if (*codptr++ != ')')
4949: merr_raise (ARGER);
4950: break;
4951: }
4952: setpiece = FALSE;
4953: }
4954: }
4955:
4956: break;
4957:
4958: case ZHALT: /* ZHALT */
4959:
4960: if (is_standard ()) {
4961: merr_raise (NOSTAND);
4962: goto err;
4963: }
4964:
4965: case HA: /* HALT or HANG */
4966:
4967:
4968: /* no arguments: HALT */
4969: if (*codptr == SP || *codptr == EOL || mcmnd == ZHALT) {
4970:
4971: if (mcmnd == ZHALT && *codptr != SP && *codptr != EOL) {
4972: expr (STRING);
4973: i = intexpr (argptr);
4974:
4975: if (merr () > OK) break;
4976: }
4977: else {
1.22 snw 4978: halt:
4979: i = 0;
1.1 snw 4980: }
4981:
4982: cleanup ();
4983:
4984: if (father) { /* advertise death to parent *//* make sure father is waiting !!! */
4985: if ((time (0L) - jobtime) < 120) sleep (2);
4986:
4987: kill (father, SIGUSR1);
4988: }
4989:
4990: exit (i); /* terminate mumps */
4991: };
4992: /* with arguments: HANG */
4993:
4994:
4995: case HANG: /* HANG */
4996:
4997: {
4998: unsigned long int waitsec;
4999: int millisec;
5000:
5001: #ifdef USE_GETTIMEOFDAY
5002: struct timeval timebuffer;
5003: #else
5004: struct timeb timebuffer;
5005: #endif
5006:
5007: expr (STRING);
5008: numlit (argptr);
5009:
5010: if (merr () > OK) break;
5011:
5012: #if !defined(__linux__)
5013: if (argptr[0] == '-') break; /* negative values without effect */
5014: if (argptr[0] == '0') break; /* zero without effect */
5015: #else
5016: /* on linux, return scheduler timeslice to kernel scheduler for hang 0 and hang with negative values
5017: for compatibility with Reference Standard M, only when process is using a realtime scheduling policy */
5018: if ((argptr[0] == '-') || (argptr[0] == '0')) {
5019: int policy;
5020:
5021: policy = sched_getscheduler (0);
5022: if ((policy == -1) || ((policy != SCHED_FIFO) && (policy != SCHED_RR))) break;
5023:
5024: sched_yield ();
5025: }
5026: #endif
5027:
5028: waitsec = 0;
5029: millisec = 0;
5030: i = 0;
5031:
5032: for (;;) { /* get integer and fractional part */
5033:
5034: if ((ch = argptr[i++]) == EOL) break;
5035:
5036: if (ch == '.') {
5037: millisec = (argptr[i++] - '0') * 100;
5038:
5039: if ((ch = argptr[i++]) != EOL) {
5040: millisec += (ch - '0') * 10;
5041:
5042: if ((ch = argptr[i]) != EOL) {
5043: millisec += (ch - '0');
5044: }
5045: }
5046:
5047: break;
5048: }
5049:
5050: waitsec = waitsec * 10 + ch - '0';
5051: }
5052:
5053: if ((i = waitsec) > 2) i -= 2;
5054:
5055: #ifdef USE_GETTIMEOFDAY
5056: gettimeofday (&timebuffer, NULL); /* get current time */
5057:
5058: waitsec += timebuffer.tv_sec; /* calculate target time */
5059: millisec += timebuffer.tv_usec;
5060: #else
5061: ftime (&timebuffer); /* get current time */
5062:
5063: waitsec += timebuffer.time; /* calculate target time */
5064: millisec += timebuffer.millitm;
5065: #endif
5066:
5067: if (millisec >= 1000) {
5068: waitsec++;
5069: millisec -= 1000;
5070: }
5071:
5072: /* do the bulk of the waiting with sleep() */
5073: while (i > 0) {
5074: j = time (0L);
5075: sleep ((unsigned) (i > 32767 ? 32767 : i)); /* sleep max. 2**15-1 sec */
5076: i -= time (0L) - j; /* subtract actual sleeping time */
5077:
5078: if (merr () == INRPT) goto err;
5079:
5080: if (evt_async_enabled && (merr () == ASYNC)) goto err;
5081: }
5082:
5083: /* do the remainder of the waiting watching the clock */
5084: for (;;) {
5085:
5086: #ifdef USE_GETTIMEOFDAY
5087:
5088: gettimeofday (&timebuffer, NULL);
5089:
5090: if (timebuffer.tv_sec > waitsec) break;
5091: if (timebuffer.tv_sec == waitsec && timebuffer.tv_usec >= millisec) break;
5092: #else
5093: ftime (&timebuffer);
5094:
5095: if (timebuffer.time > waitsec) break;
5096: if (timebuffer.time == waitsec && timebuffer.millitm >= millisec) break;
5097: #endif
5098: if (merr () == INRPT) goto err;
5099:
5100: }
5101: }
5102: break;
5103:
5104:
5105: case HALT: /* HALT */
5106:
5107: if (*codptr == SP || *codptr == EOL) goto halt;
5108:
5109: merr_raise (ARGLIST);
5110: break;
5111:
5112:
5113: case BREAK:
5114:
5115:
5116: if (*codptr == SP || *codptr == EOL) {
5117:
5118: if (breakon == FALSE) break; /* ignore BREAK */
5119:
5120: if (usermode == 0) {
5121: merr_raise (BKERR);
5122: goto err;
5123: }
5124:
5125: zbflag = TRUE;
5126: merr_raise (OK - CTRLB);
5127: zb_entry:loadsw = TRUE;
5128:
5129: #ifdef DEBUG_NEWSTACK
5130: printf ("CHECK 08 (Stack PUSH)\r\n");
5131: #endif
5132:
5133:
5134:
5135: if (++nstx > NESTLEVLS) {
5136: nstx--;
5137: merr_raise (STKOV);
5138:
5139: goto err;
5140: }
5141: else {
5142: estack++;
5143: }
5144:
5145: nestc[nstx] = BREAK;
5146:
5147: #ifdef DEBUG_NEWSTACK
5148:
5149: if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
5150:
5151: #endif
5152:
5153: nestp[nstx] = cmdptr; /* command stack address */
5154: nestn[nstx] = 0; /*!!! save name */
5155: nestr[nstx] = roucur - rouptr; /* save roucur */
5156: nestnew[nstx] = 0;
5157: ztrap[nstx][0] = EOL;
5158: nestlt[nstx] = level;
5159: level = 0; /* save level */
5160: /* save BREAK information */
5161: brkstk[nstx] = (((ECHOON ? 1 : 0) << 1) | test) << 3 | io;
5162:
5163: io = HOME;
5164: forsw = FALSE;
5165: cmdptr += stcpy (cmdptr, codptr) + 1;
5166: zerr = BKERR;
5167: goto restart;
5168: }
5169:
5170: if (is_standard ()) {
5171: merr_raise (NOSTAND);
5172: goto err;
5173: }
5174:
5175: expr (STRING);
5176: if (merr () > OK) break;
5177:
1.18 snw 5178: {
5179: char brkstr[256];
5180:
5181: stcpy (brkstr, argptr);
5182: stcnv_m2c (brkstr);
5183:
5184: if (strcmp (brkstr, "DEBUG") == 0) {
5185: debug_mode = TRUE;
5186: }
5187: else {
5188: switch (intexpr (argptr)) {
5189:
5190: case 2:
5191: DSM2err = TRUE;
5192: break; /* enable DSM V 2 error processing */
5193:
5194: case -2:
5195: DSM2err = FALSE;
5196: break; /* enable normal error processing */
5197:
5198: case 0:
5199: breakon = FALSE;
5200: break; /* disable CTRL/C */
5201:
5202: default:
5203: breakon = TRUE;
5204: break; /* enable CTRL/C */
5205: }
5206: }
1.1 snw 5207: }
1.18 snw 5208:
1.1 snw 5209: break;
5210:
5211: case VIEW:
5212:
5213: view_com ();
5214:
5215: if (repQUIT) { /* VIEW 26: repeated QUIT action */
5216:
5217: while (repQUIT-- > 0) {
5218:
5219: #ifdef DEBUG_NEWSTACK
5220: printf ("CHECK 09 (Stack POP)\r\n");
5221: #endif
5222:
5223: if (nestc[nstx] == BREAK) {
5224: if (repQUIT) continue;
5225: merr_raise (OK - CTRLB);
5226:
5227: goto zgo; /*cont. single step */
5228: }
5229:
5230: if (nestc[nstx] == FOR) {
5231:
5232: stcpy (code, cmdptr = nestp[nstx--]);
5233: estack--;
5234:
5235: codptr = code;
5236: ftyp = fortyp[--forx];
5237: fvar = forvar[forx];
5238: finc = forinc[forx];
5239: flim = forlim[forx];
5240: fi = fori[forx];
5241:
5242: if (repQUIT) continue;
5243: if ((forsw = (nestc[nstx] == FOR))) goto for_end;
5244:
5245: goto next_line;
5246: }
5247:
5248: if (nestn[nstx]) { /* reload routine */
5249: namptr = nestn[nstx];
5250:
5251: if ((nestc[nstx] != XECUTE) || loadsw) {
5252: stcpy (rou_name, namptr);
5253: zload (rou_name);
5254:
5255: ssvn_job_update ();
5256:
5257: dosave[0] = 0;
5258: }
5259:
5260: namptr--;
5261: }
5262:
5263: if (nestnew[nstx]) unnew (); /* un-NEW variables */
5264:
5265: /* restore old pointers */
5266: if ((mcmnd = nestc[nstx]) == BREAK) {
5267: if (repQUIT) continue;
5268:
5269: goto restore;
5270: } /*cont. single step */
5271:
5272: if (mcmnd == DO_BLOCK) {
5273: test = nestlt[nstx];
5274: level--;
5275: }
5276: else { /* pop $TEST */
5277: level = nestlt[nstx]; /* pop level */
5278: }
5279:
5280: roucur = nestr[nstx] + rouptr;
5281: stcpy (codptr = code, cmdptr = nestp[nstx--]);
5282: estack--;
5283: forsw = (nestc[nstx] == FOR);
5284:
5285:
5286: loadsw = TRUE;
5287:
5288: if (mcmnd == '$') {
5289: if (repQUIT) return 0;
5290: merr_raise (NOVAL);
5291: }
5292: }
5293: repQUIT = 0;
5294: }
5295: break;
5296:
5297: /* Z-COMMANDS */
1.25 snw 5298: case ZEDIT:
5299: merr_raise (cmd_zedit (&ra));
5300: MRESCHECK(ra);
5301: break;
5302:
1.1 snw 5303: case ZGO:
5304:
5305: /* ZGO with arguments: same as GOTO but with BREAK on */
5306: if (*codptr != EOL && *codptr != SP) {
5307: mcmnd = GOTO;
5308: zbflag = TRUE;
5309: merr_raise (OK - CTRLB);
5310:
5311: goto do_goto;
5312: }
5313:
5314: /* argumentless ZGO resume execution after BREAK */
5315:
5316: if (nestc[nstx] != BREAK) {
5317: merr_raise (LVLERR);
5318: break;
5319: }
5320:
5321:
5322:
5323: merr_clear (); /* stop BREAKing */
5324:
5325: zgo:
5326:
5327: #ifdef DEBUG_NEWSTACK
5328: printf ("Zgoing: (Stack POP)\r\n");
5329: #endif
5330:
5331:
5332:
5333: if (nestn[nstx]) { /* reload routine */
5334: stcpy (rou_name, (namptr = nestn[nstx]));
5335: zload (rou_name);
5336:
5337: ssvn_job_update ();
5338:
5339: if (merr () > OK) break;
5340: }
5341:
5342: level = nestlt[nstx];
5343: roucur = nestr[nstx] + rouptr;
5344: io = brkstk[nstx];
5345:
5346: if (io & 020) {
5347: DSW &= ~BIT0;
5348: }
5349: else {
5350: DSW |= BIT0; /* restore echo state */
5351: }
5352:
5353: test = (io & 010) >> 3; /* restore $TEST */
5354:
5355: /* restore $IO; default to HOME if channel not OPEN */
5356: if ((io &= 07) != HOME && devopen[io] == 0) io = HOME;
5357:
5358: stcpy (codptr = code, cmdptr = nestp[nstx--]);
5359: estack--;
5360:
5361: forsw = (nestc[nstx] == FOR);
5362:
5363:
5364: loadsw = TRUE;
5365: zbflag = FALSE;
5366:
5367: goto next0;
5368:
5369:
5370: case ZBREAK:
5371:
5372: if (*codptr == SP || *codptr == EOL) {
5373: merr_raise (ARGLIST);
5374: break;
5375: }
5376:
5377: expr (STRING);
5378: if (merr () > OK) break;
5379:
5380: zbreakon = tvexpr (argptr);
5381: if (hardcopy == DISABLE) set_zbreak (zbreakon ? STX : -1); /* enable/disable CTRL/B */
5382:
5383: zbflag = FALSE;
5384: break;
5385:
5386:
5387:
5388:
5389: case ZLOAD:
5390:
5391: if (*codptr == EOL || *codptr == SP) {
5392: stcpy (varnam, rou_name);
5393: }
5394: else {
5395: expr (NAME);
5396:
5397: if (merr () > OK) break;
5398:
5399: codptr++;
5400: }
5401:
5402: dosave[0] = EOL;
5403:
5404: if (varnam[0] == EOL) {
5405: varerr[0] = EOL;
5406: merr_raise (NOPGM);
5407: break;
5408: } /*error */
5409:
5410: loadsw = TRUE;
5411:
5412: /* a ZLOAD on the active routine always loads from disk */
5413: if (stcmp (varnam, rou_name) == 0) {
5414: for (i = 0; i < NO_OF_RBUF; i++) {
5415:
5416: if (rouptr == (buff + (i * PSIZE0))) {
5417: pgms[i][0] = EOL;
5418:
5419: break;
5420: }
5421: }
5422: }
5423:
5424: zload (varnam);
5425:
5426: if (merr () > OK) break; /* load file */
5427:
5428: stcpy (rou_name, varnam);
5429: ssvn_job_update ();
5430:
5431: break;
5432:
5433: case ZSAVE:
5434:
5435: if (*codptr == EOL || *codptr == SP) {
5436:
5437: if (rou_name[0] == EOL) {
5438: varerr[0] = EOL;
5439: merr_raise (NOPGM);
5440:
5441: break;
1.26 ! snw 5442: } /* error */
1.1 snw 5443:
5444: stcpy (varnam, rou_name);
5445: }
5446: else {
5447: expr (NAME);
5448:
5449: if (varnam[0] == '^') merr_raise (GLOBER);
5450: if (varnam[0] == '$') merr_raise (INVREF);
5451: if (merr () > OK) break;
5452:
5453: stcpy (rou_name, varnam);
5454: ssvn_job_update ();
5455:
5456: codptr++;
5457: }
5458:
5459: zsave (varnam);
5460: break;
5461:
5462:
5463: case ZREMOVE:
5464:
5465: {
5466: char *beg, *end;
5467:
5468: dosave[0] = EOL;
5469:
5470: if (*codptr == SP || *codptr == EOL) { /* no args is ZREMOVE all */
5471: loadsw = TRUE;
5472:
5473: for (i = 0; i < NO_OF_RBUF; i++) {
5474:
5475: if (rouptr == buff + (i * PSIZE0)) {
5476: pgms[i][0] = EOL;
5477: break;
5478: }
5479:
5480: }
5481:
5482: rouptr = buff + (i * PSIZE0);
5483: rouend = rouins = rouptr;
5484: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
5485:
5486: *(rouptr) = EOL;
5487: *(rouptr + 1) = EOL;
5488: *(rouptr + 2) = EOL;
5489:
5490: argptr = partition;
5491: rou_name[0] = EOL;
5492:
5493: ssvn_job_update ();
5494:
5495: break;
5496: }
5497: if (*codptr == ':') {
5498: beg = rouptr;
5499: }
5500: else if (*codptr == '*') {
5501: beg = rouptr;
5502:
5503: while ((end = (beg + UNSIGN (*beg) + 2)) < rouins) beg = end;
5504:
5505: codptr++;
5506: }
5507: else {
5508: lineref (&beg);
5509: if (merr () > OK) break;
5510: }
5511:
5512: if ((end = beg) == 0) {
5513: merr_raise (M13);
5514: break;
5515: }
5516:
5517: if (*codptr == ':') { /* same as above */
5518: codptr++;
5519:
5520: if (*codptr == '*') {
5521: end = rouins;
5522: codptr++;
5523: }
5524: else if (*codptr == ',' || *codptr == SP || *codptr == EOL) {
5525: end = rouend;
5526: }
5527: else {
5528: lineref (&end);
5529:
5530: if (end == 0) merr_raise (M13);
5531: if (merr () > OK) break;
5532:
5533: end = end + UNSIGN (*end) + 2;
5534: }
5535: }
5536: else {
5537: end = end + UNSIGN (*end) + 2;
5538: }
5539:
5540: if (beg < rouend) { /* else there's nothing to zremove */
5541:
5542: if (end >= rouend) {
5543: end = rouend = beg;
5544: }
5545: else {
5546: rouins = beg;
5547:
5548: while (end <= rouend) *beg++ = (*end++);
5549:
5550: i = beg - end;
5551: rouend += i;
5552:
5553: if (roucur > end) roucur += i;
5554: }
5555:
5556: *end = EOL;
5557: *(end + 1) = EOL;
5558:
5559: for (i = 0; i < NO_OF_RBUF; i++) {
5560: if (rouptr == (buff + (i * PSIZE0))) {
5561: ends[i] = rouend;
5562: break;
5563: }
5564: }
5565:
5566: }
5567: break;
5568: }
5569:
5570: case ZINSERT:
5571:
5572: {
5573: char *beg;
5574:
5575: if (*codptr == EOL || *codptr == SP) {
5576: merr_raise (ARGLIST);
5577: break;
1.26 ! snw 5578: } /* error */
1.1 snw 5579:
5580: dosave[0] = EOL;
5581:
1.26 ! snw 5582: /* parse strlit */
1.1 snw 5583: expr (STRING);
5584:
5585: if (merr () > OK) break;
5586:
5587: if (*codptr != ':') {
5588: zi (argptr, rouins);
5589: break;
5590: }
5591:
5592: stcpy (tmp, argptr);
5593: codptr++;
5594: lineref (&beg);
5595:
5596: if (merr () > OK) break; /* parse label */
5597:
5598: if (beg) {
5599: beg = beg + UNSIGN (*beg) + 2;
5600: }
5601: else {
5602: beg = rouptr;
5603: }
5604:
5605: if (beg > rouend + 1) {
5606: merr_raise (M13);
5607: break;
5608: }
5609:
5610: /* insert stuff */
5611: zi (tmp, beg);
5612: break;
5613: }
5614:
5615:
5616: /* PRINT is convenient -
5617: * but non-standard ZPRINT should be used instead */
5618: case 'p':
5619:
5620: if (is_standard ()) {
5621: merr_raise (NOSTAND);
5622: break;
5623: }
5624:
5625:
5626: case ZPRINT:
5627:
5628: {
5629: char *beg, *end;
5630:
5631: if (*codptr == SP || *codptr == EOL) { /* no args is ZPRINT all */
5632: beg = rouptr;
5633: end = rouend;
5634: }
5635: else {
5636: if (*codptr == ':') {
5637: beg = rouptr; /* from begin */
5638: }
5639: else if (*codptr == '*') { /* from 'linepointer' */
5640: beg = rouptr;
5641:
5642: while ((end = (beg + UNSIGN (*beg) + 2)) < rouins) beg = end;
5643: codptr++;
5644: }
5645: else {
5646: lineref (&beg);
5647: if (merr () > OK) break;
5648: } /* line reference */
5649:
5650: if (beg == 0) {
5651: beg = rouptr;
5652: rouins = beg;
5653:
5654: if (*codptr != ':') break;
5655: }
5656:
5657: if (*codptr == ':') {
5658: codptr++; /* to end */
5659:
5660: if (*codptr == SP || *codptr == ',' || *codptr == EOL)
5661: end = rouend;
5662: else {
5663: if (*codptr == '*') {
5664: end = rouins;
5665: codptr++;
5666: }
5667: else { /* to 'linepointer' */
5668: lineref (&end);
5669:
5670: if (merr () > OK) break; /* line reference */
5671: end = end + UNSIGN (*end) + 2;
5672: }
5673: }
5674: }
5675: else {
5676: end = beg + 1;
5677: }
5678: }
5679: if (rouend < end) end = rouend - 1;
5680:
5681: for (; beg < end; beg += UNSIGN (*beg) + 2) {
5682:
1.8 snw 5683: if (frm_crlf[io]) {
1.1 snw 5684: write_m ("\012\201");
5685: }
5686: else {
5687: write_m ("\012\015\201");
5688: }
5689:
5690: if ((*(beg + 1)) == EOL) break;
5691:
5692: write_m (beg + 1);
5693: if (merr () > OK) break;
5694: }
5695:
5696: rouins = beg;
5697: }
5698:
1.8 snw 5699: if (frm_crlf[io]) {
1.1 snw 5700: write_m ("\012\201");
5701: }
5702: else {
5703: write_m ("\012\015\201");
5704: }
5705:
5706: break;
5707:
5708: case WATCH:
5709: {
5710: char op;
5711:
5712:
5713: if (((ch = *codptr) == SP) || ch == EOL) {
5714:
5715: set_io(UNIX);
5716:
5717: if (dbg_enable_watch) {
5718: printf ("Watchpoints disabled.\n");
5719: dbg_enable_watch = 0;
5720: }
5721: else {
5722: printf ("Watchpoints enabled.\n");
5723: dbg_enable_watch = 1;
5724: }
5725:
5726: break;
5727:
5728: }
5729:
5730: if ((ch = *codptr) == '(') {
5731: merr_raise (ARGLIST);
5732: goto err;
5733: }
5734:
5735: for (;;) {
5736:
5737: switch (ch) {
5738:
5739: case '?':
5740: case '+':
5741: case '-':
5742: op = ch;
5743: codptr++;
5744: break;
5745:
5746: default:
5747: merr_raise (ARGLIST);
5748: goto err;
5749: }
5750:
5751: expr (NAME); /* try to interpret an mname */
5752:
5753: if (merr () > OK) goto err;
5754:
5755: stcpy (vn, varnam);
5756:
5757: switch (op) {
5758:
5759: case '+':
5760: dbg_add_watch (vn);
5761: break;
5762:
5763: case '-':
5764: dbg_remove_watch (vn);
5765: break;
5766:
5767: case '?':
5768: dbg_dump_watch (vn);
5769: break;
5770:
5771: }
5772:
5773: if (merr () > OK) goto err;
5774:
5775: if ((ch = *(codptr + 1)) == EOL) {
5776: codptr++;
5777: break;
5778: }
5779: else if ((ch = *(codptr + 1)) == ',') {
5780: codptr += 2;
5781: ch = *codptr;
5782: }
5783: else {
5784: merr_raise (ARGLIST);
5785: goto err;
5786: }
5787: }
5788:
5789:
5790: break;
5791: }
5792:
5793:
5794: case ASSERT_TKN:
5795: {
5796: expr (STRING);
5797:
5798: if (merr () > OK) goto err;
5799:
5800: if (tvexpr (argptr) == 0) {
5801: merr_raise (ASSERT);
5802: goto err;
5803: }
5804:
5805: break;
5806: }
5807:
5808: case ZWRITE:
5809: {
5810: short k;
5811: char w_tmp[512];
5812: char zwmode;
5813:
5814:
5815: if (io != HOME && devopen[io] == 'r') {
5816: merr_raise (NOWRITE);
5817: goto err;
5818: }
5819:
5820: tmp3[0] = SP;
5821: tmp3[1] = EOL;
5822:
5823: if ((ch = (*codptr)) == '(') { /* exclusive zwrite */
5824:
5825: for (;;) {
5826:
5827: codptr++;
5828: expr (NAME);
5829:
5830: if (merr () > OK) goto err;
5831: if (varnam[0] == '^') {
5832: merr_raise (GLOBER);
5833: goto err;
5834: }
5835:
5836: i = 0;
5837:
5838: while (varnam[i] != EOL) {
5839:
5840: if (varnam[i] == DELIM) {
5841: merr_raise (SBSCR);
5842: goto err;
5843: }
5844:
5845: i++;
5846: }
5847:
5848: if (stcat (tmp3, varnam) == 0) {
5849: merr_raise (M75);
5850: goto err;
5851: }
5852:
5853: if (stcat (tmp3, " \201") == 0) {
5854: merr_raise (M75);
5855: goto err;
5856: }
5857:
5858: if ((ch = *++codptr) == ')') {
5859: codptr++;
5860: break;
5861: }
5862:
5863: if (ch != ',') {
5864: merr_raise (COMMAER);
5865: goto err;
5866: }
5867: }
5868: }
5869: else {
5870: if (ch != SP && ch != EOL) goto zwritep;
5871: }
5872:
5873: /* no arguments: write local symbol table. */
5874: stcpy (tmp, " $\201");
5875:
5876: for (;;) {
5877: ordercnt = 1L;
5878:
5879: symtab (bigquery, &tmp[1], tmp2);
5880:
5881: if (*tmp2 == EOL || merr () == INRPT) break;
5882: w_tmp[0] = '=';
5883:
5884: /* subscripts: internal format different from external one */
5885: k = 0;
5886: i = 1;
5887: j = 0;
5888:
5889: while ((ch = tmp2[k++]) != EOL) {
5890:
5891: if (ch == '"') {
5892:
5893: if (j && tmp2[k] == ch) {
5894: k++;
5895: }
5896: else {
5897: toggle (j);
5898: continue;
5899: }
5900:
5901: }
5902:
5903: if (j == 0) {
5904:
5905: if (ch == '(' || ch == ',') {
5906: tmp[i++] = DELIM;
5907:
5908: continue;
5909: }
5910:
5911: if (ch == ')') break;
5912: }
5913:
5914: tmp[i++] = ch;
5915: }
5916:
5917: tmp[i] = EOL;
5918: if (kill_ok (tmp3, tmp) == 0) continue;
5919:
5920: write_m (tmp2);
5921: symtab (get_sym, &tmp[1], &w_tmp[1]);
5922: write_m (w_tmp);
5923: write_m ("\012\015\201");
5924: }
5925:
5926: break;
5927:
5928: zwritep:
5929:
5930: expr (NAME);
5931:
5932: if (merr () > OK) goto err;
5933:
5934: codptr++;
5935:
5936: if (varnam[0] == '$') {
5937:
5938: if ((varnam[1] | 0140) == 'z' && (varnam[2] | 0140) == 'f') {
5939: w_tmp[0] = '$';
5940: w_tmp[1] = 'Z';
5941: w_tmp[2] = 'F';
5942: w_tmp[3] = '(';
5943:
5944: for (i = 0; i < 44; i++) {
5945:
5946: if (zfunkey[i][0] != EOL) {
5947: intstr (&w_tmp[4], i + 1);
5948: stcat (w_tmp, ")=\201");
5949: write_m (w_tmp);
5950: write_m (zfunkey[i]);
5951: write_m ("\012\015\201");
5952: }
5953:
5954: }
5955:
5956: break;
5957: }
5958: else {
5959: break; /* do not zwrite special variables etc. other than $ZF */
5960: }
5961: }
5962:
5963: if (varnam[0] != '^') {
1.9 snw 5964: symtab (fra_dat, varnam, tmp2);
1.1 snw 5965: zwmode = 'L';
5966: }
5967: else {
5968: if (varnam[1] == '$') {
1.9 snw 5969: ssvn (fra_dat, varnam, tmp2);
1.1 snw 5970: zwmode = '$';
5971: }
5972: else {
1.9 snw 5973: global (fra_dat, varnam, tmp2);
1.1 snw 5974: zwmode = '^';
5975: }
5976: }
5977:
5978: if (tmp2[0] == '0') break; /* variable not defined */
5979:
5980: /* if $D(@varnam)=10 get next entry */
5981: if (tmp2[1] == '0') {
5982: ordercnt = 1L;
5983:
5984: if (varnam[0] != '^') {
5985: symtab (fra_query, varnam, tmp2);
5986: zwmode = 'L';
5987: }
5988: else {
5989: if (varnam[1] == '$') {
5990: ssvn (fra_query, varnam, tmp2);
5991: zwmode = '$';
5992: }
5993: else {
5994: global (fra_query, varnam, tmp2);
5995: zwmode = '^';
5996: }
5997: }
5998: }
5999: else {
6000: k = 0;
6001: i = 0;
6002: j = 0;
6003:
6004: while ((ch = varnam[k++]) != EOL) {
6005:
6006: if (ch == DELIM) {
6007:
6008: if (j) {
6009: tmp2[i++] = '"';
6010: tmp2[i++] = ',';
6011: tmp2[i++] = '"';
6012:
6013: continue;
6014: }
6015:
6016: j++;
6017:
6018: tmp2[i++] = '(';
6019: tmp2[i++] = '"';
6020:
6021: continue;
6022: }
6023:
6024: if ((tmp2[i++] = ch) == '"')
6025: tmp2[i++] = ch;
6026: }
6027:
6028: if (j) {
6029: tmp[i++] = '"';
6030: tmp2[i++] = ')';
6031: }
6032:
6033: tmp2[i] = EOL;
6034: }
6035:
6036: for (;;) { /* subscripts: internal format different from external one */
6037: k = 0;
6038: i = 0;
6039: j = 0;
6040:
6041: while ((ch = tmp2[k++]) != EOL) {
6042:
6043: if (ch == '"') {
6044: if (j && tmp2[k] == ch)
6045: k++;
6046: else {
6047: toggle (j);
6048: continue;
6049: }
6050: }
6051:
6052: if (j == 0) {
6053:
6054: if (ch == '(' || ch == ',') {
6055: tmp[i++] = DELIM;
6056:
6057: continue;
6058: }
6059:
6060: if (ch == ')') break;
6061: }
6062:
6063: tmp[i++] = ch;
6064: }
6065:
6066: tmp[i] = EOL;
6067: i = 0;
6068:
6069: while (tmp[i] == varnam[i]) {
6070:
6071: if (varnam[i] == EOL) break;
6072:
6073: i++;
6074: }
6075:
6076: if (varnam[i] != EOL) break;
6077: if (tmp[i] != EOL && tmp[i] != DELIM) break;
6078:
6079: tmp3[0] = EOL;
6080:
6081: switch (zwmode) {
6082:
6083: case 'L':
1.9 snw 6084: symtab (fra_dat, tmp, tmp3);
1.1 snw 6085: symtab (get_sym, tmp, &w_tmp[1]);
6086:
6087: break;
6088:
6089:
6090: case '$':
1.9 snw 6091: ssvn (fra_dat, tmp, tmp3);
1.1 snw 6092: ssvn (get_sym, tmp, &w_tmp[1]);
6093:
6094: break;
6095:
6096:
6097: case '^':
1.9 snw 6098: global (fra_dat, tmp, tmp3);
1.1 snw 6099: global (get_sym, tmp, &w_tmp[1]);
6100:
6101: break;
6102: }
6103:
6104: if (tmp3[0] != '0' && tmp3[1] != '0') {
6105:
6106: write_m (tmp2);
6107:
6108: w_tmp[0] = '=';
6109:
6110: write_m (w_tmp);
6111: write_m ("\012\015\201");
6112:
6113: }
6114:
6115: ordercnt = 1L;
6116:
6117: switch (zwmode) {
6118:
6119: case 'L':
6120: symtab (fra_query, tmp, tmp2);
6121:
6122: break;
6123:
6124:
6125: case '$':
6126: ssvn (fra_query, tmp, tmp2);
6127:
6128: break;
6129:
6130:
6131: case '^':
6132: global (fra_query, tmp, tmp2);
6133:
6134: break;
6135:
6136: }
6137:
6138: if (merr () == INRPT) break;
6139: }
6140:
6141: break;
6142: }
6143:
6144:
6145: case ZTRAP:
6146:
6147: if (*codptr == SP || *codptr == EOL) {
6148: merr_raise (ZTERR);
6149: varnam[0] = EOL;
6150:
6151: break;
6152: }
6153:
6154: expr (NAME);
6155: stcpy (varerr, varnam);
6156:
6157: if (merr ()) break;
6158:
6159: if (*++codptr == ':') { /* parse postcond */
6160: codptr++;
6161:
6162: expr (STRING);
6163:
6164: if (merr () > OK) goto err;
6165:
6166: if (tvexpr (argptr) == FALSE) break;
6167: }
6168:
6169: merr_raise (ZTERR);
6170: break;
6171:
6172:
1.11 snw 6173: /* user defined Z-COMMAND */
1.1 snw 6174: case PRIVATE:
6175:
6176: private: /* for in-MUMPS defined commands */
6177: i = 0;
6178: j = 0;
6179: ch = 0;
6180:
6181: while ((tmp2[i] = *codptr) != EOL) {
6182:
6183: if (tmp2[i] == SP && !j) {
6184: tmp2[i] = EOL;
6185: break;
6186: }
6187:
6188: if (tmp2[i] == '"') j = (!j);
6189:
6190: if (!j) {
6191:
6192: if (tmp2[i] == '(') ch++;
6193: if (tmp2[i] == ')') ch--;
6194:
6195: if (!ch && tmp2[i] == ',') { /* next argument: */
6196:
6197: tmp2[i] = EOL; /* call afterwards again */
6198: i = 0;
6199:
6200: while (tmp3[i] != EOL) i++;
6201:
6202: j = i;
6203: ch = 1;
6204:
6205: while (ch < i) tmp3[j++] = tmp3[ch++];
6206:
6207: tmp3[j - 1] = SP;
6208: tmp3[j] = EOL;
6209:
6210: codptr++;
6211:
6212: j = 0;
6213: ch = 0;
6214:
6215: break;
6216: }
6217: }
6218:
6219: i++;
6220: codptr++;
6221: }
6222:
6223: if (j || ch) {
6224: merr_raise (INVREF);
6225: goto err;
6226: }
6227:
6228: stcat (tmp3, codptr);
6229:
6230: if (destructor_run) {
6231: stcpy (code, "d \201");
6232: destructor_run = FALSE;
6233: }
6234: else {
6235: if (new_object) {
6236: stcpy (code, "d ^\201");
6237: new_object = FALSE;
6238: }
6239: else {
6240: stcpy (code, "d ^%\201");
6241: }
6242: }
6243:
6244: stcat (code, &tmp3[1]);
6245:
6246: codptr = code;
6247: privflag = TRUE;
6248:
6249: goto next_cmnd;
6250:
6251: evthandler: /* for event handlers */
6252: i = 0;
6253: j = 0;
6254: ch = 0;
6255:
6256: while ((tmp2[i] = *codptr) != EOL) {
6257:
6258: if (tmp2[i] == SP && !j) {
6259: tmp2[i] = EOL;
6260: break;
6261: }
6262:
6263: if (tmp2[i] == '"') j = (!j);
6264:
6265: if (!j) {
6266:
6267: if (tmp2[i] == '(') ch++;
6268: if (tmp2[i] == ')') ch--;
6269:
6270: if (!ch && tmp2[i] == ',') { /* next argument: */
6271:
6272: tmp2[i] = EOL; /* call afterwards again */
6273: i = 0;
6274:
6275: while (tmp3[i] != EOL) i++;
6276:
6277: j = i;
6278: ch = 1;
6279:
6280: while (ch < i) tmp3[j++] = tmp3[ch++];
6281:
6282: tmp3[j - 1] = SP;
6283: tmp3[j] = EOL;
6284:
6285: codptr++;
6286:
6287: j = 0;
6288: ch = 0;
6289:
6290: break;
6291: }
6292: }
6293:
6294: i++;
6295: codptr++;
6296: }
6297:
6298: if (j || ch) {
6299: merr_raise (INVREF);
6300: goto err;
6301: }
6302:
6303: stcpy (code, "d \201");
6304: stcat (code, tmp3);
6305:
6306: codptr = code;
6307: privflag = TRUE;
6308:
6309: goto next_cmnd;
6310:
6311: case ABLOCK:
6312: case AUNBLOCK:
6313: {
6314: short evt_mask[EVT_MAX];
6315:
6316: if ((rtn_dialect () != D_MDS) &&
6317: (rtn_dialect () != D_FREEM)) {
6318: merr_raise (NOSTAND);
6319: goto err;
6320: }
6321:
6322: /* declare and initialize table of events to be blocked/unblocked with this command */
6323:
6324:
6325: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = 0;
6326:
6327:
6328: /* argumentless ABLOCK/AUNBLOCK: block/unblock everything */
6329: if (((ch = *codptr) == SP) || ch == EOL) {
6330:
6331: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = 1;
6332:
6333: }
6334: else if (*codptr == '(') {
6335: /* exclusive ABLOCK/AUNBLOCK */
6336:
6337: short evt_exclusions[EVT_MAX];
6338:
6339: codptr++;
6340:
6341:
6342: for (i = 0; i < EVT_MAX; i++) evt_exclusions[i] = FALSE;
6343:
6344: for (;;) {
6345:
6346: expr (STRING);
6347:
6348: if (merr () == BRAER) merr_clear ();
6349: if (merr () > OK) goto err;
6350:
6351: codptr++;
6352:
6353: stcpy (vn, argptr);
6354:
6355: if (stcmp (vn, "COMM\201") == 0) {
6356: evt_exclusions[EVT_CLS_COMM] = TRUE;
6357: }
6358: else if (stcmp (vn, "HALT\201") == 0) {
6359: evt_exclusions[EVT_CLS_HALT] = TRUE;
6360: }
6361: else if (stcmp (vn, "IPC\201") == 0) {
6362: evt_exclusions[EVT_CLS_IPC] = TRUE;
6363: }
6364: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6365: evt_exclusions[EVT_CLS_INTERRUPT] = TRUE;
6366: }
6367: else if (stcmp (vn, "POWER\201") == 0) {
6368: evt_exclusions[EVT_CLS_POWER] = TRUE;
6369: }
6370: else if (stcmp (vn, "TIMER\201") == 0) {
6371: evt_exclusions[EVT_CLS_TIMER] = TRUE;
6372: }
6373: else if (stcmp (vn, "USER\201") == 0) {
6374: evt_exclusions[EVT_CLS_USER] = TRUE;
6375: }
6376: else if (stcmp (vn, "WAPI\201") == 0) {
6377: evt_exclusions[EVT_CLS_WAPI] = TRUE;
6378: }
6379: else {
6380: merr_raise (CMMND);
6381: goto err;
6382: }
6383:
6384: if ((ch = *(codptr + 1)) == EOL || ch == SP) {
6385: codptr++;
6386: break;
6387: }
6388: if ((ch = *(codptr + 1)) == ')') {
6389: codptr++;
6390: break;
6391: }
6392:
6393: }
6394:
6395: for (i = 0; i < EVT_MAX; i++) {
6396:
6397: if (evt_exclusions[i] == FALSE) evt_mask[i] = 1;
6398:
6399: }
6400:
6401: }
6402: else {
6403: /* inclusive ABLOCK/AUNBLOCK */
6404:
6405: for (;;) {
6406:
6407: expr (STRING); /* try to interpret a string */
6408: if (merr () > OK) goto err;
6409:
6410: codptr++;
6411:
6412: stcpy (vn, argptr);
6413:
6414: if (stcmp (vn, "COMM\201") == 0) {
6415: evt_mask[EVT_CLS_COMM] = 1;
6416: }
6417: else if (stcmp (vn, "HALT\201") == 0) {
6418: evt_mask[EVT_CLS_HALT] = 1;
6419: }
6420: else if (stcmp (vn, "IPC\201") == 0) {
6421: evt_mask[EVT_CLS_IPC] = 1;
6422: }
6423: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6424: evt_mask[EVT_CLS_INTERRUPT] = 1;
6425: }
6426: else if (stcmp (vn, "POWER\201") == 0) {
6427: evt_mask[EVT_CLS_POWER] = 1;
6428: }
6429: else if (stcmp (vn, "TIMER\201") == 0) {
6430: evt_mask[EVT_CLS_TIMER] = 1;
6431: }
6432: else if (stcmp (vn, "TRIGGER\201") == 0) {
6433: evt_mask[EVT_CLS_TRIGGER] = 1;
6434: }
6435: else if (stcmp (vn, "USER\201") == 0) {
6436: evt_mask[EVT_CLS_USER] = 1;
6437: }
6438: else if (stcmp (vn, "WAPI\201") == 0) {
6439: evt_mask[EVT_CLS_WAPI] = 1;
6440: }
6441: else {
6442: merr_raise (CMMND);
6443: goto err;
6444: }
6445:
6446: if (merr () > OK) goto err;
6447:
6448:
6449: if ((ch = *(codptr)) == EOL || ch == SP) {
6450: break;
6451: }
6452:
6453: }
6454:
6455: }
6456:
6457: for (i = 0; i < EVT_MAX; i++) {
6458:
6459: if (evt_mask[i] > 0) {
6460:
6461: if (mcmnd == ABLOCK) {
6462: evt_ablock (i);
6463: }
6464: else {
6465: evt_aunblock (i);
6466: }
6467: }
6468:
6469: }
6470:
6471:
6472: break;
6473: }
6474:
6475:
6476: case ASSIGN:
6477: merr_raise (CMMND);
6478: break;
6479:
6480:
6481: case ASTOP:
6482: case ASTART:
6483: {
6484: short evt_mask[EVT_MAX];
6485: short new_status;
6486:
6487: if ((rtn_dialect () != D_MDS) &&
6488: (rtn_dialect () != D_FREEM)) {
6489: merr_raise (NOSTAND);
6490: goto err;
6491: }
6492:
6493: /* declare and initialize table of events to be enabled with this command */
6494:
6495: if (mcmnd == ASTART) {
6496: new_status = EVT_S_ASYNC;
6497: }
6498: else {
6499: new_status = EVT_S_DISABLED;
6500: }
6501:
6502:
6503: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = EVT_S_NOMODIFY;
6504:
6505:
6506: /* argumentless ASTART/ASTOP: enable/disable everything */
6507: if (((ch = *codptr) == SP) || ch == EOL) {
6508:
6509: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = new_status;
6510:
6511: }
6512: else if (*codptr == '(') {
6513: /* exclusive ASTART */
6514:
6515: short evt_exclusions[EVT_MAX];
6516:
6517: codptr++;
6518:
6519: for (i = 0; i < EVT_MAX; i++) evt_exclusions[i] = FALSE;
6520:
6521: for (;;) {
6522:
6523: expr (STRING);
6524:
6525: if (merr () == BRAER) merr_clear ();
6526: if (merr () > OK) goto err;
6527:
6528: codptr++;
6529:
6530: stcpy (vn, argptr);
6531:
6532: if (stcmp (vn, "COMM\201") == 0) {
6533: evt_exclusions[EVT_CLS_COMM] = TRUE;
6534: }
6535: else if (stcmp (vn, "HALT\201") == 0) {
6536: evt_exclusions[EVT_CLS_HALT] = TRUE;
6537: }
6538: else if (stcmp (vn, "IPC\201") == 0) {
6539: evt_exclusions[EVT_CLS_IPC] = TRUE;
6540: }
6541: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6542: evt_exclusions[EVT_CLS_INTERRUPT] = TRUE;
6543: }
6544: else if (stcmp (vn, "POWER\201") == 0) {
6545: evt_exclusions[EVT_CLS_POWER] = TRUE;
6546: }
6547: else if (stcmp (vn, "TIMER\201") == 0) {
6548: evt_exclusions[EVT_CLS_TIMER] = TRUE;
6549: }
6550: else if (stcmp (vn, "USER\201") == 0) {
6551: evt_exclusions[EVT_CLS_USER] = TRUE;
6552: }
6553: else if (stcmp (vn, "WAPI\201") == 0) {
6554: evt_exclusions[EVT_CLS_WAPI] = TRUE;
6555: }
6556: else if (stcmp (vn, "TRIGGER\201") == 0) {
6557: evt_exclusions[EVT_CLS_TRIGGER] = TRUE;
6558: }
6559: else {
6560: merr_raise (CMMND);
6561: goto err;
6562: }
6563:
6564: if ((ch = *(codptr + 1)) == EOL || ch == SP) {
6565: codptr++;
6566: break;
6567: }
6568: if ((ch = *(codptr + 1)) == ')') {
6569: codptr++;
6570: break;
6571: }
6572:
6573: }
6574:
6575: for (i = 0; i < EVT_MAX; i++) {
6576:
6577: if (evt_exclusions[i] == FALSE) evt_mask[i] = new_status;
6578:
6579: }
6580:
6581: }
6582: else {
6583: /* inclusive ASTART */
6584:
6585: for (;;) {
6586:
6587: expr (STRING); /* try to interpret a string */
6588: if (merr () > OK) goto err;
6589:
6590: codptr++;
6591:
6592: stcpy (vn, argptr);
6593:
6594: if (stcmp (vn, "COMM\201") == 0) {
6595: evt_mask[EVT_CLS_COMM] = new_status;
6596: }
6597: else if (stcmp (vn, "HALT\201") == 0) {
6598: evt_mask[EVT_CLS_HALT] = new_status;
6599: }
6600: else if (stcmp (vn, "IPC\201") == 0) {
6601: evt_mask[EVT_CLS_IPC] = new_status;
6602: }
6603: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6604: evt_mask[EVT_CLS_INTERRUPT] = new_status;
6605: }
6606: else if (stcmp (vn, "POWER\201") == 0) {
6607: evt_mask[EVT_CLS_POWER] = new_status;
6608: }
6609: else if (stcmp (vn, "TIMER\201") == 0) {
6610: evt_mask[EVT_CLS_TIMER] = new_status;
6611: }
6612: else if (stcmp (vn, "USER\201") == 0) {
6613: evt_mask[EVT_CLS_USER] = new_status;
6614: }
6615: else if (stcmp (vn, "WAPI\201") == 0) {
6616: evt_mask[EVT_CLS_WAPI] = new_status;
6617: }
6618: else if (stcmp (vn, "TRIGGER\201") == 0) {
6619: evt_mask[EVT_CLS_TRIGGER] = new_status;
6620: }
6621: else {
6622: merr_raise (CMMND);
6623: goto err;
6624: }
6625:
6626: if (merr () > OK) goto err;
6627:
6628:
6629: if ((ch = *(codptr)) == EOL || ch == SP) {
6630: break;
6631: }
6632:
6633: }
6634:
6635: }
6636:
6637: for (i = 0; i < EVT_MAX; i++) {
6638:
6639: if (evt_status[i] == EVT_S_SYNC && evt_mask[i] == EVT_S_ASYNC) {
6640:
6641: /* cannot enable both synchronous and asynchronous
6642: event processing on the same event class at the
6643: same time */
6644:
6645: merr_raise (M102);
6646: goto err;
6647:
6648: }
6649: else {
6650:
6651: if (evt_mask[i] > EVT_S_NOMODIFY) {
6652: evt_status[i] = evt_mask[i];
6653: }
6654:
6655: }
6656:
6657: }
6658:
6659: if (mcmnd == ASTART) {
6660: evt_async_enabled = TRUE;
6661: }
6662: else {
6663: short disabled_evt_count = 0;
6664:
6665: for (i = 0; i < EVT_MAX; i++) {
6666: if (evt_status[i] == EVT_S_DISABLED) {
6667: disabled_evt_count++;
6668: }
6669: }
6670:
6671: if (disabled_evt_count == (EVT_MAX - 1)) evt_async_enabled = FALSE;
6672:
6673: }
6674:
6675: break;
6676: }
6677:
6678:
6679:
6680:
6681: case ETRIGGER:
6682:
6683: merr_raise (CMMND);
6684: break;
6685:
6686:
6687: #if defined(HAVE_MWAPI_MOTIF)
6688: case ESTART:
6689: if ((rtn_dialect () != D_MDS) &&
6690: (rtn_dialect () != D_FREEM)) {
6691: merr_raise (NOSTAND);
6692: goto err;
6693: }
6694:
6695: {
6696: if (in_syn_event_loop == TRUE) break;
6697:
6698: int evt_count;
6699: char *syn_handlers = (char *) malloc (STRLEN * sizeof (char));
6700:
6701: /* stack ^$EVENT */
6702: char key[100] = "^$EVENT\202\201";
6703: symtab (new_sym, key, " \201");
6704:
6705: evt_sync_enabled = TRUE;
6706: in_syn_event_loop = TRUE;
6707:
6708: while (evt_sync_enabled) {
6709:
6710:
6711: /* run the next iteration of GTK's event loop */
1.13 snw 6712: /* TODO: replace with libXt event loop */
6713: /* gtk_main_iteration_do (TRUE); */
1.1 snw 6714:
6715: /* dequeue any events */
6716: evt_count = mwapi_dequeue_events (syn_handlers);
6717:
6718: if (evt_count) {
6719: /* write them out */
1.13 snw 6720: /* printf ("event handlers = '%s'\r\n", syn_handlers); */
1.1 snw 6721:
6722: syn_event_entry_nstx = nstx;
6723:
6724: stcnv_c2m (syn_handlers);
6725: stcpy (tmp3, syn_handlers);
6726:
6727: syn_handlers[0] = '\0';
6728:
6729: goto evthandler;
6730: }
6731:
6732: syn_evt_loop_bottom:
6733: continue;
6734: }
6735:
6736: in_syn_event_loop = FALSE;
6737: evt_sync_enabled = FALSE;
6738:
6739: break;
6740: }
6741:
6742:
6743: case ESTOP:
6744: if ((rtn_dialect () != D_MDS) &&
6745: (rtn_dialect () != D_FREEM)) {
6746: merr_raise (NOSTAND);
6747: goto err;
6748: }
6749:
6750: evt_sync_enabled = FALSE;
6751: break;
6752: #endif
6753:
6754:
6755: default:
6756: merr_raise (CMMND);
6757:
6758: } /* command switch */
6759:
6760: if ((ch = *codptr) == EOL) {
6761: if (merr () != OK) goto err;
6762: if (forsw) goto for_end;
6763:
6764: mcmnd = 0;
6765:
6766: goto next_line;
6767: }
6768:
6769: if (ch == SP) {
6770: if (merr () == OK) goto next0;
6771:
6772: goto err;
6773: }
6774:
6775: if (ch != ',' && merr () == OK) {
6776: merr_raise (SPACER);
6777: }
1.19 snw 6778: else if (ierr <= OK) {
1.1 snw 6779: if (*++codptr != SP && *codptr != EOL) goto again;
6780:
6781: merr_raise (ARGLIST);
6782: }
6783:
6784: /* else goto err; */
6785:
6786: /* error */
6787: err:
6788:
6789: /* avoid infinite loops resulting from errors in argumentless FOR loops */
6790: if (merr () != OK && merr () != ASYNC && forsw && ftyp == 0) {
6791: argless_forsw_quit = TRUE;
6792: goto for_end;
6793: }
6794:
6795: /*
6796: * ierr == ASYNC means that the previous command was interrupted by
6797: * an async event. It is not a real error, so just go on to the next
6798: * command after resetting ierr = OK.
6799: */
6800: if (merr () == ASYNC) {
6801: merr_clear ();
6802: goto next_cmnd;
6803: }
6804:
6805: if (merr () > OK) {
6806: job_set_status (pid, JSTAT_ERROR);
6807: }
6808:
6809: if (ierr < 0) {
6810:
6811: ierr += CTRLB;
6812:
6813: if (merr () == OK) {
6814: zbflag = TRUE;
6815:
6816: goto zb_entry;
6817: }
6818: }
6819:
1.19 snw 6820:
1.1 snw 6821: if (merr () > OK ) {
6822:
6823: char er_buf[ERRLEN];
6824:
6825: merr_set_ecode_ierr ();
6826:
6827: stcpy (er_buf, errmes[merr ()]);
6828: stcnv_m2c (er_buf);
6829:
1.19 snw 6830:
1.1 snw 6831: #if !defined(MSDOS)
1.15 snw 6832: logprintf (FM_LOG_DEBUG, "xecline: interpreter error %d [%s]", ierr, er_buf);
1.1 snw 6833: #endif
6834:
6835: }
6836:
6837: zerr = ierr;
6838: merr_clear ();
6839:
6840: /* goto restart; */
6841:
6842:
6843: restart:
6844:
6845: if (param) goto restore;
6846:
6847: dosave[0] = EOL;
6848: setpiece = FALSE;
6849: setop = 0;
6850: privflag = FALSE;
6851:
6852: if (merr () == INRPT) goto err;
6853: if (zerr == STORE) symtab (kill_all, "", "");
6854:
6855: if (errfunlvl > 0) {
6856: errfunlvl--;
6857: }
6858: else {
6859:
6860: if (zerr == OK) {
6861: zerror[0] = EOL; /* reset error */
6862: }
6863: else {
6864:
6865: #ifdef DEBUG_STACK
6866: printf ("Storing NESTERR\r\n");
6867: #endif
6868:
6869: nesterr = nstx; /* save stack information at error */
6870:
6871: for (i = 1; i <= nstx; i++) getraddress (callerr[i], i);
6872:
6873: zerror[0] = '<';
6874:
6875: if (etxtflag) {
6876: stcpy (&zerror[1], errmes[zerr]);
6877: }
6878: else {
6879: intstr (&zerror[1], zerr);
6880: }
6881:
6882: stcat (zerror, ">\201");
6883:
6884: if (rou_name[0] != EOL) {
6885: char *j0;
6886: char *j1;
6887: char tmp1[256];
6888:
6889:
6890:
6891: if (nestc[nstx] == XECUTE) {
6892:
6893: if (nestn[nstx]) { /* reload routine */
6894: zload (nestn[nstx]);
6895: merr_clear ();
6896: }
6897:
6898: roucur = nestr[nstx] + rouptr; /* restore roucur */
6899: }
6900:
6901:
6902:
6903: j0 = (rouptr - 1);
6904: j = 0;
6905: tmp1[0] = EOL;
6906: j0++;
6907:
6908: if (roucur < rouend) {
6909:
6910: while (j0 < (roucur - 1)) {
6911:
6912: j1 = j0++;
6913: j++;
6914:
6915: if ((*j0 != TAB) && (*j0 != SP)) {
6916:
6917: j = 0;
6918:
6919: while ((tmp1[j] = (*(j0++))) > SP) {
6920:
6921: if (tmp1[j] == '(') tmp1[j] = EOL;
6922:
6923: j++;
6924: }
6925:
6926: tmp1[j] = EOL;
6927: j = 0;
6928: }
6929:
6930: j0 = j1;
6931: j0 += (UNSIGN (*j1)) + 2;
6932: }
6933: }
6934:
6935: stcat (zerror, tmp1);
6936:
6937: if (j > 0) {
6938: i = stlen (zerror);
6939: zerror[i++] = '+';
6940:
6941: intstr (&zerror[i], j);
6942: }
6943:
6944: stcat (zerror, "^\201");
6945:
6946:
6947:
6948: if (nestc[nstx] == XECUTE) {
6949:
6950: if (nestn[nstx]) { /* reload routine */
6951: zload (rou_name);
6952:
6953: ssvn_job_update ();
6954:
6955: merr_clear ();
6956: }
6957:
6958: stcat (zerror, nestn[nstx]);
6959: }
6960: else
6961: stcat (zerror, rou_name);
6962: }
6963:
6964: if (zerr == UNDEF) zerr = M6;
6965:
6966: /* undefined: report variable name */
6967: if (zerr == UNDEF || zerr == SBSCR || zerr == NAKED || zerr == ZTERR || zerr == DBDGD || zerr == LBLUNDEF || zerr == NOPGM || zerr == M6 || zerr == M7 || zerr == M13) {
6968:
6969: int f; /* include erroneous reference */
6970:
6971: f = stlen (zerror);
6972: zerror[f++] = SP;
6973: zname (&zerror[f], varerr);
6974: } /* end varnam section */
6975: }
6976: }
6977:
6978: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
6979: tmp4[0] = EOL;
6980:
6981: while (ierr != (OK - CTRLB)) {
6982:
6983:
6984: /* standard error handling */
6985: if (etrap[0] != EOL && stcmp (ecode, "") != 0) {
6986:
6987: on_frame_entry ();
6988:
6989: /* disable $ZTRAP error handling */
6990: ztrap[nstx][0] = EOL;
6991:
6992: stcpy (tmp4, etrap);
6993: stcat (tmp4, " quit:$quit \"\" quit\201");
6994:
6995: if (etrap_lvl > 1) {
6996: /* we've encountered an error within an error handler.
6997: save off the error code at merr_stack[nstx + 1].ECODE */
6998:
6999: stcpy (merr_stack[nstx + 1].ECODE, ecode);
7000: merr_topstk = nstx + 1;
7001: etrap_lvl++;
7002:
7003: }
7004: else {
7005: merr_topstk = nstx;
7006: etrap_lvl++;
7007: }
7008:
7009: break;
7010:
7011: }
7012:
7013:
7014:
7015: if (ztrap[nstx][0] != EOL && !DSM2err) {
7016:
7017: #ifdef DEBUG_NEWSTACK
7018:
7019: printf ("Dropped into Ztrap [");
7020:
7021: for (loop = 0; loop < 20 && ztrap[nstx][loop] != EOL; loop++) {
7022: printf ("%c", ztrap[nstx][loop]);
7023: }
7024:
7025: printf ("]\r\n");
7026:
7027: #endif
7028:
7029: tmp4[0] = GOTO;
7030: tmp4[1] = SP;
7031: stcpy (&tmp4[2], ztrap[nstx]);
7032: ztrap[nstx][0] = EOL;
7033:
7034: #ifdef DEBUG_NEWSTACK
7035:
7036: printf ("Set tmp4 to [");
7037: for (loop = 0; tmp4[loop] != EOL; loop++) printf ("%c", tmp4[loop]);
7038: printf ("]\r\n");
7039:
7040: #endif
7041:
7042: break;
7043: }
7044:
7045:
7046:
7047: if (nstx == 0) {
7048:
7049: #ifdef DEBUG_NEWSTACK
7050: printf ("Nestx was Zero\r\n");
7051: #endif
7052:
7053: forx = 0;
7054: cmdptr = cmdstack;
7055: namptr = namstck;
7056: level = 0;
7057: errfunlvl = 0;
7058: io = HOME; /* trap to direct mode: USE 0 */
7059:
7060: if (zerr == INRPT && frm_filter) {
7061: tmp4[0] = 'h';
7062: tmp4[1] = EOL;
7063: }
7064:
7065: if (DSM2err && (ztrap[NESTLEVLS + 1][0] != EOL)) { /* DSM V.2 error trapping */
7066:
7067: #ifdef DEBUG_NEWSTACK
7068: printf ("Ztrap 2\r\n");
7069: #endif
7070:
7071: tmp4[0] = GOTO;
7072: tmp4[1] = SP; /* GOTO errorhandling */
7073:
7074: stcpy (&tmp4[2], ztrap[NESTLEVLS + 1]);
7075: ztrap[NESTLEVLS + 1][0] = EOL;
7076:
7077: }
7078:
7079: break;
7080: }
7081:
7082: #ifdef DEBUG_NEWSTACK
7083: printf ("Nestc[nstx] is [%d]\r\n", nestc[nstx]);
7084: #endif
7085:
7086: if (nestc[nstx] == BREAK) break;
7087:
7088: if (merr () > OK) goto err;
7089:
7090: if (nestc[nstx] == FOR) {
7091: if (forx == 0) goto for_quit;
7092: ftyp = fortyp[--forx];
7093: fvar = forvar[forx];
7094: finc = forinc[forx];
7095: flim = forlim[forx];
7096: fi = fori[forx];
7097: }
7098: else {
7099:
7100: if (nestc[nstx] == DO_BLOCK) {
7101: test = nestlt[nstx];
7102: level--;
7103: }
7104: else { /* pop $TEST */
7105: level = nestlt[nstx]; /* pop level */
7106: }
7107:
7108: #ifdef DEBUG_NEWSTACK
7109: printf ("Nestn[nstx] is [%d]\r\n", nestn[nstx]);
7110: #endif
7111:
7112: if (nestn[nstx]) { /* 'reload' routine */
7113: namptr = nestn[nstx];
7114: stcpy (rou_name, namptr);
7115: zload (rou_name);
7116:
7117: ssvn_job_update ();
7118:
7119: dosave[0] = 0;
7120:
7121: namptr--;
7122: }
7123:
7124: #ifdef DEBUG_NEWSTACK
7125: printf ("Execcing the rest...\r\n");
7126: #endif
7127:
7128: roucur = nestr[nstx] + rouptr;
7129:
7130: if (nestnew[nstx]) unnew (); /* un-NEW variables */
7131:
7132: cmdptr = nestp[nstx];
7133:
7134: if (nestc[nstx--] == '$') { /* extrinsic function/variable */
7135: *argptr = EOL;
7136: merr_raise (zerr);
7137: errfunlvl++;
7138:
7139: return 0;
7140: }
7141: estack--;
7142: }
7143: }
7144:
7145: forsw = FALSE;
7146:
7147: /* PRINTING ERROR MESSAGES */
7148: if (tmp4[0] == EOL) {
7149:
7150: if (zerr == BKERR && brkaction[0] != EOL) {
7151: stcpy (code, brkaction);
7152: codptr = code;
7153:
7154: if (libcall == TRUE) {
7155: return zerr;
7156: }
7157: else {
7158: goto next_cmnd;
7159: }
7160: }
7161:
7162: if (libcall == TRUE) return zerr;
7163:
7164: DSW &= ~BIT0; /* enable ECHO */
7165:
1.13 snw 7166: /* print here */
1.1 snw 7167: {
7168: char *t_rtn;
7169: char *t_nsn = (char *) malloc (STRLEN * sizeof (char));
7170: char *t_cod;
7171: int t_pos;
7172:
7173: NULLPTRCHK(t_nsn,"xecline");
7174:
7175: t_rtn = strtok (zerror, ">");
7176: t_rtn = strtok (NULL, ">");
7177:
7178: if (t_rtn != NULL && t_rtn[1] == '%') {
7179: strcpy (t_nsn, "SYSTEM");
7180: }
7181: else {
7182: strcpy (t_nsn, nsname);
7183: }
7184:
7185: if (deferred_ierr > OK) {
7186: t_cod = deferrable_code;
7187: t_pos = deferrable_codptr - code + 3;
7188: }
7189: else {
7190: t_cod = code;
7191: t_pos = codptr - code + 3;
7192: }
7193:
7194: if (t_rtn != NULL) {
7195: merr_dump (zerr, t_rtn, t_nsn, t_cod, t_pos);
7196: }
7197: else {
7198: merr_dump (zerr, "<UNKNOWN>", t_nsn, t_cod, t_pos);
7199: }
7200:
7201:
7202: free (t_nsn);
1.19 snw 7203:
1.1 snw 7204: }
7205:
7206:
7207: }
7208: else {
7209: stcpy (code, tmp4);
7210:
7211: codptr = code;
7212: tmp4[0] = EOL;
7213:
7214: goto next_cmnd;
7215: }
7216:
7217: restore:
7218:
7219: io = HOME;
7220: codptr = code;
7221:
7222: if (param > 0) {
7223:
7224: j = 0;
7225: ch = 0;
7226: paramx++;
7227: param--;
7228:
7229: for (;;) {
7230: if (m_argv[++j][0] == '-') {
7231: i = 0;
7232:
7233: while ((m_argv[j][++i] != 0) && (m_argv[j][i] != 'x'));
7234:
7235: if (m_argv[j][i] != 'x') continue;
7236:
7237: j++;
7238:
7239: if (++ch < paramx) continue;
7240:
7241: strcpy (code, m_argv[j]);
7242: break;
7243: }
7244: else {
7245: if (++ch < paramx) continue;
7246:
7247: strcpy (code, "d ");
7248: strcpy (&code[2], m_argv[j]);
7249: break;
7250: }
7251: }
7252: code[strlen (code)] = EOL;
7253: codptr = code;
7254: goto next_cmnd;
7255:
7256: }
7257:
7258: if (usermode == 0) { /* application mode: direct mode implies HALT */
7259: code[0] = 'H';
7260: code[1] = EOL;
7261: codptr = code;
7262:
7263: goto next_cmnd;
7264: }
7265:
7266: if (libcall == TRUE) { /* library mode: don't go to direct mode, just return */
7267: return merr ();
7268: }
7269:
7270:
7271: do {
7272:
7273: if (frm_filter == FALSE && promflag) {
7274: stcpy (code, " \201");
7275: stcpy (&code[2], " \201");
7276: promflag = FALSE;
7277: }
7278: else {
7279:
7280: direct_mode:
7281:
7282: if (dbg_enable_watch && dbg_pending_watches) dbg_dump_watchlist ();
7283:
7284: /* DIRECT-MODE PROMPT HERE */
7285: #if defined(HAVE_LIBREADLINE) && !defined(_AIX)
7286: {
7287: char *fmrl_buf;
7288: char fmrl_prompt[256];
7289: HIST_ENTRY **hist_list;
7290: int hist_idx;
7291: HIST_ENTRY *hist_ent;
7292:
7293: if (quiet_mode == FALSE) {
7294: if (tp_level == 0) {
1.14 snw 7295: snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1, "\r\n%s.%s> ", shm_env, nsname);
1.1 snw 7296: }
7297: else {
1.14 snw 7298: snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1 , "\r\nTL%d:%s.%s> ", tp_level, shm_env, nsname);
1.1 snw 7299: }
7300: }
7301: set_io (UNIX);
7302:
7303: job_set_status (pid, JSTAT_DIRECTMODE);
1.23 snw 7304:
7305: #if defined(__NetBSD__)
7306: printf ("\r\n");
7307: #endif
7308:
1.1 snw 7309: /* readline() does its own malloc() */
7310: fmrl_buf = readline (fmrl_prompt);
7311:
7312: if (!fmrl_buf) {
7313: set_io (UNIX);
7314: printf ("\n");
7315: set_io (MUMPS);
7316:
7317: goto halt;
7318: }
1.23 snw 7319:
1.1 snw 7320:
7321: if (strlen (fmrl_buf) > 0) {
7322: add_history (fmrl_buf);
7323: }
7324:
7325: if (fmrl_buf[0] == '?') {
7326:
7327: char kb[20];
1.14 snw 7328: char db[STRLEN];
1.1 snw 7329:
1.14 snw 7330: snprintf (kb, sizeof (kb) - 1, "%%SYS.HLP\201");
7331: snprintf (db, STRLEN - 1, "\201");
1.1 snw 7332:
7333: symtab (kill_sym, kb, db);
7334:
7335: /* Invoke Online Help */
7336:
7337: set_io (MUMPS);
7338: stcpy (code, "DO ^%ZHELP\201");
7339:
7340: if (strlen (fmrl_buf) > 1) {
1.14 snw 7341: snprintf (db, STRLEN - 1, "%s\201", &fmrl_buf[1]);
1.1 snw 7342: symtab (set_sym, kb, db);
7343: }
7344:
7345: }
7346: else if (strcmp (fmrl_buf, "rbuf") == 0) {
7347: rbuf_dump ();
7348: }
7349: else if (strcmp (fmrl_buf, "jobtab") == 0) {
7350: job_dump ();
7351: }
7352: else if (strcmp (fmrl_buf, "locktab") == 0) {
7353: locktab_dump ();
7354: code[0] = '\201';
7355: codptr = code;
7356: }
7357: else if (strcmp (fmrl_buf, "shmstat") == 0) {
7358: shm_dump ();
7359: }
7360: else if (strcmp (fmrl_buf, "shmpages") == 0) {
7361: shm_dump_pages ();
7362: }
7363: else if (strcmp (fmrl_buf, "glstat") == 0) {
7364: gbl_dump_stat ();
7365: }
7366: else if (strcmp (fmrl_buf, "events") == 0) {
7367:
7368: char stat_desc[30];
7369: char *evclass_name;
7370:
7371: printf ("\n%-20s %-15s %s\n", "Event Class", "Processing Mode", "ABLOCK Count");
7372: printf ("%-20s %-15s %s\n", "-----------", "---------------", "------------");
7373:
7374: for (i = 0; i < EVT_MAX; i++) {
7375:
7376: evclass_name = evt_class_name_c (i);
7377:
7378: switch (evt_status[i]) {
7379: case EVT_S_DISABLED:
7380: strcpy (stat_desc, "Disabled");
7381: break;
7382: case EVT_S_ASYNC:
7383: strcpy (stat_desc, "Asynchronous");
7384: break;
7385: case EVT_S_SYNC:
7386: strcpy (stat_desc, "Synchronous");
7387: }
7388:
7389: printf ("%-20s %-15s %d\n", evclass_name, stat_desc, evt_blocks[i]);
7390:
7391: }
7392:
7393:
7394: }
7395: else if (strcmp (fmrl_buf, "wh") == 0) {
7396: write_history (history_file);
7397: }
7398: else if (strcmp (fmrl_buf, "trantab") == 0) {
7399: tp_tdump();
7400: }
7401: else if (isdigit(fmrl_buf[0]) || (fmrl_buf[0] == '(') || (fmrl_buf[0] == '-') || (fmrl_buf[0] == '\'') || (fmrl_buf[0] == '+') || (fmrl_buf[0] == '$') || (fmrl_buf[0] == '^')) {
7402:
1.14 snw 7403: snprintf (code, STRLEN - 1, "W %s", fmrl_buf);
1.1 snw 7404: stcnv_c2m (code);
7405:
7406: set_io (MUMPS);
7407:
7408: }
7409: #if !defined(__APPLE__)
7410: else if (strcmp (fmrl_buf, "history") == 0) {
7411:
7412: /* History List */
7413:
7414: hist_list = history_list ();
7415: if (hist_list) {
7416:
7417: for (i = 0; hist_list[i]; i++) {
7418: printf("%d: %s\n", i + history_base, hist_list[i]->line);
7419: }
7420:
7421: }
7422:
7423: stcpy (code, " \201");
7424:
7425: set_io (MUMPS);
7426:
7427: }
7428: #endif
7429: else if (strncmp (fmrl_buf, "rcl", 3) == 0) {
7430:
7431: /* Recall History Item */
7432:
7433:
7434:
7435: if (!isdigit (fmrl_buf[4])) {
7436: fprintf (stderr, "invalid history index '%s'\n", &fmrl_buf[4]);
7437:
7438: set_io (MUMPS);
7439: stcpy (code, " \201");
7440:
7441: break;
7442: }
7443:
7444: hist_idx = atoi (&fmrl_buf[4]);
7445:
7446: if ((hist_idx > history_length) || (hist_idx < 1)) {
7447: fprintf (stderr, "history entry %d out of range (valid entries are 1-%d)\n", hist_idx, history_length);
7448:
7449: set_io (MUMPS);
7450: stcpy (code, " \201");
7451:
7452: break;
7453: }
7454:
7455: hist_ent = history_get (hist_idx);
7456:
7457: printf ("%s\n", hist_ent->line);
7458:
7459: strncpy (code, hist_ent->line, 255);
7460: stcnv_c2m (code);
7461:
7462: set_io (MUMPS);
7463:
7464: }
7465: else {
7466:
7467: /* Pass to M Interpreter */
7468:
7469: set_io (MUMPS);
7470:
7471: strncpy (code, fmrl_buf, 255);
7472: stcnv_c2m (code);
7473:
7474: }
7475:
7476: /* free the buffer malloc()'d by readline() */
7477: if (fmrl_buf) free (fmrl_buf);
7478: }
7479: #else
7480:
7481: {
7482: char fmrl_prompt[256];
7483:
7484: if (tp_level == 0) {
1.14 snw 7485: snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1, "\r\n%s> \201", nsname);
1.1 snw 7486: }
7487: else {
1.14 snw 7488: snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1, "\r\nTL%d:%s> \201", tp_level, nsname);
1.1 snw 7489: }
7490:
7491: write_m (fmrl_prompt);
7492:
7493: read_m (code, -1L, 0, 255); /* Not necessarily STRLEN? */
7494: }
7495:
7496: promflag = TRUE;
7497: #endif
7498:
7499: if (merr () > OK) goto err;
7500:
7501: if (code[0] == EOL && zbflag && nestc[nstx] == BREAK) {
7502:
7503: debug_mode = TRUE;
7504: merr_raise (OK - CTRLB);
7505:
7506: goto zgo;
7507: } /* single step */
7508: }
7509: }
7510: while (code[0] == EOL);
7511:
7512: if (promflag) write_m ("\r\n\201");
7513:
7514: /* automatic ZI in direct mode: insert an entry with TAB */
7515: i = (-1);
7516: j = 0;
7517: merr_clear ();
7518:
7519: while (code[++i] != EOL) {
7520: if (code[i] == '"') toggle (j);
7521:
7522: if (code[i] == TAB && j == 0) {
7523: dosave[0] = EOL;
7524:
7525: zi (code, rouins);
7526: if (merr ()) goto err;
7527: goto restore;
7528: }
7529: }
7530:
7531: code[++i] = EOL;
7532: code[++i] = EOL;
7533:
7534: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
7535:
7536: goto next_cmnd;
7537:
7538: skip_line:
7539:
7540: if (forsw) goto for_end;
7541: goto next_line;
7542:
7543: } /*end of xecline() */
7544:
7545: void on_frame_entry(void)
7546: {
7547: return;
7548: }
7549:
7550: void rbuf_dump(void)
7551: {
7552: register int i;
7553: char rnam[256];
7554: char rpth[256];
7555: char ldtime[80];
7556: char flgs[80];
7557: time_t ag;
7558: struct tm tld;
7559:
7560:
7561: printf ("ROUTINE BUFFER CONFIGURATION\r\n");
1.2 snw 7562: printf (" ROUTINE BUFFER COUNT: %ld\r\n", NO_OF_RBUF);
1.1 snw 7563: printf (" MAX. ROUTINE BUFFER COUNT: %d\r\n", MAXNO_OF_RBUF);
7564: printf (" DEFAULT ROUTINE BUFFER SIZE (EACH): %d BYTES\r\n", DEFPSIZE0 - 1);
1.2 snw 7565: printf (" CURRENT ROUTINE BUFFER SIZE (EACH): %ld BYTES\r\n\r\n", PSIZE0 - 1);
1.1 snw 7566: printf ("BUFFERS IN USE:\r\n\r\n");
7567:
7568:
7569: for (i = 0; i < NO_OF_RBUF; i++) {
7570:
1.12 snw 7571: flgs[0] = '\0';
1.1 snw 7572:
7573: if (ages[i] == 0) {
7574: sprintf (rnam, "---------");
7575: sprintf (rpth, "[buffer empty]");
7576: sprintf (ldtime, "n/a");
7577: sprintf (flgs, "n/a");
7578: }
7579: else {
7580: stcpy (rnam, pgms[i]);
7581: stcnv_m2c (rnam);
7582:
7583: stcpy (rpth, path[i]);
7584: stcnv_m2c (rpth);
7585:
7586: ag = ages[i];
7587: tld = *localtime (&ag);
7588:
7589: strftime (ldtime, 80, "%a %Y-%m-%d %H:%M:%S %Z", &tld);
7590: if (rbuf_flags[i].dialect != D_FREEM) {
7591: strcat (flgs, "STANDARD");
7592:
7593: switch (rbuf_flags[i].dialect) {
7594:
7595: case D_M77:
7596: strcat (flgs, " [M 1977]");
7597: break;
7598:
7599: case D_M84:
7600: strcat (flgs, " [M 1984]");
7601: break;
7602:
7603: case D_M90:
7604: strcat (flgs, " [M 1990]");
7605: break;
7606:
7607: case D_M95:
7608: strcat (flgs, " [M 1995]");
7609: break;
7610:
7611: case D_MDS:
7612: strcat (flgs, " [MILLENNIUM DRAFT]");
7613: break;
7614:
7615: case D_M5:
7616: strcat (flgs, " [M5]");
7617: break;
7618: }
7619:
7620: }
7621: else {
7622: strcat (flgs, "FREEM");
7623: }
7624: }
7625:
7626: if (ages[i] != 0) {
7627: printf ("#%d [ROUTINE '%s']\r\n", i, rnam);
7628: printf (" UNIX PATH: %s\r\n", rpth);
7629: printf (" LAST ACCESS: %s\r\n", ldtime);
7630: printf (" DIALECT: %s\r\n", flgs);
7631: }
7632:
7633: }
7634:
7635: }
7636:
7637: short rbuf_slot_from_name(char *rnam)
7638: {
7639: register short i;
7640:
7641: for (i = 0; i < NO_OF_RBUF; i++) {
7642: if (stcmp (rnam, pgms[i]) == 0) {
7643: return i;
7644: }
7645: }
7646:
7647: return -1;
7648: }
7649:
7650: short is_standard(void)
7651: {
7652:
7653: if (rtn_dialect () == D_FREEM) {
7654: return FALSE;
7655: }
7656: else {
7657: return TRUE;
7658: }
7659:
7660: }
7661:
7662: int rtn_dialect(void)
7663: {
7664: short slot;
7665:
7666: slot = rbuf_slot_from_name (rou_name);
7667:
7668: return rbuf_flags[slot].dialect;
7669: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to xecline.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem / src