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