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