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