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