Annotation of freem/src/xecline.c, revision 1.12
1.1 snw 1: /*
1.12 ! snw 2: * $Id: xecline.c,v 1.11 2025/04/02 03:02:42 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.12 ! snw 27: * Revision 1.11 2025/04/02 03:02:42 snw
! 28: * Stop requiring users to pass -e to fmadm when -u or -g are passed
! 29: *
1.11 snw 30: * Revision 1.10 2025/03/27 03:27:35 snw
31: * Install init scripts to share/freem/examples/init and fix regression in method dispatch
32: *
1.10 snw 33: * Revision 1.9 2025/03/24 04:13:12 snw
34: * Replace action macro dat with fra_dat to avoid symbol conflict on OS/2
35: *
1.9 snw 36: * Revision 1.8 2025/03/24 04:05:36 snw
37: * Replace crlf with frm_crlf to avoid symbol conflict with readline on OS/2
38: *
1.8 snw 39: * Revision 1.7 2025/03/22 22:52:24 snw
40: * Add STRLEN_GBL macro to manage global string length
41: *
1.7 snw 42: * Revision 1.6 2025/03/22 21:44:32 snw
43: * Make the startup messages fewer and add environment name to direct-mode prompt
44: *
1.6 snw 45: * Revision 1.5 2025/03/09 19:50:47 snw
46: * Second phase of REUSE compliance and header reformat
47: *
1.5 snw 48: *
49: * SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
50: * SPDX-License-Identifier: AGPL-3.0-or-later
1.1 snw 51: **/
52:
53: #include <stdlib.h>
54:
55: #include "mpsdef.h"
56: #include "namespace.h"
57: #include "transact.h"
58: #include "merge.h"
59: #include "sighnd.h"
60: #include "init.h"
61: #include "events.h"
62: #include "mdebug.h"
63: #include "freem.h"
64: #include "mref.h"
65: #include "log.h"
66: #include "consttbl.h"
67: #include "shmmgr.h"
68: #include "locktab.h"
69: #include "jobtab.h"
70: #include "config.h"
71: #include "datatypes.h"
72: #include "objects.h"
73: #include "mcommand.h"
74:
75: #if defined(__linux__)
76: # include <sched.h>
77: #endif
78:
79: #if !defined(MSDOS)
80: # include "io_socket.h"
81: #endif
82:
83: #include "merr.h"
84:
85: #include <errno.h>
86: #include <unistd.h>
87: #include <string.h>
88:
89: #if !defined(MSDOS)
90: # include <syslog.h>
91: #endif
92:
93: #include <stdio.h>
94: #include <ctype.h>
95:
96: #include <time.h>
97: #include <sys/types.h>
98: #include <pwd.h>
99: #if !defined(__OpenBSD__) && !defined(__FreeBSD__)
100: # include <sys/timeb.h>
101: #endif
102: #include <sys/wait.h>
103: #include <sys/time.h>
104: #include <time.h>
105:
106: #ifdef HAVE_LIBREADLINE
107: # if defined(HAVE_READLINE_READLINE_H)
108: # include <readline/readline.h>
109: # elif defined(HAVE_READLINE_H)
110: # include <readline.h>
111: # else /* !defined(HAVE_READLINE_H) */
112: extern char *readline ();
113: # endif /* !defined(HAVE_READLINE_H) */
114: /*char *cmdline = NULL;*/
115: #else /* !defined(HAVE_READLINE_READLINE_H) */
116: /* no readline */
117: #endif /* HAVE_LIBREADLINE */
118:
119: #ifdef HAVE_READLINE_HISTORY
120: # if defined(HAVE_READLINE_HISTORY_H)
121: # include <readline/history.h>
122: # elif defined(HAVE_HISTORY_H)
123: # include <history.h>
124: # else /* !defined(HAVE_HISTORY_H) */
125: extern void add_history ();
126: extern int write_history ();
127: extern int read_history ();
128: # endif /* defined(HAVE_READLINE_HISTORY_H) */
129: /* no history */
130: #endif /* HAVE_READLINE_HISTORY */
131:
132: #include "mwapi_window.h"
133: #include "mwapi_event.h"
134:
135:
136: void on_frame_entry(void);
137: void rbuf_dump(void);
138: short rbuf_slot_from_name(char *);
139: short is_standard(void);
140:
141: /*
142: * xecline():
143: * typ (where to go on function entry): 1 = restart
144: * 2 = error
145: *
146: */
147: int xecline(int typ)
148: {
149: MACTION ra;
150: short new_and_set = FALSE;
151: short new_object = FALSE;
152: short destructor_run = FALSE;
153: short debug_mode = FALSE;
154: short libcall = FALSE;
155: char *namold;
156: long rouoldc;
157: unsigned long jobtime;
158: char label[256], routine[256];
159:
160: char *vn;
161: char *an;
162: char *tmp;
163: char *tmp2;
164: char *tmp3;
165:
166:
167: char *deferrable_codptr;
168: char deferrable_code[512];
169:
170: char *ev_handlers;
171:
172: char *reeval_codptr;
173: char reeval_code[512];
174:
175: int i;
176: int j;
177: register int ch;
178:
179: int then_ctr = 0;
180:
181: #if defined(HAVE_MWAPI_MOTIF)
182: int syn_event_entry_nstx = 0;
183: int in_syn_event_loop = FALSE;
184: #endif
185:
186: # ifdef DEBUG_NEWSTACK
187: int loop;
188: # endif
189:
190: vn = (char *) malloc ((STRLEN + 1) * sizeof (char));
191: an = (char *) malloc ((STRLEN + 1) * sizeof (char));
192: tmp = (char *) malloc ((STRLEN + 1) * sizeof (char));
193: tmp2 = (char *) malloc ((STRLEN + 1) * sizeof (char));
194: tmp3 = (char *) malloc ((STRLEN + 1) * sizeof (char));
195:
196: NULLPTRCHK(vn,"xecline");
197: NULLPTRCHK(an,"xecline");
198: NULLPTRCHK(tmp,"xecline");
199: NULLPTRCHK(tmp2,"xecline");
200: NULLPTRCHK(tmp3,"xecline");
201:
202: deferrable_codptr = deferrable_code;
203:
204: switch (typ) {
205:
206: case 0:
207: goto next_line;
208:
209: case 1:
210: goto restart;
211:
212: case 2:
213: goto err;
214:
215: case 3:
216: libcall = TRUE;
217: goto restart;
218:
219: }
220:
221: next_line: /* entry point for next command line */
222:
223:
224: job_set_status (pid, JSTAT_INTERPRETER);
225:
226: if (then_ctr > 0) {
227: test = nestlt[nstx];
228: level--;
229: then_ctr--;
230: }
231:
232: while ((roucur < rouend) && (ch = (*roucur++)) != TAB && ch != SP); /* skip label */
233:
234: if (roucur >= rouend) goto quit0; /* end of routine implies QUIT */
235:
236: while ((ch = *roucur) == TAB || ch == SP) roucur++;
237:
238: i = 0;
239: if (ch == '.') { /* get level count */
240:
241: do {
242: i++;
243: while ((ch = (*++roucur)) == SP || ch == TAB);
244: }
245: while (ch == '.');
246:
247: }
248:
249: if (i != level) {
250:
251: if (mcmnd == GOTO) {
252: merr_raise (M45);
253: goto err;
254: }
255:
256: if (i < level) {
257: goto quit0;
258: }
259: else {
260: roucur += stlen (roucur) + 2;
261: goto next_line;
262: }
263: }
264:
265: i = stcpy (code, roucur) + 1;
266: code[i] = EOL;
267: roucur += i + 1;
268: codptr = code;
269:
270: next_cmnd: /* continue line entry point */
271: if (sigint_in_for) goto for_quit;
272:
273: if (forsw && (forpost[forx][0] != '\0')) {
274:
275: stcpy (reeval_code, code);
276: reeval_codptr = codptr;
277:
278: strcpy (code, forpost[forx]);
279: stcnv_c2m (code);
280: codptr = code;
281:
282: expr (STRING);
283:
284: if (merr () > OK) {
285: stcpy (code, reeval_code);
286: codptr = reeval_codptr;
287:
288: goto err;
289: }
290:
291: if (tvexpr (argptr) == FALSE) {
292: stcpy (code, reeval_code);
293: codptr = reeval_codptr;
294:
295: goto for_quit;
296: }
297:
298: stcpy (code, reeval_code);
299: codptr = reeval_codptr;
300:
301: }
302:
303: job_set_status (pid, JSTAT_INTERPRETER);
304:
305: if (evt_async_enabled == TRUE) {
306:
307: switch (pending_signal_type) {
308:
309: case SIGWINCH:
310: evt_enqueue ("SIGWINCH", EVT_CLS_INTERRUPT, 1);
311: break;
312:
313: case SIGINT:
314: evt_enqueue ("SIGINT", EVT_CLS_INTERRUPT, 0);
315: break;
316:
317: case SIGFPE:
318: evt_enqueue ("SIGFPE", EVT_CLS_INTERRUPT, 0);
319: break;
320:
321: case SIGQUIT:
322: evt_enqueue ("SIGQUIT", EVT_CLS_INTERRUPT, 0);
323: break;
324:
325: }
326:
327: pending_signal_type = -1;
328:
329: /* process async events */
330: ev_handlers = (char *) malloc (STRLEN * sizeof (char));
331: NULLPTRCHK(ev_handlers,"xecline");
332:
333:
334: /* get a comma-delimited list of applicable handlers (e.g. ^HNDL1,^HNDL2,^HNDL3) */
335: ev_handlers[0] = NUL;
336: evt_depth = evt_get_handlers (ev_handlers);
337:
338: stcnv_c2m (ev_handlers);
339: stcpy (tmp3, ev_handlers);
340: free (ev_handlers);
341:
342: /* only execute event handlers if we have at least one such handler registered in ^$JOB($JOB,"EVENTS") */
343: if (evt_depth) {
344:
345: /* per X11-1998/28, async events are to be disabled during the execution of event handlers */
346:
347: /* TODO: this should be done by incrementing the event block counter
348: for all event types, or whatever the event extension says to do.
349:
350: In any event (rimshot here for the obvious pun), turning off all
351: event handlers this way is decidedly non-standard. Or non-what-might-
352: become the standard. Whatever. */
353:
354: evt_async_enabled = FALSE;
355: evt_async_initial = TRUE;
356: evt_async_restore = TRUE;
357:
358: goto evthandler;
359:
360: }
361:
362: }
363:
364:
365: if (merr () > OK) goto err;
366:
367: next0:
368:
369: do {
370: if ((ch = *codptr) == EOL) {
371: if (forsw) goto for_end;
372:
373: goto next_line;
374: }
375:
376: codptr++;
377: }
378: while (ch == SP);
379:
380: /* decode command word */
381:
382: if (ch < 'A') { /* Handle non-alpha first chars */
383:
384: if (ch == ';') { /* COMMENT */
385:
386: ch = *(codptr++);
387:
388: if(ch == '%') { /* DIRECTIVE */
389:
390: int dir_pos = 0;
391: int dir_wc = 0;
392: char dir_words[20][255];
393:
394: while((ch = *(codptr++)) != EOL) {
395:
396: switch (ch) {
397:
398:
399: case SP:
400:
401: dir_words[dir_wc][dir_pos] = NUL;
402:
403: dir_wc++;
404: dir_pos = 0;
405:
406: break;
407:
408:
409: default:
410:
411: dir_words[dir_wc][dir_pos++] = ch;
412:
413: }
414:
415: }
416:
417: dir_words[dir_wc][dir_pos] = NUL;
418:
419: if (strcmp (dir_words[0], "DIALECT") == 0) {
420: short rb_slot;
421:
422: rb_slot = rbuf_slot_from_name (rou_name);
423:
424: if ((strcmp (dir_words[1], "STANDARD") == 0) ||
425: (strcmp (dir_words[1], "MDS") == 0)) {
426: rbuf_flags[rb_slot].standard = TRUE;
427: rbuf_flags[rb_slot].dialect = D_MDS;
428: }
429: else if (strcmp (dir_words[1], "M77") == 0) {
430: rbuf_flags[rb_slot].standard = TRUE;
431: rbuf_flags[rb_slot].dialect = D_M77;
432: }
433: else if (strcmp (dir_words[1], "M84") == 0) {
434: rbuf_flags[rb_slot].standard = TRUE;
435: rbuf_flags[rb_slot].dialect = D_M84;
436: }
437: else if (strcmp (dir_words[1], "M90") == 0) {
438: rbuf_flags[rb_slot].standard = TRUE;
439: rbuf_flags[rb_slot].dialect = D_M90;
440: }
441: else if (strcmp (dir_words[1], "M95") == 0) {
442: rbuf_flags[rb_slot].standard = TRUE;
443: rbuf_flags[rb_slot].dialect = D_M95;
444: }
445: else if (strcmp (dir_words[1], "M5") == 0) {
446: rbuf_flags[rb_slot].standard = TRUE;
447: rbuf_flags[rb_slot].dialect = D_M5;
448: }
449: else if ((strcmp (dir_words[1], "FREEM") == 0) ||
450: (strcmp (dir_words[1], "EXTENDED") == 0)) {
451: rbuf_flags[rb_slot].standard = FALSE;
452: rbuf_flags[rb_slot].dialect = D_FREEM;
453: }
454: else {
455: merr_raise (CMMND);
456: goto err;
457: }
458: goto skip_line;
459: }
460: else {
461: goto skip_line;
462: }
463:
464: }
465:
466: goto skip_line;
467: }
468:
469: if ((!is_standard ()) && (ch == '#')) {
470: goto skip_line;
471: }
472:
473: if ((is_standard ()) && (ch == '#')) {
474: merr_raise (NOSTAND);
475: goto err;
476: }
477:
478: if (ch == '@') {
479: if (!is_standard ()) {
480: goto do_xecute;
481: }
482: else {
483: merr_raise (NOSTAND);
484: goto err;
485: }
486: }
487:
488: if (ch == '!') { /* UNIXCALL */
489:
490: if (restricted_mode) {
491: merr_raise (NOSTAND);
492: goto err;
493: }
494:
495: /* don't catch child dies signal */
496: sig_attach (SIGUSR1, SIG_IGN);
497:
498: tmp2[stcpy (tmp2, codptr)] = NUL;
499:
500: if (demomode) fputc (d1char, stdout);
501:
502: if (tmp2[0] == '!') {
503:
504: uid_t suid;
505: struct passwd *spw;
506:
507: suid = geteuid ();
508: spw = getpwuid (suid);
509:
510: set_io (UNIX);
511:
512: fprintf (stderr, "Type Ctrl-D to exit from the shell\n");
513:
514: if (strlen (spw->pw_shell)) {
515: zsystem = system (spw->pw_shell);
516: }
517: else {
518: zsystem = system ("/bin/sh");
519: }
520:
521: set_io (MUMPS);
522: sig_attach (SIGUSR1, &oncld); /* restore handler */
523:
524: }
525: else if (tmp2[0] == '<') { /* call write output to %-array */
526:
527: FILE *pipdes;
528: char key[STRLEN + 1 /*was 256 */ ];
529: char data[STRLEN + 1 /*was 256 */ ];
530: char data_kill[256];
531: data_kill[255] = EOL;
532:
533: for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL;
534:
535: snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
536: ssvn (get_sym, key, vn);
537:
538: if (vn[0] == '^') {
539:
540: if (vn[1] == '$') {
541: merr_raise (INVREF);
542: goto err;
543: }
544: else {
545: global (kill_sym, vn, data_kill);
546: }
547:
548: }
549: else {
550: symtab (kill_sym, vn, data);
551: }
552:
553: snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
554: ssvn (get_sym, key, vn);
555:
556: data[0] = '0';
557: data[1] = EOL;
558:
559: if (vn[0] == '^') {
560:
561: if (vn[1] == '$') {
562: merr_raise (INVREF);
563: goto err;
564: }
565: else {
566: global (set_sym, vn, data);
567: }
568:
569: }
570: else {
571: symtab (set_sym, vn, data);
572: }
573:
574: set_io (UNIX);
575: if ((pipdes = popen (&tmp2[1], "r")) == NULL) {
576: zsystem = 1;
577: }
578: else {
579: int glvn_len = 0;
580:
581: while (fgets (data, STRLEN, pipdes)) {
582: snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
583: ssvn (get_sym, key, vn);
584:
585: glvn_len = stlen (vn);
586: stcpy (key, vn);
587:
588: key[glvn_len] = DELIM;
589:
590: if (vn[0] == '^') {
591:
592: if (vn[1] == '$') {
593: merr_raise (INVREF);
594: goto err;
595: }
596: else {
597: global (getinc, vn, &key[glvn_len + 1]);
598: }
599:
600: }
601: else {
602: symtab (getinc, vn, &key[glvn_len + 1]);
603: }
604:
605: i = strlen (data);
606:
607: data[i] = EOL;
608:
609: if (i > 1 && data[i - 1] == LF) data[i - 1] = EOL;
610:
611: if (vn[0] == '^') {
612:
613: if (vn[1] == '$') {
614: merr_raise (INVREF);
615: goto err;
616: }
617: else {
618: global (set_sym, key, data);
619: }
620:
621: }
622: else {
623: symtab (set_sym, key, data);
624: }
625:
626: if (merr () == STORE) break;
627: }
628:
629: pclose (pipdes);
630:
631: zsystem = 0;
632: }
633: set_io (MUMPS);
634: }
635: else if (tmp2[0] == '>') { /* call read input from %-array */
636: FILE *pipdes;
637: char key[STRLEN + 1 /*was 256 */ ];
638: char data[STRLEN + 1 /*was 256 */ ];
639: int i, k, l;
640:
641: for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL;
642:
643: snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
644: ssvn (get_sym, key, vn);
645:
646: if (vn[0] == '^') {
647:
648: if (vn[1] == '$') {
649: merr_raise (INVREF);
650: goto err;
651: }
652: else {
653: global (get_sym, vn, data);
654: }
655:
656: }
657: else {
658: symtab (get_sym, vn, data);
659: }
660:
661: merr_clear ();
662: k = intexpr (data);
663:
664: set_io (UNIX);
665: if (k < 1 || (pipdes = popen (&tmp2[1], "w")) == NULL) {
666: zsystem = 1;
667: }
668: else {
669: int glvn_len = 0;
670:
671: for (i = 1; i <= k; i++) {
672: snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
673: ssvn (get_sym, key, vn);
674:
675: glvn_len = stlen (vn);
676: stcpy (key, vn);
677:
678: key[glvn_len] = DELIM;
679:
680: intstr (&key[glvn_len + 1], i);
681:
682: if (vn[0] == '^') {
683:
684: if (vn[1] == '$') {
685: merr_raise (INVREF);
686: goto err;
687: }
688: else {
689: global (get_sym, key, data);
690: }
691:
692: }
693: else {
694: symtab (get_sym, key, data);
695: }
696:
697: l = stlen (data);
698:
699: data[l++] = LF;
700: data[l] = NUL;
701:
702: fputs (data, pipdes);
703: }
704:
705: pclose (pipdes);
706:
707: zsystem = 0;
708: merr_clear ();
709: }
710: set_io (MUMPS);
711:
712: }
713: else {
714: set_io (UNIX);
715: zsystem = system (tmp2);
716: set_io (MUMPS);
717: }
718:
719: if (demomode) fputc (d1char, stdout);
720:
721: sig_attach (SIGUSR1, &oncld); /* restore handler */
722:
723:
724: if (merr () == STORE) {
725: zsystem = 1;
726: goto err;
727: }
728:
729: goto skip_line;
730: }
731:
732: merr_raise (CMMND);
733: goto err;
734: } /* END handling of non-alpha first chars */
735:
736:
737: mcmnd = ch | 0140; /* uppercase to lower case */
738:
739: i = 1;
740:
741: while ((ch = (*codptr)) != SP && ch != ':' && ch != EOL) {
742: tmp3[++i] = ch | 0140;
743: codptr++;
744: }
745:
746: j = i;
747:
748: if (j > 1) {
749: merr_raise (mcmd_tokenize (&ra, tmp3, deferrable_codptr, deferrable_code, &j));
750: MRESCHECK(ra);
751: }
752:
753:
754: if (*codptr == ':') {
755: /* handle postconditional */
756:
757: if (mcmnd == FOR) {
758: char *savcp = codptr;
759:
760: codptr++;
761: i = 0;
762: while ((forpost[forx + 1][i++] = *(codptr++)) != SP);
763:
764: forpost[forx + 1][i - 1] = '\0';
765:
766: codptr = savcp;
767: }
768:
769:
770: /* postcond after FOR,IF,ELSE not allowed in dialects other than D_FREEM */
771:
772:
773: if ((rtn_dialect () != D_FREEM) && (mcmnd == FOR || mcmnd == IF || mcmnd == ELSE)) {
774: merr_raise (NOSTAND);
775: goto err;
776: }
777:
778: codptr++;
779:
780: expr (STRING);
781:
782: if (merr () > OK) goto err;
783:
784: ch = *codptr;
785:
786: if (ch != SP && ch != EOL) {
787: merr_raise (SPACER);
788: goto err;
789: }
790:
791: if (tvexpr (argptr) == FALSE) { /* skip arguments */
792:
793: if ((mcmnd == IF) || (mcmnd == THEN) || (mcmnd == ELSE) || (mcmnd == FOR)) {
794: mcmnd = 0;
795: goto skip_line;
796: }
797:
798: mcmnd = 0; /* avoid false LEVEL error */
799:
800: for (;;) {
801: if (ch == EOL) goto skip_line;
802: if ((ch = *++codptr) == SP) goto next_cmnd;
803: if (ch != '"') continue;
804:
805: while (*codptr++ != EOL) {
806: if (*codptr != ch) continue;
807: if (*++codptr != ch) break;
808: }
809:
810: if (--codptr == code) goto err;
811: }
812: }
813:
814: }
815:
816: if (*codptr != EOL) { /* beware argumentless cmnds at end of line */
817: codptr++; /* entry for next argument in list */
818:
819: again:
820: while (*codptr == '@') { /* handle indirection */
821:
822: stcpy (tmp, codptr++); /* save code to restore on nameind */
823: expr (ARGIND);
824:
825: if (merr () > OK) goto err;
826:
827: if (((ch = (*codptr)) != SP && ch != EOL && ch != ',' && ch != ':' && ch != '=') || (ch == '@' && *(codptr + 1) == '(')) {
828: stcpy (code, tmp); /* restore code on nameind */
829: codptr = code;
830:
831: break;
832: }
833: else {
834: stcpy (argptr + stlen (argptr), codptr);
835: stcpy (code, argptr);
836:
837: codptr = code;
838: }
839: }
840: }
841:
842: switch (mcmnd) {
843:
844: case MAP:
845: merr_raise (cmd_map (&ra));
846: MRESCHECK(ra);
847: break;
848:
849: case UNMAP:
850: merr_raise (cmd_unmap (&ra));
851: MRESCHECK(ra);
852: break;
853:
854: case THEN:
855: merr_raise (cmd_then (&ra, &then_ctr));
856: MRESCHECK(ra);
857: break;
858:
859: case THROW:
860: merr_raise (cmd_throw (&ra));
861: MRESCHECK(ra);
862: break;
863:
864: case CONST:
865: merr_raise (cmd_const (&ra));
866: MRESCHECK(ra);
867: break;
868:
869: case KVALUE:
870: merr_raise (cmd_kvalue (&ra));
871: MRESCHECK(ra);
872: break;
873:
874: case KSUBSC:
875: merr_raise (cmd_ksubscripts (&ra));
876: MRESCHECK(ra);
877: break;
878:
879: case TSTART:
880: merr_raise (cmd_tstart (&ra));
881: MRESCHECK(ra);
882: break;
883:
884: case TCOMMIT:
885: merr_raise (cmd_tcommit (&ra));
886: MRESCHECK(ra);
887: break;
888:
889: case TROLLBACK:
890: merr_raise (cmd_trollback (&ra));
891: MRESCHECK(ra);
892: break;
893:
894: case SET:
895:
896: set0:
897: if ((ch = (*codptr)) >= 'A') { /* no set$piece nor multiset */
898: short setref = FALSE;
899: short stclass = SC_UNCHANGED;
900:
901: expr (NAME);
902: if (merr () > OK) break;
903: stcpy (vn, varnam);
904:
905: if (isalpha (vn[0]) && *(codptr + 1) == ':') {
906: char sc_string[255];
1.12 ! snw 907:
1.1 snw 908: codptr += 2;
909: expr (NAME);
910:
911: stcpy (sc_string, varnam);
912: for (i = 0; i < stlen (sc_string); i++) {
913: sc_string[i] = toupper (sc_string[i]);
914: }
915:
916: stcnv_m2c (sc_string);
917: if (strcmp (sc_string, "PRIVATE") == 0) {
918: stclass = SC_PRIVATE;
919: }
920: else if (strcmp (sc_string, "PUBLIC") == 0) {
921: stclass = SC_PUBLIC;
922: }
923: else {
924: merr_raise (OBJACINVALID);
925: break;
926: }
927: }
928:
929: if ((*++codptr != '=') || (*(codptr + 1) == '=')) {
930: ch = *codptr;
931:
932: /* double char symbol ** (power) is encoded by ' ' */
933: if (ch == '*' && *(codptr + 1) == ch) {
934: codptr++;
935: ch = ' ';
936: }
937:
938: /* negated boolean operator */
939: else if ((ch == '\'') && (*(codptr + 2) == '=')) ch = SETBIT (*++codptr);
940:
941: if (*++codptr != '=') {
942:
943: /* SET A++ or SET A-- equivalent to SET A+=1 SET A-=1 currently disabled */
944: //#ifdef NEVER
945: if ((ch == '+' || ch == '-') && ch == *codptr) {
946: codptr++;
947: setop = ch;
948: argptr[0] = '1';
949: argptr[1] = EOL;
950:
951: goto set2;
952: }
953: //#endif /* NEVER */
954:
955: merr_raise (ASSIGNER);
956: break;
957: }
958:
959: setop = ch;
960: }
961:
962: codptr++;
963:
964: ch = *codptr;
965:
966: if (ch == '.') {
967: setref = TRUE;
968: codptr++;
969: expr (NAME);
970: }
971: else {
972: expr (STRING);
973: }
974:
975:
976: if (merr () > OK) break;
977:
978:
979: set2:
980:
981: if (vn[0] == '^') {
982:
983: stcpy (an, argptr);
984:
985: if (setref == TRUE) {
986: merr_raise (INVREF);
987: goto err;
988: }
989:
990: if (vn[1] == '$') {
991: ssvn (set_sym, vn, an);
992: }
993: else {
994: global (set_sym, vn, an);
995: }
996:
997: }
998: else {
999: stcpy (an, argptr);
1000:
1001: if (setref == TRUE) {
1002: symtab (new_sym, vn, "");
1003: symtab (m_alias, vn, varnam);
1004: codptr++;
1005: }
1006: else {
1007: if (new_object == FALSE) {
1008: symtab (set_sym, vn, an);
1009: switch (stclass) {
1010:
1011: case SC_PUBLIC:
1012: obj_set_field_public (vn);
1013: break;
1014:
1015: case SC_PRIVATE:
1016: obj_set_field_private (vn);
1017: break;
1018:
1019: }
1020: }
1021: }
1022: }
1023:
1024: if (merr () > OK) {
1025: stcpy (varerr, vn);
1026: break;
1027: }
1028:
1029: if (((new_and_set == TRUE) || (new_object == TRUE)) && (*codptr != SP) && (*codptr != EOL)) {
1030: new_and_set = FALSE;
1031: new_object = FALSE;
1032:
1033: merr_raise (INEWMUL);
1034: goto err;
1035: }
1036:
1037: if (new_and_set == TRUE) new_and_set = FALSE;
1038: if (new_object == TRUE) new_object = FALSE;
1.12 ! snw 1039: /*
1.1 snw 1040: set1:
1.12 ! snw 1041: */
1.1 snw 1042: if (*codptr != ',') break;
1043:
1044: if (*++codptr == '@') goto again;
1045:
1046: goto set0;
1047: }
1048:
1049: /****** special SET syntax: multiple SET, set$piece, special variables */
1050: {
1051: char multiset, vnset[256]; /* multiset variables */
1052: long arg3, arg4; /* 3rd,4th arg in set$piece */
1053:
1054: if ((multiset = (ch == '('))) {
1055: vnset[0] = EOL;
1056: codptr++;
1057: }
1058:
1059: set:
1060: if (*codptr == '$' && (*(codptr + 1) | 0140) == 'p') { /* set$piece */
1061:
1062: if (multiset) {
1063: merr_raise (INVREF);
1064: goto err;
1065: }
1066:
1067: setpiece = 'p';
1068:
1069: while (*++codptr != '(') {
1070:
1071: if (*codptr == EOL) {
1072: merr_raise (INVREF);
1073: goto err;
1074: }
1075:
1076: }
1077:
1078: codptr++;
1079:
1080: expr (NAME);
1081:
1082: if (merr () > OK) goto err;
1083:
1084: stcpy (vn, varnam);
1085:
1086: codptr++;
1087:
1088: if (*codptr++ != ',') {
1089: merr_raise (COMMAER);
1090: goto err;
1091: }
1092:
1.7 snw 1093: expr (STRING);
1094:
1.1 snw 1095: if (merr () > OK) goto err;
1096:
1097: stcpy (tmp2, argptr);
1098:
1099: if (*codptr != ')') {
1100:
1101: codptr++;
1102:
1103: expr (STRING);
1104:
1105: if (merr () > OK) goto err;
1106:
1107: arg3 = intexpr (argptr);
1108:
1109: if (merr () == MXNUM) {
1110: arg3 = 256;
1111: merr_clear ();
1112: }
1113:
1114: }
1115: else {
1116: arg3 = 1;
1117: }
1118:
1119: if (*codptr != ')') {
1120:
1121: codptr++;
1122:
1123: expr (STRING);
1124:
1125: if (merr () > OK) goto err;
1126:
1127: if (*codptr != ')') {
1128: merr_raise (BRAER);
1129: goto err;
1130: }
1131:
1132: arg4 = intexpr (argptr);
1133:
1134: if (merr () == MXNUM) {
1135: arg4 = 256;
1136: merr_clear ();
1137: }
1138:
1139: }
1140: else {
1141: arg4 = arg3;
1142: }
1143: } /* set$piece */
1144: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'q' && (*(codptr + 2) | 0140) == 's') { /* TODO: verify this works (jpw) was (*codptr == '$q'...*/
1145: /*SET $QSUBSCRIPT */
1146:
1147: if (multiset) {
1148: merr_raise (INVREF);
1149: goto err;
1150: }
1151:
1152: setpiece = 'q';
1153:
1154: while (*++codptr != '(') {
1155:
1156: if (*codptr == EOL) {
1157: merr_raise (INVREF);
1158: goto err;
1159: }
1160:
1161: }
1162:
1163: codptr++;
1164:
1165: expr (NAME);
1166:
1167: if (merr () > OK) goto err;
1168:
1169: stcpy (vn, varnam);
1170:
1171: if (*++codptr == ',') {
1172: codptr++;
1173:
1174: expr (STRING);
1175:
1176: if (merr () > OK) goto err;
1177:
1178: stcpy (tmp2, argptr);
1179: }
1180:
1181: if (*codptr != ')') {
1182: merr_raise (BRAER);
1183: goto err;
1184: }
1185:
1186: }
1187: else if (*codptr == '$' &&
1188: (*(codptr + 1) | 0140) == 'd' &&
1189: (*(codptr + 2) | 0140) == 'i') {
1190:
1191: short rb_slot;
1192:
1193: rb_slot = rbuf_slot_from_name (rou_name);
1194:
1195: while ((*(++codptr)) != '=');
1196:
1197: codptr++;
1198:
1199: expr (STRING);
1200:
1201: stcnv_m2c (argptr);
1202:
1203: if ((strcmp (argptr, "STANDARD") == 0) ||
1204: (strcmp (argptr, "MDS") == 0)) {
1205: rbuf_flags[rb_slot].standard = TRUE;
1206: rbuf_flags[rb_slot].dialect = D_MDS;
1207: }
1208: else if (strcmp (argptr, "M77") == 0) {
1209: rbuf_flags[rb_slot].standard = TRUE;
1210: rbuf_flags[rb_slot].dialect = D_M77;
1211: }
1212: else if (strcmp (argptr, "M84") == 0) {
1213: rbuf_flags[rb_slot].standard = TRUE;
1214: rbuf_flags[rb_slot].dialect = D_M84;
1215: }
1216: else if (strcmp (argptr, "M90") == 0) {
1217: rbuf_flags[rb_slot].standard = TRUE;
1218: rbuf_flags[rb_slot].dialect = D_M90;
1219: }
1220: else if (strcmp (argptr, "M95") == 0) {
1221: rbuf_flags[rb_slot].standard = TRUE;
1222: rbuf_flags[rb_slot].dialect = D_M95;
1223: }
1224: else if (strcmp (argptr, "M5") == 0) {
1225: rbuf_flags[rb_slot].standard = TRUE;
1226: rbuf_flags[rb_slot].dialect = D_M5;
1227: }
1228: else if ((strcmp (argptr, "FREEM") == 0) ||
1229: (strcmp (argptr, "EXTENDED") == 0)) {
1230: rbuf_flags[rb_slot].standard = TRUE;
1231: rbuf_flags[rb_slot].dialect = D_FREEM;
1232: }
1233: else {
1234: merr_raise (CMMND);
1235: goto err;
1236: }
1237:
1238: goto s_end;
1239:
1240: }
1241: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) != 't' && (*(codptr + 2) | 0140) != 'c') {
1242:
1243: /* set $extract */
1244: if (multiset) {
1245: merr_raise (INVREF);
1246: goto err;
1247: }
1248:
1249: setpiece = 'e';
1250:
1251: while (*++codptr != '(') {
1252:
1253: if (*codptr == EOL) {
1254: merr_raise (INVREF);
1255: goto err;
1256: }
1257:
1258: }
1259:
1260: codptr++;
1261:
1262: expr (NAME);
1263:
1264: if (merr () > OK) goto err;
1265:
1266: stcpy (vn, varnam);
1267:
1268: codptr++;
1269:
1270: if (*codptr != ')') {
1271: codptr++;
1272:
1273: expr (STRING);
1274:
1275: if (merr () > OK) goto err;
1276:
1277: arg3 = intexpr (argptr);
1278:
1279: if (merr () == MXNUM) {
1280: arg3 = 256;
1281: merr_clear ();
1282: }
1283: }
1284: else {
1285: arg3 = 1;
1286: }
1287:
1288: if (*codptr != ')') {
1289: codptr++;
1290:
1291: expr (STRING);
1292:
1293: if (merr () > OK) goto err;
1294:
1295: if (*codptr != ')') {
1296: merr_raise (BRAER);
1297: goto err;
1298: }
1299:
1300: arg4 = intexpr (argptr);
1301:
1302: if (merr () == MXNUM) {
1303: arg4 = 256;
1304: merr_clear ();
1305: }
1306:
1307: }
1308: else {
1309: arg4 = arg3;
1310: }
1311:
1312: }
1313: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) == 'c') {
1314: /* set $ecode */
1315:
1316: if (multiset) {
1317: merr_raise (INVREF);
1318: goto err;
1319: }
1320:
1321: while ((*(++codptr)) != '=');
1322:
1323: codptr++;
1324:
1325: expr (STRING);
1326:
1327: if (merr () > OK) goto err;
1328:
1329: switch (argptr[0]) {
1330:
1331: case ',':
1332:
1333: switch (argptr[1]) {
1334:
1335: case ',':
1336: merr_raise (M101);
1337: goto err;
1338:
1339: }
1340:
1341: break;
1342:
1343: }
1344:
1345: merr_raise (merr_set_ecode (argptr));
1346:
1347: #if 0
1348: set_io (UNIX);
1349: stcnv_m2c (ecode);
1350: stcnv_m2c (etrap);
1351: printf ("\n\n*** IN SET $ECODE: ecode = '%s' etrap = '%s'\n", ecode, etrap);
1352: stcnv_c2m (etrap);
1353: stcnv_c2m (ecode);
1354: set_io (MUMPS);
1355: #endif
1356:
1357: if (merr () > OK) goto err;
1358:
1359: goto s_end;
1360:
1361: }
1362: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) == 't') {
1363: /* set $etrap */
1364:
1365: if (multiset) {
1366: merr_raise (INVREF);
1367: goto err;
1368: }
1369:
1370: while ((*(++codptr)) != '=');
1371:
1372: codptr++;
1373:
1374: expr (STRING);
1375:
1376: if (merr () > OK) goto err;
1377:
1378: stcpy (etrap, argptr);
1379:
1380: #if 0
1381: set_io (UNIX);
1382: stcnv_m2c (ecode);
1383: stcnv_m2c (etrap);
1384: printf ("\n\n***IN SET $ETRAP: ecode = '%s' etrap = '%s'\n", ecode, etrap);
1385: stcnv_c2m (etrap);
1386: stcnv_c2m (ecode);
1387: set_io (MUMPS);
1388: #endif
1389:
1390: goto s_end;
1391:
1392: }
1393: else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'g' && cset) { /* set$get */
1394:
1395: if (multiset) {
1396: merr_raise (INVREF);
1397: goto err;
1398: }
1399:
1400: setpiece = 'g';
1401:
1402: while (*++codptr != '(') {
1403:
1404: if (*codptr == EOL) {
1405: merr_raise (INVREF);
1406: goto err;
1407: }
1408: }
1409:
1410: codptr++;
1411:
1412: expr (NAME);
1413:
1414: if (merr () > OK) goto err;
1415:
1416: stcpy (vn, varnam);
1417:
1418: if (*++codptr == ',') {
1419: codptr++;
1420:
1421: expr (STRING);
1422:
1423: if (merr () > OK) goto err;
1424:
1425: stcpy (tmp2, argptr);
1426: }
1427: else {
1428: tmp2[0] = EOL;
1429: }
1430:
1431: if (*codptr != ')') {
1432: merr_raise (BRAER);
1433: goto err;
1434: }
1435: }
1436: else {
1437: if (*codptr == '$') {
1438: codptr++;
1439:
1440: expr (NAME);
1441:
1442: if (merr () > OK) goto err;
1443:
1444: stcpy (tmp, varnam);
1445:
1446: varnam[0] = '$';
1447:
1448: stcpy (&varnam[1], tmp);
1449:
1450: i = 0;
1451: while ((ch = varnam[++i]) != EOL) {
1452: if (ch >= 'A' && ch <= 'Z') {
1453: varnam[i] |= 0140; /*to lowercase */
1454: }
1455: }
1456: }
1457: else {
1458: expr (NAME);
1459:
1460: if (merr () > OK) goto err;
1461: }
1462:
1463: stcpy (vn, varnam);
1464: }
1465:
1466: if (multiset) {
1467: vnset[i = stlen (vnset)] = SOH;
1468:
1469: stcpy (&vnset[++i], vn);
1470:
1471: if (*++codptr == ',') {
1472: codptr++;
1473: goto set;
1474: }
1475:
1476: if (*codptr != ')') {
1477: merr_raise (COMMAER);
1478: goto err;
1479: }
1480: }
1481:
1482: if (*++codptr != '=') {
1483: ch = *codptr;
1484:
1485: if (!cset || *++codptr != '=' || multiset || setpiece || varnam[0] == '$') {
1486: merr_raise (ASSIGNER);
1487: break;
1488: }
1489:
1490: setop = ch;
1491: }
1492:
1493: codptr++;
1494:
1495: expr (STRING);
1496:
1497: if (merr () > OK) goto err;
1498:
1499: if (multiset)
1500: multi:
1501: {
1502: i = 0;
1503: while (vnset[i] == SOH) i++;
1504:
1505: j = 0;
1506: while ((vn[j] = vnset[i]) != SOH && vnset[i] != EOL) {
1507: vnset[i++] = SOH;
1508: j++;
1509: }
1510:
1511: vn[j] = EOL;
1512:
1513: if (j == 0) goto s_end;
1514: }
1515:
1516: if (setpiece == 'p') {
1517: long m, n;
1518:
1519: if (arg4 < arg3 || arg4 < 1) {
1520: setpiece = FALSE;
1521: break;
1522: }
1523:
1524: if (arg3 <= 0) arg3 = 1;
1525:
1526: if (vn[0] == '^') {
1527: if (vn[1] == '$') {
1528: ssvn (get_sym, vn, tmp3);
1529: }
1530: else {
1531: global (get_sym, vn, tmp3);
1532: }
1533: }
1534: else {
1535: symtab (get_sym, vn, tmp3);
1536: }
1537:
1538:
1539: if (merr () == UNDEF || merr () == M6 || merr () == M7) {
1540: tmp3[0] = EOL;
1541: merr_clear ();
1542: }
1543: else if (merr () != OK) {
1544: stcpy (varerr, vn);
1545: }
1546:
1547: ch = 0;
1548: m = 0;
1549: n = 0;
1550:
1551: j = stlen (tmp2);
1552:
1553: while (n < arg3 - 1) {
1554:
1555: if ((ch = find (&tmp3[m], tmp2)) <= 0) {
1556:
1557: while (++n < arg3) {
1558: if (stcat (tmp3, tmp2) == 0) {
1559: merr_raise (M75);
1560: goto err;
1561: }
1562: }
1563:
1564: arg3 = arg4 = stlen (tmp3);
1565:
1566: goto set10;
1567: }
1568:
1569: n++;
1570: m += j + ch - 1;
1571: }
1572:
1573: if (arg3 > 1) {
1574: arg3 = m;
1575: }
1576: else {
1577: arg3 = 0;
1578: }
1579:
1580: while (n++ < arg4) {
1581:
1582: if ((ch = find (&tmp3[m], tmp2)) <= 0) {
1583: arg4 = stlen (tmp3);
1584:
1585: goto set10;
1586: }
1587:
1588: m += j + ch - 1;
1589: }
1590:
1591: arg4 = m - j;
1592:
1593: set10:
1594:
1595: stcpy0 (tmp2, tmp3, (long) arg3);
1596:
1597: tmp2[arg3] = EOL;
1598:
1599: if (stcat (tmp2, argptr) == 0) {
1600: merr_raise (M75);
1601: goto err;
1602: }
1603:
1604: if (stcat (tmp2, &tmp3[arg4]) == 0) {
1605: merr_raise (M56); //JPW
1606: goto err;
1607: }
1608:
1609: stcpy (argptr, tmp2);
1610:
1611: setpiece = FALSE;
1612: }
1613: else if (setpiece == 'q') { /* SET$QSUBSCRIPT */
1614:
1615: setpiece = FALSE;
1616:
1617: if (vn[0] == '^') {
1618: if (vn[1] == '$') {
1619: ssvn (get_sym, vn, tmp3);
1620: }
1621: else {
1622: global (get_sym, vn, tmp3);
1623: }
1624: }
1625: else {
1626: symtab (get_sym, vn, tmp3);
1627: }
1628:
1629: if (merr () == UNDEF || merr () == M6 || merr () == M7) {
1630: tmp3[0] = EOL;
1631: merr_clear ();
1632: }
1633: else if (merr () != OK) {
1634: stcpy (varerr, vn);
1635: }
1636:
1637: if (merr () == OK) {
1638: /* 2nd $QS argument */
1639: if ((arg4 = intexpr (tmp2)) < -1) merr_raise (ARGER);
1640: if (merr () != OK) break;
1641:
1642: /* special if source is empty */
1643: if (tmp3[0] != EOL || (arg4 != 0)) {
1644: /* special: Set env to empty: no |""| */
1645: if ((arg4 == -1) && (*argptr == EOL)) {
1646: tmp2[0] = EOL;
1647: }
1648: else if ((arg4 != 0) && !znamenumeric (argptr)) {
1649: /* put replacement string in tmp2 with */
1650: /* quotes around env or subscript, unless numeric */
1651: i = 0;
1652: j = -1;
1653: tmp2[0] = '"';
1654:
1655: while ((tmp2[++i] = argptr[++j]) != EOL) {
1656: if (tmp2[i] == '"') tmp2[++i] = '"';
1657:
1658: if (i >= (STRLEN - 2)) {
1659: merr_raise (M75);
1660: break;
1661: }
1662: }
1663:
1664: tmp2[i] = '"';
1665: tmp2[++i] = EOL;
1666: }
1667: else {
1668: stcpy (tmp2, argptr);
1669: }
1670:
1671: /* source is tmp3, dest is argptr, replacement is tmp2 */
1672: {
1673: int ch, cpflag, quote, piececounter;
1674:
1675: piececounter = 0;
1676: i = 0;
1677: j = 0;
1678: quote = FALSE;
1679: cpflag = FALSE;
1680:
1681: /* if source has no env, process right now */
1682: if ((arg4 == -1) && (tmp3[tmp3[0] == '^'] != '|') && tmp2[0] != EOL) {
1683:
1684: if (tmp3[0] == '^') {
1685: argptr[j++] = '^';
1686: i = 1;
1687: }
1688:
1689: argptr[j++] = '|';
1690: ch = 0;
1691:
1692: while ((argptr[j] = tmp2[ch++]) != EOL) j++;
1693:
1694: argptr[j++] = '|';
1695:
1696: }
1697: else if (arg4 == 0) { /* '^'+name may be separated by env */
1698: if (tmp2[0] == '^') argptr[j++] = '^';
1699: if (tmp3[0] == '^') i++;
1700: }
1701:
1702: while ((ch = tmp3[i++]) != EOL) {
1703: if (ch == '"') quote = !quote;
1704:
1705: if (!quote) {
1706:
1707: if (ch == ',') {
1708: piececounter++;
1709: argptr[j++] = ch;
1710:
1711: continue;
1712: }
1713:
1714: if ((ch == '(' && piececounter == 0)) {
1715: if (!cpflag && (arg4 == 0)) {
1716: i--;
1717: }
1718: else {
1719: piececounter = 1;
1720: argptr[j++] = ch;
1721:
1722: continue;
1723: }
1724: }
1725:
1726: if (ch == '|') {
1727: if (piececounter == 0) {
1728: piececounter = (-1);
1729: }
1730: else if (piececounter == (-1)) {
1731: piececounter = 0;
1732: }
1733:
1734: if (tmp2[0] != EOL || piececounter > 0) argptr[j++] = ch;
1735:
1736: continue;
1737: }
1738: }
1739:
1740: if (piececounter == arg4) {
1741: if (cpflag) continue;
1742:
1743: cpflag = TRUE;
1744: ch = 0;
1745:
1746: if (arg4 == 0 && tmp2[0] == '^') ch = 1;
1747:
1748: while ((argptr[j] = tmp2[ch++]) != EOL) j++;
1749: }
1750: else {
1751: argptr[j++] = ch;
1752: }
1753:
1754: if (j >= (STRLEN - 1)) {
1755: merr_raise (M75);
1756: break;
1757: }
1758: } /* while ((ch = tmp3[i++]) != EOL) ... */
1759:
1760: if (piececounter && (piececounter == arg4)) argptr[j++] = ')';
1761:
1762: if (piececounter < arg4) {
1763:
1764: if (piececounter == 0) {
1765: argptr[j++] = '(';
1766: }
1767: else {
1768: argptr[j - 1] = ',';
1769: }
1770:
1771: while (++piececounter < arg4) {
1772: argptr[j++] = '"';
1773: argptr[j++] = '"';
1774: argptr[j++] = ',';
1775:
1776: if (j >= STRLEN) {
1777: merr_raise (M75);
1778: break;
1779: }
1780:
1781: }
1782: }
1783:
1784: ch = 0;
1785:
1786: if (argptr[j - 1] != ')') {
1787: while ((argptr[j++] = tmp2[ch++]) != EOL);
1788: argptr[j - 1] = ')';
1789: }
1790: }
1791:
1792: argptr[j] = EOL;
1793:
1794: if (j >= STRLEN) {
1795: merr_raise (M75);
1796: break;
1797: }
1798:
1799: }
1800: }
1801: else {
1802: break;
1803: }
1804: } /* set$qsubscript */
1805: else if (setpiece == 'e') { /* SETtable $EXTRACT *//* parameters ok?? */
1806:
1807: if (arg3 > arg4 || arg4 < 1) {
1808: setpiece = FALSE;
1809: break;
1810: }
1811:
1812: if (arg3 <= 0) arg3 = 1;
1813:
1814: if (arg3 > STRLEN) {
1815: merr_raise (M75);
1816: goto err;
1817: }
1818:
1819: /* get value of glvn */
1820: if (vn[0] == '^') {
1821: if (vn[1] == '$') {
1822: ssvn (get_sym, vn, tmp3);
1823: }
1824: else {
1825: global (get_sym, vn, tmp3);
1826: }
1827: }
1828: else {
1829: symtab (get_sym, vn, tmp3);
1830: }
1831:
1832:
1833: /* if UNDEF assume null string */
1834: if (merr () == UNDEF || merr () == M6 || merr () == M7) {
1835: tmp3[0] = EOL;
1836: merr_clear ();
1837: }
1838: else if (merr () != OK) {
1839: stcpy (varerr, vn);
1840: }
1841:
1842: j = stlen (tmp3);
1843:
1844: /* pad with SPaces if source string is too short */
1845: while (j < arg3) tmp3[j++] = SP;
1846:
1847: tmp3[j] = EOL;
1848:
1849: if (stlen (tmp3) > arg4) {
1850: stcpy (tmp2, &tmp3[arg4]);
1851: }
1852: else {
1853: tmp2[0] = EOL;
1854: }
1855:
1856: tmp3[arg3 - 1] = EOL;
1857:
1858: /* compose new value of glvn */
1859: if (stcat (tmp3, argptr) == 0) {
1860: merr_raise (M75);
1861: goto err;
1862: }
1863:
1864: if (stcat (tmp3, tmp2) == 0) {
1865: merr_raise (M75);
1866: goto err;
1867: }
1868:
1869: stcpy (argptr, tmp3);
1870: setpiece = FALSE;
1871: }
1872: else if (setpiece == 'g') { /* SETtable $GET */
1873: setpiece = FALSE;
1874: ch = (stcmp (tmp2, argptr) == 0) ? killone : set_sym;
1875:
1876: if (vn[0] == '^') {
1877: stcpy (an, argptr);
1878: if (vn[1] == '$') {
1879: ssvn (ch, vn, an);
1880: }
1881: else {
1882: global (ch, vn, an);
1883: }
1884: }
1885: else {
1886: stcpy (an, argptr);
1887: symtab (ch, vn, an);
1888: }
1889:
1890: if (merr () != OK) stcpy (varerr, vn);
1891: break;
1892: }
1893:
1894: if (vn[0] == '^') { /* global variables and SSVNs */
1895: stcpy (an, argptr);
1896:
1897: if (vn[1] == '$') {
1898: ssvn (set_sym, vn, an);
1899: }
1900: else {
1901: global (set_sym, vn, an);
1902: }
1903:
1904:
1905: if (merr () > OK) {
1906: stcpy (varerr, vn);
1907: goto err;
1908: }
1909: }
1910: else if (vn[0] != '$') { /* local variables */
1911: stcpy (an, argptr);
1912: symtab (set_sym, vn, an);
1913:
1914: if (merr () > OK) {
1915: stcpy (varerr, vn);
1916: goto err;
1917: }
1918: }
1919: else { /* $-variables */
1920:
1921: if (vn[1] == 'x') { /* set $X */
1922: j = intexpr (argptr);
1923:
1924: if (merr () == MXNUM) {
1925: j = 256;
1926: merr_clear ();
1927: }
1928:
1929: if (j < 0) {
1930: merr_raise (M43);
1931: goto err;
1932: }
1933:
1934: if (io == HOME) {
1935: argptr[0] = ESC;
1936: argptr[1] = '[';
1937: argptr[2] = EOL;
1938:
1939: if (ypos[HOME] > 1) {
1940: intstr (tmp3, ypos[HOME] + 1);
1941: stcat (argptr, tmp3);
1942: }
1943:
1944: if (j > 0) {
1945: stcat (argptr, ";\201");
1946: intstr (tmp3, j + 1);
1947: stcat (argptr, tmp3);
1948: }
1949:
1950: stcat (argptr, "H\201");
1951: write_m (argptr);
1952: }
1953:
1954: xpos[io] = j;
1955: goto s_end;
1956: }
1957: else if (vn[1] == 'y') { /* set $Y */
1958:
1959: j = intexpr (argptr);
1960:
1961: if (merr () == MXNUM) {
1962: j = 256;
1963: merr_clear ();
1964: }
1965:
1966: if (j < 0) {
1967: merr_raise (M43);
1968: goto err;
1969: }
1970:
1971: if (io == HOME) {
1972:
1973: argptr[0] = ESC;
1974: argptr[1] = '[';
1975: argptr[2] = EOL;
1976:
1977: if (j > 0) {
1978: intstr (tmp3, j + 1);
1979: stcat (argptr, tmp3);
1980: }
1981:
1982: if (xpos[HOME] > 0) {
1983: stcat (argptr, ";\201");
1984: intstr (tmp3, xpos[HOME] + 1);
1985: stcat (argptr, tmp3);
1986: }
1987:
1988: stcat (argptr, "H\201");
1989: write_m (argptr);
1990: }
1991:
1992: ypos[io] = j;
1993: goto s_end;
1994: }
1995: else if (vn[1] == 't') { /* set $t */
1996: test = tvexpr (argptr);
1997: goto s_end;
1998: }
1999: else if (vn[1] == 'j') { /* set $job */
2000: pid = intexpr (argptr);
2001: lock (" \201", -1, 's');
2002: goto s_end;
2003: }
2004: #if !defined(_SCO_DS)
2005: else if (vn[1] == 'h') { /* set $horolog */
2006: long int day;
2007: long int sec;
2008: struct timespec sh_ts;
2009:
2010: if (!is_horolog (argptr)) {
2011: merr_raise (ZINVHORO);
2012: goto err;
2013: }
2014:
2015: sec = 0L;
2016:
2017: for (i = 0; argptr[i] != EOL; i++) {
2018:
2019: if (argptr[i] == ',') {
2020: sec = intexpr (&argptr[i + 1]);
2021: break;
2022: }
2023:
2024: }
2025:
2026: if (sec < 0 || sec >= 86400L) {
2027: merr_raise (ARGER);
2028: goto err;
2029: }
2030:
2031: day = intexpr (argptr) - 47117L;
2032:
2033: if (day < 0 || day > 49710L) {
2034: merr_raise (ARGER);
2035: goto err;
2036: }
2037:
1.3 snw 2038: sec += day * 86400 + FreeM_timezone;
2039: day = FreeM_timezone;
1.1 snw 2040:
2041: sh_ts.tv_sec = sec;
2042:
2043: #if defined(__linux__)
2044: if (clock_settime (CLOCK_REALTIME, &sh_ts) != 0) {
2045: merr_raise (PROTECT);
2046: goto err;
2047: }
2048: #endif
2049:
2050: #ifndef LINUX
2051: /* daylight savings time status may have changed */
2052: {
2053: struct tm *ctdata;
2054: long clock;
2055:
2056: clock = time (0L);
2057: ctdata = localtime (&clock);
2058:
1.3 snw 2059: if (day -= (FreeM_timezone = ctdata->tm_tzadj)) {
1.1 snw 2060: sec -= day;
2061: tzoffset += day;
2062: stime (&sec);
2063: }
2064: }
2065: #endif /* LINUX */
2066: goto s_end;
2067:
2068:
2069: }
2070: #endif /* _SCO_DS */
2071: else if ((vn[1] == 'r') || ((vn[1] == 'z') && (vn[2] == 'r') && vn[3] == EOL)) { /* set $reference */
2072:
2073: if (argptr[0] == EOL) {
2074: zref[0] = EOL;
2075: break;
2076: }
2077:
2078: stcpy (tmp4, codptr);
2079: stcpy (code, argptr);
2080:
2081: codptr = code;
2082:
2083: expr (NAME);
2084: stcpy (code, tmp4);
2085:
2086: codptr = code;
2087:
2088: if (argptr[0] != '^') merr_raise (INVREF);
2089: if (ierr <= OK) nakoffs = stcpy (zref, argptr); /* save reference */ /* SMW - TODO */
2090:
2091: goto s_end;
2092: }
2093: else if (vn[1] == 'z') { /* $Z.. variables *//* if not intrinsic: make it user defined */
2094:
2095: i = stcpy (&tmp[1], &vn[1]) + 1;
2096:
2097: if (vn[3] == DELIM) i = 3; /* set $zf() function keys */
2098:
2099: tmp[0] = SP;
2100: tmp[i] = SP;
2101: tmp[++i] = EOL;
2102:
2103: if (find (zsvn, tmp) == FALSE) {
2104:
2105: i = 2;
2106: while (vn[i] != EOL) {
2107:
2108: if (vn[i++] == DELIM) {
2109: merr_raise (INVREF);
2110: goto err;
2111: }
2112:
2113: }
2114:
2115: udfsvn (set_sym, &vn[2], argptr);
2116: break;
2117: }
2118:
2119: if ((!stcmp (&vn[2], "l\201")) || (!stcmp (&vn[2], "local\201"))) { /* set $zlocal */
2120:
2121: if (argptr[0] == EOL) {
2122: zloc[0] = EOL;
2123: break;
2124: }
2125:
2126: stcpy (tmp4, codptr);
2127: stcpy (code, argptr);
2128:
2129: codptr = code;
2130:
2131: expr (NAME);
2132: stcpy (code, tmp4);
2133:
2134: codptr = code;
2135:
2136: if (argptr[0] == '^') merr_raise (INVREF);
2137: if (ierr <= OK) stcpy (zloc, argptr); /* save reference */
2138:
2139: break;
2140: }
2141: if ((!stcmp (&vn[2], "t\201")) || (!stcmp (&vn[2], "tr\201")) || (!stcmp (&vn[2], "trap\201"))) { /* set $ztrap */
2142:
2143: if (stlen (argptr) > ZTLEN) {
2144: merr_raise (M75);
2145: goto err;
2146: }
2147:
2148: /* DSM V.2 error trapping */
2149: #ifdef DEBUG_NEWSTACK
2150: printf ("Setting Ztrap, DSM2err [%d]\r\n", DSM2err);
2151: #endif
2152:
2153:
2154: if (DSM2err) {
2155: stcpy (ztrap[NESTLEVLS + 1], argptr);
2156: }
2157: else {
2158: stcpy (ztrap[nstx], argptr);
2159: }
2160:
2161: }
2162: else if (!stcmp (&vn[2], "p\201") || !stcmp (&vn[2], "precision\201")) { /* set $zprecision */
2163:
2164: short tmp_zprecise;
2165:
2166: if ((tmp_zprecise = intexpr (argptr)) < 0) {
2167: merr_raise (MXNUM);
2168: goto err;
2169: }
2170:
2171: if (!fp_mode) {
2172:
2173: if (merr () == MXNUM) goto err;
2174:
2175: if (tmp_zprecise > 20000) {
2176: merr_raise (MXNUM);
2177: goto err;
2178: }
2179:
2180: }
2181: #if !defined(_AIX)
2182: else {
2183:
2184: if (tmp_zprecise > DBL_DIG) {
2185: merr_raise (MXNUM);
2186: goto err;
2187: }
2188:
2189: sprintf (fp_conversion, "%%.%df\201", tmp_zprecise);
2190:
2191: }
2192: #endif
2193:
2194: zprecise = tmp_zprecise;
2195:
2196:
2197: }
2198: else if (vn[2] == 'f' && vn[3] == DELIM) { /* set $zf() function keys */
2199:
2200: i = intexpr (&vn[4]) - 1;
2201:
2202: if (i < 0 || i > 43) {
2203: merr_raise (FUNARG);
2204: goto err;
2205: }
2206:
2207: if (stlen (argptr) > FUNLEN) {
2208: merr_raise (M75);
2209: goto err;
2210: }
2211:
2212: stcpy (zfunkey[i], argptr);
2213:
2214: }
2215: 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 */
2216:
2217: short k;
2218:
2219: i = 0;
2220:
2221: for (ch = 0; ch <= 255; ch++) {
2222: j = argptr - partition;
2223:
2224: while ((k = partition[j++]) != EOL) {
2225:
2226: if (UNSIGN (k) == ch) {
2227: tmp[i++] = k;
2228: break;
2229: }
2230:
2231: }
2232:
2233: }
2234:
2235: tmp[i] = EOL;
2236:
2237: switch (vn[3]) {
2238:
2239: case 'c':
2240: stcpy (zmc, tmp);
2241: break;
2242:
2243: case 'n':
2244: stcpy (zmn, tmp);
2245: break;
2246:
2247: case 'p':
2248: stcpy (zmp, tmp);
2249: break;
2250: /* 'a': always union of zml+zmu */
2251:
2252: case 'l':
2253: stcpy (zml, tmp);
2254: break;
2255:
2256: case 'u':
2257: stcpy (zmu, tmp);
2258: break;
2259: /* 'e': always 'everything' */
2260: }
2261:
2262: }
2263: else {
2264: merr_raise (INVREF);
2265: break;
2266: }
2267: }
2268: else {
2269: merr_raise (INVREF);
2270: goto err;
2271: } /* end of processing for $Z.. intrinsic special variables */
2272: } /* svns=$vars */
2273:
2274: if (multiset) goto multi;
2275: } /* end of scope for special SET syntaxes */
2276:
2277: s_end:
2278: if (*codptr != ',') break;
2279: if (*++codptr == '@') goto again;
2280:
2281: goto set0;
2282:
2283: case IF:
2284: merr_raise (cmd_if (&ra));
2285: MRESCHECK(ra);
2286: break;
2287:
2288:
2289: case OO_USING:
2290: merr_raise (cmd_using (&ra));
2291: MRESCHECK(ra);
2292: break;
2293:
2294: case OO_WITH:
2295: merr_raise (cmd_with (&ra));
2296: MRESCHECK(ra);
2297: break;
2298:
2299: case WRITE:
2300: merr_raise (cmd_write(&ra, &i));
2301: MRESCHECK(ra);
2302: break;
2303:
2304: case READ:
2305: merr_raise (cmd_read (&ra));
2306: MRESCHECK(ra);
2307: break;
2308:
2309: case ELSE:
2310: merr_raise (cmd_else (&ra));
2311: MRESCHECK(ra);
2312: break;
2313:
2314: case ZQUIT:
2315:
2316: {
2317: int zq_lvlct;
2318:
2319: if (rtn_dialect () != D_FREEM) {
2320: merr_raise (NOSTAND);
2321: goto err;
2322: }
2323:
2324: if (*codptr == EOL) {
2325: zq_lvlct = nstx;
2326: }
2327: else {
2328: expr (STRING);
2329:
2330: zq_lvlct = intexpr (argptr);
2331:
2332: if (merr () > OK) goto err;
2333:
2334: if (zq_lvlct < 0 || zq_lvlct > nstx) {
2335: merr_raise (LVLERR);
2336: goto err;
2337: }
2338: else if (zq_lvlct != nstx) {
2339: repQUIT = nstx - zq_lvlct;
2340: }
2341: else {
2342: merr_raise (LVLERR);
2343: goto err;
2344: }
2345: }
2346:
2347: break;
2348: }
2349:
2350: case QUIT:
2351:
2352: if (tp_level > 0) {
2353: merr_raise (M42);
2354: goto err;
2355: }
2356:
2357: #ifdef DEBUG_NEWSTACK
2358: printf ("At QUIT command, checking stack...\r\n");
2359: #endif
2360:
2361:
2362:
2363: #ifdef DEBUG_NEWSTACK
2364: printf ("nestc[nstx] is (%d)\r\n", nestc[nstx]);
2365: #endif
2366:
2367: if (*codptr != EOL && *codptr != SP && nestc[nstx] != '$') {
2368: #ifdef DEBUG_NEWSTACK
2369: printf ("IERR\r\n");
2370: #endif
2371:
2372: merr_raise (ARGER);
2373: break;
2374: }
2375:
2376:
2377:
2378: if (nestc[nstx] == '$') { /* extrinsic function/variable */
2379:
2380:
2381: #ifdef DEBUG_NEWSTACK
2382: printf ("EXTRINSIC\r\n");
2383: #endif
2384: //printf (" extr_types[%d] = '%d'\r\n", nstx, extr_types[nstx]);
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: // printf ("nestc[nstx] was BREAK\r\n");
5101: if (repQUIT) continue;
5102: merr_raise (OK - CTRLB);
5103:
5104: goto zgo; /*cont. single step */
5105: }
5106: // else {
5107: // printf ("nestc[nstx] was _not_ BREAK\r\n");
5108: // }
5109:
5110: if (nestc[nstx] == FOR) {
5111:
5112: stcpy (code, cmdptr = nestp[nstx--]);
5113: estack--;
5114:
5115: codptr = code;
5116: ftyp = fortyp[--forx];
5117: fvar = forvar[forx];
5118: finc = forinc[forx];
5119: flim = forlim[forx];
5120: fi = fori[forx];
5121:
5122: if (repQUIT) continue;
5123: if ((forsw = (nestc[nstx] == FOR))) goto for_end;
5124:
5125: goto next_line;
5126: }
5127:
5128: if (nestn[nstx]) { /* reload routine */
5129: namptr = nestn[nstx];
5130:
5131: if ((nestc[nstx] != XECUTE) || loadsw) {
5132: stcpy (rou_name, namptr);
5133: zload (rou_name);
5134:
5135: ssvn_job_update ();
5136:
5137: dosave[0] = 0;
5138: }
5139:
5140: namptr--;
5141: }
5142:
5143: if (nestnew[nstx]) unnew (); /* un-NEW variables */
5144:
5145: /* restore old pointers */
5146: if ((mcmnd = nestc[nstx]) == BREAK) {
5147: if (repQUIT) continue;
5148:
5149: goto restore;
5150: } /*cont. single step */
5151:
5152: if (mcmnd == DO_BLOCK) {
5153: test = nestlt[nstx];
5154: level--;
5155: }
5156: else { /* pop $TEST */
5157: level = nestlt[nstx]; /* pop level */
5158: }
5159:
5160: roucur = nestr[nstx] + rouptr;
5161: stcpy (codptr = code, cmdptr = nestp[nstx--]);
5162: estack--;
5163: forsw = (nestc[nstx] == FOR);
5164:
5165:
5166: loadsw = TRUE;
5167:
5168: if (mcmnd == '$') {
5169: if (repQUIT) return 0;
5170: merr_raise (NOVAL);
5171: }
5172: }
5173: repQUIT = 0;
5174: }
5175: break;
5176:
5177: /* Z-COMMANDS */
5178: case ZGO:
5179:
5180: /* ZGO with arguments: same as GOTO but with BREAK on */
5181: if (*codptr != EOL && *codptr != SP) {
5182: mcmnd = GOTO;
5183: zbflag = TRUE;
5184: merr_raise (OK - CTRLB);
5185:
5186: goto do_goto;
5187: }
5188:
5189: /* argumentless ZGO resume execution after BREAK */
5190:
5191: if (nestc[nstx] != BREAK) {
5192: merr_raise (LVLERR);
5193: break;
5194: }
5195:
5196:
5197:
5198: merr_clear (); /* stop BREAKing */
5199:
5200: zgo:
5201:
5202: #ifdef DEBUG_NEWSTACK
5203: printf ("Zgoing: (Stack POP)\r\n");
5204: #endif
5205:
5206:
5207:
5208: if (nestn[nstx]) { /* reload routine */
5209: stcpy (rou_name, (namptr = nestn[nstx]));
5210: zload (rou_name);
5211:
5212: ssvn_job_update ();
5213:
5214: if (merr () > OK) break;
5215: }
5216:
5217: level = nestlt[nstx];
5218: roucur = nestr[nstx] + rouptr;
5219: io = brkstk[nstx];
5220:
5221: if (io & 020) {
5222: DSW &= ~BIT0;
5223: }
5224: else {
5225: DSW |= BIT0; /* restore echo state */
5226: }
5227:
5228: test = (io & 010) >> 3; /* restore $TEST */
5229:
5230: /* restore $IO; default to HOME if channel not OPEN */
5231: if ((io &= 07) != HOME && devopen[io] == 0) io = HOME;
5232:
5233: stcpy (codptr = code, cmdptr = nestp[nstx--]);
5234: estack--;
5235:
5236: forsw = (nestc[nstx] == FOR);
5237:
5238:
5239: loadsw = TRUE;
5240: zbflag = FALSE;
5241:
5242: goto next0;
5243:
5244:
5245: case ZBREAK:
5246:
5247: if (*codptr == SP || *codptr == EOL) {
5248: merr_raise (ARGLIST);
5249: break;
5250: }
5251:
5252: expr (STRING);
5253: if (merr () > OK) break;
5254:
5255: zbreakon = tvexpr (argptr);
5256: if (hardcopy == DISABLE) set_zbreak (zbreakon ? STX : -1); /* enable/disable CTRL/B */
5257:
5258: zbflag = FALSE;
5259: break;
5260:
5261:
5262:
5263:
5264: case ZLOAD:
5265:
5266: if (*codptr == EOL || *codptr == SP) {
5267: stcpy (varnam, rou_name);
5268: }
5269: else {
5270: expr (NAME);
5271:
5272: if (merr () > OK) break;
5273:
5274: codptr++;
5275: }
5276:
5277: dosave[0] = EOL;
5278:
5279: if (varnam[0] == EOL) {
5280: varerr[0] = EOL;
5281: merr_raise (NOPGM);
5282: break;
5283: } /*error */
5284:
5285: loadsw = TRUE;
5286:
5287: /* a ZLOAD on the active routine always loads from disk */
5288: if (stcmp (varnam, rou_name) == 0) {
5289: for (i = 0; i < NO_OF_RBUF; i++) {
5290:
5291: if (rouptr == (buff + (i * PSIZE0))) {
5292: pgms[i][0] = EOL;
5293:
5294: break;
5295: }
5296: }
5297: }
5298:
5299: zload (varnam);
5300:
5301: if (merr () > OK) break; /* load file */
5302:
5303: stcpy (rou_name, varnam);
5304: ssvn_job_update ();
5305:
5306: break;
5307:
5308: case ZSAVE:
5309:
5310: if (*codptr == EOL || *codptr == SP) {
5311:
5312: if (rou_name[0] == EOL) {
5313: varerr[0] = EOL;
5314: merr_raise (NOPGM);
5315:
5316: break;
5317: } /*error */
5318:
5319: stcpy (varnam, rou_name);
5320: }
5321: else {
5322: expr (NAME);
5323:
5324: if (varnam[0] == '^') merr_raise (GLOBER);
5325: if (varnam[0] == '$') merr_raise (INVREF);
5326: if (merr () > OK) break;
5327:
5328: stcpy (rou_name, varnam);
5329: ssvn_job_update ();
5330:
5331: codptr++;
5332: }
5333:
5334: zsave (varnam);
5335: break;
5336:
5337:
5338: case ZREMOVE:
5339:
5340: {
5341: char *beg, *end;
5342:
5343: dosave[0] = EOL;
5344:
5345: if (*codptr == SP || *codptr == EOL) { /* no args is ZREMOVE all */
5346: loadsw = TRUE;
5347:
5348: for (i = 0; i < NO_OF_RBUF; i++) {
5349:
5350: if (rouptr == buff + (i * PSIZE0)) {
5351: pgms[i][0] = EOL;
5352: break;
5353: }
5354:
5355: }
5356:
5357: rouptr = buff + (i * PSIZE0);
5358: rouend = rouins = rouptr;
5359: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
5360:
5361: *(rouptr) = EOL;
5362: *(rouptr + 1) = EOL;
5363: *(rouptr + 2) = EOL;
5364:
5365: argptr = partition;
5366: rou_name[0] = EOL;
5367:
5368: ssvn_job_update ();
5369:
5370: break;
5371: }
5372: if (*codptr == ':') {
5373: beg = rouptr;
5374: }
5375: else if (*codptr == '*') {
5376: beg = rouptr;
5377:
5378: while ((end = (beg + UNSIGN (*beg) + 2)) < rouins) beg = end;
5379:
5380: codptr++;
5381: }
5382: else {
5383: lineref (&beg);
5384: if (merr () > OK) break;
5385: }
5386:
5387: if ((end = beg) == 0) {
5388: merr_raise (M13);
5389: break;
5390: }
5391:
5392: if (*codptr == ':') { /* same as above */
5393: codptr++;
5394:
5395: if (*codptr == '*') {
5396: end = rouins;
5397: codptr++;
5398: }
5399: else if (*codptr == ',' || *codptr == SP || *codptr == EOL) {
5400: end = rouend;
5401: }
5402: else {
5403: lineref (&end);
5404:
5405: if (end == 0) merr_raise (M13);
5406: if (merr () > OK) break;
5407:
5408: end = end + UNSIGN (*end) + 2;
5409: }
5410: }
5411: else {
5412: end = end + UNSIGN (*end) + 2;
5413: }
5414:
5415: if (beg < rouend) { /* else there's nothing to zremove */
5416:
5417: if (end >= rouend) {
5418: end = rouend = beg;
5419: }
5420: else {
5421: rouins = beg;
5422:
5423: while (end <= rouend) *beg++ = (*end++);
5424:
5425: i = beg - end;
5426: rouend += i;
5427:
5428: if (roucur > end) roucur += i;
5429: }
5430:
5431: *end = EOL;
5432: *(end + 1) = EOL;
5433:
5434: for (i = 0; i < NO_OF_RBUF; i++) {
5435: if (rouptr == (buff + (i * PSIZE0))) {
5436: ends[i] = rouend;
5437: break;
5438: }
5439: }
5440:
5441: }
5442: break;
5443: }
5444:
5445: case ZINSERT:
5446:
5447: {
5448: char *beg;
5449:
5450: if (*codptr == EOL || *codptr == SP) {
5451: merr_raise (ARGLIST);
5452: break;
5453: } /*error */
5454:
5455: dosave[0] = EOL;
5456:
5457: /* parse stringlit */
5458: expr (STRING);
5459:
5460: if (merr () > OK) break;
5461:
5462: if (*codptr != ':') {
5463: zi (argptr, rouins);
5464: break;
5465: }
5466:
5467: stcpy (tmp, argptr);
5468: codptr++;
5469: lineref (&beg);
5470:
5471: if (merr () > OK) break; /* parse label */
5472:
5473: if (beg) {
5474: beg = beg + UNSIGN (*beg) + 2;
5475: }
5476: else {
5477: beg = rouptr;
5478: }
5479:
5480: if (beg > rouend + 1) {
5481: merr_raise (M13);
5482: break;
5483: }
5484:
5485: /* insert stuff */
5486: zi (tmp, beg);
5487: break;
5488: }
5489:
5490:
5491: /* PRINT is convenient -
5492: * but non-standard ZPRINT should be used instead */
5493: case 'p':
5494:
5495: if (is_standard ()) {
5496: merr_raise (NOSTAND);
5497: break;
5498: }
5499:
5500:
5501: case ZPRINT:
5502:
5503: {
5504: char *beg, *end;
5505:
5506: if (*codptr == SP || *codptr == EOL) { /* no args is ZPRINT all */
5507: beg = rouptr;
5508: end = rouend;
5509: }
5510: else {
5511: if (*codptr == ':') {
5512: beg = rouptr; /* from begin */
5513: }
5514: else if (*codptr == '*') { /* from 'linepointer' */
5515: beg = rouptr;
5516:
5517: while ((end = (beg + UNSIGN (*beg) + 2)) < rouins) beg = end;
5518: codptr++;
5519: }
5520: else {
5521: lineref (&beg);
5522: if (merr () > OK) break;
5523: } /* line reference */
5524:
5525: if (beg == 0) {
5526: beg = rouptr;
5527: rouins = beg;
5528:
5529: if (*codptr != ':') break;
5530: }
5531:
5532: if (*codptr == ':') {
5533: codptr++; /* to end */
5534:
5535: if (*codptr == SP || *codptr == ',' || *codptr == EOL)
5536: end = rouend;
5537: else {
5538: if (*codptr == '*') {
5539: end = rouins;
5540: codptr++;
5541: }
5542: else { /* to 'linepointer' */
5543: lineref (&end);
5544:
5545: if (merr () > OK) break; /* line reference */
5546: end = end + UNSIGN (*end) + 2;
5547: }
5548: }
5549: }
5550: else {
5551: end = beg + 1;
5552: }
5553: }
5554: if (rouend < end) end = rouend - 1;
5555:
5556: for (; beg < end; beg += UNSIGN (*beg) + 2) {
5557:
1.8 snw 5558: if (frm_crlf[io]) {
1.1 snw 5559: write_m ("\012\201");
5560: }
5561: else {
5562: write_m ("\012\015\201");
5563: }
5564:
5565: if ((*(beg + 1)) == EOL) break;
5566:
5567: write_m (beg + 1);
5568: if (merr () > OK) break;
5569: }
5570:
5571: rouins = beg;
5572: }
5573:
1.8 snw 5574: if (frm_crlf[io]) {
1.1 snw 5575: write_m ("\012\201");
5576: }
5577: else {
5578: write_m ("\012\015\201");
5579: }
5580:
5581: break;
5582:
5583: case WATCH:
5584: {
5585: char op;
5586:
5587:
5588: if (((ch = *codptr) == SP) || ch == EOL) {
5589:
5590: set_io(UNIX);
5591:
5592: if (dbg_enable_watch) {
5593: printf ("Watchpoints disabled.\n");
5594: dbg_enable_watch = 0;
5595: }
5596: else {
5597: printf ("Watchpoints enabled.\n");
5598: dbg_enable_watch = 1;
5599: }
5600:
5601: break;
5602:
5603: }
5604:
5605: if ((ch = *codptr) == '(') {
5606: merr_raise (ARGLIST);
5607: goto err;
5608: }
5609:
5610: for (;;) {
5611:
5612: switch (ch) {
5613:
5614: case '?':
5615: case '+':
5616: case '-':
5617: op = ch;
5618: codptr++;
5619: break;
5620:
5621: default:
5622: merr_raise (ARGLIST);
5623: goto err;
5624: }
5625:
5626: expr (NAME); /* try to interpret an mname */
5627:
5628: if (merr () > OK) goto err;
5629:
5630: stcpy (vn, varnam);
5631:
5632: switch (op) {
5633:
5634: case '+':
5635: dbg_add_watch (vn);
5636: break;
5637:
5638: case '-':
5639: dbg_remove_watch (vn);
5640: break;
5641:
5642: case '?':
5643: dbg_dump_watch (vn);
5644: break;
5645:
5646: }
5647:
5648: if (merr () > OK) goto err;
5649:
5650: if ((ch = *(codptr + 1)) == EOL) {
5651: codptr++;
5652: break;
5653: }
5654: else if ((ch = *(codptr + 1)) == ',') {
5655: codptr += 2;
5656: ch = *codptr;
5657: }
5658: else {
5659: merr_raise (ARGLIST);
5660: goto err;
5661: }
5662: }
5663:
5664:
5665: break;
5666: }
5667:
5668:
5669: case ASSERT_TKN:
5670: {
5671: expr (STRING);
5672:
5673: if (merr () > OK) goto err;
5674:
5675: if (tvexpr (argptr) == 0) {
5676: merr_raise (ASSERT);
5677: goto err;
5678: }
5679:
5680: break;
5681: }
5682:
5683: case ZWRITE:
5684: {
5685: short k;
5686: char w_tmp[512];
5687: char zwmode;
5688:
5689:
5690: if (io != HOME && devopen[io] == 'r') {
5691: merr_raise (NOWRITE);
5692: goto err;
5693: }
5694:
5695: tmp3[0] = SP;
5696: tmp3[1] = EOL;
5697:
5698: if ((ch = (*codptr)) == '(') { /* exclusive zwrite */
5699:
5700: for (;;) {
5701:
5702: codptr++;
5703: expr (NAME);
5704:
5705: if (merr () > OK) goto err;
5706: if (varnam[0] == '^') {
5707: merr_raise (GLOBER);
5708: goto err;
5709: }
5710:
5711: i = 0;
5712:
5713: while (varnam[i] != EOL) {
5714:
5715: if (varnam[i] == DELIM) {
5716: merr_raise (SBSCR);
5717: goto err;
5718: }
5719:
5720: i++;
5721: }
5722:
5723: if (stcat (tmp3, varnam) == 0) {
5724: merr_raise (M75);
5725: goto err;
5726: }
5727:
5728: if (stcat (tmp3, " \201") == 0) {
5729: merr_raise (M75);
5730: goto err;
5731: }
5732:
5733: if ((ch = *++codptr) == ')') {
5734: codptr++;
5735: break;
5736: }
5737:
5738: if (ch != ',') {
5739: merr_raise (COMMAER);
5740: goto err;
5741: }
5742: }
5743: }
5744: else {
5745: if (ch != SP && ch != EOL) goto zwritep;
5746: }
5747:
5748: /* no arguments: write local symbol table. */
5749: stcpy (tmp, " $\201");
5750:
5751: for (;;) {
5752: ordercnt = 1L;
5753:
5754: symtab (bigquery, &tmp[1], tmp2);
5755:
5756: if (*tmp2 == EOL || merr () == INRPT) break;
5757: w_tmp[0] = '=';
5758:
5759: /* subscripts: internal format different from external one */
5760: k = 0;
5761: i = 1;
5762: j = 0;
5763:
5764: while ((ch = tmp2[k++]) != EOL) {
5765:
5766: if (ch == '"') {
5767:
5768: if (j && tmp2[k] == ch) {
5769: k++;
5770: }
5771: else {
5772: toggle (j);
5773: continue;
5774: }
5775:
5776: }
5777:
5778: if (j == 0) {
5779:
5780: if (ch == '(' || ch == ',') {
5781: tmp[i++] = DELIM;
5782:
5783: continue;
5784: }
5785:
5786: if (ch == ')') break;
5787: }
5788:
5789: tmp[i++] = ch;
5790: }
5791:
5792: tmp[i] = EOL;
5793: if (kill_ok (tmp3, tmp) == 0) continue;
5794:
5795: write_m (tmp2);
5796: symtab (get_sym, &tmp[1], &w_tmp[1]);
5797: write_m (w_tmp);
5798: write_m ("\012\015\201");
5799: }
5800:
5801: break;
5802:
5803: zwritep:
5804:
5805: expr (NAME);
5806:
5807: //if (varnam[0] == '^') merr_raise (GLOBER);
5808: if (merr () > OK) goto err;
5809:
5810: codptr++;
5811:
5812: if (varnam[0] == '$') {
5813:
5814: if ((varnam[1] | 0140) == 'z' && (varnam[2] | 0140) == 'f') {
5815: w_tmp[0] = '$';
5816: w_tmp[1] = 'Z';
5817: w_tmp[2] = 'F';
5818: w_tmp[3] = '(';
5819:
5820: for (i = 0; i < 44; i++) {
5821:
5822: if (zfunkey[i][0] != EOL) {
5823: intstr (&w_tmp[4], i + 1);
5824: stcat (w_tmp, ")=\201");
5825: write_m (w_tmp);
5826: write_m (zfunkey[i]);
5827: write_m ("\012\015\201");
5828: }
5829:
5830: }
5831:
5832: break;
5833: }
5834: else {
5835: break; /* do not zwrite special variables etc. other than $ZF */
5836: }
5837: }
5838:
5839: if (varnam[0] != '^') {
1.9 snw 5840: symtab (fra_dat, varnam, tmp2);
1.1 snw 5841: zwmode = 'L';
5842: }
5843: else {
5844: if (varnam[1] == '$') {
1.9 snw 5845: ssvn (fra_dat, varnam, tmp2);
1.1 snw 5846: zwmode = '$';
5847: }
5848: else {
1.9 snw 5849: global (fra_dat, varnam, tmp2);
1.1 snw 5850: zwmode = '^';
5851: }
5852: }
5853:
5854: if (tmp2[0] == '0') break; /* variable not defined */
5855:
5856: /* if $D(@varnam)=10 get next entry */
5857: if (tmp2[1] == '0') {
5858: ordercnt = 1L;
5859:
5860: if (varnam[0] != '^') {
5861: symtab (fra_query, varnam, tmp2);
5862: zwmode = 'L';
5863: }
5864: else {
5865: if (varnam[1] == '$') {
5866: ssvn (fra_query, varnam, tmp2);
5867: zwmode = '$';
5868: }
5869: else {
5870: global (fra_query, varnam, tmp2);
5871: zwmode = '^';
5872: }
5873: }
5874: }
5875: else {
5876: k = 0;
5877: i = 0;
5878: j = 0;
5879:
5880: while ((ch = varnam[k++]) != EOL) {
5881:
5882: if (ch == DELIM) {
5883:
5884: if (j) {
5885: tmp2[i++] = '"';
5886: tmp2[i++] = ',';
5887: tmp2[i++] = '"';
5888:
5889: continue;
5890: }
5891:
5892: j++;
5893:
5894: tmp2[i++] = '(';
5895: tmp2[i++] = '"';
5896:
5897: continue;
5898: }
5899:
5900: if ((tmp2[i++] = ch) == '"')
5901: tmp2[i++] = ch;
5902: }
5903:
5904: if (j) {
5905: tmp[i++] = '"';
5906: tmp2[i++] = ')';
5907: }
5908:
5909: tmp2[i] = EOL;
5910: }
5911:
5912: for (;;) { /* subscripts: internal format different from external one */
5913: k = 0;
5914: i = 0;
5915: j = 0;
5916:
5917: while ((ch = tmp2[k++]) != EOL) {
5918:
5919: if (ch == '"') {
5920: if (j && tmp2[k] == ch)
5921: k++;
5922: else {
5923: toggle (j);
5924: continue;
5925: }
5926: }
5927:
5928: if (j == 0) {
5929:
5930: if (ch == '(' || ch == ',') {
5931: tmp[i++] = DELIM;
5932:
5933: continue;
5934: }
5935:
5936: if (ch == ')') break;
5937: }
5938:
5939: tmp[i++] = ch;
5940: }
5941:
5942: tmp[i] = EOL;
5943: i = 0;
5944:
5945: while (tmp[i] == varnam[i]) {
5946:
5947: if (varnam[i] == EOL) break;
5948:
5949: i++;
5950: }
5951:
5952: if (varnam[i] != EOL) break;
5953: if (tmp[i] != EOL && tmp[i] != DELIM) break;
5954:
5955: tmp3[0] = EOL;
5956:
5957: switch (zwmode) {
5958:
5959: case 'L':
1.9 snw 5960: symtab (fra_dat, tmp, tmp3);
1.1 snw 5961: symtab (get_sym, tmp, &w_tmp[1]);
5962:
5963: break;
5964:
5965:
5966: case '$':
1.9 snw 5967: ssvn (fra_dat, tmp, tmp3);
1.1 snw 5968: ssvn (get_sym, tmp, &w_tmp[1]);
5969:
5970: break;
5971:
5972:
5973: case '^':
1.9 snw 5974: global (fra_dat, tmp, tmp3);
1.1 snw 5975: global (get_sym, tmp, &w_tmp[1]);
5976:
5977: break;
5978: }
5979:
5980: if (tmp3[0] != '0' && tmp3[1] != '0') {
5981:
5982: write_m (tmp2);
5983:
5984: w_tmp[0] = '=';
5985:
5986: write_m (w_tmp);
5987: write_m ("\012\015\201");
5988:
5989: }
5990:
5991: ordercnt = 1L;
5992:
5993: switch (zwmode) {
5994:
5995: case 'L':
5996: symtab (fra_query, tmp, tmp2);
5997:
5998: break;
5999:
6000:
6001: case '$':
6002: ssvn (fra_query, tmp, tmp2);
6003:
6004: break;
6005:
6006:
6007: case '^':
6008: global (fra_query, tmp, tmp2);
6009:
6010: break;
6011:
6012: }
6013:
6014: if (merr () == INRPT) break;
6015: }
6016:
6017: break;
6018: }
6019:
6020:
6021: case ZTRAP:
6022:
6023: if (*codptr == SP || *codptr == EOL) {
6024: merr_raise (ZTERR);
6025: varnam[0] = EOL;
6026:
6027: break;
6028: }
6029:
6030: expr (NAME);
6031: stcpy (varerr, varnam);
6032:
6033: if (merr ()) break;
6034:
6035: if (*++codptr == ':') { /* parse postcond */
6036: codptr++;
6037:
6038: expr (STRING);
6039:
6040: if (merr () > OK) goto err;
6041:
6042: if (tvexpr (argptr) == FALSE) break;
6043: }
6044:
6045: merr_raise (ZTERR);
6046: break;
6047:
6048:
1.11 snw 6049: /* user defined Z-COMMAND */
1.1 snw 6050: case PRIVATE:
6051:
6052: private: /* for in-MUMPS defined commands */
6053: i = 0;
6054: j = 0;
6055: ch = 0;
6056:
6057: while ((tmp2[i] = *codptr) != EOL) {
6058:
6059: if (tmp2[i] == SP && !j) {
6060: tmp2[i] = EOL;
6061: break;
6062: }
6063:
6064: if (tmp2[i] == '"') j = (!j);
6065:
6066: if (!j) {
6067:
6068: if (tmp2[i] == '(') ch++;
6069: if (tmp2[i] == ')') ch--;
6070:
6071: if (!ch && tmp2[i] == ',') { /* next argument: */
6072:
6073: tmp2[i] = EOL; /* call afterwards again */
6074: i = 0;
6075:
6076: while (tmp3[i] != EOL) i++;
6077:
6078: j = i;
6079: ch = 1;
6080:
6081: while (ch < i) tmp3[j++] = tmp3[ch++];
6082:
6083: tmp3[j - 1] = SP;
6084: tmp3[j] = EOL;
6085:
6086: codptr++;
6087:
6088: j = 0;
6089: ch = 0;
6090:
6091: break;
6092: }
6093: }
6094:
6095: i++;
6096: codptr++;
6097: }
6098:
6099: if (j || ch) {
6100: merr_raise (INVREF);
6101: goto err;
6102: }
6103:
6104: stcat (tmp3, codptr);
6105:
6106: if (destructor_run) {
6107: stcpy (code, "d \201");
6108: destructor_run = FALSE;
6109: }
6110: else {
6111: if (new_object) {
6112: stcpy (code, "d ^\201");
6113: new_object = FALSE;
6114: }
6115: else {
6116: stcpy (code, "d ^%\201");
6117: }
6118: }
6119:
6120: stcat (code, &tmp3[1]);
6121:
6122: codptr = code;
6123: privflag = TRUE;
6124:
6125: goto next_cmnd;
6126:
6127: evthandler: /* for event handlers */
6128: i = 0;
6129: j = 0;
6130: ch = 0;
6131:
6132: while ((tmp2[i] = *codptr) != EOL) {
6133:
6134: if (tmp2[i] == SP && !j) {
6135: tmp2[i] = EOL;
6136: break;
6137: }
6138:
6139: if (tmp2[i] == '"') j = (!j);
6140:
6141: if (!j) {
6142:
6143: if (tmp2[i] == '(') ch++;
6144: if (tmp2[i] == ')') ch--;
6145:
6146: if (!ch && tmp2[i] == ',') { /* next argument: */
6147:
6148: tmp2[i] = EOL; /* call afterwards again */
6149: i = 0;
6150:
6151: while (tmp3[i] != EOL) i++;
6152:
6153: j = i;
6154: ch = 1;
6155:
6156: while (ch < i) tmp3[j++] = tmp3[ch++];
6157:
6158: tmp3[j - 1] = SP;
6159: tmp3[j] = EOL;
6160:
6161: codptr++;
6162:
6163: j = 0;
6164: ch = 0;
6165:
6166: break;
6167: }
6168: }
6169:
6170: i++;
6171: codptr++;
6172: }
6173:
6174: if (j || ch) {
6175: merr_raise (INVREF);
6176: goto err;
6177: }
6178:
6179: stcpy (code, "d \201");
6180: stcat (code, tmp3);
6181:
6182: codptr = code;
6183: privflag = TRUE;
6184:
6185: goto next_cmnd;
6186:
6187: case ABLOCK:
6188: case AUNBLOCK:
6189: {
6190: short evt_mask[EVT_MAX];
6191:
6192: if ((rtn_dialect () != D_MDS) &&
6193: (rtn_dialect () != D_FREEM)) {
6194: merr_raise (NOSTAND);
6195: goto err;
6196: }
6197:
6198: /* declare and initialize table of events to be blocked/unblocked with this command */
6199:
6200:
6201: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = 0;
6202:
6203:
6204: /* argumentless ABLOCK/AUNBLOCK: block/unblock everything */
6205: if (((ch = *codptr) == SP) || ch == EOL) {
6206:
6207: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = 1;
6208:
6209: }
6210: else if (*codptr == '(') {
6211: /* exclusive ABLOCK/AUNBLOCK */
6212:
6213: short evt_exclusions[EVT_MAX];
6214:
6215: codptr++;
6216:
6217:
6218: for (i = 0; i < EVT_MAX; i++) evt_exclusions[i] = FALSE;
6219:
6220: for (;;) {
6221:
6222: expr (STRING);
6223:
6224: if (merr () == BRAER) merr_clear ();
6225: if (merr () > OK) goto err;
6226:
6227: codptr++;
6228:
6229: stcpy (vn, argptr);
6230:
6231: if (stcmp (vn, "COMM\201") == 0) {
6232: evt_exclusions[EVT_CLS_COMM] = TRUE;
6233: }
6234: else if (stcmp (vn, "HALT\201") == 0) {
6235: evt_exclusions[EVT_CLS_HALT] = TRUE;
6236: }
6237: else if (stcmp (vn, "IPC\201") == 0) {
6238: evt_exclusions[EVT_CLS_IPC] = TRUE;
6239: }
6240: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6241: evt_exclusions[EVT_CLS_INTERRUPT] = TRUE;
6242: }
6243: else if (stcmp (vn, "POWER\201") == 0) {
6244: evt_exclusions[EVT_CLS_POWER] = TRUE;
6245: }
6246: else if (stcmp (vn, "TIMER\201") == 0) {
6247: evt_exclusions[EVT_CLS_TIMER] = TRUE;
6248: }
6249: else if (stcmp (vn, "USER\201") == 0) {
6250: evt_exclusions[EVT_CLS_USER] = TRUE;
6251: }
6252: else if (stcmp (vn, "WAPI\201") == 0) {
6253: evt_exclusions[EVT_CLS_WAPI] = TRUE;
6254: }
6255: else {
6256: merr_raise (CMMND);
6257: goto err;
6258: }
6259:
6260: if ((ch = *(codptr + 1)) == EOL || ch == SP) {
6261: codptr++;
6262: break;
6263: }
6264: if ((ch = *(codptr + 1)) == ')') {
6265: codptr++;
6266: break;
6267: }
6268:
6269: }
6270:
6271: for (i = 0; i < EVT_MAX; i++) {
6272:
6273: if (evt_exclusions[i] == FALSE) evt_mask[i] = 1;
6274:
6275: }
6276:
6277: }
6278: else {
6279: /* inclusive ABLOCK/AUNBLOCK */
6280:
6281: for (;;) {
6282:
6283: expr (STRING); /* try to interpret a string */
6284: if (merr () > OK) goto err;
6285:
6286: codptr++;
6287:
6288: stcpy (vn, argptr);
6289:
6290: if (stcmp (vn, "COMM\201") == 0) {
6291: evt_mask[EVT_CLS_COMM] = 1;
6292: }
6293: else if (stcmp (vn, "HALT\201") == 0) {
6294: evt_mask[EVT_CLS_HALT] = 1;
6295: }
6296: else if (stcmp (vn, "IPC\201") == 0) {
6297: evt_mask[EVT_CLS_IPC] = 1;
6298: }
6299: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6300: evt_mask[EVT_CLS_INTERRUPT] = 1;
6301: }
6302: else if (stcmp (vn, "POWER\201") == 0) {
6303: evt_mask[EVT_CLS_POWER] = 1;
6304: }
6305: else if (stcmp (vn, "TIMER\201") == 0) {
6306: evt_mask[EVT_CLS_TIMER] = 1;
6307: }
6308: else if (stcmp (vn, "TRIGGER\201") == 0) {
6309: evt_mask[EVT_CLS_TRIGGER] = 1;
6310: }
6311: else if (stcmp (vn, "USER\201") == 0) {
6312: evt_mask[EVT_CLS_USER] = 1;
6313: }
6314: else if (stcmp (vn, "WAPI\201") == 0) {
6315: evt_mask[EVT_CLS_WAPI] = 1;
6316: }
6317: else {
6318: merr_raise (CMMND);
6319: goto err;
6320: }
6321:
6322: if (merr () > OK) goto err;
6323:
6324:
6325: if ((ch = *(codptr)) == EOL || ch == SP) {
6326: break;
6327: }
6328:
6329: }
6330:
6331: }
6332:
6333: for (i = 0; i < EVT_MAX; i++) {
6334:
6335: if (evt_mask[i] > 0) {
6336:
6337: if (mcmnd == ABLOCK) {
6338: evt_ablock (i);
6339: }
6340: else {
6341: evt_aunblock (i);
6342: }
6343: }
6344:
6345: }
6346:
6347:
6348: break;
6349: }
6350:
6351:
6352: case ASSIGN:
6353: merr_raise (CMMND);
6354: break;
6355:
6356:
6357: case ASTOP:
6358: case ASTART:
6359: {
6360: short evt_mask[EVT_MAX];
6361: short new_status;
6362:
6363: if ((rtn_dialect () != D_MDS) &&
6364: (rtn_dialect () != D_FREEM)) {
6365: merr_raise (NOSTAND);
6366: goto err;
6367: }
6368:
6369: /* declare and initialize table of events to be enabled with this command */
6370:
6371: if (mcmnd == ASTART) {
6372: new_status = EVT_S_ASYNC;
6373: }
6374: else {
6375: new_status = EVT_S_DISABLED;
6376: }
6377:
6378:
6379: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = EVT_S_NOMODIFY;
6380:
6381:
6382: /* argumentless ASTART/ASTOP: enable/disable everything */
6383: if (((ch = *codptr) == SP) || ch == EOL) {
6384:
6385: for (i = 0; i < EVT_MAX; i++) evt_mask[i] = new_status;
6386:
6387: }
6388: else if (*codptr == '(') {
6389: /* exclusive ASTART */
6390:
6391: short evt_exclusions[EVT_MAX];
6392:
6393: codptr++;
6394:
6395: for (i = 0; i < EVT_MAX; i++) evt_exclusions[i] = FALSE;
6396:
6397: for (;;) {
6398:
6399: expr (STRING);
6400:
6401: if (merr () == BRAER) merr_clear ();
6402: if (merr () > OK) goto err;
6403:
6404: codptr++;
6405:
6406: stcpy (vn, argptr);
6407:
6408: if (stcmp (vn, "COMM\201") == 0) {
6409: evt_exclusions[EVT_CLS_COMM] = TRUE;
6410: }
6411: else if (stcmp (vn, "HALT\201") == 0) {
6412: evt_exclusions[EVT_CLS_HALT] = TRUE;
6413: }
6414: else if (stcmp (vn, "IPC\201") == 0) {
6415: evt_exclusions[EVT_CLS_IPC] = TRUE;
6416: }
6417: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6418: evt_exclusions[EVT_CLS_INTERRUPT] = TRUE;
6419: }
6420: else if (stcmp (vn, "POWER\201") == 0) {
6421: evt_exclusions[EVT_CLS_POWER] = TRUE;
6422: }
6423: else if (stcmp (vn, "TIMER\201") == 0) {
6424: evt_exclusions[EVT_CLS_TIMER] = TRUE;
6425: }
6426: else if (stcmp (vn, "USER\201") == 0) {
6427: evt_exclusions[EVT_CLS_USER] = TRUE;
6428: }
6429: else if (stcmp (vn, "WAPI\201") == 0) {
6430: evt_exclusions[EVT_CLS_WAPI] = TRUE;
6431: }
6432: else if (stcmp (vn, "TRIGGER\201") == 0) {
6433: evt_exclusions[EVT_CLS_TRIGGER] = TRUE;
6434: }
6435: else {
6436: merr_raise (CMMND);
6437: goto err;
6438: }
6439:
6440: if ((ch = *(codptr + 1)) == EOL || ch == SP) {
6441: codptr++;
6442: break;
6443: }
6444: if ((ch = *(codptr + 1)) == ')') {
6445: codptr++;
6446: break;
6447: }
6448:
6449: }
6450:
6451: for (i = 0; i < EVT_MAX; i++) {
6452:
6453: if (evt_exclusions[i] == FALSE) evt_mask[i] = new_status;
6454:
6455: }
6456:
6457: }
6458: else {
6459: /* inclusive ASTART */
6460:
6461: for (;;) {
6462:
6463: expr (STRING); /* try to interpret a string */
6464: if (merr () > OK) goto err;
6465:
6466: codptr++;
6467:
6468: stcpy (vn, argptr);
6469:
6470: if (stcmp (vn, "COMM\201") == 0) {
6471: evt_mask[EVT_CLS_COMM] = new_status;
6472: }
6473: else if (stcmp (vn, "HALT\201") == 0) {
6474: evt_mask[EVT_CLS_HALT] = new_status;
6475: }
6476: else if (stcmp (vn, "IPC\201") == 0) {
6477: evt_mask[EVT_CLS_IPC] = new_status;
6478: }
6479: else if (stcmp (vn, "INTERRUPT\201") == 0) {
6480: evt_mask[EVT_CLS_INTERRUPT] = new_status;
6481: }
6482: else if (stcmp (vn, "POWER\201") == 0) {
6483: evt_mask[EVT_CLS_POWER] = new_status;
6484: }
6485: else if (stcmp (vn, "TIMER\201") == 0) {
6486: evt_mask[EVT_CLS_TIMER] = new_status;
6487: }
6488: else if (stcmp (vn, "USER\201") == 0) {
6489: evt_mask[EVT_CLS_USER] = new_status;
6490: }
6491: else if (stcmp (vn, "WAPI\201") == 0) {
6492: evt_mask[EVT_CLS_WAPI] = new_status;
6493: }
6494: else if (stcmp (vn, "TRIGGER\201") == 0) {
6495: evt_mask[EVT_CLS_TRIGGER] = new_status;
6496: }
6497: else {
6498: merr_raise (CMMND);
6499: goto err;
6500: }
6501:
6502: if (merr () > OK) goto err;
6503:
6504:
6505: if ((ch = *(codptr)) == EOL || ch == SP) {
6506: break;
6507: }
6508:
6509: }
6510:
6511: }
6512:
6513: for (i = 0; i < EVT_MAX; i++) {
6514:
6515: if (evt_status[i] == EVT_S_SYNC && evt_mask[i] == EVT_S_ASYNC) {
6516:
6517: /* cannot enable both synchronous and asynchronous
6518: event processing on the same event class at the
6519: same time */
6520:
6521: merr_raise (M102);
6522: goto err;
6523:
6524: }
6525: else {
6526:
6527: if (evt_mask[i] > EVT_S_NOMODIFY) {
6528: evt_status[i] = evt_mask[i];
6529: }
6530:
6531: }
6532:
6533: }
6534:
6535: if (mcmnd == ASTART) {
6536: evt_async_enabled = TRUE;
6537: }
6538: else {
6539: short disabled_evt_count = 0;
6540:
6541: for (i = 0; i < EVT_MAX; i++) {
6542: if (evt_status[i] == EVT_S_DISABLED) {
6543: disabled_evt_count++;
6544: }
6545: }
6546:
6547: if (disabled_evt_count == (EVT_MAX - 1)) evt_async_enabled = FALSE;
6548:
6549: }
6550:
6551: break;
6552: }
6553:
6554:
6555:
6556:
6557: case ETRIGGER:
6558:
6559: merr_raise (CMMND);
6560: break;
6561:
6562:
6563: #if defined(HAVE_MWAPI_MOTIF)
6564: case ESTART:
6565: if ((rtn_dialect () != D_MDS) &&
6566: (rtn_dialect () != D_FREEM)) {
6567: merr_raise (NOSTAND);
6568: goto err;
6569: }
6570:
6571: {
6572: if (in_syn_event_loop == TRUE) break;
6573:
6574: int evt_count;
6575: char *syn_handlers = (char *) malloc (STRLEN * sizeof (char));
6576:
6577: /* stack ^$EVENT */
6578: char key[100] = "^$EVENT\202\201";
6579: symtab (new_sym, key, " \201");
6580:
6581: evt_sync_enabled = TRUE;
6582: in_syn_event_loop = TRUE;
6583:
6584: while (evt_sync_enabled) {
6585:
6586:
6587: /* run the next iteration of GTK's event loop */
6588: //TODO: replace with libXt event loop
6589: //gtk_main_iteration_do (TRUE);
6590:
6591: /* dequeue any events */
6592: evt_count = mwapi_dequeue_events (syn_handlers);
6593:
6594: if (evt_count) {
6595: /* write them out */
6596: //printf ("event handlers = '%s'\r\n", syn_handlers);
6597:
6598: syn_event_entry_nstx = nstx;
6599:
6600: stcnv_c2m (syn_handlers);
6601: stcpy (tmp3, syn_handlers);
6602:
6603: syn_handlers[0] = '\0';
6604:
6605: goto evthandler;
6606: }
6607:
6608: syn_evt_loop_bottom:
6609: continue;
6610: }
6611:
6612: in_syn_event_loop = FALSE;
6613: evt_sync_enabled = FALSE;
6614:
6615: break;
6616: }
6617:
6618:
6619: case ESTOP:
6620: if ((rtn_dialect () != D_MDS) &&
6621: (rtn_dialect () != D_FREEM)) {
6622: merr_raise (NOSTAND);
6623: goto err;
6624: }
6625:
6626: evt_sync_enabled = FALSE;
6627: break;
6628: #endif
6629:
6630:
6631: default:
6632: merr_raise (CMMND);
6633:
6634: } /* command switch */
6635:
6636: if ((ch = *codptr) == EOL) {
6637: if (merr () != OK) goto err;
6638: if (forsw) goto for_end;
6639:
6640: mcmnd = 0;
6641:
6642: goto next_line;
6643: }
6644:
6645: if (ch == SP) {
6646: if (merr () == OK) goto next0;
6647:
6648: goto err;
6649: }
6650:
6651: if (ch != ',' && merr () == OK) {
6652: merr_raise (SPACER);
6653: }
6654: else if ((ierr <= OK) || (debug_mode == TRUE)) {
6655: if (debug_mode) goto direct_mode;
6656: if (*++codptr != SP && *codptr != EOL) goto again;
6657:
6658: merr_raise (ARGLIST);
6659: }
6660:
6661: /* else goto err; */
6662:
6663: /* error */
6664: err:
6665:
6666: /* avoid infinite loops resulting from errors in argumentless FOR loops */
6667: if (merr () != OK && merr () != ASYNC && forsw && ftyp == 0) {
6668: argless_forsw_quit = TRUE;
6669: goto for_end;
6670: }
6671:
6672: /*
6673: * ierr == ASYNC means that the previous command was interrupted by
6674: * an async event. It is not a real error, so just go on to the next
6675: * command after resetting ierr = OK.
6676: */
6677: if (merr () == ASYNC) {
6678: merr_clear ();
6679: goto next_cmnd;
6680: }
6681:
6682: if (merr () > OK) {
6683: job_set_status (pid, JSTAT_ERROR);
6684: }
6685:
6686: if (ierr < 0) {
6687:
6688: ierr += CTRLB;
6689:
6690: if (merr () == OK) {
6691: zbflag = TRUE;
6692:
6693: goto zb_entry;
6694: }
6695: }
6696:
6697: if (merr () > OK ) {
6698:
6699: char er_buf[ERRLEN];
6700:
6701: merr_set_ecode_ierr ();
6702:
6703: stcpy (er_buf, errmes[merr ()]);
6704: stcnv_m2c (er_buf);
6705:
6706: #if !defined(MSDOS)
6707: m_log (LOG_ERR, er_buf);
6708: #endif
6709:
6710: }
6711:
6712: zerr = ierr;
6713: merr_clear ();
6714:
6715: /* goto restart; */
6716:
6717:
6718: restart:
6719:
6720: if (param) goto restore;
6721:
6722: dosave[0] = EOL;
6723: setpiece = FALSE;
6724: setop = 0;
6725: privflag = FALSE;
6726:
6727: if (merr () == INRPT) goto err;
6728: if (zerr == STORE) symtab (kill_all, "", "");
6729:
6730: if (errfunlvl > 0) {
6731: errfunlvl--;
6732: }
6733: else {
6734:
6735: if (zerr == OK) {
6736: zerror[0] = EOL; /* reset error */
6737: }
6738: else {
6739:
6740: #ifdef DEBUG_STACK
6741: printf ("Storing NESTERR\r\n");
6742: #endif
6743:
6744: nesterr = nstx; /* save stack information at error */
6745:
6746: for (i = 1; i <= nstx; i++) getraddress (callerr[i], i);
6747:
6748: zerror[0] = '<';
6749:
6750: if (etxtflag) {
6751: stcpy (&zerror[1], errmes[zerr]);
6752: }
6753: else {
6754: intstr (&zerror[1], zerr);
6755: }
6756:
6757: stcat (zerror, ">\201");
6758:
6759: if (rou_name[0] != EOL) {
6760: char *j0;
6761: char *j1;
6762: char tmp1[256];
6763:
6764:
6765:
6766: if (nestc[nstx] == XECUTE) {
6767:
6768: if (nestn[nstx]) { /* reload routine */
6769: zload (nestn[nstx]);
6770: merr_clear ();
6771: }
6772:
6773: roucur = nestr[nstx] + rouptr; /* restore roucur */
6774: }
6775:
6776:
6777:
6778: j0 = (rouptr - 1);
6779: j = 0;
6780: tmp1[0] = EOL;
6781: j0++;
6782:
6783: if (roucur < rouend) {
6784:
6785: while (j0 < (roucur - 1)) {
6786:
6787: j1 = j0++;
6788: j++;
6789:
6790: if ((*j0 != TAB) && (*j0 != SP)) {
6791:
6792: j = 0;
6793:
6794: while ((tmp1[j] = (*(j0++))) > SP) {
6795:
6796: if (tmp1[j] == '(') tmp1[j] = EOL;
6797:
6798: j++;
6799: }
6800:
6801: tmp1[j] = EOL;
6802: j = 0;
6803: }
6804:
6805: j0 = j1;
6806: j0 += (UNSIGN (*j1)) + 2;
6807: }
6808: }
6809:
6810: stcat (zerror, tmp1);
6811:
6812: if (j > 0) {
6813: i = stlen (zerror);
6814: zerror[i++] = '+';
6815:
6816: intstr (&zerror[i], j);
6817: }
6818:
6819: stcat (zerror, "^\201");
6820:
6821:
6822:
6823: if (nestc[nstx] == XECUTE) {
6824:
6825: if (nestn[nstx]) { /* reload routine */
6826: zload (rou_name);
6827:
6828: ssvn_job_update ();
6829:
6830: merr_clear ();
6831: }
6832:
6833: stcat (zerror, nestn[nstx]);
6834: }
6835: else
6836: stcat (zerror, rou_name);
6837: }
6838:
6839: if (zerr == UNDEF) zerr = M6;
6840:
6841: /* undefined: report variable name */
6842: if (zerr == UNDEF || zerr == SBSCR || zerr == NAKED || zerr == ZTERR || zerr == DBDGD || zerr == LBLUNDEF || zerr == NOPGM || zerr == M6 || zerr == M7 || zerr == M13) {
6843:
6844: int f; /* include erroneous reference */
6845:
6846: f = stlen (zerror);
6847: zerror[f++] = SP;
6848: zname (&zerror[f], varerr);
6849: } /* end varnam section */
6850: }
6851: }
6852:
6853: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
6854: tmp4[0] = EOL;
6855:
6856: while (ierr != (OK - CTRLB)) {
6857:
6858:
6859: /* standard error handling */
6860: if (etrap[0] != EOL && stcmp (ecode, "") != 0) {
6861:
6862: on_frame_entry ();
6863:
6864: /* disable $ZTRAP error handling */
6865: ztrap[nstx][0] = EOL;
6866:
6867: stcpy (tmp4, etrap);
6868: stcat (tmp4, " quit:$quit \"\" quit\201");
6869:
6870: if (etrap_lvl > 1) {
6871: /* we've encountered an error within an error handler.
6872: save off the error code at merr_stack[nstx + 1].ECODE */
6873:
6874: stcpy (merr_stack[nstx + 1].ECODE, ecode);
6875: merr_topstk = nstx + 1;
6876: etrap_lvl++;
6877:
6878: }
6879: else {
6880: merr_topstk = nstx;
6881: etrap_lvl++;
6882: }
6883:
6884: break;
6885:
6886: }
6887:
6888:
6889:
6890: if (ztrap[nstx][0] != EOL && !DSM2err) {
6891:
6892: #ifdef DEBUG_NEWSTACK
6893:
6894: printf ("Dropped into Ztrap [");
6895:
6896: for (loop = 0; loop < 20 && ztrap[nstx][loop] != EOL; loop++) {
6897: printf ("%c", ztrap[nstx][loop]);
6898: }
6899:
6900: printf ("]\r\n");
6901:
6902: #endif
6903:
6904: tmp4[0] = GOTO;
6905: tmp4[1] = SP;
6906: stcpy (&tmp4[2], ztrap[nstx]);
6907: ztrap[nstx][0] = EOL;
6908:
6909: #ifdef DEBUG_NEWSTACK
6910:
6911: printf ("Set tmp4 to [");
6912: for (loop = 0; tmp4[loop] != EOL; loop++) printf ("%c", tmp4[loop]);
6913: printf ("]\r\n");
6914:
6915: #endif
6916:
6917: break;
6918: }
6919:
6920:
6921:
6922: if (nstx == 0) {
6923:
6924: #ifdef DEBUG_NEWSTACK
6925: printf ("Nestx was Zero\r\n");
6926: #endif
6927:
6928: forx = 0;
6929: cmdptr = cmdstack;
6930: namptr = namstck;
6931: level = 0;
6932: errfunlvl = 0;
6933: io = HOME; /* trap to direct mode: USE 0 */
6934:
6935: if (zerr == INRPT && frm_filter) {
6936: tmp4[0] = 'h';
6937: tmp4[1] = EOL;
6938: }
6939:
6940: if (DSM2err && (ztrap[NESTLEVLS + 1][0] != EOL)) { /* DSM V.2 error trapping */
6941:
6942: #ifdef DEBUG_NEWSTACK
6943: printf ("Ztrap 2\r\n");
6944: #endif
6945:
6946: tmp4[0] = GOTO;
6947: tmp4[1] = SP; /* GOTO errorhandling */
6948:
6949: stcpy (&tmp4[2], ztrap[NESTLEVLS + 1]);
6950: ztrap[NESTLEVLS + 1][0] = EOL;
6951:
6952: }
6953:
6954: break;
6955: }
6956:
6957: #ifdef DEBUG_NEWSTACK
6958: printf ("Nestc[nstx] is [%d]\r\n", nestc[nstx]);
6959: #endif
6960:
6961: if (nestc[nstx] == BREAK) break;
6962:
6963: if (merr () > OK) goto err;
6964:
6965: if (nestc[nstx] == FOR) {
6966: if (forx == 0) goto for_quit;
6967: ftyp = fortyp[--forx];
6968: fvar = forvar[forx];
6969: finc = forinc[forx];
6970: flim = forlim[forx];
6971: fi = fori[forx];
6972: }
6973: else {
6974:
6975: if (nestc[nstx] == DO_BLOCK) {
6976: test = nestlt[nstx];
6977: level--;
6978: }
6979: else { /* pop $TEST */
6980: level = nestlt[nstx]; /* pop level */
6981: }
6982:
6983: #ifdef DEBUG_NEWSTACK
6984: printf ("Nestn[nstx] is [%d]\r\n", nestn[nstx]);
6985: #endif
6986:
6987: if (nestn[nstx]) { /* 'reload' routine */
6988: namptr = nestn[nstx];
6989: stcpy (rou_name, namptr);
6990: zload (rou_name);
6991:
6992: ssvn_job_update ();
6993:
6994: dosave[0] = 0;
6995:
6996: namptr--;
6997: }
6998:
6999: #ifdef DEBUG_NEWSTACK
7000: printf ("Execcing the rest...\r\n");
7001: #endif
7002:
7003: roucur = nestr[nstx] + rouptr;
7004:
7005: if (nestnew[nstx]) unnew (); /* un-NEW variables */
7006:
7007: cmdptr = nestp[nstx];
7008:
7009: if (nestc[nstx--] == '$') { /* extrinsic function/variable */
7010: *argptr = EOL;
7011: merr_raise (zerr);
7012: errfunlvl++;
7013:
7014: return 0;
7015: }
7016: estack--;
7017: }
7018: }
7019:
7020: forsw = FALSE;
7021:
7022: /* PRINTING ERROR MESSAGES */
7023: if (tmp4[0] == EOL) {
7024:
7025: if (zerr == BKERR && brkaction[0] != EOL) {
7026: stcpy (code, brkaction);
7027: codptr = code;
7028:
7029: if (libcall == TRUE) {
7030: return zerr;
7031: }
7032: else {
7033: goto next_cmnd;
7034: }
7035: }
7036:
7037: if (libcall == TRUE) return zerr;
7038:
7039: DSW &= ~BIT0; /* enable ECHO */
7040:
7041: // print here
7042: {
7043: char *t_rtn;
7044: char *t_nsn = (char *) malloc (STRLEN * sizeof (char));
7045: char *t_cod;
7046: int t_pos;
7047:
7048: NULLPTRCHK(t_nsn,"xecline");
7049:
7050: t_rtn = strtok (zerror, ">");
7051: t_rtn = strtok (NULL, ">");
7052:
7053: if (t_rtn != NULL && t_rtn[1] == '%') {
7054: strcpy (t_nsn, "SYSTEM");
7055: }
7056: else {
7057: strcpy (t_nsn, nsname);
7058: }
7059:
7060: if (deferred_ierr > OK) {
7061: t_cod = deferrable_code;
7062: t_pos = deferrable_codptr - code + 3;
7063: }
7064: else {
7065: t_cod = code;
7066: t_pos = codptr - code + 3;
7067: }
7068:
7069: if (t_rtn != NULL) {
7070: merr_dump (zerr, t_rtn, t_nsn, t_cod, t_pos);
7071: }
7072: else {
7073: merr_dump (zerr, "<UNKNOWN>", t_nsn, t_cod, t_pos);
7074: }
7075:
7076:
7077: free (t_nsn);
7078: }
7079:
7080:
7081: }
7082: else {
7083: stcpy (code, tmp4);
7084:
7085: codptr = code;
7086: tmp4[0] = EOL;
7087:
7088: goto next_cmnd;
7089: }
7090:
7091: restore:
7092:
7093: io = HOME;
7094: codptr = code;
7095:
7096: if (param > 0) {
7097:
7098: j = 0;
7099: ch = 0;
7100: paramx++;
7101: param--;
7102:
7103: for (;;) {
7104: if (m_argv[++j][0] == '-') {
7105: i = 0;
7106:
7107: while ((m_argv[j][++i] != 0) && (m_argv[j][i] != 'x'));
7108:
7109: if (m_argv[j][i] != 'x') continue;
7110:
7111: j++;
7112:
7113: if (++ch < paramx) continue;
7114:
7115: strcpy (code, m_argv[j]);
7116: break;
7117: }
7118: else {
7119: if (++ch < paramx) continue;
7120:
7121: strcpy (code, "d ");
7122: strcpy (&code[2], m_argv[j]);
7123: break;
7124: }
7125: }
7126: code[strlen (code)] = EOL;
7127: codptr = code;
7128: goto next_cmnd;
7129:
7130: }
7131:
7132: if (usermode == 0) { /* application mode: direct mode implies HALT */
7133: code[0] = 'H';
7134: code[1] = EOL;
7135: codptr = code;
7136:
7137: goto next_cmnd;
7138: }
7139: else {
7140: if (debug_mode) goto direct_mode;
7141: }
7142:
7143: if (libcall == TRUE) { /* library mode: don't go to direct mode, just return */
7144: return merr ();
7145: }
7146:
7147:
7148: do {
7149:
7150: if (frm_filter == FALSE && promflag) {
7151: stcpy (code, " \201");
7152: stcpy (&code[2], " \201");
7153: promflag = FALSE;
7154: }
7155: else {
7156:
7157: direct_mode:
7158:
7159: if (dbg_enable_watch && dbg_pending_watches) dbg_dump_watchlist ();
7160:
7161: /* DIRECT-MODE PROMPT HERE */
7162: #if defined(HAVE_LIBREADLINE) && !defined(_AIX)
7163: {
7164: char *fmrl_buf;
7165: char fmrl_prompt[256];
7166: HIST_ENTRY **hist_list;
7167: int hist_idx;
7168: HIST_ENTRY *hist_ent;
7169:
7170: if (quiet_mode == FALSE) {
7171: if (tp_level == 0) {
1.6 snw 7172: snprintf (fmrl_prompt, 255, "\r\n%s.%s> ", shm_env, nsname);
1.1 snw 7173: }
7174: else {
1.6 snw 7175: snprintf (fmrl_prompt, 255, "\r\nTL%d:%s.%s> ", tp_level, shm_env, nsname);
1.1 snw 7176: }
7177: }
7178: set_io (UNIX);
7179:
7180: job_set_status (pid, JSTAT_DIRECTMODE);
7181:
7182: /* readline() does its own malloc() */
7183: fmrl_buf = readline (fmrl_prompt);
7184:
7185: if (!fmrl_buf) {
7186: set_io (UNIX);
7187: printf ("\n");
7188: set_io (MUMPS);
7189:
7190: goto halt;
7191: }
7192:
7193: if (strlen (fmrl_buf) > 0) {
7194: add_history (fmrl_buf);
7195: }
7196:
7197: if (fmrl_buf[0] == '?') {
7198:
7199: char kb[20];
7200: char db[255];
7201:
7202: snprintf (kb, 19, "%%SYS.HLP\201");
7203: snprintf (db, 19, "\201");
7204:
7205: symtab (kill_sym, kb, db);
7206:
7207: /* Invoke Online Help */
7208:
7209: set_io (MUMPS);
7210: stcpy (code, "DO ^%ZHELP\201");
7211:
7212: if (strlen (fmrl_buf) > 1) {
7213: snprintf (db, 254, "%s\201", &fmrl_buf[1]);
7214: symtab (set_sym, kb, db);
7215: }
7216:
7217: }
7218: else if (strcmp (fmrl_buf, "step") == 0) {
7219: debug_mode = TRUE;
7220: goto zgo;
7221: }
7222: else if ((strcmp (fmrl_buf, "cont") == 0) || (strcmp (fmrl_buf, "continue") == 0)) {
7223: debug_mode = FALSE;
7224: }
7225: else if (strcmp (fmrl_buf, "rbuf") == 0) {
7226: rbuf_dump ();
7227: }
7228: else if (strcmp (fmrl_buf, "jobtab") == 0) {
7229: job_dump ();
7230: }
7231: else if (strcmp (fmrl_buf, "locktab") == 0) {
7232: locktab_dump ();
7233: code[0] = '\201';
7234: codptr = code;
7235: }
7236: else if (strcmp (fmrl_buf, "shmstat") == 0) {
7237: shm_dump ();
7238: }
7239: else if (strcmp (fmrl_buf, "shmpages") == 0) {
7240: shm_dump_pages ();
7241: }
7242: else if (strcmp (fmrl_buf, "glstat") == 0) {
7243: gbl_dump_stat ();
7244: }
7245: else if (strcmp (fmrl_buf, "events") == 0) {
7246:
7247: char stat_desc[30];
7248: char *evclass_name;
7249:
7250: printf ("\n%-20s %-15s %s\n", "Event Class", "Processing Mode", "ABLOCK Count");
7251: printf ("%-20s %-15s %s\n", "-----------", "---------------", "------------");
7252:
7253: for (i = 0; i < EVT_MAX; i++) {
7254:
7255: evclass_name = evt_class_name_c (i);
7256:
7257: switch (evt_status[i]) {
7258: case EVT_S_DISABLED:
7259: strcpy (stat_desc, "Disabled");
7260: break;
7261: case EVT_S_ASYNC:
7262: strcpy (stat_desc, "Asynchronous");
7263: break;
7264: case EVT_S_SYNC:
7265: strcpy (stat_desc, "Synchronous");
7266: }
7267:
7268: printf ("%-20s %-15s %d\n", evclass_name, stat_desc, evt_blocks[i]);
7269:
7270: }
7271:
7272:
7273: }
7274: else if (strcmp (fmrl_buf, "wh") == 0) {
7275: write_history (history_file);
7276: }
7277: else if (strcmp (fmrl_buf, "trantab") == 0) {
7278: tp_tdump();
7279: }
7280: else if (isdigit(fmrl_buf[0]) || (fmrl_buf[0] == '(') || (fmrl_buf[0] == '-') || (fmrl_buf[0] == '\'') || (fmrl_buf[0] == '+') || (fmrl_buf[0] == '$') || (fmrl_buf[0] == '^')) {
7281:
7282: snprintf (code, 255, "W %s", fmrl_buf);
7283: stcnv_c2m (code);
7284:
7285: set_io (MUMPS);
7286:
7287: }
7288: #if !defined(__APPLE__)
7289: else if (strcmp (fmrl_buf, "history") == 0) {
7290:
7291: /* History List */
7292:
7293: hist_list = history_list ();
7294: if (hist_list) {
7295:
7296: for (i = 0; hist_list[i]; i++) {
7297: printf("%d: %s\n", i + history_base, hist_list[i]->line);
7298: }
7299:
7300: }
7301:
7302: stcpy (code, " \201");
7303:
7304: set_io (MUMPS);
7305:
7306: }
7307: #endif
7308: else if (strncmp (fmrl_buf, "rcl", 3) == 0) {
7309:
7310: /* Recall History Item */
7311:
7312:
7313:
7314: if (!isdigit (fmrl_buf[4])) {
7315: fprintf (stderr, "invalid history index '%s'\n", &fmrl_buf[4]);
7316:
7317: set_io (MUMPS);
7318: stcpy (code, " \201");
7319:
7320: break;
7321: }
7322:
7323: hist_idx = atoi (&fmrl_buf[4]);
7324:
7325: if ((hist_idx > history_length) || (hist_idx < 1)) {
7326: fprintf (stderr, "history entry %d out of range (valid entries are 1-%d)\n", hist_idx, history_length);
7327:
7328: set_io (MUMPS);
7329: stcpy (code, " \201");
7330:
7331: break;
7332: }
7333:
7334: hist_ent = history_get (hist_idx);
7335:
7336: printf ("%s\n", hist_ent->line);
7337:
7338: strncpy (code, hist_ent->line, 255);
7339: stcnv_c2m (code);
7340:
7341: set_io (MUMPS);
7342:
7343: }
7344: else {
7345:
7346: /* Pass to M Interpreter */
7347:
7348: set_io (MUMPS);
7349:
7350: strncpy (code, fmrl_buf, 255);
7351: stcnv_c2m (code);
7352:
7353: }
7354:
7355: /* free the buffer malloc()'d by readline() */
7356: if (fmrl_buf) free (fmrl_buf);
7357: }
7358: #else
7359:
7360: {
7361: char fmrl_prompt[256];
7362:
7363: if (tp_level == 0) {
7364: snprintf (fmrl_prompt, 256, "\r\n%s> \201", nsname);
7365: }
7366: else {
7367: snprintf (fmrl_prompt, 256, "\r\nTL%d:%s> \201", tp_level, nsname);
7368: }
7369:
7370: write_m (fmrl_prompt);
7371:
7372: read_m (code, -1L, 0, 255); /* Not necessarily STRLEN? */
7373: }
7374:
7375: promflag = TRUE;
7376: #endif
7377:
7378: if (merr () > OK) goto err;
7379:
7380:
7381: // printf ("zbflag = %d\r\n", zbflag);
7382:
7383: if (code[0] == EOL && zbflag && nestc[nstx] == BREAK) {
7384:
7385: //printf ("cont single step\r\n");
7386: debug_mode = TRUE;
7387: merr_raise (OK - CTRLB);
7388:
7389: //printf ("ierr now '%d'\r\n", ierr);
7390: goto zgo;
7391: } /* single step */
7392: }
7393: }
7394: while (code[0] == EOL);
7395:
7396: if (promflag) write_m ("\r\n\201");
7397:
7398: /* automatic ZI in direct mode: insert an entry with TAB */
7399: i = (-1);
7400: j = 0;
7401: merr_clear ();
7402:
7403: while (code[++i] != EOL) {
7404: if (code[i] == '"') toggle (j);
7405:
7406: if (code[i] == TAB && j == 0) {
7407: dosave[0] = EOL;
7408:
7409: zi (code, rouins);
7410: if (merr ()) goto err;
7411: goto restore;
7412: }
7413: }
7414:
7415: code[++i] = EOL;
7416: code[++i] = EOL;
7417:
7418: roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
7419:
7420: goto next_cmnd;
7421:
7422: skip_line:
7423:
7424: if (forsw) goto for_end;
7425: goto next_line;
7426:
7427: } /*end of xecline() */
7428:
7429: void on_frame_entry(void)
7430: {
7431: return;
7432: }
7433:
7434: void rbuf_dump(void)
7435: {
7436: register int i;
7437: char rnam[256];
7438: char rpth[256];
7439: char ldtime[80];
7440: char flgs[80];
7441: time_t ag;
7442: struct tm tld;
7443:
7444:
7445: printf ("ROUTINE BUFFER CONFIGURATION\r\n");
1.2 snw 7446: printf (" ROUTINE BUFFER COUNT: %ld\r\n", NO_OF_RBUF);
1.1 snw 7447: printf (" MAX. ROUTINE BUFFER COUNT: %d\r\n", MAXNO_OF_RBUF);
7448: printf (" DEFAULT ROUTINE BUFFER SIZE (EACH): %d BYTES\r\n", DEFPSIZE0 - 1);
1.2 snw 7449: printf (" CURRENT ROUTINE BUFFER SIZE (EACH): %ld BYTES\r\n\r\n", PSIZE0 - 1);
1.1 snw 7450: printf ("BUFFERS IN USE:\r\n\r\n");
7451:
7452:
7453: for (i = 0; i < NO_OF_RBUF; i++) {
7454:
1.12 ! snw 7455: flgs[0] = '\0';
1.1 snw 7456:
7457: if (ages[i] == 0) {
7458: sprintf (rnam, "---------");
7459: sprintf (rpth, "[buffer empty]");
7460: sprintf (ldtime, "n/a");
7461: sprintf (flgs, "n/a");
7462: }
7463: else {
7464: stcpy (rnam, pgms[i]);
7465: stcnv_m2c (rnam);
7466:
7467: stcpy (rpth, path[i]);
7468: stcnv_m2c (rpth);
7469:
7470: ag = ages[i];
7471: tld = *localtime (&ag);
7472:
7473: strftime (ldtime, 80, "%a %Y-%m-%d %H:%M:%S %Z", &tld);
7474: if (rbuf_flags[i].dialect != D_FREEM) {
7475: strcat (flgs, "STANDARD");
7476:
7477: switch (rbuf_flags[i].dialect) {
7478:
7479: case D_M77:
7480: strcat (flgs, " [M 1977]");
7481: break;
7482:
7483: case D_M84:
7484: strcat (flgs, " [M 1984]");
7485: break;
7486:
7487: case D_M90:
7488: strcat (flgs, " [M 1990]");
7489: break;
7490:
7491: case D_M95:
7492: strcat (flgs, " [M 1995]");
7493: break;
7494:
7495: case D_MDS:
7496: strcat (flgs, " [MILLENNIUM DRAFT]");
7497: break;
7498:
7499: case D_M5:
7500: strcat (flgs, " [M5]");
7501: break;
7502: }
7503:
7504: }
7505: else {
7506: strcat (flgs, "FREEM");
7507: }
7508: }
7509:
7510: if (ages[i] != 0) {
7511: printf ("#%d [ROUTINE '%s']\r\n", i, rnam);
7512: printf (" UNIX PATH: %s\r\n", rpth);
7513: printf (" LAST ACCESS: %s\r\n", ldtime);
7514: printf (" DIALECT: %s\r\n", flgs);
7515: }
7516:
7517: }
7518:
7519: }
7520:
7521: short rbuf_slot_from_name(char *rnam)
7522: {
7523: register short i;
7524:
7525: for (i = 0; i < NO_OF_RBUF; i++) {
7526: if (stcmp (rnam, pgms[i]) == 0) {
7527: return i;
7528: }
7529: }
7530:
7531: return -1;
7532: }
7533:
7534: short is_standard(void)
7535: {
7536:
7537: if (rtn_dialect () == D_FREEM) {
7538: return FALSE;
7539: }
7540: else {
7541: return TRUE;
7542: }
7543:
7544: }
7545:
7546: int rtn_dialect(void)
7547: {
7548: short slot;
7549:
7550: slot = rbuf_slot_from_name (rou_name);
7551:
7552: return rbuf_flags[slot].dialect;
7553: }
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