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