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