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