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