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