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