|
|
| version 1.3, 2025/03/01 04:45:51 | version 1.20, 2025/04/30 17:19:16 |
|---|---|
| Line 1 | Line 1 |
| /* | /* |
| * * | * $Id$ |
| * * * | |
| * * * | |
| * *************** | |
| * * * * * | |
| * * MUMPS * | |
| * * * * * | |
| * *************** | |
| * * * | |
| * * * | |
| * * | |
| * | |
| * xecline.c | |
| * freem interpreter proper | * freem interpreter proper |
| * | * |
| * | * |
| * Author: Serena Willis <jpw@coherent-logic.com> | * Author: Serena Willis <snw@coherent-logic.com> |
| * Copyright (C) 1998 MUG Deutschland | * Copyright (C) 1998 MUG Deutschland |
| * Copyright (C) 2020 Coherent Logic Development LLC | * Copyright (C) 2020, 2025 Coherent Logic Development LLC |
| * | * |
| * | * |
| * This file is part of FreeM. | * This file is part of FreeM. |
| Line 35 | Line 23 |
| * You should have received a copy of the GNU Affero Public License | * You should have received a copy of the GNU Affero Public License |
| * along with FreeM. If not, see <https://www.gnu.org/licenses/>. | * along with FreeM. If not, see <https://www.gnu.org/licenses/>. |
| * | * |
| * $Log$ | |
| * Revision 1.20 2025/04/30 17:19:16 snw | |
| * Improve backtraces in debugger | |
| * | |
| * Revision 1.19 2025/04/30 14:41:03 snw | |
| * Further debugger work | |
| * | |
| * Revision 1.18 2025/04/29 18:46:17 snw | |
| * Begin work on interactive debugger | |
| * | |
| * Revision 1.17 2025/04/28 19:38:55 snw | |
| * Add trace mode | |
| * | |
| * Revision 1.16 2025/04/28 14:52:54 snw | |
| * Temporarily revert global handler refactor and fix reference regression in xecline | |
| * | |
| * Revision 1.15 2025/04/15 16:49:36 snw | |
| * Make use of logprintf throughout codebase | |
| * | |
| * Revision 1.14 2025/04/13 04:22:43 snw | |
| * Fix snprintf calls | |
| * | |
| * Revision 1.13 2025/04/10 01:24:39 snw | |
| * Remove C++ style comments | |
| * | |
| * Revision 1.12 2025/04/09 19:52:02 snw | |
| * Eliminate as many warnings as possible while building with -Wall | |
| * | |
| * Revision 1.11 2025/04/02 03:02:42 snw | |
| * Stop requiring users to pass -e to fmadm when -u or -g are passed | |
| * | |
| * 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 <stdlib.h> |
| Line 137 int xecline(int typ) | Line 177 int xecline(int typ) |
| short new_and_set = FALSE; | short new_and_set = FALSE; |
| short new_object = FALSE; | short new_object = FALSE; |
| short destructor_run = FALSE; | short destructor_run = FALSE; |
| short debug_mode = FALSE; | |
| short libcall = FALSE; | short libcall = FALSE; |
| char *namold; | char *namold; |
| long rouoldc; | long rouoldc; |
| unsigned long jobtime; | unsigned long jobtime; |
| char label[256], routine[256]; | char label[256], routine[256]; |
| char tracestr[512]; | |
| char *vn; | char *vn; |
| char *an; | char *an; |
| char *tmp; | char *tmp; |
| Line 207 int xecline(int typ) | Line 248 int xecline(int typ) |
| next_line: /* entry point for next command line */ | next_line: /* entry point for next command line */ |
| if (debug_mode) { | |
| debug_mode = debugger (DEBENTRY_LINE, codptr); | |
| } | |
| job_set_status (pid, JSTAT_INTERPRETER); | job_set_status (pid, JSTAT_INTERPRETER); |
| Line 255 next_line: /* entry point for n | Line 299 next_line: /* entry point for n |
| codptr = code; | codptr = code; |
| next_cmnd: /* continue line entry point */ | next_cmnd: /* continue line entry point */ |
| if (debug_mode) { | |
| debug_mode = debugger (DEBENTRY_CMD, codptr); | |
| } | |
| if (sigint_in_for) goto for_quit; | if (sigint_in_for) goto for_quit; |
| if (forsw && (forpost[forx][0] != '\0')) { | if (forsw && (forpost[forx][0] != '\0')) { |
| Line 512 next0: | Line 560 next0: |
| else if (tmp2[0] == '<') { /* call write output to %-array */ | else if (tmp2[0] == '<') { /* call write output to %-array */ |
| FILE *pipdes; | FILE *pipdes; |
| char key[STRLEN + 1 /*was 256 */ ]; | char key[STRLEN]; |
| char data[STRLEN + 1 /*was 256 */ ]; | char data[STRLEN]; |
| char data_kill[256]; | char data_kill[256]; |
| data_kill[255] = EOL; | data_kill[255] = EOL; |
| for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL; | for (i = 0; i < STRLEN - 1; i++) vn[i] = EOL; |
| snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid); | snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid); |
| ssvn (get_sym, key, vn); | ssvn (get_sym, key, vn); |
| if (vn[0] == '^') { | if (vn[0] == '^') { |
| Line 537 next0: | Line 585 next0: |
| symtab (kill_sym, vn, data); | symtab (kill_sym, vn, data); |
| } | } |
| snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid); | snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid); |
| ssvn (get_sym, key, vn); | ssvn (get_sym, key, vn); |
| data[0] = '0'; | data[0] = '0'; |
| Line 566 next0: | Line 614 next0: |
| int glvn_len = 0; | int glvn_len = 0; |
| while (fgets (data, STRLEN, pipdes)) { | while (fgets (data, STRLEN, pipdes)) { |
| snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid); | snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid); |
| ssvn (get_sym, key, vn); | ssvn (get_sym, key, vn); |
| glvn_len = stlen (vn); | glvn_len = stlen (vn); |
| Line 627 next0: | Line 675 next0: |
| for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL; | for (i = 0; i < STRLEN + 1; i++) vn[i] = EOL; |
| snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid); | snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid); |
| ssvn (get_sym, key, vn); | ssvn (get_sym, key, vn); |
| if (vn[0] == '^') { | if (vn[0] == '^') { |
| Line 656 next0: | Line 704 next0: |
| int glvn_len = 0; | int glvn_len = 0; |
| for (i = 1; i <= k; i++) { | for (i = 1; i <= k; i++) { |
| snprintf (key, 255, "^$JOB\202%d\202PIPE_GLVN\201", pid); | snprintf (key, STRLEN - 1, "^$JOB\202%d\202PIPE_GLVN\201", pid); |
| ssvn (get_sym, key, vn); | ssvn (get_sym, key, vn); |
| glvn_len = stlen (vn); | glvn_len = stlen (vn); |
| Line 826 again: | Line 874 again: |
| } | } |
| } | } |
| if (trace_mode) tracestr[0] = '\0'; | |
| switch (mcmnd) { | switch (mcmnd) { |
| case MAP: | case MAP: |
| Line 891 set0: | Line 941 set0: |
| if (isalpha (vn[0]) && *(codptr + 1) == ':') { | if (isalpha (vn[0]) && *(codptr + 1) == ':') { |
| char sc_string[255]; | char sc_string[255]; |
| register int sci; | |
| codptr += 2; | codptr += 2; |
| expr (NAME); | expr (NAME); |
| Line 928 set0: | Line 977 set0: |
| if (*++codptr != '=') { | if (*++codptr != '=') { |
| /* SET A++ or SET A-- equivalent to SET A+=1 SET A-=1 currently disabled */ | /* unary ++/-- */ |
| //#ifdef NEVER | |
| if ((ch == '+' || ch == '-') && ch == *codptr) { | if ((ch == '+' || ch == '-') && ch == *codptr) { |
| codptr++; | codptr++; |
| setop = ch; | setop = ch; |
| Line 938 set0: | Line 986 set0: |
| goto set2; | goto set2; |
| } | } |
| //#endif /* NEVER */ | |
| merr_raise (ASSIGNER); | merr_raise (ASSIGNER); |
| break; | break; |
| Line 951 set0: | Line 998 set0: |
| ch = *codptr; | ch = *codptr; |
| if (ch == '.') { | if (ch == '.') { |
| setref = TRUE; | if (!isdigit (*(codptr + 1))) { |
| codptr++; | setref = TRUE; |
| expr (NAME); | codptr++; |
| expr (NAME); | |
| } | |
| else { | |
| expr (STRING); | |
| } | |
| } | } |
| else { | else { |
| expr (STRING); | expr (STRING); |
| Line 1024 set2: | Line 1076 set2: |
| if (new_and_set == TRUE) new_and_set = FALSE; | if (new_and_set == TRUE) new_and_set = FALSE; |
| if (new_object == TRUE) new_object = FALSE; | if (new_object == TRUE) new_object = FALSE; |
| /* | |
| set1: | set1: |
| */ | |
| if (*codptr != ',') break; | if (*codptr != ',') break; |
| if (*++codptr == '@') goto again; | if (*++codptr == '@') goto again; |
| Line 1076 set: | Line 1130 set: |
| goto err; | goto err; |
| } | } |
| expr (STRING); | expr (STRING); |
| if (merr () > OK) goto err; | if (merr () > OK) goto err; |
| stcpy (tmp2, argptr); | stcpy (tmp2, argptr); |
| Line 1588 set10: | Line 1642 set10: |
| } | } |
| if (stcat (tmp2, &tmp3[arg4]) == 0) { | if (stcat (tmp2, &tmp3[arg4]) == 0) { |
| merr_raise (M56); //JPW | merr_raise (M56); /* snw */ |
| goto err; | goto err; |
| } | } |
| Line 2335 s_end: | Line 2389 s_end: |
| case QUIT: | case QUIT: |
| if (trace_mode) { | |
| fprintf (stderr, ">> TRACE: $STACK = %d QUIT CMD = %c\r\n", nstx, nestc[nstx]); | |
| } | |
| if (tp_level > 0) { | if (tp_level > 0) { |
| merr_raise (M42); | merr_raise (M42); |
| goto err; | goto err; |
| Line 2364 s_end: | Line 2422 s_end: |
| if (nestc[nstx] == '$') { /* extrinsic function/variable */ | if (nestc[nstx] == '$') { /* extrinsic function/variable */ |
| if (trace_mode) { | |
| fprintf (stderr, ">> TRACE: QUIT FROM EXTRINSIC\r\n"); | |
| } | |
| #ifdef DEBUG_NEWSTACK | #ifdef DEBUG_NEWSTACK |
| printf ("EXTRINSIC\r\n"); | printf ("EXTRINSIC\r\n"); |
| #endif | #endif |
| //printf (" extr_types[%d] = '%d'\r\n", nstx, extr_types[nstx]); | |
| if (*codptr == EOL || *codptr == SP) { | if (*codptr == EOL || *codptr == SP) { |
| #ifdef DEBUG_NEWSTACK | #ifdef DEBUG_NEWSTACK |
| Line 2394 s_end: | Line 2455 s_end: |
| else { | else { |
| expr (STRING); | expr (STRING); |
| if (trace_mode) { | |
| fprintf (stderr, ">> TRACE: QUIT FROM SUBROUTINE\r\n"); | |
| } | |
| if (ierr != OK - CTRLB && merr () != OK && merr () != INRPT) { | if (ierr != OK - CTRLB && merr () != OK && merr () != INRPT) { |
| Line 2560 quit0: | Line 2625 quit0: |
| printf ("CHECK 03 (Stack PUSH)\r\n"); | printf ("CHECK 03 (Stack PUSH)\r\n"); |
| #endif | #endif |
| if (++nstx > NESTLEVLS) { | if (++nstx > NESTLEVLS) { |
| nstx--; | nstx--; |
| merr_raise (STKOV); | merr_raise (STKOV); |
| Line 2586 quit0: | Line 2650 quit0: |
| nestn[nstx] = 0; /* no overring of routine */ | nestn[nstx] = 0; /* no overring of routine */ |
| nestr[nstx] = roucur - rouptr; /* save roucur: only for $V(26) needed */ | nestr[nstx] = roucur - rouptr; /* save roucur: only for $V(26) needed */ |
| ztrap[nstx][0] = EOL; | ztrap[nstx][0] = EOL; |
| forsw = TRUE; | forsw = TRUE; |
| ftyp = 0; /* no args is FOREVER */ | ftyp = 0; /* no args is FOREVER */ |
| Line 3030 do_xecute: | Line 3094 do_xecute: |
| do_goto: | do_goto: |
| if (trace_mode) { | |
| char rn[256]; | |
| stcpy (rn, rou_name); | |
| stcnv_m2c (rn); | |
| switch (mcmnd) { | |
| case DO: | |
| snprintf (tracestr, sizeof (tracestr) - 1, "rtn = %s $stack = %d do ", rn, nstx); | |
| break; | |
| case GOTO: | |
| snprintf (tracestr, sizeof (tracestr) - 1, "rtn = %s $stack = %d goto ", rn, nstx); | |
| break; | |
| } | |
| } | |
| offset = 0; | offset = 0; |
| label[0] = routine[0] = EOL; | label[0] = routine[0] = EOL; |
| dofram0 = 0; | dofram0 = 0; |
| Line 3064 do_goto: | Line 3143 do_goto: |
| stcpy (label, varnam); | stcpy (label, varnam); |
| if (trace_mode) { | |
| char ttt[256]; | |
| stcpy (ttt, label); | |
| stcnv_m2c (ttt); | |
| strcat (tracestr, ttt); | |
| } | |
| ch = *++codptr; | ch = *++codptr; |
| } | } |
| Line 3079 do_goto: | Line 3166 do_goto: |
| /* unless argument is numeric, expr returns wrong codptr */ | /* unless argument is numeric, expr returns wrong codptr */ |
| if ((ch = *codptr) != SP && (ch != EOL) && (ch != ',') && (ch != '^')) ch = *++codptr; | if ((ch = *codptr) != SP && (ch != EOL) && (ch != ',') && (ch != '^')) ch = *++codptr; |
| if (trace_mode) { | |
| char ttt[256]; | |
| snprintf (ttt, 255, "+%d", offset); | |
| strcat (tracestr, ttt); | |
| } | |
| } | } |
| if (ch == '^') { /* parse routine */ | if (ch == '^') { /* parse routine */ |
| Line 3089 do_goto: | Line 3181 do_goto: |
| if (merr () > OK) goto err; | if (merr () > OK) goto err; |
| stcpy (routine, varnam); | stcpy (routine, varnam); |
| if (trace_mode) { | |
| char ttt[256]; | |
| char ttx[256]; | |
| stcpy (ttt, routine); | |
| stcnv_m2c (ttt); | |
| snprintf (ttx, 255, "^%s", ttt); | |
| strcat (tracestr, ttx); | |
| } | |
| dosave[0] = EOL; | dosave[0] = EOL; |
| ch = *++codptr; | ch = *++codptr; |
| loadsw = TRUE; | loadsw = TRUE; |
| } | } |
| if (trace_mode) { | |
| fprintf (stderr, ">> TRACE: %s\r\n", tracestr); | |
| } | |
| if (ch == '(' && mcmnd == DO) { /* parse parameter */ | if (ch == '(' && mcmnd == DO) { /* parse parameter */ |
| if (offset) { | if (offset) { |
| Line 3753 off3: | Line 3859 off3: |
| break; | break; |
| case KILL: | case KILL: |
| /* argumentless: KILL all local variables */ | /* argumentless: KILL all local variables */ |
| if (((ch = *codptr) == SP) || ch == EOL) { | if (((ch = *codptr) == SP) || ch == EOL) { |
| symtab (kill_all, "", ""); | symtab (kill_all, "", ""); |
| Line 3787 off3: | Line 3893 off3: |
| if (destructor_ct) { | if (destructor_ct) { |
| for (cd = 0; cd < destructor_ct; cd++) { | for (cd = 0; cd < destructor_ct; cd++) { |
| strcat (destc, destructors[cd]); | if (strlen (destructors[cd]) > 0) { |
| strcat (destc, ","); | strcat (destc, destructors[cd]); |
| strcat (destc, ","); | |
| } | |
| } | } |
| destructor_ct = 0; | destructor_ct = 0; |
| Line 3936 off3: | Line 4044 off3: |
| stcpy (objvar, vn); | stcpy (objvar, vn); |
| symtab (dat, objvar, datres); | symtab (fra_dat, objvar, datres); |
| dat_res = atoi (datres); | dat_res = atoi (datres); |
| if (dat_res > 0) { | if (dat_res > 0) { |
| Line 3970 off3: | Line 4078 off3: |
| if (merr () > OK) goto err; | if (merr () > OK) goto err; |
| /* TODO: check this snprintf for proper sizing */ | |
| snprintf (&tmp3[1], 255, "%s\201", &constructor[1]); | snprintf (&tmp3[1], 255, "%s\201", &constructor[1]); |
| goto private; | goto private; |
| Line 3990 off3: | Line 4099 off3: |
| goto set2; | goto set2; |
| } | } |
| /* | |
| post_new: | post_new: |
| */ | |
| ch = nstx; | ch = nstx; |
| while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */ | while (nestc[ch] == FOR) ch--; /* FOR does not define a NEW level */ |
| Line 4320 use0: /* entry point for proces | Line 4430 use0: /* entry point for proces |
| break; | break; |
| case 2: | case 2: |
| crlf[io] = tvexpr (argptr); | frm_crlf[io] = tvexpr (argptr); |
| break; | break; |
| case 3: | case 3: |
| Line 4422 use_socket: | Line 4532 use_socket: |
| /* need to evaluate the following 6 lines carefully - smw 2023-10-15 */ | /* need to evaluate the following 6 lines carefully - smw 2023-10-15 */ |
| if (k != HOME) { | if (k != HOME) { |
| crlf[k] = FALSE; | frm_crlf[k] = FALSE; |
| fm_nodelay[k] = FALSE; | fm_nodelay[k] = FALSE; |
| xpos[k] = 0; | xpos[k] = 0; |
| ypos[k] = 0; | ypos[k] = 0; |
| Line 5047 open_socket: | Line 5157 open_socket: |
| expr (STRING); | expr (STRING); |
| if (merr () > OK) break; | if (merr () > OK) break; |
| switch (intexpr (argptr)) { | { |
| char brkstr[256]; | |
| case 2: | |
| DSM2err = TRUE; | stcpy (brkstr, argptr); |
| break; /* enable DSM V 2 error processing */ | stcnv_m2c (brkstr); |
| case -2: | if (strcmp (brkstr, "DEBUG") == 0) { |
| DSM2err = FALSE; | debug_mode = TRUE; |
| break; /* enable normal error processing */ | } |
| else { | |
| case 0: | switch (intexpr (argptr)) { |
| breakon = FALSE; | |
| break; /* disable CTRL/C */ | case 2: |
| DSM2err = TRUE; | |
| default: | break; /* enable DSM V 2 error processing */ |
| breakon = TRUE; | |
| break; /* enable CTRL/C */ | 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; | break; |
| case VIEW: | case VIEW: |
| Line 5080 open_socket: | Line 5203 open_socket: |
| #endif | #endif |
| if (nestc[nstx] == BREAK) { | if (nestc[nstx] == BREAK) { |
| // printf ("nestc[nstx] was BREAK\r\n"); | |
| if (repQUIT) continue; | if (repQUIT) continue; |
| merr_raise (OK - CTRLB); | merr_raise (OK - CTRLB); |
| goto zgo; /*cont. single step */ | goto zgo; /*cont. single step */ |
| } | } |
| // else { | |
| // printf ("nestc[nstx] was _not_ BREAK\r\n"); | |
| // } | |
| if (nestc[nstx] == FOR) { | if (nestc[nstx] == FOR) { |
| Line 5538 zgo: | Line 5657 zgo: |
| for (; beg < end; beg += UNSIGN (*beg) + 2) { | for (; beg < end; beg += UNSIGN (*beg) + 2) { |
| if (crlf[io]) { | if (frm_crlf[io]) { |
| write_m ("\012\201"); | write_m ("\012\201"); |
| } | } |
| else { | else { |
| Line 5554 zgo: | Line 5673 zgo: |
| rouins = beg; | rouins = beg; |
| } | } |
| if (crlf[io]) { | if (frm_crlf[io]) { |
| write_m ("\012\201"); | write_m ("\012\201"); |
| } | } |
| else { | else { |
| Line 5664 zgo: | Line 5783 zgo: |
| } | } |
| case ZWRITE: | case ZWRITE: |
| zwrite: | |
| { | { |
| short k; | short k; |
| char w_tmp[512]; | char w_tmp[512]; |
| Line 5790 zwritep: | Line 5906 zwritep: |
| expr (NAME); | expr (NAME); |
| //if (varnam[0] == '^') merr_raise (GLOBER); | |
| if (merr () > OK) goto err; | if (merr () > OK) goto err; |
| codptr++; | codptr++; |
| Line 5823 zwritep: | Line 5938 zwritep: |
| } | } |
| if (varnam[0] != '^') { | if (varnam[0] != '^') { |
| symtab (dat, varnam, tmp2); | symtab (fra_dat, varnam, tmp2); |
| zwmode = 'L'; | zwmode = 'L'; |
| } | } |
| else { | else { |
| if (varnam[1] == '$') { | if (varnam[1] == '$') { |
| ssvn (dat, varnam, tmp2); | ssvn (fra_dat, varnam, tmp2); |
| zwmode = '$'; | zwmode = '$'; |
| } | } |
| else { | else { |
| global (dat, varnam, tmp2); | global (fra_dat, varnam, tmp2); |
| zwmode = '^'; | zwmode = '^'; |
| } | } |
| } | } |
| Line 5943 zwritep: | Line 6058 zwritep: |
| switch (zwmode) { | switch (zwmode) { |
| case 'L': | case 'L': |
| symtab (dat, tmp, tmp3); | symtab (fra_dat, tmp, tmp3); |
| symtab (get_sym, tmp, &w_tmp[1]); | symtab (get_sym, tmp, &w_tmp[1]); |
| break; | break; |
| case '$': | case '$': |
| ssvn (dat, tmp, tmp3); | ssvn (fra_dat, tmp, tmp3); |
| ssvn (get_sym, tmp, &w_tmp[1]); | ssvn (get_sym, tmp, &w_tmp[1]); |
| break; | break; |
| case '^': | case '^': |
| global (dat, tmp, tmp3); | global (fra_dat, tmp, tmp3); |
| global (get_sym, tmp, &w_tmp[1]); | global (get_sym, tmp, &w_tmp[1]); |
| break; | break; |
| Line 6032 zwritep: | Line 6147 zwritep: |
| break; | break; |
| case ZALLOCATE: | /* user defined Z-COMMAND */ |
| /* 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: | case PRIVATE: |
| private: /* for in-MUMPS defined commands */ | private: /* for in-MUMPS defined commands */ |
| Line 6626 evthandler: /* for event hand | Line 6686 evthandler: /* for event hand |
| /* run the next iteration of GTK's event loop */ | /* run the next iteration of GTK's event loop */ |
| //TODO: replace with libXt event loop | /* TODO: replace with libXt event loop */ |
| //gtk_main_iteration_do (TRUE); | /* gtk_main_iteration_do (TRUE); */ |
| /* dequeue any events */ | /* dequeue any events */ |
| evt_count = mwapi_dequeue_events (syn_handlers); | evt_count = mwapi_dequeue_events (syn_handlers); |
| if (evt_count) { | if (evt_count) { |
| /* write them out */ | /* write them out */ |
| //printf ("event handlers = '%s'\r\n", syn_handlers); | /* printf ("event handlers = '%s'\r\n", syn_handlers); */ |
| syn_event_entry_nstx = nstx; | syn_event_entry_nstx = nstx; |
| Line 6692 syn_evt_loop_bottom: | Line 6752 syn_evt_loop_bottom: |
| if (ch != ',' && merr () == OK) { | if (ch != ',' && merr () == OK) { |
| merr_raise (SPACER); | merr_raise (SPACER); |
| } | } |
| else if ((ierr <= OK) || (debug_mode == TRUE)) { | else if (ierr <= OK) { |
| if (debug_mode) goto direct_mode; | |
| if (*++codptr != SP && *codptr != EOL) goto again; | if (*++codptr != SP && *codptr != EOL) goto again; |
| merr_raise (ARGLIST); | merr_raise (ARGLIST); |
| Line 6735 err: | Line 6794 err: |
| } | } |
| } | } |
| if (merr () > OK ) { | if (merr () > OK ) { |
| char er_buf[ERRLEN]; | char er_buf[ERRLEN]; |
| Line 6744 err: | Line 6804 err: |
| stcpy (er_buf, errmes[merr ()]); | stcpy (er_buf, errmes[merr ()]); |
| stcnv_m2c (er_buf); | stcnv_m2c (er_buf); |
| /* | |
| if (usermode == 1 && ztrap[nstx][0] == EOL && etrap[0] == '\0') { | |
| debug_mode = TRUE; | |
| debugger (DEBENTRY_ERROR, codptr); | |
| } | |
| */ | |
| #if !defined(MSDOS) | #if !defined(MSDOS) |
| m_log (LOG_ERR, er_buf); | logprintf (FM_LOG_DEBUG, "xecline: interpreter error %d [%s]", ierr, er_buf); |
| #endif | #endif |
| } | } |
| Line 7079 restart: | Line 7148 restart: |
| DSW &= ~BIT0; /* enable ECHO */ | DSW &= ~BIT0; /* enable ECHO */ |
| // print here | /* print here */ |
| { | { |
| char *t_rtn; | char *t_rtn; |
| char *t_nsn = (char *) malloc (STRLEN * sizeof (char)); | char *t_nsn = (char *) malloc (STRLEN * sizeof (char)); |
| Line 7116 restart: | Line 7185 restart: |
| free (t_nsn); | free (t_nsn); |
| } | } |
| Line 7177 restore: | Line 7247 restore: |
| goto next_cmnd; | goto next_cmnd; |
| } | } |
| else { | |
| if (debug_mode) goto direct_mode; | |
| } | |
| if (libcall == TRUE) { /* library mode: don't go to direct mode, just return */ | if (libcall == TRUE) { /* library mode: don't go to direct mode, just return */ |
| return merr (); | return merr (); |
| Line 7210 direct_mode: | Line 7277 direct_mode: |
| if (quiet_mode == FALSE) { | if (quiet_mode == FALSE) { |
| if (tp_level == 0) { | if (tp_level == 0) { |
| snprintf (fmrl_prompt, 255, "\r\n%s> ", nsname); | snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1, "\r\n%s.%s> ", shm_env, nsname); |
| } | } |
| else { | else { |
| snprintf (fmrl_prompt, 255, "\r\nTL%d:%s> ", tp_level, nsname); | snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1 , "\r\nTL%d:%s.%s> ", tp_level, shm_env, nsname); |
| } | } |
| } | } |
| set_io (UNIX); | set_io (UNIX); |
| Line 7238 direct_mode: | Line 7305 direct_mode: |
| if (fmrl_buf[0] == '?') { | if (fmrl_buf[0] == '?') { |
| char kb[20]; | char kb[20]; |
| char db[255]; | char db[STRLEN]; |
| snprintf (kb, 19, "%%SYS.HLP\201"); | snprintf (kb, sizeof (kb) - 1, "%%SYS.HLP\201"); |
| snprintf (db, 19, "\201"); | snprintf (db, STRLEN - 1, "\201"); |
| symtab (kill_sym, kb, db); | symtab (kill_sym, kb, db); |
| Line 7251 direct_mode: | Line 7318 direct_mode: |
| stcpy (code, "DO ^%ZHELP\201"); | stcpy (code, "DO ^%ZHELP\201"); |
| if (strlen (fmrl_buf) > 1) { | if (strlen (fmrl_buf) > 1) { |
| snprintf (db, 254, "%s\201", &fmrl_buf[1]); | snprintf (db, STRLEN - 1, "%s\201", &fmrl_buf[1]); |
| symtab (set_sym, kb, db); | 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) { | else if (strcmp (fmrl_buf, "rbuf") == 0) { |
| rbuf_dump (); | rbuf_dump (); |
| } | } |
| Line 7320 direct_mode: | Line 7380 direct_mode: |
| } | } |
| else if (isdigit(fmrl_buf[0]) || (fmrl_buf[0] == '(') || (fmrl_buf[0] == '-') || (fmrl_buf[0] == '\'') || (fmrl_buf[0] == '+') || (fmrl_buf[0] == '$') || (fmrl_buf[0] == '^')) { | 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); | snprintf (code, STRLEN - 1, "W %s", fmrl_buf); |
| stcnv_c2m (code); | stcnv_c2m (code); |
| set_io (MUMPS); | set_io (MUMPS); |
| Line 7402 direct_mode: | Line 7462 direct_mode: |
| char fmrl_prompt[256]; | char fmrl_prompt[256]; |
| if (tp_level == 0) { | if (tp_level == 0) { |
| snprintf (fmrl_prompt, 256, "\r\n%s> \201", nsname); | snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1, "\r\n%s> \201", nsname); |
| } | } |
| else { | else { |
| snprintf (fmrl_prompt, 256, "\r\nTL%d:%s> \201", tp_level, nsname); | snprintf (fmrl_prompt, sizeof (fmrl_prompt) - 1, "\r\nTL%d:%s> \201", tp_level, nsname); |
| } | } |
| write_m (fmrl_prompt); | write_m (fmrl_prompt); |
| Line 7417 direct_mode: | Line 7477 direct_mode: |
| #endif | #endif |
| if (merr () > OK) goto err; | if (merr () > OK) goto err; |
| // printf ("zbflag = %d\r\n", zbflag); | |
| if (code[0] == EOL && zbflag && nestc[nstx] == BREAK) { | if (code[0] == EOL && zbflag && nestc[nstx] == BREAK) { |
| //printf ("cont single step\r\n"); | |
| debug_mode = TRUE; | debug_mode = TRUE; |
| merr_raise (OK - CTRLB); | merr_raise (OK - CTRLB); |
| //printf ("ierr now '%d'\r\n", ierr); | |
| goto zgo; | goto zgo; |
| } /* single step */ | } /* single step */ |
| } | } |
| Line 7493 void rbuf_dump(void) | Line 7548 void rbuf_dump(void) |
| for (i = 0; i < NO_OF_RBUF; i++) { | for (i = 0; i < NO_OF_RBUF; i++) { |
| sprintf (flgs, ""); | flgs[0] = '\0'; |
| if (ages[i] == 0) { | if (ages[i] == 0) { |
| sprintf (rnam, "---------"); | sprintf (rnam, "---------"); |