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