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