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