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