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