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