![[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|
Return to xecline.c CVS log | Up to [Coherent Logic Development] / freem / src |
Install init scripts to share/freem/examples/init and fix regression in method dispatch
/*
* $Id: xecline.c,v 1.10 2025/03/27 03:27:35 snw Exp $
* freem interpreter proper
*
*
* Author: Serena Willis <snw@coherent-logic.com>
* Copyright (C) 1998 MUG Deutschland
* Copyright (C) 2020, 2025 Coherent Logic Development LLC
*
*
* This file is part of FreeM.
*
* FreeM is free software: you can redistribute it and/or modify
* it under the terms of the GNU Affero Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* FreeM is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Affero Public License for more details.
*
* You should have received a copy of the GNU Affero Public License
* along with FreeM. If not, see <https://www.gnu.org/licenses/>.
*
* $Log: xecline.c,v $
* Revision 1.10 2025/03/27 03:27:35 snw
* Install init scripts to share/freem/examples/init and fix regression in method dispatch
*
* Revision 1.9 2025/03/24 04:13:12 snw
* Replace action macro dat with fra_dat to avoid symbol conflict on OS/2
*
* Revision 1.8 2025/03/24 04:05:36 snw
* Replace crlf with frm_crlf to avoid symbol conflict with readline on OS/2
*
* Revision 1.7 2025/03/22 22:52:24 snw
* Add STRLEN_GBL macro to manage global string length
*
* Revision 1.6 2025/03/22 21:44:32 snw
* Make the startup messages fewer and add environment name to direct-mode prompt
*
* Revision 1.5 2025/03/09 19:50:47 snw
* Second phase of REUSE compliance and header reformat
*
*
* SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
* SPDX-License-Identifier: AGPL-3.0-or-later
**/
#include <stdlib.h>
#include "mpsdef.h"
#include "namespace.h"
#include "transact.h"
#include "merge.h"
#include "sighnd.h"
#include "init.h"
#include "events.h"
#include "mdebug.h"
#include "freem.h"
#include "mref.h"
#include "log.h"
#include "consttbl.h"
#include "shmmgr.h"
#include "locktab.h"
#include "jobtab.h"
#include "config.h"
#include "datatypes.h"
#include "objects.h"
#include "mcommand.h"
#if defined(__linux__)
# include <sched.h>
#endif
#if !defined(MSDOS)
# include "io_socket.h"
#endif
#include "merr.h"
#include <errno.h>
#include <unistd.h>
#include <string.h>
#if !defined(MSDOS)
# include <syslog.h>
#endif
#include <stdio.h>
#include <ctype.h>
#include <time.h>
#include <sys/types.h>
#include <pwd.h>
#if !defined(__OpenBSD__) && !defined(__FreeBSD__)
# include <sys/timeb.h>
#endif
#include <sys/wait.h>
#include <sys/time.h>
#include <time.h>
#ifdef HAVE_LIBREADLINE
# if defined(HAVE_READLINE_READLINE_H)
# include <readline/readline.h>
# elif defined(HAVE_READLINE_H)
# include <readline.h>
# else /* !defined(HAVE_READLINE_H) */
extern char *readline ();
# endif /* !defined(HAVE_READLINE_H) */
/*char *cmdline = NULL;*/
#else /* !defined(HAVE_READLINE_READLINE_H) */
/* no readline */
#endif /* HAVE_LIBREADLINE */
#ifdef HAVE_READLINE_HISTORY
# if defined(HAVE_READLINE_HISTORY_H)
# include <readline/history.h>
# elif defined(HAVE_HISTORY_H)
# include <history.h>
# else /* !defined(HAVE_HISTORY_H) */
extern void add_history ();
extern int write_history ();
extern int read_history ();
# endif /* defined(HAVE_READLINE_HISTORY_H) */
/* no history */
#endif /* HAVE_READLINE_HISTORY */
#include "mwapi_window.h"
#include "mwapi_event.h"
void on_frame_entry(void);
void rbuf_dump(void);
short rbuf_slot_from_name(char *);
short is_standard(void);
/*
* xecline():
* typ (where to go on function entry): 1 = restart
* 2 = error
*
*/
int xecline(int typ)
{
MACTION ra;
short new_and_set = FALSE;
short new_object = FALSE;
short destructor_run = FALSE;
short debug_mode = FALSE;
short libcall = FALSE;
char *namold;
long rouoldc;
unsigned long jobtime;
char label[256], routine[256];
char *vn;
char *an;
char *tmp;
char *tmp2;
char *tmp3;
char *deferrable_codptr;
char deferrable_code[512];
char *ev_handlers;
char *reeval_codptr;
char reeval_code[512];
int i;
int j;
register int ch;
int then_ctr = 0;
#if defined(HAVE_MWAPI_MOTIF)
int syn_event_entry_nstx = 0;
int in_syn_event_loop = FALSE;
#endif
# ifdef DEBUG_NEWSTACK
int loop;
# endif
vn = (char *) malloc ((STRLEN + 1) * sizeof (char));
an = (char *) malloc ((STRLEN + 1) * sizeof (char));
tmp = (char *) malloc ((STRLEN + 1) * sizeof (char));
tmp2 = (char *) malloc ((STRLEN + 1) * sizeof (char));
tmp3 = (char *) malloc ((STRLEN + 1) * sizeof (char));
NULLPTRCHK(vn,"xecline");
NULLPTRCHK(an,"xecline");
NULLPTRCHK(tmp,"xecline");
NULLPTRCHK(tmp2,"xecline");
NULLPTRCHK(tmp3,"xecline");
deferrable_codptr = deferrable_code;
switch (typ) {
case 0:
goto next_line;
case 1:
goto restart;
case 2:
goto err;
case 3:
libcall = TRUE;
goto restart;
}
next_line: /* entry point for next command line */
job_set_status (pid, JSTAT_INTERPRETER);
if (then_ctr > 0) {
test = nestlt[nstx];
level--;
then_ctr--;
}
while ((roucur < rouend) && (ch = (*roucur++)) != TAB && ch != SP); /* skip label */
if (roucur >= rouend) goto quit0; /* end of routine implies QUIT */
while ((ch = *roucur) == TAB || ch == SP) roucur++;
i = 0;
if (ch == '.') { /* get level count */
do {
i++;
while ((ch = (*++roucur)) == SP || ch == TAB);
}
while (ch == '.');
}
if (i != level) {
if (mcmnd == GOTO) {
merr_raise (M45);
goto err;
}
if (i < level) {
goto quit0;
}
else {
roucur += stlen (roucur) + 2;
goto next_line;
}
}
i = stcpy (code, roucur) + 1;
code[i] = EOL;
roucur += i + 1;
codptr = code;
next_cmnd: /* continue line entry point */
if (sigint_in_for) goto for_quit;
if (forsw && (forpost[forx][0] != '\0')) {
stcpy (reeval_code, code);
reeval_codptr = codptr;
strcpy (code, forpost[forx]);
stcnv_c2m (code);
codptr = code;
expr (STRING);
if (merr () > OK) {
stcpy (code, reeval_code);
codptr = reeval_codptr;
goto err;
}
if (tvexpr (argptr) == FALSE) {
stcpy (code, reeval_code);
codptr = reeval_codptr;
goto for_quit;
}
stcpy (code, reeval_code);
codptr = reeval_codptr;
}
job_set_status (pid, JSTAT_INTERPRETER);
if (evt_async_enabled == TRUE) {
switch (pending_signal_type) {
case SIGWINCH:
evt_enqueue ("SIGWINCH", EVT_CLS_INTERRUPT, 1);
break;
case SIGINT:
evt_enqueue ("SIGINT", EVT_CLS_INTERRUPT, 0);
break;
case SIGFPE:
evt_enqueue ("SIGFPE", EVT_CLS_INTERRUPT, 0);
break;
case SIGQUIT:
evt_enqueue ("SIGQUIT", EVT_CLS_INTERRUPT, 0);
break;
}
pending_signal_type = -1;
/* process async events */
ev_handlers = (char *) malloc (STRLEN * sizeof (char));
NULLPTRCHK(ev_handlers,"xecline");
/* get a comma-delimited list of applicable handlers (e.g. ^HNDL1,^HNDL2,^HNDL3) */
ev_handlers[0] = NUL;
evt_depth = evt_get_handlers (ev_handlers);
stcnv_c2m (ev_handlers);
stcpy (tmp3, ev_handlers);
free (ev_handlers);
/* only execute event handlers if we have at least one such handler registered in ^$JOB($JOB,"EVENTS") */
if (evt_depth) {
/* per X11-1998/28, async events are to be disabled during the execution of event handlers */
/* TODO: this should be done by incrementing the event block counter
for all event types, or whatever the event extension says to do.
In any event (rimshot here for the obvious pun), turning off all
event handlers this way is decidedly non-standard. Or non-what-might-
become the standard. Whatever. */
evt_async_enabled = FALSE;
evt_async_initial = TRUE;
evt_async_restore = TRUE;
goto evthandler;
}
}
if (merr () > OK) goto err;
next0:
do {
if ((ch = *codptr) == EOL) {
if (forsw) goto for_end;
goto next_line;
}
codptr++;
}
while (ch == SP);
/* decode command word */
if (ch < 'A') { /* Handle non-alpha first chars */
if (ch == ';') { /* COMMENT */
ch = *(codptr++);
if(ch == '%') { /* DIRECTIVE */
int dir_pos = 0;
int dir_wc = 0;
char dir_words[20][255];
while((ch = *(codptr++)) != EOL) {
switch (ch) {
case SP:
dir_words[dir_wc][dir_pos] = NUL;
dir_wc++;
dir_pos = 0;
break;
default:
dir_words[dir_wc][dir_pos++] = ch;
}
}
dir_words[dir_wc][dir_pos] = NUL;
if (strcmp (dir_words[0], "DIALECT") == 0) {
short rb_slot;
rb_slot = rbuf_slot_from_name (rou_name);
if ((strcmp (dir_words[1], "STANDARD") == 0) ||
(strcmp (dir_words[1], "MDS") == 0)) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_MDS;
}
else if (strcmp (dir_words[1], "M77") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M77;
}
else if (strcmp (dir_words[1], "M84") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M84;
}
else if (strcmp (dir_words[1], "M90") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M90;
}
else if (strcmp (dir_words[1], "M95") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M95;
}
else if (strcmp (dir_words[1], "M5") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M5;
}
else if ((strcmp (dir_words[1], "FREEM") == 0) ||
(strcmp (dir_words[1], "EXTENDED") == 0)) {
rbuf_flags[rb_slot].standard = FALSE;
rbuf_flags[rb_slot].dialect = D_FREEM;
}
else {
merr_raise (CMMND);
goto err;
}
goto skip_line;
}
else {
goto skip_line;
}
}
goto skip_line;
}
if ((!is_standard ()) && (ch == '#')) {
goto skip_line;
}
if ((is_standard ()) && (ch == '#')) {
merr_raise (NOSTAND);
goto err;
}
if (ch == '@') {
if (!is_standard ()) {
goto do_xecute;
}
else {
merr_raise (NOSTAND);
goto err;
}
}
if (ch == '!') { /* UNIXCALL */
if (restricted_mode) {
merr_raise (NOSTAND);
goto err;
}
/* don't catch child dies signal */
sig_attach (SIGUSR1, SIG_IGN);
tmp2[stcpy (tmp2, codptr)] = NUL;
if (demomode) fputc (d1char, stdout);
if (tmp2[0] == '!') {
uid_t suid;
struct passwd *spw;
suid = geteuid ();
spw = getpwuid (suid);
set_io (UNIX);
fprintf (stderr, "Type Ctrl-D to exit from the shell\n");
if (strlen (spw->pw_shell)) {
zsystem = system (spw->pw_shell);
}
else {
zsystem = system ("/bin/sh");
}
set_io (MUMPS);
sig_attach (SIGUSR1, &oncld); /* restore handler */
}
else if (tmp2[0] == '<') { /* call write output to %-array */
FILE *pipdes;
char key[STRLEN + 1 /*was 256 */ ];
char data[STRLEN + 1 /*was 256 */ ];
char data_kill[256];
data_kill[255] = EOL;
for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL;
snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
ssvn (get_sym, key, vn);
if (vn[0] == '^') {
if (vn[1] == '$') {
merr_raise (INVREF);
goto err;
}
else {
global (kill_sym, vn, data_kill);
}
}
else {
symtab (kill_sym, vn, data);
}
snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
ssvn (get_sym, key, vn);
data[0] = '0';
data[1] = EOL;
if (vn[0] == '^') {
if (vn[1] == '$') {
merr_raise (INVREF);
goto err;
}
else {
global (set_sym, vn, data);
}
}
else {
symtab (set_sym, vn, data);
}
set_io (UNIX);
if ((pipdes = popen (&tmp2[1], "r")) == NULL) {
zsystem = 1;
}
else {
int glvn_len = 0;
while (fgets (data, STRLEN, pipdes)) {
snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
ssvn (get_sym, key, vn);
glvn_len = stlen (vn);
stcpy (key, vn);
key[glvn_len] = DELIM;
if (vn[0] == '^') {
if (vn[1] == '$') {
merr_raise (INVREF);
goto err;
}
else {
global (getinc, vn, &key[glvn_len + 1]);
}
}
else {
symtab (getinc, vn, &key[glvn_len + 1]);
}
i = strlen (data);
data[i] = EOL;
if (i > 1 && data[i - 1] == LF) data[i - 1] = EOL;
if (vn[0] == '^') {
if (vn[1] == '$') {
merr_raise (INVREF);
goto err;
}
else {
global (set_sym, key, data);
}
}
else {
symtab (set_sym, key, data);
}
if (merr () == STORE) break;
}
pclose (pipdes);
zsystem = 0;
}
set_io (MUMPS);
}
else if (tmp2[0] == '>') { /* call read input from %-array */
FILE *pipdes;
char key[STRLEN + 1 /*was 256 */ ];
char data[STRLEN + 1 /*was 256 */ ];
int i, k, l;
for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL;
snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
ssvn (get_sym, key, vn);
if (vn[0] == '^') {
if (vn[1] == '$') {
merr_raise (INVREF);
goto err;
}
else {
global (get_sym, vn, data);
}
}
else {
symtab (get_sym, vn, data);
}
merr_clear ();
k = intexpr (data);
set_io (UNIX);
if (k < 1 || (pipdes = popen (&tmp2[1], "w")) == NULL) {
zsystem = 1;
}
else {
int glvn_len = 0;
for (i = 1; i <= k; i++) {
snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid);
ssvn (get_sym, key, vn);
glvn_len = stlen (vn);
stcpy (key, vn);
key[glvn_len] = DELIM;
intstr (&key[glvn_len + 1], i);
if (vn[0] == '^') {
if (vn[1] == '$') {
merr_raise (INVREF);
goto err;
}
else {
global (get_sym, key, data);
}
}
else {
symtab (get_sym, key, data);
}
l = stlen (data);
data[l++] = LF;
data[l] = NUL;
fputs (data, pipdes);
}
pclose (pipdes);
zsystem = 0;
merr_clear ();
}
set_io (MUMPS);
}
else {
set_io (UNIX);
zsystem = system (tmp2);
set_io (MUMPS);
}
if (demomode) fputc (d1char, stdout);
sig_attach (SIGUSR1, &oncld); /* restore handler */
if (merr () == STORE) {
zsystem = 1;
goto err;
}
goto skip_line;
}
merr_raise (CMMND);
goto err;
} /* END handling of non-alpha first chars */
mcmnd = ch | 0140; /* uppercase to lower case */
i = 1;
while ((ch = (*codptr)) != SP && ch != ':' && ch != EOL) {
tmp3[++i] = ch | 0140;
codptr++;
}
j = i;
if (j > 1) {
merr_raise (mcmd_tokenize (&ra, tmp3, deferrable_codptr, deferrable_code, &j));
MRESCHECK(ra);
}
if (*codptr == ':') {
/* handle postconditional */
if (mcmnd == FOR) {
char *savcp = codptr;
codptr++;
i = 0;
while ((forpost[forx + 1][i++] = *(codptr++)) != SP);
forpost[forx + 1][i - 1] = '\0';
codptr = savcp;
}
/* postcond after FOR,IF,ELSE not allowed in dialects other than D_FREEM */
if ((rtn_dialect () != D_FREEM) && (mcmnd == FOR || mcmnd == IF || mcmnd == ELSE)) {
merr_raise (NOSTAND);
goto err;
}
codptr++;
expr (STRING);
if (merr () > OK) goto err;
ch = *codptr;
if (ch != SP && ch != EOL) {
merr_raise (SPACER);
goto err;
}
if (tvexpr (argptr) == FALSE) { /* skip arguments */
if ((mcmnd == IF) || (mcmnd == THEN) || (mcmnd == ELSE) || (mcmnd == FOR)) {
mcmnd = 0;
goto skip_line;
}
mcmnd = 0; /* avoid false LEVEL error */
for (;;) {
if (ch == EOL) goto skip_line;
if ((ch = *++codptr) == SP) goto next_cmnd;
if (ch != '"') continue;
while (*codptr++ != EOL) {
if (*codptr != ch) continue;
if (*++codptr != ch) break;
}
if (--codptr == code) goto err;
}
}
}
if (*codptr != EOL) { /* beware argumentless cmnds at end of line */
codptr++; /* entry for next argument in list */
again:
while (*codptr == '@') { /* handle indirection */
stcpy (tmp, codptr++); /* save code to restore on nameind */
expr (ARGIND);
if (merr () > OK) goto err;
if (((ch = (*codptr)) != SP && ch != EOL && ch != ',' && ch != ':' && ch != '=') || (ch == '@' && *(codptr + 1) == '(')) {
stcpy (code, tmp); /* restore code on nameind */
codptr = code;
break;
}
else {
stcpy (argptr + stlen (argptr), codptr);
stcpy (code, argptr);
codptr = code;
}
}
}
switch (mcmnd) {
case MAP:
merr_raise (cmd_map (&ra));
MRESCHECK(ra);
break;
case UNMAP:
merr_raise (cmd_unmap (&ra));
MRESCHECK(ra);
break;
case THEN:
merr_raise (cmd_then (&ra, &then_ctr));
MRESCHECK(ra);
break;
case THROW:
merr_raise (cmd_throw (&ra));
MRESCHECK(ra);
break;
case CONST:
merr_raise (cmd_const (&ra));
MRESCHECK(ra);
break;
case KVALUE:
merr_raise (cmd_kvalue (&ra));
MRESCHECK(ra);
break;
case KSUBSC:
merr_raise (cmd_ksubscripts (&ra));
MRESCHECK(ra);
break;
case TSTART:
merr_raise (cmd_tstart (&ra));
MRESCHECK(ra);
break;
case TCOMMIT:
merr_raise (cmd_tcommit (&ra));
MRESCHECK(ra);
break;
case TROLLBACK:
merr_raise (cmd_trollback (&ra));
MRESCHECK(ra);
break;
case SET:
set0:
if ((ch = (*codptr)) >= 'A') { /* no set$piece nor multiset */
short setref = FALSE;
short stclass = SC_UNCHANGED;
expr (NAME);
if (merr () > OK) break;
stcpy (vn, varnam);
if (isalpha (vn[0]) && *(codptr + 1) == ':') {
char sc_string[255];
register int sci;
codptr += 2;
expr (NAME);
stcpy (sc_string, varnam);
for (i = 0; i < stlen (sc_string); i++) {
sc_string[i] = toupper (sc_string[i]);
}
stcnv_m2c (sc_string);
if (strcmp (sc_string, "PRIVATE") == 0) {
stclass = SC_PRIVATE;
}
else if (strcmp (sc_string, "PUBLIC") == 0) {
stclass = SC_PUBLIC;
}
else {
merr_raise (OBJACINVALID);
break;
}
}
if ((*++codptr != '=') || (*(codptr + 1) == '=')) {
ch = *codptr;
/* double char symbol ** (power) is encoded by ' ' */
if (ch == '*' && *(codptr + 1) == ch) {
codptr++;
ch = ' ';
}
/* negated boolean operator */
else if ((ch == '\'') && (*(codptr + 2) == '=')) ch = SETBIT (*++codptr);
if (*++codptr != '=') {
/* SET A++ or SET A-- equivalent to SET A+=1 SET A-=1 currently disabled */
//#ifdef NEVER
if ((ch == '+' || ch == '-') && ch == *codptr) {
codptr++;
setop = ch;
argptr[0] = '1';
argptr[1] = EOL;
goto set2;
}
//#endif /* NEVER */
merr_raise (ASSIGNER);
break;
}
setop = ch;
}
codptr++;
ch = *codptr;
if (ch == '.') {
setref = TRUE;
codptr++;
expr (NAME);
}
else {
expr (STRING);
}
if (merr () > OK) break;
set2:
if (vn[0] == '^') {
stcpy (an, argptr);
if (setref == TRUE) {
merr_raise (INVREF);
goto err;
}
if (vn[1] == '$') {
ssvn (set_sym, vn, an);
}
else {
global (set_sym, vn, an);
}
}
else {
stcpy (an, argptr);
if (setref == TRUE) {
symtab (new_sym, vn, "");
symtab (m_alias, vn, varnam);
codptr++;
}
else {
if (new_object == FALSE) {
symtab (set_sym, vn, an);
switch (stclass) {
case SC_PUBLIC:
obj_set_field_public (vn);
break;
case SC_PRIVATE:
obj_set_field_private (vn);
break;
}
}
}
}
if (merr () > OK) {
stcpy (varerr, vn);
break;
}
if (((new_and_set == TRUE) || (new_object == TRUE)) && (*codptr != SP) && (*codptr != EOL)) {
new_and_set = FALSE;
new_object = FALSE;
merr_raise (INEWMUL);
goto err;
}
if (new_and_set == TRUE) new_and_set = FALSE;
if (new_object == TRUE) new_object = FALSE;
set1:
if (*codptr != ',') break;
if (*++codptr == '@') goto again;
goto set0;
}
/****** special SET syntax: multiple SET, set$piece, special variables */
{
char multiset, vnset[256]; /* multiset variables */
long arg3, arg4; /* 3rd,4th arg in set$piece */
if ((multiset = (ch == '('))) {
vnset[0] = EOL;
codptr++;
}
set:
if (*codptr == '$' && (*(codptr + 1) | 0140) == 'p') { /* set$piece */
if (multiset) {
merr_raise (INVREF);
goto err;
}
setpiece = 'p';
while (*++codptr != '(') {
if (*codptr == EOL) {
merr_raise (INVREF);
goto err;
}
}
codptr++;
expr (NAME);
if (merr () > OK) goto err;
stcpy (vn, varnam);
codptr++;
if (*codptr++ != ',') {
merr_raise (COMMAER);
goto err;
}
expr (STRING);
if (merr () > OK) goto err;
stcpy (tmp2, argptr);
if (*codptr != ')') {
codptr++;
expr (STRING);
if (merr () > OK) goto err;
arg3 = intexpr (argptr);
if (merr () == MXNUM) {
arg3 = 256;
merr_clear ();
}
}
else {
arg3 = 1;
}
if (*codptr != ')') {
codptr++;
expr (STRING);
if (merr () > OK) goto err;
if (*codptr != ')') {
merr_raise (BRAER);
goto err;
}
arg4 = intexpr (argptr);
if (merr () == MXNUM) {
arg4 = 256;
merr_clear ();
}
}
else {
arg4 = arg3;
}
} /* set$piece */
else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'q' && (*(codptr + 2) | 0140) == 's') { /* TODO: verify this works (jpw) was (*codptr == '$q'...*/
/*SET $QSUBSCRIPT */
if (multiset) {
merr_raise (INVREF);
goto err;
}
setpiece = 'q';
while (*++codptr != '(') {
if (*codptr == EOL) {
merr_raise (INVREF);
goto err;
}
}
codptr++;
expr (NAME);
if (merr () > OK) goto err;
stcpy (vn, varnam);
if (*++codptr == ',') {
codptr++;
expr (STRING);
if (merr () > OK) goto err;
stcpy (tmp2, argptr);
}
if (*codptr != ')') {
merr_raise (BRAER);
goto err;
}
}
else if (*codptr == '$' &&
(*(codptr + 1) | 0140) == 'd' &&
(*(codptr + 2) | 0140) == 'i') {
short rb_slot;
rb_slot = rbuf_slot_from_name (rou_name);
while ((*(++codptr)) != '=');
codptr++;
expr (STRING);
stcnv_m2c (argptr);
if ((strcmp (argptr, "STANDARD") == 0) ||
(strcmp (argptr, "MDS") == 0)) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_MDS;
}
else if (strcmp (argptr, "M77") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M77;
}
else if (strcmp (argptr, "M84") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M84;
}
else if (strcmp (argptr, "M90") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M90;
}
else if (strcmp (argptr, "M95") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M95;
}
else if (strcmp (argptr, "M5") == 0) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_M5;
}
else if ((strcmp (argptr, "FREEM") == 0) ||
(strcmp (argptr, "EXTENDED") == 0)) {
rbuf_flags[rb_slot].standard = TRUE;
rbuf_flags[rb_slot].dialect = D_FREEM;
}
else {
merr_raise (CMMND);
goto err;
}
goto s_end;
}
else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) != 't' && (*(codptr + 2) | 0140) != 'c') {
/* set $extract */
if (multiset) {
merr_raise (INVREF);
goto err;
}
setpiece = 'e';
while (*++codptr != '(') {
if (*codptr == EOL) {
merr_raise (INVREF);
goto err;
}
}
codptr++;
expr (NAME);
if (merr () > OK) goto err;
stcpy (vn, varnam);
codptr++;
if (*codptr != ')') {
codptr++;
expr (STRING);
if (merr () > OK) goto err;
arg3 = intexpr (argptr);
if (merr () == MXNUM) {
arg3 = 256;
merr_clear ();
}
}
else {
arg3 = 1;
}
if (*codptr != ')') {
codptr++;
expr (STRING);
if (merr () > OK) goto err;
if (*codptr != ')') {
merr_raise (BRAER);
goto err;
}
arg4 = intexpr (argptr);
if (merr () == MXNUM) {
arg4 = 256;
merr_clear ();
}
}
else {
arg4 = arg3;
}
}
else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) == 'c') {
/* set $ecode */
if (multiset) {
merr_raise (INVREF);
goto err;
}
while ((*(++codptr)) != '=');
codptr++;
expr (STRING);
if (merr () > OK) goto err;
switch (argptr[0]) {
case ',':
switch (argptr[1]) {
case ',':
merr_raise (M101);
goto err;
}
break;
}
merr_raise (merr_set_ecode (argptr));
#if 0
set_io (UNIX);
stcnv_m2c (ecode);
stcnv_m2c (etrap);
printf ("\n\n*** IN SET $ECODE: ecode = '%s' etrap = '%s'\n", ecode, etrap);
stcnv_c2m (etrap);
stcnv_c2m (ecode);
set_io (MUMPS);
#endif
if (merr () > OK) goto err;
goto s_end;
}
else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'e' && (*(codptr + 2) | 0140) == 't') {
/* set $etrap */
if (multiset) {
merr_raise (INVREF);
goto err;
}
while ((*(++codptr)) != '=');
codptr++;
expr (STRING);
if (merr () > OK) goto err;
stcpy (etrap, argptr);
#if 0
set_io (UNIX);
stcnv_m2c (ecode);
stcnv_m2c (etrap);
printf ("\n\n***IN SET $ETRAP: ecode = '%s' etrap = '%s'\n", ecode, etrap);
stcnv_c2m (etrap);
stcnv_c2m (ecode);
set_io (MUMPS);
#endif
goto s_end;
}
else if (*codptr == '$' && (*(codptr + 1) | 0140) == 'g' && cset) { /* set$get */
if (multiset) {
merr_raise (INVREF);
goto err;
}
setpiece = 'g';
while (*++codptr != '(') {
if (*codptr == EOL) {
merr_raise (INVREF);
goto err;
}
}
codptr++;
expr (NAME);
if (merr () > OK) goto err;
stcpy (vn, varnam);
if (*++codptr == ',') {
codptr++;
expr (STRING);
if (merr () > OK) goto err;
stcpy (tmp2, argptr);
}
else {
tmp2[0] = EOL;
}
if (*codptr != ')') {
merr_raise (BRAER);
goto err;
}
}
else {
if (*codptr == '$') {
codptr++;
expr (NAME);
if (merr () > OK) goto err;
stcpy (tmp, varnam);
varnam[0] = '$';
stcpy (&varnam[1], tmp);
i = 0;
while ((ch = varnam[++i]) != EOL) {
if (ch >= 'A' && ch <= 'Z') {
varnam[i] |= 0140; /*to lowercase */
}
}
}
else {
expr (NAME);
if (merr () > OK) goto err;
}
stcpy (vn, varnam);
}
if (multiset) {
vnset[i = stlen (vnset)] = SOH;
stcpy (&vnset[++i], vn);
if (*++codptr == ',') {
codptr++;
goto set;
}
if (*codptr != ')') {
merr_raise (COMMAER);
goto err;
}
}
if (*++codptr != '=') {
ch = *codptr;
if (!cset || *++codptr != '=' || multiset || setpiece || varnam[0] == '$') {
merr_raise (ASSIGNER);
break;
}
setop = ch;
}
codptr++;
expr (STRING);
if (merr () > OK) goto err;
if (multiset)
multi:
{
i = 0;
while (vnset[i] == SOH) i++;
j = 0;
while ((vn[j] = vnset[i]) != SOH && vnset[i] != EOL) {
vnset[i++] = SOH;
j++;
}
vn[j] = EOL;
if (j == 0) goto s_end;
}
if (setpiece == 'p') {
long m, n;
if (arg4 < arg3 || arg4 < 1) {
setpiece = FALSE;
break;
}
if (arg3 <= 0) arg3 = 1;
if (vn[0] == '^') {
if (vn[1] == '$') {
ssvn (get_sym, vn, tmp3);
}
else {
global (get_sym, vn, tmp3);
}
}
else {
symtab (get_sym, vn, tmp3);
}
if (merr () == UNDEF || merr () == M6 || merr () == M7) {
tmp3[0] = EOL;
merr_clear ();
}
else if (merr () != OK) {
stcpy (varerr, vn);
}
ch = 0;
m = 0;
n = 0;
j = stlen (tmp2);
while (n < arg3 - 1) {
if ((ch = find (&tmp3[m], tmp2)) <= 0) {
while (++n < arg3) {
if (stcat (tmp3, tmp2) == 0) {
merr_raise (M75);
goto err;
}
}
arg3 = arg4 = stlen (tmp3);
goto set10;
}
n++;
m += j + ch - 1;
}
if (arg3 > 1) {
arg3 = m;
}
else {
arg3 = 0;
}
while (n++ < arg4) {
if ((ch = find (&tmp3[m], tmp2)) <= 0) {
arg4 = stlen (tmp3);
goto set10;
}
m += j + ch - 1;
}
arg4 = m - j;
set10:
stcpy0 (tmp2, tmp3, (long) arg3);
tmp2[arg3] = EOL;
if (stcat (tmp2, argptr) == 0) {
merr_raise (M75);
goto err;
}
if (stcat (tmp2, &tmp3[arg4]) == 0) {
merr_raise (M56); //JPW
goto err;
}
stcpy (argptr, tmp2);
setpiece = FALSE;
}
else if (setpiece == 'q') { /* SET$QSUBSCRIPT */
setpiece = FALSE;
if (vn[0] == '^') {
if (vn[1] == '$') {
ssvn (get_sym, vn, tmp3);
}
else {
global (get_sym, vn, tmp3);
}
}
else {
symtab (get_sym, vn, tmp3);
}
if (merr () == UNDEF || merr () == M6 || merr () == M7) {
tmp3[0] = EOL;
merr_clear ();
}
else if (merr () != OK) {
stcpy (varerr, vn);
}
if (merr () == OK) {
/* 2nd $QS argument */
if ((arg4 = intexpr (tmp2)) < -1) merr_raise (ARGER);
if (merr () != OK) break;
/* special if source is empty */
if (tmp3[0] != EOL || (arg4 != 0)) {
/* special: Set env to empty: no |""| */
if ((arg4 == -1) && (*argptr == EOL)) {
tmp2[0] = EOL;
}
else if ((arg4 != 0) && !znamenumeric (argptr)) {
/* put replacement string in tmp2 with */
/* quotes around env or subscript, unless numeric */
i = 0;
j = -1;
tmp2[0] = '"';
while ((tmp2[++i] = argptr[++j]) != EOL) {
if (tmp2[i] == '"') tmp2[++i] = '"';
if (i >= (STRLEN - 2)) {
merr_raise (M75);
break;
}
}
tmp2[i] = '"';
tmp2[++i] = EOL;
}
else {
stcpy (tmp2, argptr);
}
/* source is tmp3, dest is argptr, replacement is tmp2 */
{
int ch, cpflag, quote, piececounter;
piececounter = 0;
i = 0;
j = 0;
quote = FALSE;
cpflag = FALSE;
/* if source has no env, process right now */
if ((arg4 == -1) && (tmp3[tmp3[0] == '^'] != '|') && tmp2[0] != EOL) {
if (tmp3[0] == '^') {
argptr[j++] = '^';
i = 1;
}
argptr[j++] = '|';
ch = 0;
while ((argptr[j] = tmp2[ch++]) != EOL) j++;
argptr[j++] = '|';
}
else if (arg4 == 0) { /* '^'+name may be separated by env */
if (tmp2[0] == '^') argptr[j++] = '^';
if (tmp3[0] == '^') i++;
}
while ((ch = tmp3[i++]) != EOL) {
if (ch == '"') quote = !quote;
if (!quote) {
if (ch == ',') {
piececounter++;
argptr[j++] = ch;
continue;
}
if ((ch == '(' && piececounter == 0)) {
if (!cpflag && (arg4 == 0)) {
i--;
}
else {
piececounter = 1;
argptr[j++] = ch;
continue;
}
}
if (ch == '|') {
if (piececounter == 0) {
piececounter = (-1);
}
else if (piececounter == (-1)) {
piececounter = 0;
}
if (tmp2[0] != EOL || piececounter > 0) argptr[j++] = ch;
continue;
}
}
if (piececounter == arg4) {
if (cpflag) continue;
cpflag = TRUE;
ch = 0;
if (arg4 == 0 && tmp2[0] == '^') ch = 1;
while ((argptr[j] = tmp2[ch++]) != EOL) j++;
}
else {
argptr[j++] = ch;
}
if (j >= (STRLEN - 1)) {
merr_raise (M75);
break;
}
} /* while ((ch = tmp3[i++]) != EOL) ... */
if (piececounter && (piececounter == arg4)) argptr[j++] = ')';
if (piececounter < arg4) {
if (piececounter == 0) {
argptr[j++] = '(';
}
else {
argptr[j - 1] = ',';
}
while (++piececounter < arg4) {
argptr[j++] = '"';
argptr[j++] = '"';
argptr[j++] = ',';
if (j >= STRLEN) {
merr_raise (M75);
break;
}
}
}
ch = 0;
if (argptr[j - 1] != ')') {
while ((argptr[j++] = tmp2[ch++]) != EOL);
argptr[j - 1] = ')';
}
}
argptr[j] = EOL;
if (j >= STRLEN) {
merr_raise (M75);
break;
}
}
}
else {
break;
}
} /* set$qsubscript */
else if (setpiece == 'e') { /* SETtable $EXTRACT *//* parameters ok?? */
if (arg3 > arg4 || arg4 < 1) {
setpiece = FALSE;
break;
}
if (arg3 <= 0) arg3 = 1;
if (arg3 > STRLEN) {
merr_raise (M75);
goto err;
}
/* get value of glvn */
if (vn[0] == '^') {
if (vn[1] == '$') {
ssvn (get_sym, vn, tmp3);
}
else {
global (get_sym, vn, tmp3);
}
}
else {
symtab (get_sym, vn, tmp3);
}
/* if UNDEF assume null string */
if (merr () == UNDEF || merr () == M6 || merr () == M7) {
tmp3[0] = EOL;
merr_clear ();
}
else if (merr () != OK) {
stcpy (varerr, vn);
}
j = stlen (tmp3);
/* pad with SPaces if source string is too short */
while (j < arg3) tmp3[j++] = SP;
tmp3[j] = EOL;
if (stlen (tmp3) > arg4) {
stcpy (tmp2, &tmp3[arg4]);
}
else {
tmp2[0] = EOL;
}
tmp3[arg3 - 1] = EOL;
/* compose new value of glvn */
if (stcat (tmp3, argptr) == 0) {
merr_raise (M75);
goto err;
}
if (stcat (tmp3, tmp2) == 0) {
merr_raise (M75);
goto err;
}
stcpy (argptr, tmp3);
setpiece = FALSE;
}
else if (setpiece == 'g') { /* SETtable $GET */
setpiece = FALSE;
ch = (stcmp (tmp2, argptr) == 0) ? killone : set_sym;
if (vn[0] == '^') {
stcpy (an, argptr);
if (vn[1] == '$') {
ssvn (ch, vn, an);
}
else {
global (ch, vn, an);
}
}
else {
stcpy (an, argptr);
symtab (ch, vn, an);
}
if (merr () != OK) stcpy (varerr, vn);
break;
}
if (vn[0] == '^') { /* global variables and SSVNs */
stcpy (an, argptr);
if (vn[1] == '$') {
ssvn (set_sym, vn, an);
}
else {
global (set_sym, vn, an);
}
if (merr () > OK) {
stcpy (varerr, vn);
goto err;
}
}
else if (vn[0] != '$') { /* local variables */
stcpy (an, argptr);
symtab (set_sym, vn, an);
if (merr () > OK) {
stcpy (varerr, vn);
goto err;
}
}
else { /* $-variables */
if (vn[1] == 'x') { /* set $X */
j = intexpr (argptr);
if (merr () == MXNUM) {
j = 256;
merr_clear ();
}
if (j < 0) {
merr_raise (M43);
goto err;
}
if (io == HOME) {
argptr[0] = ESC;
argptr[1] = '[';
argptr[2] = EOL;
if (ypos[HOME] > 1) {
intstr (tmp3, ypos[HOME] + 1);
stcat (argptr, tmp3);
}
if (j > 0) {
stcat (argptr, ";\201");
intstr (tmp3, j + 1);
stcat (argptr, tmp3);
}
stcat (argptr, "H\201");
write_m (argptr);
}
xpos[io] = j;
goto s_end;
}
else if (vn[1] == 'y') { /* set $Y */
j = intexpr (argptr);
if (merr () == MXNUM) {
j = 256;
merr_clear ();
}
if (j < 0) {
merr_raise (M43);
goto err;
}
if (io == HOME) {
argptr[0] = ESC;
argptr[1] = '[';
argptr[2] = EOL;
if (j > 0) {
intstr (tmp3, j + 1);
stcat (argptr, tmp3);
}
if (xpos[HOME] > 0) {
stcat (argptr, ";\201");
intstr (tmp3, xpos[HOME] + 1);
stcat (argptr, tmp3);
}
stcat (argptr, "H\201");
write_m (argptr);
}
ypos[io] = j;
goto s_end;
}
else if (vn[1] == 't') { /* set $t */
test = tvexpr (argptr);
goto s_end;
}
else if (vn[1] == 'j') { /* set $job */
pid = intexpr (argptr);
lock (" \201", -1, 's');
goto s_end;
}
#if !defined(_SCO_DS)
else if (vn[1] == 'h') { /* set $horolog */
long int day;
long int sec;
struct timespec sh_ts;
if (!is_horolog (argptr)) {
merr_raise (ZINVHORO);
goto err;
}
sec = 0L;
for (i = 0; argptr[i] != EOL; i++) {
if (argptr[i] == ',') {
sec = intexpr (&argptr[i + 1]);
break;
}
}
if (sec < 0 || sec >= 86400L) {
merr_raise (ARGER);
goto err;
}
day = intexpr (argptr) - 47117L;
if (day < 0 || day > 49710L) {
merr_raise (ARGER);
goto err;
}
sec += day * 86400 + FreeM_timezone;
day = FreeM_timezone;
sh_ts.tv_sec = sec;
#if defined(__linux__)
if (clock_settime (CLOCK_REALTIME, &sh_ts) != 0) {
merr_raise (PROTECT);
goto err;
}
#endif
#ifndef LINUX
/* daylight savings time status may have changed */
{
struct tm *ctdata;
long clock;
clock = time (0L);
ctdata = localtime (&clock);
if (day -= (FreeM_timezone = ctdata->tm_tzadj)) {
sec -= day;
tzoffset += day;
stime (&sec);
}
}
#endif /* LINUX */
goto s_end;
}
#endif /* _SCO_DS */
else if ((vn[1] == 'r') || ((vn[1] == 'z') && (vn[2] == 'r') && vn[3] == EOL)) { /* set $reference */
if (argptr[0] == EOL) {
zref[0] = EOL;
break;
}
stcpy (tmp4, codptr);
stcpy (code, argptr);
codptr = code;
expr (NAME);
stcpy (code, tmp4);
codptr = code;
if (argptr[0] != '^') merr_raise (INVREF);
if (ierr <= OK) nakoffs = stcpy (zref, argptr); /* save reference */ /* SMW - TODO */
goto s_end;
}
else if (vn[1] == 'z') { /* $Z.. variables *//* if not intrinsic: make it user defined */
i = stcpy (&tmp[1], &vn[1]) + 1;
if (vn[3] == DELIM) i = 3; /* set $zf() function keys */
tmp[0] = SP;
tmp[i] = SP;
tmp[++i] = EOL;
if (find (zsvn, tmp) == FALSE) {
i = 2;
while (vn[i] != EOL) {
if (vn[i++] == DELIM) {
merr_raise (INVREF);
goto err;
}
}
udfsvn (set_sym, &vn[2], argptr);
break;
}
if ((!stcmp (&vn[2], "l\201")) || (!stcmp (&vn[2], "local\201"))) { /* set $zlocal */
if (argptr[0] == EOL) {
zloc[0] = EOL;
break;
}
stcpy (tmp4, codptr);
stcpy (code, argptr);
codptr = code;
expr (NAME);
stcpy (code, tmp4);
codptr = code;
if (argptr[0] == '^') merr_raise (INVREF);
if (ierr <= OK) stcpy (zloc, argptr); /* save reference */
break;
}
if ((!stcmp (&vn[2], "t\201")) || (!stcmp (&vn[2], "tr\201")) || (!stcmp (&vn[2], "trap\201"))) { /* set $ztrap */
if (stlen (argptr) > ZTLEN) {
merr_raise (M75);
goto err;
}
/* DSM V.2 error trapping */
#ifdef DEBUG_NEWSTACK
printf ("Setting Ztrap, DSM2err [%d]\r\n", DSM2err);
#endif
if (DSM2err) {
stcpy (ztrap[NESTLEVLS + 1], argptr);
}
else {
stcpy (ztrap[nstx], argptr);
}
}
else if (!stcmp (&vn[2], "p\201") || !stcmp (&vn[2], "precision\201")) { /* set $zprecision */
short tmp_zprecise;
if ((tmp_zprecise = intexpr (argptr)) < 0) {
merr_raise (MXNUM);
goto err;
}
if (!fp_mode) {
if (merr () == MXNUM) goto err;
if (tmp_zprecise > 20000) {
merr_raise (MXNUM);
goto err;
}
}
#if !defined(_AIX)
else {
if (tmp_zprecise > DBL_DIG) {
merr_raise (MXNUM);
goto err;
}
sprintf (fp_conversion, "%%.%df\201", tmp_zprecise);
}
#endif
zprecise = tmp_zprecise;
}
else if (vn[2] == 'f' && vn[3] == DELIM) { /* set $zf() function keys */
i = intexpr (&vn[4]) - 1;
if (i < 0 || i > 43) {
merr_raise (FUNARG);
goto err;
}
if (stlen (argptr) > FUNLEN) {
merr_raise (M75);
goto err;
}
stcpy (zfunkey[i], argptr);
}
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 */
short k;
i = 0;
for (ch = 0; ch <= 255; ch++) {
j = argptr - partition;
while ((k = partition[j++]) != EOL) {
if (UNSIGN (k) == ch) {
tmp[i++] = k;
break;
}
}
}
tmp[i] = EOL;
switch (vn[3]) {
case 'c':
stcpy (zmc, tmp);
break;
case 'n':
stcpy (zmn, tmp);
break;
case 'p':
stcpy (zmp, tmp);
break;
/* 'a': always union of zml+zmu */
case 'l':
stcpy (zml, tmp);
break;
case 'u':
stcpy (zmu, tmp);
break;
/* 'e': always 'everything' */
}
}
else {
merr_raise (INVREF);
break;
}
}
else {
merr_raise (INVREF);
goto err;
} /* end of processing for $Z.. intrinsic special variables */
} /* svns=$vars */
if (multiset) goto multi;
} /* end of scope for special SET syntaxes */
s_end:
if (*codptr != ',') break;
if (*++codptr == '@') goto again;
goto set0;
case IF:
merr_raise (cmd_if (&ra));
MRESCHECK(ra);
break;
case OO_USING:
merr_raise (cmd_using (&ra));
MRESCHECK(ra);
break;
case OO_WITH:
merr_raise (cmd_with (&ra));
MRESCHECK(ra);
break;
case WRITE:
merr_raise (cmd_write(&ra, &i));
MRESCHECK(ra);
break;
case READ:
merr_raise (cmd_read (&ra));
MRESCHECK(ra);
break;
case ELSE:
merr_raise (cmd_else (&ra));
MRESCHECK(ra);
break;
case ZQUIT:
{
int zq_lvlct;
if (rtn_dialect () != D_FREEM) {
merr_raise (NOSTAND);
goto err;
}
if (*codptr == EOL) {
zq_lvlct = nstx;
}
else {
expr (STRING);
zq_lvlct = intexpr (argptr);
if (merr () > OK) goto err;
if (zq_lvlct < 0 || zq_lvlct > nstx) {
merr_raise (LVLERR);
goto err;
}
else if (zq_lvlct != nstx) {
repQUIT = nstx - zq_lvlct;
}
else {
merr_raise (LVLERR);
goto err;
}
}
break;
}
case QUIT:
if (tp_level > 0) {
merr_raise (M42);
goto err;
}
#ifdef DEBUG_NEWSTACK
printf ("At QUIT command, checking stack...\r\n");
#endif
#ifdef DEBUG_NEWSTACK
printf ("nestc[nstx] is (%d)\r\n", nestc[nstx]);
#endif
if (*codptr != EOL && *codptr != SP && nestc[nstx] != '$') {
#ifdef DEBUG_NEWSTACK
printf ("IERR\r\n");
#endif
merr_raise (ARGER);
break;
}
if (nestc[nstx] == '$') { /* extrinsic function/variable */
#ifdef DEBUG_NEWSTACK
printf ("EXTRINSIC\r\n");
#endif
//printf (" extr_types[%d] = '%d'\r\n", nstx, extr_types[nstx]);
if (*codptr == EOL || *codptr == SP) {
#ifdef DEBUG_NEWSTACK
printf ("CODPTR is [%d]\r\n", *codptr);
#endif
if (exfdefault[0] == EOL) {
*argptr = EOL;
merr_raise (NOVAL);
}
else { /* there is a default expression... */
stcpy (&code[1], exfdefault);
expr (STRING);
if (ierr != OK - CTRLB && merr () != OK && merr () != INRPT) {
#ifdef DEBUG_NEWSTACK
printf ("Break at 1st IERR\r\n");
#endif
break;
}
}
}
else {
expr (STRING);
if (ierr != OK - CTRLB && merr () != OK && merr () != INRPT) {
#ifdef DEBUG_NEWSTACK
printf ("Break at 2nd IERR\r\n");
#endif
break;
}
if (dt_check (extr_types[nstx], argptr, 0) == FALSE) {
extr_types[nstx] = DT_STRING;
merr_raise (TYPMISMATCH);
break;
}
}
#ifdef DEBUG_NEWSTACK
printf ("CHECK 01 (Stack POP)\r\n");
#endif
if (nestn[nstx]) { /* reload routine */
namptr = nestn[nstx];
stcpy (rou_name, namptr);
zload (rou_name);
ssvn_job_update ();
dosave[0] = 0;
namptr--;
}
if (nestnew[nstx]) unnew (); /* un-NEW variables */
/* restore old pointers */
level = nestlt[nstx]; /* pop level */
roucur = nestr[nstx] + rouptr;
extr_types[nstx] = DT_STRING;
stcpy (codptr = code, cmdptr = nestp[nstx--]);
estack--;
forsw = (nestc[nstx] == FOR);
loadsw = TRUE;
return 0;
}
if (nestc[nstx] == BREAK) {
merr_clear ();
merr_set_break ();
goto zgo;
} /*cont. single step */
quit0:
#ifdef DEBUG_NEWSTACK
printf ("CHECK 02 (Stack POP)\r\n");
#endif
if (evt_depth) {
evt_depth--;
if (evt_depth == 0 && evt_async_restore == TRUE) {
evt_async_enabled = TRUE;
evt_async_restore = FALSE;
}
}
if (etrap_lvl) etrap_lvl--;
if (nstx == 0) goto restore; /* nothing to quit */
if (nestc[nstx] == FOR) {
stcpy (code, cmdptr = nestp[nstx--]);
estack--;
codptr = code;
ftyp = fortyp[--forx];
fvar = forvar[forx];
finc = forinc[forx];
fpost = forpost[forx];
flim = forlim[forx];
fi = fori[forx];
if ((forsw = (nestc[nstx] == FOR))) goto for_end;
goto next_line;
}
if (nestn[nstx]) { /* reload routine */
namptr = nestn[nstx];
if ((nestc[nstx] != XECUTE) || loadsw) {
stcpy (rou_name, namptr);
zload (rou_name);
ssvn_job_update ();
dosave[0] = 0;
}
namptr--;
}
if (nestnew[nstx]) unnew (); /* un-NEW variables */
/* restore old pointers */
if ((mcmnd = nestc[nstx]) == BREAK) goto restore; /* cont. single step */
if (mcmnd == DO_BLOCK) {
test = nestlt[nstx];
level--;
}
else { /* pop $TEST */
level = nestlt[nstx]; /* pop level */
}
if (nstx) {
roucur = nestr[nstx] + rouptr;
}
else {
roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
}
stcpy (codptr = code, cmdptr = nestp[nstx--]);
estack--;
forsw = (nestc[nstx] == FOR);
loadsw = TRUE;
if (deferred_ierr > OK) { /* smw - TODO: how to handle deferred_ierr now */
merr_raise (deferred_ierr);
}
#if defined(HAVE_MWAPI_MOTIF)
if ((in_syn_event_loop == TRUE) && (nstx == syn_event_entry_nstx)) goto syn_evt_loop_bottom;
#endif
break;
case FOR:
if ((ch = *codptr) == EOL) goto skip_line; /* ignore empty line */
#ifdef DEBUG_NEWSTACK
printf ("CHECK 03 (Stack PUSH)\r\n");
#endif
if (++nstx > NESTLEVLS) {
nstx--;
merr_raise (STKOV);
break;
}
else {
estack++;
}
fvar = forvar[++forx];
finc = forinc[forx];
fpost = forpost[forx];
flim = forlim[forx];
fi = fori[forx];
nestc[nstx] = FOR; /* stack set-up */
#ifdef DEBUG_NEWSTACK
if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
#endif
nestp[nstx] = cmdptr;
nestn[nstx] = 0; /* no overring of routine */
nestr[nstx] = roucur - rouptr; /* save roucur: only for $V(26) needed */
ztrap[nstx][0] = EOL;
forsw = TRUE;
ftyp = 0; /* no args is FOREVER */
if (ch == SP) {
goto for_go;
}
else { /* find local variable */
if (ch == '^') {
merr_raise (GLOBER);
break;
}
if (ch == '$') {
merr_raise (INVREF);
break;
}
if (*(codptr + 1) == '=') { /* single char local variable */
if ((ch < 'A' && ch != '%') || (ch > 'Z' && ch < 'a') || ch > 'z') {
merr_raise (INVREF);
break;
}
fvar[0] = ch;
fvar[1] = EOL;
codptr += 2;
}
else {
expr (NAME);
if (*++codptr != '=') merr_raise (ASSIGNER);
if (merr () != OK) break;
stcpy (fvar, varnam);
codptr++;
}
ftyp++;
}
for_nxt_arg:
expr (STRING);
if (merr () != OK) break;
stcpy (tmp, argptr);
if ((ch = *codptr) != ':') {
if (ch == ',' || ch == SP || ch == EOL) {
ftyp = 1;
goto for_init;
}
merr_raise (ARGLIST);
break;
}
numlit (tmp); /* numeric interpretation */
codptr++;
expr (STRING);
if (merr () != OK) break;
numlit (argptr);
stcpy (finc, argptr); /* increment */
if ((ch = *codptr) != ':') {
if (ch == ',' || ch == EOL || ch == SP) {
ftyp = 2;
goto for_init;
}
merr_raise (ARGLIST);
break;
}
codptr++;
expr (STRING);
if (merr () != OK) break;
numlit (argptr);
stcpy (flim, argptr); /* limit */
ftyp = 3;
if ((ch = *codptr) != ',' && ch != SP && ch != EOL) {
merr_raise (ARGLIST);
break;
}
if ((*finc != '-' && comp (flim, tmp)) || (*finc == '-' && comp (tmp, flim))) {
symtab (set_sym, fvar, tmp);
if (merr () > OK) {
stcpy (varerr, vn);
break;
}
goto for_quit;
}
for_init:
symtab (set_sym, fvar, tmp);
if (merr () > OK) {
stcpy (varerr, fvar);
break;
}
/* optimize frequent special case: */
/* increment by one and no additional FOR arguments */
/* if limit value it must be a positive integer */
if (ftyp > 1 && finc[0] == '1' && finc[1] == EOL) {
j = TRUE;
if (ftyp == 3) {
i = 0;
while ((ch = flim[i]) != EOL) {
if (ch < '0' || ch > '9') j = FALSE;
i++;
}
fi = i;
fori[forx] = i;
}
if (j && ((ch = *codptr) == SP || ch == EOL)) {
ftyp += 2;
if (ch == SP) codptr++;
}
}
for_go:
fortyp[forx] = ftyp;
#ifdef DEBUG_NEWSTACK
if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
#endif
nestp[nstx] = cmdptr;
cmdptr += stcpy (cmdptr, codptr) + 1;
if (ftyp > 3) goto next_cmnd;
/* skip following for arguments if there are any */
for10:
if (*codptr == SP) goto next_cmnd;
i = 0;
while ((((ch = *codptr) != SP) || i) && ch != EOL) {
if (ch == '"') i = !i;
codptr++;
} /* skip rest of FOR list */
goto next_cmnd;
for_end: /* end of line return */
#ifdef DEBUG_NEWSTACK
printf ("For_end: nstx: %d, Nestp: (%d)\r\n", nstx, nestp[nstx]);
#endif
stcpy (codptr = code, nestp[nstx]); /* restore old pointers */
switch (ftyp) {
case 5: /* frequent special case: increment 1 */
symtab (getinc, fvar, tmp);
/* compare fvar-value to flim-value */
/* fi: i=0; while (flim[i]>='0') i++; */
/* Note: EOL<'-'<'.'<'0' tmp has at least one character */
ch = '0';
j = 1;
while (tmp[j] >= ch) j++;
if (j < fi) goto next_cmnd;
if (j == fi) {
j = 0;
while (tmp[j] == flim[j]) {
if (tmp[j] == EOL) goto next_cmnd;
j++;
}
if (tmp[j] <= flim[j]) goto next_cmnd;
}
if (flim[0] != '-' && tmp[0] == '-') goto next_cmnd;
stcpy (tmp2, "-1\201"); /* correct last inc */
add (tmp, tmp2);
symtab (set_sym, fvar, tmp);
goto for_quit;
case 4: /* frequent special case: increment 1 without limit */
symtab (getinc, fvar, tmp);
case 0: /* argumentless FOR */
if(argless_forsw_quit == TRUE) {
/* if we have a positive QUIT condition, bail from the FOR loop */
argless_forsw_quit = FALSE;
goto for_quit;
}
else {
/* otherwise, just keep on truckin' */
goto next_cmnd;
}
case 3: /* FOR with increment and limit test */
symtab (get_sym, fvar, tmp);
numlit (tmp);
stcpy (tmp2, finc); /* add may change forinc */
add (tmp, tmp2);
if (*finc != '-') {
if (comp (flim, tmp)) goto for_quit;
}
else {
if (comp (tmp, flim)) goto for_quit;
}
symtab (set_sym, fvar, tmp);
goto for10;
case 2: /* FOR with increment without limit test */
symtab (get_sym, fvar, tmp);
numlit (tmp);
stcpy (tmp2, finc); /* add may change forinc */
add (tmp, tmp2);
symtab (set_sym, fvar, tmp);
goto for10;
} /* end switch */
for_quit:
cmdptr = nestp[nstx];
if (*codptr++ == ',') goto for_nxt_arg;
forpost[forx][0] = '\0';
nstx--;
estack--;
forx--;
ftyp = fortyp[forx];
fvar = forvar[forx];
finc = forinc[forx];
flim = forlim[forx];
fi = fori[forx];
if ((forsw = (nestc[nstx] == FOR))) goto for_end;
if (sigint_in_for) {
merr_raise (INRPT);
sigint_in_for = FALSE;
}
if (merr () > OK) goto err;
goto next_line;
case MERGE:
{
char lhs[256];
char rhs[256];
char k_buf[STRLEN];
if ((rtn_dialect () != D_M95) &&
(rtn_dialect () != D_MDS) &&
(rtn_dialect () != D_M5) &&
(rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
expr (NAME);
if (merr () > OK) break;
key_to_name (lhs, varnam, 255);
stcnv_c2m (lhs);
if (*++codptr != '=') {
merr_raise (ASSIGNER);
break;
}
codptr++;
expr (NAME);
if (merr () > OK) break;
codptr++;
key_to_name (rhs, varnam, 255);
stcnv_c2m (rhs);
stcpy (k_buf, "%INTMERGELHS\201\201");
symtab (set_sym, k_buf, lhs);
stcpy (k_buf, "%INTMERGERHS\201\201");
symtab (set_sym, k_buf, rhs);
stcpy (&tmp3[1], "SYSWMERGE \201");
goto private;
break;
}
case RLOAD:
if ((rtn_dialect () != D_MDS) &&
(rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
stcpy (&tmp3[1], "zrload \201");
goto private;
case RSAVE:
if ((rtn_dialect () != D_MDS) &&
(rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
stcpy (&tmp3[1], "zrsave \201");
goto private;
case XECUTE:
do_xecute:
expr (STRING);
if (merr () > OK) break;
stcpy (tmp, argptr);
if (*codptr == ':') { /* argument postcond */
codptr++;
expr (STRING);
if (merr () > OK) break;
if (tvexpr (argptr) == FALSE) break;
}
if (++nstx > NESTLEVLS) {
nstx--;
merr_raise (STKOV);
break;
}
else {
estack++;
}
#ifdef DEBUG_NEWSTACK
if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
#endif
nestc[nstx] = XECUTE;
nestp[nstx] = cmdptr; /* command stack address */
nestr[nstx] = roucur - rouptr; /* save roucur */
nestlt[nstx] = level;
level = 0; /* save level */
nestnew[nstx] = 0;
ztrap[nstx][0] = EOL;
while ((*(namptr++)) != EOL);
stcpy ((nestn[nstx] = namptr), rou_name); /* save routine name */
forsw = FALSE;
loadsw = FALSE;
cmdptr += stcpy (cmdptr, codptr) + 1;
stcpy (code, tmp);
roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
codptr = code;
goto next_cmnd;
case DO:
if (evt_async_initial == TRUE) {
evt_async_initial = FALSE;
}
else {
evt_depth++;
}
rouoldc = roucur - rouptr;
namold = 0;
case GOTO:
do_goto:
offset = 0;
label[0] = routine[0] = EOL;
dofram0 = 0;
if (((ch = *codptr) != '+') && (ch != '^')) { /* parse label */
if (ch == SP || ch == EOL) { /* no args: blockstructured DO */
if (mcmnd != DO) {
merr_raise (ARGLIST);
break;
}
/* direct mode: DO +1 */
if (nstx == 0 && roucur >= rouend) {
roucu0 = rouptr;
goto off1;
}
mcmnd = DO_BLOCK;
roucu0 = roucur; /* continue with next line */
forsw = FALSE;
goto off2;
}
expr (LABEL);
if (merr () > OK) goto err;
stcpy (label, varnam);
ch = *++codptr;
}
if (ch == '+') { /* parse offset */
codptr++;
expr (OFFSET);
if (merr () > OK) goto err;
offset = intexpr (argptr);
dosave[0] = EOL;
/* unless argument is numeric, expr returns wrong codptr */
if ((ch = *codptr) != SP && (ch != EOL) && (ch != ',') && (ch != '^')) ch = *++codptr;
}
if (ch == '^') { /* parse routine */
codptr++;
expr (LABEL);
if (merr () > OK) goto err;
stcpy (routine, varnam);
dosave[0] = EOL;
ch = *++codptr;
loadsw = TRUE;
}
if (ch == '(' && mcmnd == DO) { /* parse parameter */
if (offset) {
merr_raise (ARGLIST);
goto err;
}
if (*++codptr == ')') {
ch = *++codptr;
}
else {
dofram0 = dofrmptr;
i = 0;
for (;;) {
setpiece = TRUE; /* to avoid error on closing bracket */
if (*codptr == '.' && (*(codptr + 1) < '0' || *(codptr + 1) > '9')) {
codptr++;
expr (NAME);
codptr++;
*dofrmptr++ = DELIM; /* to indicate call by name */
dofrmptr += stcpy (dofrmptr, varnam) + 1;
}
else {
expr (STRING);
dofrmptr += stcpy (dofrmptr, argptr) + 1;
}
setpiece = FALSE;
i++;
if (merr () > OK) {
dofrmptr = dofram0;
goto err;
}
ch = *codptr++;
if (ch == ',') continue;
if (ch != ')') {
merr_raise (COMMAER);
dofrmptr = dofram0;
goto err;
}
ch = *codptr;
break;
}
}
}
if (ch == ':') { /* parse postcond */
codptr++;
expr (STRING);
if (merr () > OK) {
if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
goto err;
}
if (tvexpr (argptr) == FALSE) {
if (*codptr != ',') mcmnd = 0; /* avoid false LEVEL Error */
if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
break;
}
}
if (mcmnd == GOTO) { /* GOTO: clear FORs from stack */
#ifdef DEBUG_NEWSTACK
printf ("CHECK 05 Multi-POP on FOR\r\n");
#endif
while (nestc[nstx] == FOR) {
#ifdef DEBUG_NEWSTACK
printf ("POP");
#endif
cmdptr = nestp[nstx--];
estack--;
forx--;
ftyp = fortyp[forx];
fvar = forvar[forx];
finc = forinc[forx];
flim = forlim[forx];
fi = fori[forx];
}
#ifdef DEBUG_NEWSTACK
printf ("\r\n");
#endif
loadsw = TRUE;
}
job_entry: /* entry called from successful JOB */
if (routine[0] != EOL) {
#ifdef DEBUG_NEWSTACK
printf ("CHECK 06\r\n");
#endif
if (mcmnd == DO) {
while ((*(namptr++)) != EOL);
namold = namptr;
stcpy (namptr, rou_name);
ssvn_job_update ();
}
/* if (GOTO label^rou) under a (DO label) */
/* save away old routine to restore on quit */
else if (nstx > 0) {
#ifdef DEBUG_NEWSTACK
printf ("CHECK 06, stack is greater than 0\r\n");
#endif
while (nestc[nstx] == FOR) {
#ifdef DEBUG_NEWSTACK
printf ("POP");
#endif
nstx--;
estack--;
forx--;
ftyp = fortyp[forx];
fvar = forvar[forx];
finc = forinc[forx];
flim = forlim[forx];
fi = fori[forx];
}
if (nestn[nstx] == 0) {
while ((*(namptr++)) != EOL);
stcpy ((nestn[nstx] = namptr), rou_name);
}
}
zload (routine);
if (merr () > OK) goto err; /* load file */
ssvn_job_update ();
} /* if (routine[0] != EOL) */
{
char *reg, *reg1;
reg1 = rouptr;
reg = reg1;
if (label[0] != EOL) {
if (forsw && mcmnd == DO && stcmp (label, dosave) == 0) {
roucu0 = xdosave;
goto off1;
}
while (reg < rouend) {
reg++;
j = 0;
while (*reg == label[j]) {
reg++;
j++;
}
if (label[j] == EOL) {
if (*reg == TAB || *reg == SP) goto off;
/* call of procedure without specifying a parameter list */
if (*reg == '(') {
if (dofram0 == 0) dofram0 = dofrmptr;
goto off;
}
}
reg = (reg1 = reg1 + UNSIGN (*reg1) + 2);
}
{
merr_raise (M13);
stcpy (varerr, label); /* to be included in error message */
if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
zload (rou_name);
ssvn_job_update ();
goto err;
}
}
off:
if (label[0] == EOL && offset > 0) offset--;
while (offset-- > 0) reg1 = reg1 + (UNSIGN (*reg1) + 2);
if (forsw) {
xdosave = reg1;
stcpy (dosave, label);
}
roucu0 = reg1;
}
if (roucu0 >= rouend) {
merr_raise (M13);
stcpy (varerr, label); /* to be included in error message */
if (dofram0) dofrmptr = dofram0; /* reset frame pointer */
zload (rou_name);
ssvn_job_update ();
goto err;
}
off1:
if (routine[0] != EOL) stcpy (rou_name, routine);
ssvn_job_update ();
roucu0++;
forsw = FALSE;
if (mcmnd != DO) { /* i.e. GOTO or JOB */
roucur = roucu0;
goto off3;
}
off2:
#ifdef DEBUG_NEWSTACK
printf ("CHECK 07 (Stack PUSH)\r\n");
#endif
if (++nstx > NESTLEVLS) {
nstx--;
merr_raise (STKOV);
goto err;
}
else {
on_frame_entry ();
estack++;
}
nestc[nstx] = mcmnd;
#ifdef DEBUG_NEWSTACK
if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
#endif
nestp[nstx] = cmdptr;
nestn[nstx] = namold;
nestr[nstx] = rouoldc;
nestnew[nstx] = 0;
if (mcmnd != DO_BLOCK) {
nestlt[nstx] = level;
level = 0;
}
else { /* push level ; clr level */
nestlt[nstx] = test;
level++;
} /* push $TEST ; inc level */
ztrap[nstx][0] = EOL;
cmdptr += stcpy (cmdptr, codptr) + 1;
roucur = roucu0;
/* processing for private Z-Command: */
if (privflag) {
#ifdef DEBUG_NEWPTR
printf ("Xecline 01 (using NEWPTR): ");
printf ("[nstx] is [%d], [nestnew] is [%d]", nstx, nestnew[nstx]);
printf ("- Initialized to newptr\r\n");
#endif /* Debug */
nestnew[nstx] = newptr;
stcpy (vn, zargdefname);
/*was: vn[0] = '%'; vn[1] = EOL; */
symtab (new_sym, vn, "");
/*djw change 'input variable for Z command' to get value of $V(202) */
/*was: vn[0] = '%'; vn[1] = EOL; */
stcpy (vn, zargdefname);
symtab (set_sym, vn, tmp2);
privflag = FALSE;
}
off3:
if (dofram0) {
char *reg, *reg1;
reg = roucu0;
reg1 = dofram0;
while ((ch = (*reg++)) != '(') {
if (ch == SP || ch == TAB || ch == EOL) break;
}
if (ch != '(') {
merr_raise (TOOPARA);
dofrmptr = dofram0;
goto err;
}
j = 0;
while ((ch = (*reg++)) != EOL) {
if ((ch == ',' && j) || ch == ')') {
varnam[j] = EOL;
#ifdef DEBUG_NEWPTR
printf ("Xecline 02: ");
printf ("[nstx] is [%d], [nestnew] is [%d]\r\n", nstx, nestnew[nstx]);
#endif
if (nestnew[nstx] == 0) nestnew[nstx] = newptr;
if (reg1 < dofrmptr) {
if (*reg1 == DELIM) { /* call by reference */
if (stcmp (reg1 + 1, varnam)) { /* are they different?? */
symtab (new_sym, varnam, "");
symtab (m_alias, varnam, reg1 + 1);
}
}
else {
symtab (new_sym, varnam, ""); /* call by value */
symtab (set_sym, varnam, reg1);
}
reg1 += stlen (reg1) + 1;
}
else {
symtab (new_sym, varnam, "");
}
if (ch == ')') break;
j = 0;
continue;
}
if ((ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9' && j) || (ch == '%' && j == 0)) {
varnam[j++] = ch;
continue;
}
merr_raise (ARGLIST);
dofrmptr = dofram0; /* reset frame pointer */
goto err;
}
if (reg1 < dofrmptr) {
merr_raise (TOOPARA);
dofrmptr = dofram0;
goto err;
}
dofrmptr = dofram0;
}
goto next_line;
/* ZJOB *//* same as JOB, but without timeout */
/* not recommended; just for backward compatibility */
case ZJOB:
if (is_standard ()) {
merr_raise (NOSTAND);
goto err;
}
case JOB:
if (rtn_dialect () == D_M77) {
merr_raise (NOSTAND);
goto err;
}
if (*codptr == SP || *codptr == EOL) {
merr_raise (M13);
varerr[0] = EOL; /* to be included in error message */
break;
}
loadsw = TRUE;
offset = 0;
frm_timeout = (-1L);
label[0] = routine[0] = EOL;
if (((ch = *codptr) != '+') && (ch != '^')) { /* parse label */
expr (LABEL);
if (merr () > OK) goto err;
stcpy (label, varnam);
ch = *++codptr;
}
if (ch == '+') { /* parse offset */
codptr++;
expr (OFFSET);
if (merr () > OK) goto err;
offset = intexpr (argptr);
/* unless argument is numeric, expr returns wrong codptr */
if ((ch = *codptr) != SP && (ch != EOL) && (ch != ',') && (ch != '^')) ch = *++codptr;
}
if (ch == '^') { /* parse routine */
codptr++;
expr (LABEL);
if (merr () > OK) goto err;
stcpy (routine, varnam);
dosave[0] = EOL;
ch = *++codptr;
}
dofram0 = NULL;
if (ch == '(') { /* parse parameter */
if (offset) {
merr_raise (ARGLIST);
goto err;
}
codptr++;
dofram0 = dofrmptr;
i = 0;
for (;;) {
setpiece = TRUE; /* to avoid error on closing bracket */
if (*codptr == '.' && (*(codptr + 1) < '0' || *(codptr + 1) > '9')) {
codptr++;
expr (NAME);
codptr++;
*dofrmptr++ = DELIM; /* to indicate call by name */
dofrmptr += stcpy (dofrmptr, varnam) + 1;
}
else {
expr (STRING);
dofrmptr += stcpy (dofrmptr, argptr) + 1;
}
setpiece = FALSE;
i++;
if (merr () > OK) {
dofrmptr = dofram0;
goto err;
}
ch = *codptr++;
if (ch == ',') continue;
if (ch != ')') {
merr_raise (COMMAER);
dofrmptr = dofram0;
goto err;
}
ch = *codptr;
break;
}
}
if (ch == ':' && *(codptr + 1) == ch) {
codptr++; /* timeout,no jobparams */
}
else if (ch == ':' && *(codptr + 1) == '(') { /* parse any 'job parameters', but ignore them otherwise */
codptr++;
setpiece = TRUE; /* to avoid bracket error at end of jobparameters */
for (;;) {
if (*++codptr != ':') expr (STRING);
if (*codptr == ':') continue;
if (*codptr++ != ')') merr_raise (ARGER);
break;
}
setpiece = FALSE;
ch = (*codptr);
}
if (ch == ':') { /* timeout */
codptr++;
expr (STRING);
if ((frm_timeout = intexpr (argptr)) < 0L) frm_timeout = 0L;
if (merr () > OK) goto err;
test = TRUE;
}
if (mcmnd == ZJOB) frm_timeout = 0L; /* ZJOB-command has timeout 0 */
close_all_globals (); /* close all globals */
j = getpid (); /* job number of father process */
if (lonelyflag) { /* single user */
if (frm_timeout < 0L) {
merr_raise (PROTECT); /* error without timeout */
}
else {
test = FALSE; /* timeout always fails */
}
break;
}
while ((i = fork ()) == -1) {
if (frm_timeout == 0L) {
test = FALSE;
break;
}
if (frm_timeout > 0L) frm_timeout--;
sleep (1);
}
if (mcmnd == ZJOB && zjobflag) {
if (i == 0) { /* we are in child process */
intstr (zb, j); /* $JOB of father job */
father = j;
pid = getpid (); /* this is our new job number */
jobtime = time (0L);;
nstx = 0; /* clear stack */
estack = 0;
forx = 0;
forsw = FALSE;
level = 0;
cmdptr = cmdstack; /* - command stack pointer */
namptr = namstck; /* - routine name stack pointer */
usermode = 0; /* application mode */
merr_clear ();
lock (" \201", -1, 'j'); /* tell lock about JOB */
goto job_entry;
}
/* ignore signal while here */
sig_attach (SIGUSR1, SIG_IGN);
while (wait (&zsystem) != i);
sig_attach (SIGUSR1, &oncld); /* restore handler */
merr_clear (); /* there might be a INRPT from other job */
set_io (MUMPS);
break;
}
if (i == 0) { /* we are in child process */
intstr (zb, j); /* $JOB of father job */
father = j;
pid = getpid (); /* $J = process ID */
usermode = 0; /* no programmer mode */
DSW |= BIT0; /* disable echo */
zbreakon = DISABLE; /* disable CTRL/B */
breakon = DISABLE; /* disable CTRL/C */
hardcopy = DISABLE; /* disable hardcopy function */
fclose (stdin); /* close normal input */
jour_flag = 0; /* no protocol */
nstx = 0; /* clear stack */
estack = 0;
forx = 0;
forsw = FALSE;
level = 0;
cmdptr = cmdstack; /* - command stack pointer */
namptr = namstck; /* - routine name stack pointer */
/* init random number */
if ((nrandom = time (0L) * getpid ()) < 0) nrandom = (-nrandom);
merr_clear ();
lock (" \201", -1, 'j'); /* tell lock about JOB */
goto job_entry;
}
intstr (zb, i); /* $JOB of the process just started */
break;
case KILL:
/* argumentless: KILL all local variables */
if (((ch = *codptr) == SP) || ch == EOL) {
symtab (kill_all, "", "");
break;
}
if (ch != '(') {
char destc[255];
register int cd;
destc[0] = '\0';
expr (NAME);
/* aviod a disaster if someone types KILL ^PATDAT[TEST] ! */
if (((ch = *++codptr) != SP) && ch != EOL && ch != ',') merr_raise (INVREF);
if (merr () > OK) goto err;
if (varnam[0] == '^') {
if (varnam[1] != '$') {
global (kill_sym, varnam, tmp);
}
else {
ssvn (kill_sym, varnam, tmp);
}
break;
}
symtab (kill_sym, varnam, tmp);
if (destructor_ct) {
for (cd = 0; cd < destructor_ct; cd++) {
if (strlen (destructors[cd]) > 0) {
strcat (destc, destructors[cd]);
strcat (destc, ",");
}
}
destructor_ct = 0;
destc[strlen(destc) - 1] = '\201';
stcpy (&tmp3[1], destc);
destructor_run = TRUE;
goto private;
}
break;
}
/* exclusive kill */
tmp[0] = SP;
tmp[1] = EOL;
for (;;) {
codptr++;
expr (NAME);
if (merr () > OK) goto err;
if (varnam[0] == '^') {
merr_raise (GLOBER);
goto err;
}
i = 0;
while (varnam[i] != EOL) {
if (varnam[i] == DELIM) {
merr_raise (SBSCR);
goto err;
}
i++;
}
if (stcat (tmp, varnam) == 0) {
merr_raise (M75);
goto err;
}
if (stcat (tmp, " \201") == 0) {
merr_raise (M75);
goto err;
}
if ((ch = *++codptr) == ')') {
codptr++;
break;
}
if (ch != ',') {
merr_raise (COMMAER);
goto err;
}
}
symtab (killexcl, tmp, "");
break;
case NEWCMD:
if ((rtn_dialect () == D_M77) ||
(rtn_dialect () == D_M84)) {
merr_raise (NOSTAND);
goto err;
}
/*case ZNEW:*/
/* argumentless: NEW all local variables */
if (((ch = *codptr) == SP) || ch == EOL) {
ch = nstx;
while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */
#ifdef DEBUG_NEWPTR
printf ("Xecline 03: (TODO - NEW ALL) ");
printf ("[ch] is %d, [nestnew] is %d\r\n", ch, nestnew[ch]);
#endif
if (nestnew[ch] == 0) nestnew[ch] = newptr;
symtab (new_all, "", "");
break;
}
if (ch != '(') {
expr (NAME);
if (merr () > OK) goto err;
codptr++;
if (varnam[0] == '^') {
merr_raise (GLOBER);
goto err;
}
if (varnam[0] == '$') {
i = 0;
while ((ch = varnam[++i]) != EOL) if (ch >= 'A' && ch <= 'Z') varnam[i] = ch + 32;
/* set $reference */
if ((stcmp (&varnam[1], "r\201")) && (stcmp (&varnam[1], "reference\201")) && (stcmp (&varnam[1], "zr\201")) && (stcmp (&varnam[1], "zreference\201")) &&
(stcmp (&varnam[1], "t\201")) && (stcmp (&varnam[1], "test\201")) && (stcmp (&varnam[1], "j\201")) && (stcmp (&varnam[1], "job\201")) &&
(stcmp (&varnam[1], "zi\201")) && (stcmp (&varnam[1], "zinrpt\201")) && (stcmp (&varnam[1], "et\201")) && (stcmp (&varnam[1], "etrap\201")) &&
(stcmp (&varnam[1], "es\201")) && (stcmp (&varnam[1], "estack\201"))) {
merr_raise (INVREF);
goto err;
}
}
/* new and set, new object */
if (*codptr == '=') {
if ((rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
codptr++;
stcpy (vn, varnam);
if (*codptr != '$') {
/* this is a new-and-set */
expr (STRING);
new_and_set = TRUE;
}
else {
if ((*codptr == '$') &&
(*(codptr + 1) == '#') &&
(*(codptr + 2) == '^')) {
char class[255];
char constructor[255];
char objvar[255];
char datres[5];
int dat_res;
stcpy (objvar, vn);
symtab (fra_dat, objvar, datres);
dat_res = atoi (datres);
if (dat_res > 0) {
merr_raise (OBJCONFLICT);
goto err;
}
stcnv_m2c (objvar);
codptr += 2;
/* this is probably an object instantiation */
expr (NAME);
if (merr () > OK) goto err;
stcpy (class, varnam);
stcnv_m2c (class);
new_object = TRUE;
codptr++;
obj_get_constructor (constructor, class, objvar);
for (dat_res = 0; dat_res < strlen (class); dat_res++) {
if (class[dat_res] == '\202') {
class[dat_res] = '\0';
break;
}
}
obj_create_symbols (objvar, class);
if (merr () > OK) goto err;
snprintf (&tmp3[1], 255, "%s\201", &constructor[1]);
goto private;
}
else {
if (*codptr == '$') {
expr (STRING);
new_and_set = TRUE;
}
else {
merr_raise (ILLFUN);
goto err;
}
}
}
goto set2;
}
post_new:
ch = nstx;
while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */
#ifdef DEBUG_NEWPTR
printf ("Xecline 04 (DANGER): ");
printf ("[ch] is %d, [nestnew] is %d\r\n", ch, nestnew[ch]);
#endif
if (nestnew[ch] == 0) nestnew[ch] = newptr;
symtab (new_sym, varnam, "");
break;
}
/* exclusive new */
tmp[0] = SP;
tmp[1] = EOL;
for (;;) {
codptr++;
expr (NAME);
if (merr () > OK) goto err;
if (varnam[0] == '^') {
merr_raise (GLOBER);
goto err;
}
if (varnam[0] == '$') {
merr_raise (INVREF);
goto err;
}
i = 0;
while (varnam[i] != EOL) {
if (varnam[i] == DELIM) {
merr_raise (SBSCR);
goto err;
}
i++;
}
if (stcat (tmp, varnam) == 0) {
merr_raise (M75);
goto err;
}
if (stcat (tmp, " \201") == 0) {
merr_raise (M75);
goto err;
}
if ((ch = *++codptr) == ')') {
codptr++;
break;
}
if (ch != ',') {
merr_raise (COMMAER);
goto err;
}
}
ch = nstx;
while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */
#ifdef DEBUG_NEWPTR
printf ("Xecline 05 (TODO): ");
printf ("[ch] is %d, [nestnew] is %d\r\n", ch, nestnew[ch]);
#endif
if (nestnew[ch] == 0) nestnew[ch] = newptr;
symtab (newexcl, tmp, "");
break;
case LOCK:
/* argumentless: UNLOCK */
if ((ch = *codptr) == SP || ch == EOL) {
locktab_unlock_all ();
break;
}
if (ch == '+' || ch == '-') {
if ((rtn_dialect () == D_M77) ||
(rtn_dialect () == D_M84)) {
merr_raise (NOSTAND);
goto err;
}
tmp[0] = ch;
ch = (*++codptr);
}
else {
tmp[0] = SP;
}
if (ch != '(') {
expr (NAME);
if (merr () > OK) goto err;
stcpy (&tmp[1], varnam);
stcat (tmp, "\001\201");
}
else { /* multiple lock */
tmp[1] = EOL;
for (;;) {
codptr++;
expr (NAME);
if (merr () > OK) goto err;
stcat (tmp, varnam);
stcat (tmp, "\001\201");
if ((ch = *++codptr) == ')') break;
if (ch != ',') {
merr_raise (COMMAER);
goto err;
}
}
}
frm_timeout = (-1L); /* no timeout */
if (*++codptr == ':') {
codptr++;
expr (STRING);
frm_timeout = intexpr (argptr);
if (merr () > OK) goto err;
if (frm_timeout < 0L) frm_timeout = 0L;
}
lock (tmp, frm_timeout, LOCK);
break;
case USE:
if (*codptr == SP || *codptr == EOL) {
merr_raise (ARGER);
goto err;
}
expr (STRING);
j = intexpr (argptr);
if (j > MAXSEQ && j < MAXDEV) {
io = j;
goto use_socket;
}
if (j < 0 || j > MAXDEV) {
merr_raise (NODEVICE);
}
else if (j != HOME && devopen[j] == 0) {
merr_raise (NOPEN);
}
if (merr () > OK) goto err;
io = j;
if (io == HOME && *codptr == ':' && *(codptr + 1) == '(') {
use0: /* entry point for processing of device parameters */
codptr += 2;
j = 1;
setpiece = TRUE; /* so a surplus closing bracket will not be an error */
while (*codptr != ')') {
if (*codptr == ':') {
codptr++;
j++;
continue;
}
expr (STRING);
if (merr () > OK) {
setpiece = FALSE;
goto err;
}
switch (j) {
case 1:
i = intexpr (argptr);
if (i < 0) i = 0;
if (i > 255) i = 255;
RightMargin = i;
break;
case 3:
i = intexpr (argptr);
if (i < 0) i = 0;
if (i > 255) i = 255;
InFieldLen = i;
break;
case 5:
DSW = intexpr (argptr);
break;
case 7:
i = intexpr (argptr);
ypos[HOME] = i / 256;
xpos[HOME] = i % 256;
if (DSW & BIT7) {
i = io;
io = HOME;
argptr[0] = ESC;
argptr[1] = '[';
argptr[2] = EOL;
if (ypos[HOME]) {
intstr (&argptr[2], ypos[HOME] + 1);
}
if (xpos[HOME]) {
tmp3[0] = ';';
intstr (&tmp3[1], xpos[HOME] + 1);
stcat (argptr, tmp3);
}
stcat (argptr, "H\201");
write_m (argptr);
io = i;
}
break;
case 9:
i = 0;
j = 0;
while ((ch = argptr[i++]) != EOL) LineTerm[j++] = ch;
LineTerm[j] = EOL;
break;
case 10:
BrkKey = (*argptr);
/* make new break active */
set_io (UNIX);
set_io (MUMPS);
}
}
setpiece = FALSE;
codptr++;
break;
}
else if (*codptr == ':') {
codptr++;
if (io == HOME) { /* old syntax: enable/disable echo */
expr (STRING);
if (merr () > OK) goto err;
if (tvexpr (argptr)) {
DSW &= ~BIT0;
}
else {
DSW |= BIT0;
}
}
else {
if (*codptr == '(') {
codptr++;
setpiece = TRUE;
}
j = 1;
while (*codptr != ')') {
if (*codptr == ':') {
codptr++;
j++;
continue;
}
else if (setpiece == FALSE) {
merr_raise (SPACER);
goto err;
}
expr (STRING);
if (merr () > OK) {
setpiece = FALSE;
goto err;
}
switch (j) {
case 1:
fseek (opnfile[io], (long) intexpr (argptr), 0);
break;
case 2:
frm_crlf[io] = tvexpr (argptr);
break;
case 3:
fm_nodelay[io] = tvexpr (argptr);
break;
}
if (setpiece == FALSE) break;
}
if (setpiece) {
codptr++;
setpiece = FALSE;
}
break;
}
}
break;
use_socket:
{
char use_parm[256];
int upct = 0;
if (*codptr == ':') {
codptr++;
}
else {
while ((ch = *(codptr++)) != SP && ch != EOL);
codptr--;
break;
}
if (*codptr != '/') {
merr_raise (ARGLIST);
goto err;
}
codptr++;
while ((ch = *codptr++) != SP && ch != EOL && isalpha (ch)) {
use_parm[upct++] = ch;
}
use_parm[upct] = NUL;
for (upct = 0; upct < strlen (use_parm); upct++) {
use_parm[upct] = toupper (use_parm[upct]);
}
if (strcmp (use_parm, "CONNECT") == 0) {
msck_connect (io);
if (merr () > OK) goto err;
}
else if (strcmp (use_parm, "BIND") == 0) {
write_m("BIND\r\n\201");
}
else {
merr_raise (ARGLIST);
goto err;
}
break;
}
case OPEN:
{
short k;
if (*codptr == SP || *codptr == EOL) {
merr_raise (FILERR);
goto err;
}
expr (STRING);
k = intexpr (argptr);
if (merr () > OK) goto err;
if (k < 0 || k > MAXDEV) {
merr_raise (NODEVICE);
goto err;
}
if (k > MAXSEQ) goto open_socket;
if (restricted_mode) {
merr_raise (NOSTAND);
goto err;
}
/* need to evaluate the following 6 lines carefully - smw 2023-10-15 */
if (k != HOME) {
frm_crlf[k] = FALSE;
fm_nodelay[k] = FALSE;
xpos[k] = 0;
ypos[k] = 0;
}
/* OPEN implies a previous CLOSE on same channel */
if ((k != HOME) && devopen[k]) {
fclose (opnfile[k]);
devopen[k] = 0;
if (io == k) io = HOME;
}
/* process device parameters on HOME at USE command. */
if (k == HOME && *codptr == ':' && *(codptr + 1) == '(') goto use0;
if (*codptr != ':') {
if (k == HOME) break;
if (dev[k][0] == EOL) {
merr_raise (FILERR);
merr_set_iochan_err (k, FILERR, "file not found");
goto err;
}
goto open10;
}
codptr++;
if (k == HOME) {
if (*codptr != ':') { /* turn echo on/off */
expr (STRING);
if (merr () > OK) goto err;
if (tvexpr (argptr)) {
DSW &= ~BIT0;
}
else {
DSW |= BIT0;
}
}
if (*codptr == ':') { /* dummy timeout on HOME */
codptr++;
if (*codptr != SP && *codptr != EOL) {
expr (STRING);
if (merr () > OK) goto err;
test = TRUE;
break;
}
else {
merr_raise (INVEXPR);
goto err;
}
}
}
else {
int op_pos;
expr (STRING);
if (merr () > OK) goto err;
stcpy (dev[k], argptr);
frm_timeout = (-1L);
if (*codptr == ':') {
codptr++;
expr (STRING);
frm_timeout = intexpr (argptr);
if (merr () > OK) goto err;
if (frm_timeout < 0L) frm_timeout = 0L;
}
open10:
j = stcpy (tmp, dev[k]);
i = dev[k][j - 1];
while (--j >= 0) {
if (dev[k][j] == '/') break;
}
stcpy (tmp2, dev[k]);
if (j <= 0) {
tmp2[stlen (tmp2)] = NUL;
tmp[1] = 'r';
i = '+';
}
else { /* default is read+write */
tmp2[j] = NUL;
j = stcpy (&tmp[1], &tmp[j + 1]);
tmp[0] = SP;
tmp[j + 1] = SP;
tmp[j + 2] = EOL;
j = 0;
while ((ch = tmp[++j]) != EOL) if (ch >= 'A' && ch <= 'Z') tmp[j] = ch + 32;
if (find (" r w a r+ w+ a+ read write append read+ write+ append+ \201", tmp) == FALSE) {
tmp[1] = 'r';
i = '+';
tmp2[strlen (tmp2)] = '/';
}
}
tmp[0] = tmp[1];
tmp[1] = NUL; /* NUL not EOL !!! */
if (i == '+') {
tmp[1] = i;
tmp[2] = NUL;
}
op_pos = 0;
open20:
if (oucpath[op_pos] != EOL) {
j = stlen (dev[k]);
while (--j >= 0) if (dev[k][j] == '/') break;
while (--j >= 0) if (dev[k][j] == '/') break;
if (j < 0) {
strcpy (tmp3, tmp2);
stcpy (tmp2, &oucpath[op_pos]);
j = 0;
while (tmp2[j] != ':' && tmp2[j] != EOL) j++;
tmp2[j] = EOL;
stcpy (act_oucpath[k], tmp2);
op_pos += j;
if (j) tmp2[j++] = '/';
strcpy (&tmp2[j], tmp3);
}
}
/* r = READ only access;
* w = WRITE new file;
* a = WRITE append;
* r+ = READ/WRITE access;
* w+ = WRITE new file;
* a+ = WRITE append;
*/
j = tmp[0];
sq_modes[k] = j;
if (j == 'r' && tmp[1] == '+') {
sq_modes[k] = '+';
}
if (j == 'r' && frm_timeout < 0L) {
errno = 0;
while ((opnfile[k] = fopen (tmp2, tmp)) == NULL) {
if (errno == EINTR) {
errno = 0;
continue;
} /* interrupt */
if (errno == EMFILE || errno == ENFILE) {
close_all_globals ();
continue;
}
if (dev[k][0] != '/' && oucpath[op_pos++] != EOL) {
strcpy (tmp2, tmp3);
goto open20;
}
act_oucpath[k][0] = EOL;
merr_raise ((errno == ENOENT ? FILERR : PROTECT));
switch (merr ()) {
case FILERR:
merr_set_iochan_err (k, FILERR, "file not found");
break;
case PROTECT:
merr_set_iochan_err (k, PROTECT, "file protection violation");
break;
}
goto err;
}
ssvn_job_add_device (k, tmp2);
devopen[k] = ((i == '+') ? i : j);
break;
}
if (j == 'r' || j == 'w' || j == 'a') {
if (frm_timeout >= 0L) {
test = TRUE;
if (setjmp (sjbuf)) {
test = FALSE;
goto endopn;
}
sig_attach (SIGALRM, &ontimo);
alarm ((unsigned) (frm_timeout < 3 ? 3 : frm_timeout));
}
for (;;) {
errno = 0;
if ((opnfile[k] = fopen (tmp2, tmp)) != NULL) break;
if (merr () == INRPT) goto err;
if (errno == EINTR) continue; /* interrupt */
if (errno == EMFILE || errno == ENFILE) {
close_all_globals ();
continue;
}
if (frm_timeout < 0L) {
if (dev[k][0] != '/' && oucpath[op_pos++] != EOL) {
strcpy (tmp2, tmp3);
goto open20;
}
if (errno == ENOENT) continue;
act_oucpath[k][0] = EOL;
merr_raise (PROTECT);
merr_set_iochan_err (k, PROTECT, "file protection violation");
goto err;
}
if (frm_timeout == 0L) {
test = FALSE;
goto endopn;
}
sleep (1);
frm_timeout--;
}
devopen[k] = ((i == '+') ? i : j);
endopn:;
alarm (0); /* reset alarm request */
}
else {
merr_raise (ARGLIST);
merr_set_iochan_err (k, ARGLIST, "invalid argument");
goto err;
}
}
open_socket:
if (*codptr != ':') {
if (j == 'w') {
merr_raise (FILEXWR);
merr_set_iochan_err (k, FILEXWR, "cannot open existing file for WRITE");
}
else {
merr_raise (ARGLIST);
merr_set_iochan_err (k, ARGLIST, "invalid argument");
}
goto err;
}
codptr++;
expr (STRING);
if (merr () > OK) goto err;
stcpy (vn, argptr);
stcnv_m2c (vn);
msck_open (k, vn);
if (merr () > OK) goto err;
ssvn_job_add_device (k, vn);
break;
}
break;
case CLOSE:
/* no arguments: close all exept HOME */
if (*codptr == SP || *codptr == EOL) {
if (rtn_dialect () != D_FREEM) {
merr_raise (NOSTAND);
break;
}
j = 1;
while (j <= MAXDEV) {
if (j < FIRSTSCK) {
if (jour_flag && (j == 2)) {
j++;
continue;
}
if (devopen[j]) fclose (opnfile[j]);
ssvn_job_remove_device (j);
devopen[j++] = 0;
}
else {
msck_close (j++);
}
}
io = HOME;
break;
}
expr (STRING);
j = intexpr (argptr);
if (merr () > OK) break;
if (j >= FIRSTSCK && j < MAXDEV) {
msck_close (j);
ssvn_job_remove_device (j);
break;
}
/*ignore close on illgal units */
if ((j >= 0 && j <= MAXDEV && j != HOME) && (jour_flag == 0 || (j != 2))) { /*ignore close on protocol channel */
if (devopen[j]) fclose (opnfile[j]);
devopen[j] = 0;
ssvn_job_remove_device (j);
if (io == j) io = HOME;
}
/* parse any 'device parameters', but ignore them otherwise */
if (*codptr == ':') {
if (*++codptr != '(') {
expr (STRING);
}
else {
setpiece = TRUE; /* to avoid bracket error at end of deviceparameters */
for (;;)
{
if (*++codptr != ':')
expr (STRING);
if (*codptr == ':')
continue;
if (*codptr++ != ')')
merr_raise (ARGER);
break;
}
setpiece = FALSE;
}
}
break;
case ZHALT: /* ZHALT */
if (is_standard ()) {
merr_raise (NOSTAND);
goto err;
}
case HA: /* HALT or HANG */
/* no arguments: HALT */
if (*codptr == SP || *codptr == EOL || mcmnd == ZHALT) {
if (mcmnd == ZHALT && *codptr != SP && *codptr != EOL) {
expr (STRING);
i = intexpr (argptr);
if (merr () > OK) break;
}
else {
halt:i = 0;
}
cleanup ();
if (father) { /* advertise death to parent *//* make sure father is waiting !!! */
if ((time (0L) - jobtime) < 120) sleep (2);
kill (father, SIGUSR1);
}
exit (i); /* terminate mumps */
};
/* with arguments: HANG */
case HANG: /* HANG */
{
unsigned long int waitsec;
int millisec;
#ifdef USE_GETTIMEOFDAY
struct timeval timebuffer;
#else
struct timeb timebuffer;
#endif
expr (STRING);
numlit (argptr);
if (merr () > OK) break;
#if !defined(__linux__)
if (argptr[0] == '-') break; /* negative values without effect */
if (argptr[0] == '0') break; /* zero without effect */
#else
/* on linux, return scheduler timeslice to kernel scheduler for hang 0 and hang with negative values
for compatibility with Reference Standard M, only when process is using a realtime scheduling policy */
if ((argptr[0] == '-') || (argptr[0] == '0')) {
int policy;
policy = sched_getscheduler (0);
if ((policy == -1) || ((policy != SCHED_FIFO) && (policy != SCHED_RR))) break;
sched_yield ();
}
#endif
waitsec = 0;
millisec = 0;
i = 0;
for (;;) { /* get integer and fractional part */
if ((ch = argptr[i++]) == EOL) break;
if (ch == '.') {
millisec = (argptr[i++] - '0') * 100;
if ((ch = argptr[i++]) != EOL) {
millisec += (ch - '0') * 10;
if ((ch = argptr[i]) != EOL) {
millisec += (ch - '0');
}
}
break;
}
waitsec = waitsec * 10 + ch - '0';
}
if ((i = waitsec) > 2) i -= 2;
#ifdef USE_GETTIMEOFDAY
gettimeofday (&timebuffer, NULL); /* get current time */
waitsec += timebuffer.tv_sec; /* calculate target time */
millisec += timebuffer.tv_usec;
#else
ftime (&timebuffer); /* get current time */
waitsec += timebuffer.time; /* calculate target time */
millisec += timebuffer.millitm;
#endif
if (millisec >= 1000) {
waitsec++;
millisec -= 1000;
}
/* do the bulk of the waiting with sleep() */
while (i > 0) {
j = time (0L);
sleep ((unsigned) (i > 32767 ? 32767 : i)); /* sleep max. 2**15-1 sec */
i -= time (0L) - j; /* subtract actual sleeping time */
if (merr () == INRPT) goto err;
if (evt_async_enabled && (merr () == ASYNC)) goto err;
}
/* do the remainder of the waiting watching the clock */
for (;;) {
#ifdef USE_GETTIMEOFDAY
gettimeofday (&timebuffer, NULL);
if (timebuffer.tv_sec > waitsec) break;
if (timebuffer.tv_sec == waitsec && timebuffer.tv_usec >= millisec) break;
#else
ftime (&timebuffer);
if (timebuffer.time > waitsec) break;
if (timebuffer.time == waitsec && timebuffer.millitm >= millisec) break;
#endif
if (merr () == INRPT) goto err;
}
}
break;
case HALT: /* HALT */
if (*codptr == SP || *codptr == EOL) goto halt;
merr_raise (ARGLIST);
break;
case BREAK:
if (*codptr == SP || *codptr == EOL) {
if (breakon == FALSE) break; /* ignore BREAK */
if (usermode == 0) {
merr_raise (BKERR);
goto err;
}
zbflag = TRUE;
merr_raise (OK - CTRLB);
zb_entry:loadsw = TRUE;
#ifdef DEBUG_NEWSTACK
printf ("CHECK 08 (Stack PUSH)\r\n");
#endif
if (++nstx > NESTLEVLS) {
nstx--;
merr_raise (STKOV);
goto err;
}
else {
estack++;
}
nestc[nstx] = BREAK;
#ifdef DEBUG_NEWSTACK
if (!cmdptr) printf ("CMDPTR is ZERO!\r\n");
#endif
nestp[nstx] = cmdptr; /* command stack address */
nestn[nstx] = 0; /*!!! save name */
nestr[nstx] = roucur - rouptr; /* save roucur */
nestnew[nstx] = 0;
ztrap[nstx][0] = EOL;
nestlt[nstx] = level;
level = 0; /* save level */
/* save BREAK information */
brkstk[nstx] = (((ECHOON ? 1 : 0) << 1) | test) << 3 | io;
io = HOME;
forsw = FALSE;
cmdptr += stcpy (cmdptr, codptr) + 1;
zerr = BKERR;
goto restart;
}
if (is_standard ()) {
merr_raise (NOSTAND);
goto err;
}
expr (STRING);
if (merr () > OK) break;
switch (intexpr (argptr)) {
case 2:
DSM2err = TRUE;
break; /* enable DSM V 2 error processing */
case -2:
DSM2err = FALSE;
break; /* enable normal error processing */
case 0:
breakon = FALSE;
break; /* disable CTRL/C */
default:
breakon = TRUE;
break; /* enable CTRL/C */
}
break;
case VIEW:
view_com ();
if (repQUIT) { /* VIEW 26: repeated QUIT action */
while (repQUIT-- > 0) {
#ifdef DEBUG_NEWSTACK
printf ("CHECK 09 (Stack POP)\r\n");
#endif
if (nestc[nstx] == BREAK) {
// printf ("nestc[nstx] was BREAK\r\n");
if (repQUIT) continue;
merr_raise (OK - CTRLB);
goto zgo; /*cont. single step */
}
// else {
// printf ("nestc[nstx] was _not_ BREAK\r\n");
// }
if (nestc[nstx] == FOR) {
stcpy (code, cmdptr = nestp[nstx--]);
estack--;
codptr = code;
ftyp = fortyp[--forx];
fvar = forvar[forx];
finc = forinc[forx];
flim = forlim[forx];
fi = fori[forx];
if (repQUIT) continue;
if ((forsw = (nestc[nstx] == FOR))) goto for_end;
goto next_line;
}
if (nestn[nstx]) { /* reload routine */
namptr = nestn[nstx];
if ((nestc[nstx] != XECUTE) || loadsw) {
stcpy (rou_name, namptr);
zload (rou_name);
ssvn_job_update ();
dosave[0] = 0;
}
namptr--;
}
if (nestnew[nstx]) unnew (); /* un-NEW variables */
/* restore old pointers */
if ((mcmnd = nestc[nstx]) == BREAK) {
if (repQUIT) continue;
goto restore;
} /*cont. single step */
if (mcmnd == DO_BLOCK) {
test = nestlt[nstx];
level--;
}
else { /* pop $TEST */
level = nestlt[nstx]; /* pop level */
}
roucur = nestr[nstx] + rouptr;
stcpy (codptr = code, cmdptr = nestp[nstx--]);
estack--;
forsw = (nestc[nstx] == FOR);
loadsw = TRUE;
if (mcmnd == '$') {
if (repQUIT) return 0;
merr_raise (NOVAL);
}
}
repQUIT = 0;
}
break;
/* Z-COMMANDS */
case ZGO:
/* ZGO with arguments: same as GOTO but with BREAK on */
if (*codptr != EOL && *codptr != SP) {
mcmnd = GOTO;
zbflag = TRUE;
merr_raise (OK - CTRLB);
goto do_goto;
}
/* argumentless ZGO resume execution after BREAK */
if (nestc[nstx] != BREAK) {
merr_raise (LVLERR);
break;
}
merr_clear (); /* stop BREAKing */
zgo:
#ifdef DEBUG_NEWSTACK
printf ("Zgoing: (Stack POP)\r\n");
#endif
if (nestn[nstx]) { /* reload routine */
stcpy (rou_name, (namptr = nestn[nstx]));
zload (rou_name);
ssvn_job_update ();
if (merr () > OK) break;
}
level = nestlt[nstx];
roucur = nestr[nstx] + rouptr;
io = brkstk[nstx];
if (io & 020) {
DSW &= ~BIT0;
}
else {
DSW |= BIT0; /* restore echo state */
}
test = (io & 010) >> 3; /* restore $TEST */
/* restore $IO; default to HOME if channel not OPEN */
if ((io &= 07) != HOME && devopen[io] == 0) io = HOME;
stcpy (codptr = code, cmdptr = nestp[nstx--]);
estack--;
forsw = (nestc[nstx] == FOR);
loadsw = TRUE;
zbflag = FALSE;
goto next0;
case ZBREAK:
if (*codptr == SP || *codptr == EOL) {
merr_raise (ARGLIST);
break;
}
expr (STRING);
if (merr () > OK) break;
zbreakon = tvexpr (argptr);
if (hardcopy == DISABLE) set_zbreak (zbreakon ? STX : -1); /* enable/disable CTRL/B */
zbflag = FALSE;
break;
case ZLOAD:
if (*codptr == EOL || *codptr == SP) {
stcpy (varnam, rou_name);
}
else {
expr (NAME);
if (merr () > OK) break;
codptr++;
}
dosave[0] = EOL;
if (varnam[0] == EOL) {
varerr[0] = EOL;
merr_raise (NOPGM);
break;
} /*error */
loadsw = TRUE;
/* a ZLOAD on the active routine always loads from disk */
if (stcmp (varnam, rou_name) == 0) {
for (i = 0; i < NO_OF_RBUF; i++) {
if (rouptr == (buff + (i * PSIZE0))) {
pgms[i][0] = EOL;
break;
}
}
}
zload (varnam);
if (merr () > OK) break; /* load file */
stcpy (rou_name, varnam);
ssvn_job_update ();
break;
case ZSAVE:
if (*codptr == EOL || *codptr == SP) {
if (rou_name[0] == EOL) {
varerr[0] = EOL;
merr_raise (NOPGM);
break;
} /*error */
stcpy (varnam, rou_name);
}
else {
expr (NAME);
if (varnam[0] == '^') merr_raise (GLOBER);
if (varnam[0] == '$') merr_raise (INVREF);
if (merr () > OK) break;
stcpy (rou_name, varnam);
ssvn_job_update ();
codptr++;
}
zsave (varnam);
break;
case ZREMOVE:
{
char *beg, *end;
dosave[0] = EOL;
if (*codptr == SP || *codptr == EOL) { /* no args is ZREMOVE all */
loadsw = TRUE;
for (i = 0; i < NO_OF_RBUF; i++) {
if (rouptr == buff + (i * PSIZE0)) {
pgms[i][0] = EOL;
break;
}
}
rouptr = buff + (i * PSIZE0);
rouend = rouins = rouptr;
roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
*(rouptr) = EOL;
*(rouptr + 1) = EOL;
*(rouptr + 2) = EOL;
argptr = partition;
rou_name[0] = EOL;
ssvn_job_update ();
break;
}
if (*codptr == ':') {
beg = rouptr;
}
else if (*codptr == '*') {
beg = rouptr;
while ((end = (beg + UNSIGN (*beg) + 2)) < rouins) beg = end;
codptr++;
}
else {
lineref (&beg);
if (merr () > OK) break;
}
if ((end = beg) == 0) {
merr_raise (M13);
break;
}
if (*codptr == ':') { /* same as above */
codptr++;
if (*codptr == '*') {
end = rouins;
codptr++;
}
else if (*codptr == ',' || *codptr == SP || *codptr == EOL) {
end = rouend;
}
else {
lineref (&end);
if (end == 0) merr_raise (M13);
if (merr () > OK) break;
end = end + UNSIGN (*end) + 2;
}
}
else {
end = end + UNSIGN (*end) + 2;
}
if (beg < rouend) { /* else there's nothing to zremove */
if (end >= rouend) {
end = rouend = beg;
}
else {
rouins = beg;
while (end <= rouend) *beg++ = (*end++);
i = beg - end;
rouend += i;
if (roucur > end) roucur += i;
}
*end = EOL;
*(end + 1) = EOL;
for (i = 0; i < NO_OF_RBUF; i++) {
if (rouptr == (buff + (i * PSIZE0))) {
ends[i] = rouend;
break;
}
}
}
break;
}
case ZINSERT:
{
char *beg;
if (*codptr == EOL || *codptr == SP) {
merr_raise (ARGLIST);
break;
} /*error */
dosave[0] = EOL;
/* parse stringlit */
expr (STRING);
if (merr () > OK) break;
if (*codptr != ':') {
zi (argptr, rouins);
break;
}
stcpy (tmp, argptr);
codptr++;
lineref (&beg);
if (merr () > OK) break; /* parse label */
if (beg) {
beg = beg + UNSIGN (*beg) + 2;
}
else {
beg = rouptr;
}
if (beg > rouend + 1) {
merr_raise (M13);
break;
}
/* insert stuff */
zi (tmp, beg);
break;
}
/* PRINT is convenient -
* but non-standard ZPRINT should be used instead */
case 'p':
if (is_standard ()) {
merr_raise (NOSTAND);
break;
}
case ZPRINT:
{
char *beg, *end;
if (*codptr == SP || *codptr == EOL) { /* no args is ZPRINT all */
beg = rouptr;
end = rouend;
}
else {
if (*codptr == ':') {
beg = rouptr; /* from begin */
}
else if (*codptr == '*') { /* from 'linepointer' */
beg = rouptr;
while ((end = (beg + UNSIGN (*beg) + 2)) < rouins) beg = end;
codptr++;
}
else {
lineref (&beg);
if (merr () > OK) break;
} /* line reference */
if (beg == 0) {
beg = rouptr;
rouins = beg;
if (*codptr != ':') break;
}
if (*codptr == ':') {
codptr++; /* to end */
if (*codptr == SP || *codptr == ',' || *codptr == EOL)
end = rouend;
else {
if (*codptr == '*') {
end = rouins;
codptr++;
}
else { /* to 'linepointer' */
lineref (&end);
if (merr () > OK) break; /* line reference */
end = end + UNSIGN (*end) + 2;
}
}
}
else {
end = beg + 1;
}
}
if (rouend < end) end = rouend - 1;
for (; beg < end; beg += UNSIGN (*beg) + 2) {
if (frm_crlf[io]) {
write_m ("\012\201");
}
else {
write_m ("\012\015\201");
}
if ((*(beg + 1)) == EOL) break;
write_m (beg + 1);
if (merr () > OK) break;
}
rouins = beg;
}
if (frm_crlf[io]) {
write_m ("\012\201");
}
else {
write_m ("\012\015\201");
}
break;
case WATCH:
{
char op;
if (((ch = *codptr) == SP) || ch == EOL) {
set_io(UNIX);
if (dbg_enable_watch) {
printf ("Watchpoints disabled.\n");
dbg_enable_watch = 0;
}
else {
printf ("Watchpoints enabled.\n");
dbg_enable_watch = 1;
}
break;
}
if ((ch = *codptr) == '(') {
merr_raise (ARGLIST);
goto err;
}
for (;;) {
switch (ch) {
case '?':
case '+':
case '-':
op = ch;
codptr++;
break;
default:
merr_raise (ARGLIST);
goto err;
}
expr (NAME); /* try to interpret an mname */
if (merr () > OK) goto err;
stcpy (vn, varnam);
switch (op) {
case '+':
dbg_add_watch (vn);
break;
case '-':
dbg_remove_watch (vn);
break;
case '?':
dbg_dump_watch (vn);
break;
}
if (merr () > OK) goto err;
if ((ch = *(codptr + 1)) == EOL) {
codptr++;
break;
}
else if ((ch = *(codptr + 1)) == ',') {
codptr += 2;
ch = *codptr;
}
else {
merr_raise (ARGLIST);
goto err;
}
}
break;
}
case ASSERT_TKN:
{
expr (STRING);
if (merr () > OK) goto err;
if (tvexpr (argptr) == 0) {
merr_raise (ASSERT);
goto err;
}
break;
}
case ZWRITE:
zwrite:
{
short k;
char w_tmp[512];
char zwmode;
if (io != HOME && devopen[io] == 'r') {
merr_raise (NOWRITE);
goto err;
}
tmp3[0] = SP;
tmp3[1] = EOL;
if ((ch = (*codptr)) == '(') { /* exclusive zwrite */
for (;;) {
codptr++;
expr (NAME);
if (merr () > OK) goto err;
if (varnam[0] == '^') {
merr_raise (GLOBER);
goto err;
}
i = 0;
while (varnam[i] != EOL) {
if (varnam[i] == DELIM) {
merr_raise (SBSCR);
goto err;
}
i++;
}
if (stcat (tmp3, varnam) == 0) {
merr_raise (M75);
goto err;
}
if (stcat (tmp3, " \201") == 0) {
merr_raise (M75);
goto err;
}
if ((ch = *++codptr) == ')') {
codptr++;
break;
}
if (ch != ',') {
merr_raise (COMMAER);
goto err;
}
}
}
else {
if (ch != SP && ch != EOL) goto zwritep;
}
/* no arguments: write local symbol table. */
stcpy (tmp, " $\201");
for (;;) {
ordercnt = 1L;
symtab (bigquery, &tmp[1], tmp2);
if (*tmp2 == EOL || merr () == INRPT) break;
w_tmp[0] = '=';
/* subscripts: internal format different from external one */
k = 0;
i = 1;
j = 0;
while ((ch = tmp2[k++]) != EOL) {
if (ch == '"') {
if (j && tmp2[k] == ch) {
k++;
}
else {
toggle (j);
continue;
}
}
if (j == 0) {
if (ch == '(' || ch == ',') {
tmp[i++] = DELIM;
continue;
}
if (ch == ')') break;
}
tmp[i++] = ch;
}
tmp[i] = EOL;
if (kill_ok (tmp3, tmp) == 0) continue;
write_m (tmp2);
symtab (get_sym, &tmp[1], &w_tmp[1]);
write_m (w_tmp);
write_m ("\012\015\201");
}
break;
zwritep:
expr (NAME);
//if (varnam[0] == '^') merr_raise (GLOBER);
if (merr () > OK) goto err;
codptr++;
if (varnam[0] == '$') {
if ((varnam[1] | 0140) == 'z' && (varnam[2] | 0140) == 'f') {
w_tmp[0] = '$';
w_tmp[1] = 'Z';
w_tmp[2] = 'F';
w_tmp[3] = '(';
for (i = 0; i < 44; i++) {
if (zfunkey[i][0] != EOL) {
intstr (&w_tmp[4], i + 1);
stcat (w_tmp, ")=\201");
write_m (w_tmp);
write_m (zfunkey[i]);
write_m ("\012\015\201");
}
}
break;
}
else {
break; /* do not zwrite special variables etc. other than $ZF */
}
}
if (varnam[0] != '^') {
symtab (fra_dat, varnam, tmp2);
zwmode = 'L';
}
else {
if (varnam[1] == '$') {
ssvn (fra_dat, varnam, tmp2);
zwmode = '$';
}
else {
global (fra_dat, varnam, tmp2);
zwmode = '^';
}
}
if (tmp2[0] == '0') break; /* variable not defined */
/* if $D(@varnam)=10 get next entry */
if (tmp2[1] == '0') {
ordercnt = 1L;
if (varnam[0] != '^') {
symtab (fra_query, varnam, tmp2);
zwmode = 'L';
}
else {
if (varnam[1] == '$') {
ssvn (fra_query, varnam, tmp2);
zwmode = '$';
}
else {
global (fra_query, varnam, tmp2);
zwmode = '^';
}
}
}
else {
k = 0;
i = 0;
j = 0;
while ((ch = varnam[k++]) != EOL) {
if (ch == DELIM) {
if (j) {
tmp2[i++] = '"';
tmp2[i++] = ',';
tmp2[i++] = '"';
continue;
}
j++;
tmp2[i++] = '(';
tmp2[i++] = '"';
continue;
}
if ((tmp2[i++] = ch) == '"')
tmp2[i++] = ch;
}
if (j) {
tmp[i++] = '"';
tmp2[i++] = ')';
}
tmp2[i] = EOL;
}
for (;;) { /* subscripts: internal format different from external one */
k = 0;
i = 0;
j = 0;
while ((ch = tmp2[k++]) != EOL) {
if (ch == '"') {
if (j && tmp2[k] == ch)
k++;
else {
toggle (j);
continue;
}
}
if (j == 0) {
if (ch == '(' || ch == ',') {
tmp[i++] = DELIM;
continue;
}
if (ch == ')') break;
}
tmp[i++] = ch;
}
tmp[i] = EOL;
i = 0;
while (tmp[i] == varnam[i]) {
if (varnam[i] == EOL) break;
i++;
}
if (varnam[i] != EOL) break;
if (tmp[i] != EOL && tmp[i] != DELIM) break;
tmp3[0] = EOL;
switch (zwmode) {
case 'L':
symtab (fra_dat, tmp, tmp3);
symtab (get_sym, tmp, &w_tmp[1]);
break;
case '$':
ssvn (fra_dat, tmp, tmp3);
ssvn (get_sym, tmp, &w_tmp[1]);
break;
case '^':
global (fra_dat, tmp, tmp3);
global (get_sym, tmp, &w_tmp[1]);
break;
}
if (tmp3[0] != '0' && tmp3[1] != '0') {
write_m (tmp2);
w_tmp[0] = '=';
write_m (w_tmp);
write_m ("\012\015\201");
}
ordercnt = 1L;
switch (zwmode) {
case 'L':
symtab (fra_query, tmp, tmp2);
break;
case '$':
ssvn (fra_query, tmp, tmp2);
break;
case '^':
global (fra_query, tmp, tmp2);
break;
}
if (merr () == INRPT) break;
}
break;
}
case ZTRAP:
if (*codptr == SP || *codptr == EOL) {
merr_raise (ZTERR);
varnam[0] = EOL;
break;
}
expr (NAME);
stcpy (varerr, varnam);
if (merr ()) break;
if (*++codptr == ':') { /* parse postcond */
codptr++;
expr (STRING);
if (merr () > OK) goto err;
if (tvexpr (argptr) == FALSE) break;
}
merr_raise (ZTERR);
break;
case ZALLOCATE:
/* argumentless is not permitted */
if (*codptr == SP || *codptr == EOL) {
merr_raise (ARGLIST);
break;
}
expr (NAME);
if (merr () > OK) goto err;
tmp[0] = SP;
stcpy (&tmp[1], varnam);
stcat (tmp, "\001\201");
frm_timeout = (-1L); /* no timeout */
if (*++codptr == ':') {
codptr++;
expr (STRING);
frm_timeout = intexpr (argptr);
if (merr () > OK) goto err;
if (frm_timeout < 0L) frm_timeout = 0L;
}
lock (tmp, frm_timeout, ZALLOCATE);
break;
case ZDEALLOCATE:
tmp[0] = SP;
if (*codptr == SP || *codptr == EOL) {
tmp[1] = EOL;
}
else {
expr (NAME);
if (merr () > OK) goto err;
stcpy (&tmp[1], varnam);
codptr++;
}
lock (tmp, -1L, ZDEALLOCATE); /* -1: no timeout */
break;
/* user defined Z-COMMAND */
case PRIVATE:
private: /* for in-MUMPS defined commands */
i = 0;
j = 0;
ch = 0;
while ((tmp2[i] = *codptr) != EOL) {
if (tmp2[i] == SP && !j) {
tmp2[i] = EOL;
break;
}
if (tmp2[i] == '"') j = (!j);
if (!j) {
if (tmp2[i] == '(') ch++;
if (tmp2[i] == ')') ch--;
if (!ch && tmp2[i] == ',') { /* next argument: */
tmp2[i] = EOL; /* call afterwards again */
i = 0;
while (tmp3[i] != EOL) i++;
j = i;
ch = 1;
while (ch < i) tmp3[j++] = tmp3[ch++];
tmp3[j - 1] = SP;
tmp3[j] = EOL;
codptr++;
j = 0;
ch = 0;
break;
}
}
i++;
codptr++;
}
if (j || ch) {
merr_raise (INVREF);
goto err;
}
stcat (tmp3, codptr);
if (destructor_run) {
stcpy (code, "d \201");
destructor_run = FALSE;
}
else {
if (new_object) {
stcpy (code, "d ^\201");
new_object = FALSE;
}
else {
stcpy (code, "d ^%\201");
}
}
stcat (code, &tmp3[1]);
codptr = code;
privflag = TRUE;
goto next_cmnd;
evthandler: /* for event handlers */
i = 0;
j = 0;
ch = 0;
while ((tmp2[i] = *codptr) != EOL) {
if (tmp2[i] == SP && !j) {
tmp2[i] = EOL;
break;
}
if (tmp2[i] == '"') j = (!j);
if (!j) {
if (tmp2[i] == '(') ch++;
if (tmp2[i] == ')') ch--;
if (!ch && tmp2[i] == ',') { /* next argument: */
tmp2[i] = EOL; /* call afterwards again */
i = 0;
while (tmp3[i] != EOL) i++;
j = i;
ch = 1;
while (ch < i) tmp3[j++] = tmp3[ch++];
tmp3[j - 1] = SP;
tmp3[j] = EOL;
codptr++;
j = 0;
ch = 0;
break;
}
}
i++;
codptr++;
}
if (j || ch) {
merr_raise (INVREF);
goto err;
}
stcpy (code, "d \201");
stcat (code, tmp3);
codptr = code;
privflag = TRUE;
goto next_cmnd;
case ABLOCK:
case AUNBLOCK:
{
short evt_mask[EVT_MAX];
if ((rtn_dialect () != D_MDS) &&
(rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
/* declare and initialize table of events to be blocked/unblocked with this command */
for (i = 0; i < EVT_MAX; i++) evt_mask[i] = 0;
/* argumentless ABLOCK/AUNBLOCK: block/unblock everything */
if (((ch = *codptr) == SP) || ch == EOL) {
for (i = 0; i < EVT_MAX; i++) evt_mask[i] = 1;
}
else if (*codptr == '(') {
/* exclusive ABLOCK/AUNBLOCK */
short evt_exclusions[EVT_MAX];
codptr++;
for (i = 0; i < EVT_MAX; i++) evt_exclusions[i] = FALSE;
for (;;) {
expr (STRING);
if (merr () == BRAER) merr_clear ();
if (merr () > OK) goto err;
codptr++;
stcpy (vn, argptr);
if (stcmp (vn, "COMM\201") == 0) {
evt_exclusions[EVT_CLS_COMM] = TRUE;
}
else if (stcmp (vn, "HALT\201") == 0) {
evt_exclusions[EVT_CLS_HALT] = TRUE;
}
else if (stcmp (vn, "IPC\201") == 0) {
evt_exclusions[EVT_CLS_IPC] = TRUE;
}
else if (stcmp (vn, "INTERRUPT\201") == 0) {
evt_exclusions[EVT_CLS_INTERRUPT] = TRUE;
}
else if (stcmp (vn, "POWER\201") == 0) {
evt_exclusions[EVT_CLS_POWER] = TRUE;
}
else if (stcmp (vn, "TIMER\201") == 0) {
evt_exclusions[EVT_CLS_TIMER] = TRUE;
}
else if (stcmp (vn, "USER\201") == 0) {
evt_exclusions[EVT_CLS_USER] = TRUE;
}
else if (stcmp (vn, "WAPI\201") == 0) {
evt_exclusions[EVT_CLS_WAPI] = TRUE;
}
else {
merr_raise (CMMND);
goto err;
}
if ((ch = *(codptr + 1)) == EOL || ch == SP) {
codptr++;
break;
}
if ((ch = *(codptr + 1)) == ')') {
codptr++;
break;
}
}
for (i = 0; i < EVT_MAX; i++) {
if (evt_exclusions[i] == FALSE) evt_mask[i] = 1;
}
}
else {
/* inclusive ABLOCK/AUNBLOCK */
for (;;) {
expr (STRING); /* try to interpret a string */
if (merr () > OK) goto err;
codptr++;
stcpy (vn, argptr);
if (stcmp (vn, "COMM\201") == 0) {
evt_mask[EVT_CLS_COMM] = 1;
}
else if (stcmp (vn, "HALT\201") == 0) {
evt_mask[EVT_CLS_HALT] = 1;
}
else if (stcmp (vn, "IPC\201") == 0) {
evt_mask[EVT_CLS_IPC] = 1;
}
else if (stcmp (vn, "INTERRUPT\201") == 0) {
evt_mask[EVT_CLS_INTERRUPT] = 1;
}
else if (stcmp (vn, "POWER\201") == 0) {
evt_mask[EVT_CLS_POWER] = 1;
}
else if (stcmp (vn, "TIMER\201") == 0) {
evt_mask[EVT_CLS_TIMER] = 1;
}
else if (stcmp (vn, "TRIGGER\201") == 0) {
evt_mask[EVT_CLS_TRIGGER] = 1;
}
else if (stcmp (vn, "USER\201") == 0) {
evt_mask[EVT_CLS_USER] = 1;
}
else if (stcmp (vn, "WAPI\201") == 0) {
evt_mask[EVT_CLS_WAPI] = 1;
}
else {
merr_raise (CMMND);
goto err;
}
if (merr () > OK) goto err;
if ((ch = *(codptr)) == EOL || ch == SP) {
break;
}
}
}
for (i = 0; i < EVT_MAX; i++) {
if (evt_mask[i] > 0) {
if (mcmnd == ABLOCK) {
evt_ablock (i);
}
else {
evt_aunblock (i);
}
}
}
break;
}
case ASSIGN:
merr_raise (CMMND);
break;
case ASTOP:
case ASTART:
{
short evt_mask[EVT_MAX];
short new_status;
if ((rtn_dialect () != D_MDS) &&
(rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
/* declare and initialize table of events to be enabled with this command */
if (mcmnd == ASTART) {
new_status = EVT_S_ASYNC;
}
else {
new_status = EVT_S_DISABLED;
}
for (i = 0; i < EVT_MAX; i++) evt_mask[i] = EVT_S_NOMODIFY;
/* argumentless ASTART/ASTOP: enable/disable everything */
if (((ch = *codptr) == SP) || ch == EOL) {
for (i = 0; i < EVT_MAX; i++) evt_mask[i] = new_status;
}
else if (*codptr == '(') {
/* exclusive ASTART */
short evt_exclusions[EVT_MAX];
codptr++;
for (i = 0; i < EVT_MAX; i++) evt_exclusions[i] = FALSE;
for (;;) {
expr (STRING);
if (merr () == BRAER) merr_clear ();
if (merr () > OK) goto err;
codptr++;
stcpy (vn, argptr);
if (stcmp (vn, "COMM\201") == 0) {
evt_exclusions[EVT_CLS_COMM] = TRUE;
}
else if (stcmp (vn, "HALT\201") == 0) {
evt_exclusions[EVT_CLS_HALT] = TRUE;
}
else if (stcmp (vn, "IPC\201") == 0) {
evt_exclusions[EVT_CLS_IPC] = TRUE;
}
else if (stcmp (vn, "INTERRUPT\201") == 0) {
evt_exclusions[EVT_CLS_INTERRUPT] = TRUE;
}
else if (stcmp (vn, "POWER\201") == 0) {
evt_exclusions[EVT_CLS_POWER] = TRUE;
}
else if (stcmp (vn, "TIMER\201") == 0) {
evt_exclusions[EVT_CLS_TIMER] = TRUE;
}
else if (stcmp (vn, "USER\201") == 0) {
evt_exclusions[EVT_CLS_USER] = TRUE;
}
else if (stcmp (vn, "WAPI\201") == 0) {
evt_exclusions[EVT_CLS_WAPI] = TRUE;
}
else if (stcmp (vn, "TRIGGER\201") == 0) {
evt_exclusions[EVT_CLS_TRIGGER] = TRUE;
}
else {
merr_raise (CMMND);
goto err;
}
if ((ch = *(codptr + 1)) == EOL || ch == SP) {
codptr++;
break;
}
if ((ch = *(codptr + 1)) == ')') {
codptr++;
break;
}
}
for (i = 0; i < EVT_MAX; i++) {
if (evt_exclusions[i] == FALSE) evt_mask[i] = new_status;
}
}
else {
/* inclusive ASTART */
for (;;) {
expr (STRING); /* try to interpret a string */
if (merr () > OK) goto err;
codptr++;
stcpy (vn, argptr);
if (stcmp (vn, "COMM\201") == 0) {
evt_mask[EVT_CLS_COMM] = new_status;
}
else if (stcmp (vn, "HALT\201") == 0) {
evt_mask[EVT_CLS_HALT] = new_status;
}
else if (stcmp (vn, "IPC\201") == 0) {
evt_mask[EVT_CLS_IPC] = new_status;
}
else if (stcmp (vn, "INTERRUPT\201") == 0) {
evt_mask[EVT_CLS_INTERRUPT] = new_status;
}
else if (stcmp (vn, "POWER\201") == 0) {
evt_mask[EVT_CLS_POWER] = new_status;
}
else if (stcmp (vn, "TIMER\201") == 0) {
evt_mask[EVT_CLS_TIMER] = new_status;
}
else if (stcmp (vn, "USER\201") == 0) {
evt_mask[EVT_CLS_USER] = new_status;
}
else if (stcmp (vn, "WAPI\201") == 0) {
evt_mask[EVT_CLS_WAPI] = new_status;
}
else if (stcmp (vn, "TRIGGER\201") == 0) {
evt_mask[EVT_CLS_TRIGGER] = new_status;
}
else {
merr_raise (CMMND);
goto err;
}
if (merr () > OK) goto err;
if ((ch = *(codptr)) == EOL || ch == SP) {
break;
}
}
}
for (i = 0; i < EVT_MAX; i++) {
if (evt_status[i] == EVT_S_SYNC && evt_mask[i] == EVT_S_ASYNC) {
/* cannot enable both synchronous and asynchronous
event processing on the same event class at the
same time */
merr_raise (M102);
goto err;
}
else {
if (evt_mask[i] > EVT_S_NOMODIFY) {
evt_status[i] = evt_mask[i];
}
}
}
if (mcmnd == ASTART) {
evt_async_enabled = TRUE;
}
else {
short disabled_evt_count = 0;
for (i = 0; i < EVT_MAX; i++) {
if (evt_status[i] == EVT_S_DISABLED) {
disabled_evt_count++;
}
}
if (disabled_evt_count == (EVT_MAX - 1)) evt_async_enabled = FALSE;
}
break;
}
case ETRIGGER:
merr_raise (CMMND);
break;
#if defined(HAVE_MWAPI_MOTIF)
case ESTART:
if ((rtn_dialect () != D_MDS) &&
(rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
{
if (in_syn_event_loop == TRUE) break;
int evt_count;
char *syn_handlers = (char *) malloc (STRLEN * sizeof (char));
/* stack ^$EVENT */
char key[100] = "^$EVENT\202\201";
symtab (new_sym, key, " \201");
evt_sync_enabled = TRUE;
in_syn_event_loop = TRUE;
while (evt_sync_enabled) {
/* run the next iteration of GTK's event loop */
//TODO: replace with libXt event loop
//gtk_main_iteration_do (TRUE);
/* dequeue any events */
evt_count = mwapi_dequeue_events (syn_handlers);
if (evt_count) {
/* write them out */
//printf ("event handlers = '%s'\r\n", syn_handlers);
syn_event_entry_nstx = nstx;
stcnv_c2m (syn_handlers);
stcpy (tmp3, syn_handlers);
syn_handlers[0] = '\0';
goto evthandler;
}
syn_evt_loop_bottom:
continue;
}
in_syn_event_loop = FALSE;
evt_sync_enabled = FALSE;
break;
}
case ESTOP:
if ((rtn_dialect () != D_MDS) &&
(rtn_dialect () != D_FREEM)) {
merr_raise (NOSTAND);
goto err;
}
evt_sync_enabled = FALSE;
break;
#endif
default:
merr_raise (CMMND);
} /* command switch */
if ((ch = *codptr) == EOL) {
if (merr () != OK) goto err;
if (forsw) goto for_end;
mcmnd = 0;
goto next_line;
}
if (ch == SP) {
if (merr () == OK) goto next0;
goto err;
}
if (ch != ',' && merr () == OK) {
merr_raise (SPACER);
}
else if ((ierr <= OK) || (debug_mode == TRUE)) {
if (debug_mode) goto direct_mode;
if (*++codptr != SP && *codptr != EOL) goto again;
merr_raise (ARGLIST);
}
/* else goto err; */
/* error */
err:
/* avoid infinite loops resulting from errors in argumentless FOR loops */
if (merr () != OK && merr () != ASYNC && forsw && ftyp == 0) {
argless_forsw_quit = TRUE;
goto for_end;
}
/*
* ierr == ASYNC means that the previous command was interrupted by
* an async event. It is not a real error, so just go on to the next
* command after resetting ierr = OK.
*/
if (merr () == ASYNC) {
merr_clear ();
goto next_cmnd;
}
if (merr () > OK) {
job_set_status (pid, JSTAT_ERROR);
}
if (ierr < 0) {
ierr += CTRLB;
if (merr () == OK) {
zbflag = TRUE;
goto zb_entry;
}
}
if (merr () > OK ) {
char er_buf[ERRLEN];
merr_set_ecode_ierr ();
stcpy (er_buf, errmes[merr ()]);
stcnv_m2c (er_buf);
#if !defined(MSDOS)
m_log (LOG_ERR, er_buf);
#endif
}
zerr = ierr;
merr_clear ();
/* goto restart; */
restart:
if (param) goto restore;
dosave[0] = EOL;
setpiece = FALSE;
setop = 0;
privflag = FALSE;
if (merr () == INRPT) goto err;
if (zerr == STORE) symtab (kill_all, "", "");
if (errfunlvl > 0) {
errfunlvl--;
}
else {
if (zerr == OK) {
zerror[0] = EOL; /* reset error */
}
else {
#ifdef DEBUG_STACK
printf ("Storing NESTERR\r\n");
#endif
nesterr = nstx; /* save stack information at error */
for (i = 1; i <= nstx; i++) getraddress (callerr[i], i);
zerror[0] = '<';
if (etxtflag) {
stcpy (&zerror[1], errmes[zerr]);
}
else {
intstr (&zerror[1], zerr);
}
stcat (zerror, ">\201");
if (rou_name[0] != EOL) {
char *j0;
char *j1;
char tmp1[256];
if (nestc[nstx] == XECUTE) {
if (nestn[nstx]) { /* reload routine */
zload (nestn[nstx]);
merr_clear ();
}
roucur = nestr[nstx] + rouptr; /* restore roucur */
}
j0 = (rouptr - 1);
j = 0;
tmp1[0] = EOL;
j0++;
if (roucur < rouend) {
while (j0 < (roucur - 1)) {
j1 = j0++;
j++;
if ((*j0 != TAB) && (*j0 != SP)) {
j = 0;
while ((tmp1[j] = (*(j0++))) > SP) {
if (tmp1[j] == '(') tmp1[j] = EOL;
j++;
}
tmp1[j] = EOL;
j = 0;
}
j0 = j1;
j0 += (UNSIGN (*j1)) + 2;
}
}
stcat (zerror, tmp1);
if (j > 0) {
i = stlen (zerror);
zerror[i++] = '+';
intstr (&zerror[i], j);
}
stcat (zerror, "^\201");
if (nestc[nstx] == XECUTE) {
if (nestn[nstx]) { /* reload routine */
zload (rou_name);
ssvn_job_update ();
merr_clear ();
}
stcat (zerror, nestn[nstx]);
}
else
stcat (zerror, rou_name);
}
if (zerr == UNDEF) zerr = M6;
/* undefined: report variable name */
if (zerr == UNDEF || zerr == SBSCR || zerr == NAKED || zerr == ZTERR || zerr == DBDGD || zerr == LBLUNDEF || zerr == NOPGM || zerr == M6 || zerr == M7 || zerr == M13) {
int f; /* include erroneous reference */
f = stlen (zerror);
zerror[f++] = SP;
zname (&zerror[f], varerr);
} /* end varnam section */
}
}
roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
tmp4[0] = EOL;
while (ierr != (OK - CTRLB)) {
/* standard error handling */
if (etrap[0] != EOL && stcmp (ecode, "") != 0) {
on_frame_entry ();
/* disable $ZTRAP error handling */
ztrap[nstx][0] = EOL;
stcpy (tmp4, etrap);
stcat (tmp4, " quit:$quit \"\" quit\201");
if (etrap_lvl > 1) {
/* we've encountered an error within an error handler.
save off the error code at merr_stack[nstx + 1].ECODE */
stcpy (merr_stack[nstx + 1].ECODE, ecode);
merr_topstk = nstx + 1;
etrap_lvl++;
}
else {
merr_topstk = nstx;
etrap_lvl++;
}
break;
}
if (ztrap[nstx][0] != EOL && !DSM2err) {
#ifdef DEBUG_NEWSTACK
printf ("Dropped into Ztrap [");
for (loop = 0; loop < 20 && ztrap[nstx][loop] != EOL; loop++) {
printf ("%c", ztrap[nstx][loop]);
}
printf ("]\r\n");
#endif
tmp4[0] = GOTO;
tmp4[1] = SP;
stcpy (&tmp4[2], ztrap[nstx]);
ztrap[nstx][0] = EOL;
#ifdef DEBUG_NEWSTACK
printf ("Set tmp4 to [");
for (loop = 0; tmp4[loop] != EOL; loop++) printf ("%c", tmp4[loop]);
printf ("]\r\n");
#endif
break;
}
if (nstx == 0) {
#ifdef DEBUG_NEWSTACK
printf ("Nestx was Zero\r\n");
#endif
forx = 0;
cmdptr = cmdstack;
namptr = namstck;
level = 0;
errfunlvl = 0;
io = HOME; /* trap to direct mode: USE 0 */
if (zerr == INRPT && frm_filter) {
tmp4[0] = 'h';
tmp4[1] = EOL;
}
if (DSM2err && (ztrap[NESTLEVLS + 1][0] != EOL)) { /* DSM V.2 error trapping */
#ifdef DEBUG_NEWSTACK
printf ("Ztrap 2\r\n");
#endif
tmp4[0] = GOTO;
tmp4[1] = SP; /* GOTO errorhandling */
stcpy (&tmp4[2], ztrap[NESTLEVLS + 1]);
ztrap[NESTLEVLS + 1][0] = EOL;
}
break;
}
#ifdef DEBUG_NEWSTACK
printf ("Nestc[nstx] is [%d]\r\n", nestc[nstx]);
#endif
if (nestc[nstx] == BREAK) break;
if (merr () > OK) goto err;
if (nestc[nstx] == FOR) {
if (forx == 0) goto for_quit;
ftyp = fortyp[--forx];
fvar = forvar[forx];
finc = forinc[forx];
flim = forlim[forx];
fi = fori[forx];
}
else {
if (nestc[nstx] == DO_BLOCK) {
test = nestlt[nstx];
level--;
}
else { /* pop $TEST */
level = nestlt[nstx]; /* pop level */
}
#ifdef DEBUG_NEWSTACK
printf ("Nestn[nstx] is [%d]\r\n", nestn[nstx]);
#endif
if (nestn[nstx]) { /* 'reload' routine */
namptr = nestn[nstx];
stcpy (rou_name, namptr);
zload (rou_name);
ssvn_job_update ();
dosave[0] = 0;
namptr--;
}
#ifdef DEBUG_NEWSTACK
printf ("Execcing the rest...\r\n");
#endif
roucur = nestr[nstx] + rouptr;
if (nestnew[nstx]) unnew (); /* un-NEW variables */
cmdptr = nestp[nstx];
if (nestc[nstx--] == '$') { /* extrinsic function/variable */
*argptr = EOL;
merr_raise (zerr);
errfunlvl++;
return 0;
}
estack--;
}
}
forsw = FALSE;
/* PRINTING ERROR MESSAGES */
if (tmp4[0] == EOL) {
if (zerr == BKERR && brkaction[0] != EOL) {
stcpy (code, brkaction);
codptr = code;
if (libcall == TRUE) {
return zerr;
}
else {
goto next_cmnd;
}
}
if (libcall == TRUE) return zerr;
DSW &= ~BIT0; /* enable ECHO */
// print here
{
char *t_rtn;
char *t_nsn = (char *) malloc (STRLEN * sizeof (char));
char *t_cod;
int t_pos;
NULLPTRCHK(t_nsn,"xecline");
t_rtn = strtok (zerror, ">");
t_rtn = strtok (NULL, ">");
if (t_rtn != NULL && t_rtn[1] == '%') {
strcpy (t_nsn, "SYSTEM");
}
else {
strcpy (t_nsn, nsname);
}
if (deferred_ierr > OK) {
t_cod = deferrable_code;
t_pos = deferrable_codptr - code + 3;
}
else {
t_cod = code;
t_pos = codptr - code + 3;
}
if (t_rtn != NULL) {
merr_dump (zerr, t_rtn, t_nsn, t_cod, t_pos);
}
else {
merr_dump (zerr, "<UNKNOWN>", t_nsn, t_cod, t_pos);
}
free (t_nsn);
}
}
else {
stcpy (code, tmp4);
codptr = code;
tmp4[0] = EOL;
goto next_cmnd;
}
restore:
io = HOME;
codptr = code;
if (param > 0) {
j = 0;
ch = 0;
paramx++;
param--;
for (;;) {
if (m_argv[++j][0] == '-') {
i = 0;
while ((m_argv[j][++i] != 0) && (m_argv[j][i] != 'x'));
if (m_argv[j][i] != 'x') continue;
j++;
if (++ch < paramx) continue;
strcpy (code, m_argv[j]);
break;
}
else {
if (++ch < paramx) continue;
strcpy (code, "d ");
strcpy (&code[2], m_argv[j]);
break;
}
}
code[strlen (code)] = EOL;
codptr = code;
goto next_cmnd;
}
if (usermode == 0) { /* application mode: direct mode implies HALT */
code[0] = 'H';
code[1] = EOL;
codptr = code;
goto next_cmnd;
}
else {
if (debug_mode) goto direct_mode;
}
if (libcall == TRUE) { /* library mode: don't go to direct mode, just return */
return merr ();
}
do {
if (frm_filter == FALSE && promflag) {
stcpy (code, " \201");
stcpy (&code[2], " \201");
promflag = FALSE;
}
else {
direct_mode:
if (dbg_enable_watch && dbg_pending_watches) dbg_dump_watchlist ();
/* DIRECT-MODE PROMPT HERE */
#if defined(HAVE_LIBREADLINE) && !defined(_AIX)
{
char *fmrl_buf;
char fmrl_prompt[256];
HIST_ENTRY **hist_list;
int hist_idx;
HIST_ENTRY *hist_ent;
if (quiet_mode == FALSE) {
if (tp_level == 0) {
snprintf (fmrl_prompt, 255, "\r\n%s.%s> ", shm_env, nsname);
}
else {
snprintf (fmrl_prompt, 255, "\r\nTL%d:%s.%s> ", tp_level, shm_env, nsname);
}
}
set_io (UNIX);
job_set_status (pid, JSTAT_DIRECTMODE);
/* readline() does its own malloc() */
fmrl_buf = readline (fmrl_prompt);
if (!fmrl_buf) {
set_io (UNIX);
printf ("\n");
set_io (MUMPS);
goto halt;
}
if (strlen (fmrl_buf) > 0) {
add_history (fmrl_buf);
}
if (fmrl_buf[0] == '?') {
char kb[20];
char db[255];
snprintf (kb, 19, "%%SYS.HLP\201");
snprintf (db, 19, "\201");
symtab (kill_sym, kb, db);
/* Invoke Online Help */
set_io (MUMPS);
stcpy (code, "DO ^%ZHELP\201");
if (strlen (fmrl_buf) > 1) {
snprintf (db, 254, "%s\201", &fmrl_buf[1]);
symtab (set_sym, kb, db);
}
}
else if (strcmp (fmrl_buf, "step") == 0) {
debug_mode = TRUE;
goto zgo;
}
else if ((strcmp (fmrl_buf, "cont") == 0) || (strcmp (fmrl_buf, "continue") == 0)) {
debug_mode = FALSE;
}
else if (strcmp (fmrl_buf, "rbuf") == 0) {
rbuf_dump ();
}
else if (strcmp (fmrl_buf, "jobtab") == 0) {
job_dump ();
}
else if (strcmp (fmrl_buf, "locktab") == 0) {
locktab_dump ();
code[0] = '\201';
codptr = code;
}
else if (strcmp (fmrl_buf, "shmstat") == 0) {
shm_dump ();
}
else if (strcmp (fmrl_buf, "shmpages") == 0) {
shm_dump_pages ();
}
else if (strcmp (fmrl_buf, "glstat") == 0) {
gbl_dump_stat ();
}
else if (strcmp (fmrl_buf, "events") == 0) {
char stat_desc[30];
char *evclass_name;
printf ("\n%-20s %-15s %s\n", "Event Class", "Processing Mode", "ABLOCK Count");
printf ("%-20s %-15s %s\n", "-----------", "---------------", "------------");
for (i = 0; i < EVT_MAX; i++) {
evclass_name = evt_class_name_c (i);
switch (evt_status[i]) {
case EVT_S_DISABLED:
strcpy (stat_desc, "Disabled");
break;
case EVT_S_ASYNC:
strcpy (stat_desc, "Asynchronous");
break;
case EVT_S_SYNC:
strcpy (stat_desc, "Synchronous");
}
printf ("%-20s %-15s %d\n", evclass_name, stat_desc, evt_blocks[i]);
}
}
else if (strcmp (fmrl_buf, "wh") == 0) {
write_history (history_file);
}
else if (strcmp (fmrl_buf, "trantab") == 0) {
tp_tdump();
}
else if (isdigit(fmrl_buf[0]) || (fmrl_buf[0] == '(') || (fmrl_buf[0] == '-') || (fmrl_buf[0] == '\'') || (fmrl_buf[0] == '+') || (fmrl_buf[0] == '$') || (fmrl_buf[0] == '^')) {
snprintf (code, 255, "W %s", fmrl_buf);
stcnv_c2m (code);
set_io (MUMPS);
}
#if !defined(__APPLE__)
else if (strcmp (fmrl_buf, "history") == 0) {
/* History List */
hist_list = history_list ();
if (hist_list) {
for (i = 0; hist_list[i]; i++) {
printf("%d: %s\n", i + history_base, hist_list[i]->line);
}
}
stcpy (code, " \201");
set_io (MUMPS);
}
#endif
else if (strncmp (fmrl_buf, "rcl", 3) == 0) {
/* Recall History Item */
if (!isdigit (fmrl_buf[4])) {
fprintf (stderr, "invalid history index '%s'\n", &fmrl_buf[4]);
set_io (MUMPS);
stcpy (code, " \201");
break;
}
hist_idx = atoi (&fmrl_buf[4]);
if ((hist_idx > history_length) || (hist_idx < 1)) {
fprintf (stderr, "history entry %d out of range (valid entries are 1-%d)\n", hist_idx, history_length);
set_io (MUMPS);
stcpy (code, " \201");
break;
}
hist_ent = history_get (hist_idx);
printf ("%s\n", hist_ent->line);
strncpy (code, hist_ent->line, 255);
stcnv_c2m (code);
set_io (MUMPS);
}
else {
/* Pass to M Interpreter */
set_io (MUMPS);
strncpy (code, fmrl_buf, 255);
stcnv_c2m (code);
}
/* free the buffer malloc()'d by readline() */
if (fmrl_buf) free (fmrl_buf);
}
#else
{
char fmrl_prompt[256];
if (tp_level == 0) {
snprintf (fmrl_prompt, 256, "\r\n%s> \201", nsname);
}
else {
snprintf (fmrl_prompt, 256, "\r\nTL%d:%s> \201", tp_level, nsname);
}
write_m (fmrl_prompt);
read_m (code, -1L, 0, 255); /* Not necessarily STRLEN? */
}
promflag = TRUE;
#endif
if (merr () > OK) goto err;
// printf ("zbflag = %d\r\n", zbflag);
if (code[0] == EOL && zbflag && nestc[nstx] == BREAK) {
//printf ("cont single step\r\n");
debug_mode = TRUE;
merr_raise (OK - CTRLB);
//printf ("ierr now '%d'\r\n", ierr);
goto zgo;
} /* single step */
}
}
while (code[0] == EOL);
if (promflag) write_m ("\r\n\201");
/* automatic ZI in direct mode: insert an entry with TAB */
i = (-1);
j = 0;
merr_clear ();
while (code[++i] != EOL) {
if (code[i] == '"') toggle (j);
if (code[i] == TAB && j == 0) {
dosave[0] = EOL;
zi (code, rouins);
if (merr ()) goto err;
goto restore;
}
}
code[++i] = EOL;
code[++i] = EOL;
roucur = buff + (NO_OF_RBUF * PSIZE0 + 1);
goto next_cmnd;
skip_line:
if (forsw) goto for_end;
goto next_line;
} /*end of xecline() */
void on_frame_entry(void)
{
return;
}
void rbuf_dump(void)
{
register int i;
char rnam[256];
char rpth[256];
char ldtime[80];
char flgs[80];
time_t ag;
struct tm tld;
printf ("ROUTINE BUFFER CONFIGURATION\r\n");
printf (" ROUTINE BUFFER COUNT: %ld\r\n", NO_OF_RBUF);
printf (" MAX. ROUTINE BUFFER COUNT: %d\r\n", MAXNO_OF_RBUF);
printf (" DEFAULT ROUTINE BUFFER SIZE (EACH): %d BYTES\r\n", DEFPSIZE0 - 1);
printf (" CURRENT ROUTINE BUFFER SIZE (EACH): %ld BYTES\r\n\r\n", PSIZE0 - 1);
printf ("BUFFERS IN USE:\r\n\r\n");
for (i = 0; i < NO_OF_RBUF; i++) {
sprintf (flgs, "");
if (ages[i] == 0) {
sprintf (rnam, "---------");
sprintf (rpth, "[buffer empty]");
sprintf (ldtime, "n/a");
sprintf (flgs, "n/a");
}
else {
stcpy (rnam, pgms[i]);
stcnv_m2c (rnam);
stcpy (rpth, path[i]);
stcnv_m2c (rpth);
ag = ages[i];
tld = *localtime (&ag);
strftime (ldtime, 80, "%a %Y-%m-%d %H:%M:%S %Z", &tld);
if (rbuf_flags[i].dialect != D_FREEM) {
strcat (flgs, "STANDARD");
switch (rbuf_flags[i].dialect) {
case D_M77:
strcat (flgs, " [M 1977]");
break;
case D_M84:
strcat (flgs, " [M 1984]");
break;
case D_M90:
strcat (flgs, " [M 1990]");
break;
case D_M95:
strcat (flgs, " [M 1995]");
break;
case D_MDS:
strcat (flgs, " [MILLENNIUM DRAFT]");
break;
case D_M5:
strcat (flgs, " [M5]");
break;
}
}
else {
strcat (flgs, "FREEM");
}
}
if (ages[i] != 0) {
printf ("#%d [ROUTINE '%s']\r\n", i, rnam);
printf (" UNIX PATH: %s\r\n", rpth);
printf (" LAST ACCESS: %s\r\n", ldtime);
printf (" DIALECT: %s\r\n", flgs);
}
}
}
short rbuf_slot_from_name(char *rnam)
{
register short i;
for (i = 0; i < NO_OF_RBUF; i++) {
if (stcmp (rnam, pgms[i]) == 0) {
return i;
}
}
return -1;
}
short is_standard(void)
{
if (rtn_dialect () == D_FREEM) {
return FALSE;
}
else {
return TRUE;
}
}
int rtn_dialect(void)
{
short slot;
slot = rbuf_slot_from_name (rou_name);
return rbuf_flags[slot].dialect;
}