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