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