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