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