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