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