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