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