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