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