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