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