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