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