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