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