home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Imain < prev    next >
Encoding:
Text File  |  1990-07-19  |  39.2 KB  |  1,697 lines
  1. /*
  2.  * Main program, initialization, termination, and such.
  3.  */
  4.  
  5. #include <math.h>
  6. #include "../h/config.h"
  7. #include "../h/rt.h"
  8. #include "rproto.h"
  9. #include "../h/version.h"
  10. #include "../h/header.h"
  11. #include "../h/opdefs.h"
  12. #include <ctype.h>
  13.  
  14. /*
  15.  * Prototype.
  16.  */
  17.  
  18. hidden    novalue    env_err    Params((char *msg,char *name,char *val));
  19.  
  20. /*
  21.  * The following code is operating-system dependent [@imain.01].  Include files
  22.  *  and declarations that are system-dependent.
  23.  */
  24.  
  25. #if PORT
  26. #include <signal.h>
  27.    /* probably needs something more */
  28. Deliberate Syntax Error
  29. #endif                    /* PORT */
  30.  
  31. #if ARM
  32. #include <signal.h>
  33. #endif                    /* ARM */
  34.  
  35. #if AMIGA
  36. #include <signal.h>
  37. #include <fcntl.h>
  38.  
  39. int chkbreak;                /* if nonzero, check for ^C */
  40. #endif                    /* AMIGA */
  41.  
  42. #if ATARI_ST
  43. #include <fcntl.h>
  44. #endif                    /* ATARI_ST */
  45.  
  46. #if HIGHC_386
  47. #include <system.cf>
  48.  
  49. int _fmode = 0;            /* force CR-LF on std.. files */
  50. #endif                    /* HIGHC_386 */
  51.  
  52. #if MACINTOSH
  53. #include <signal.h>
  54. #if MPW
  55. #include <Types.h>
  56. #include <Events.h>
  57. #include <FCntl.h>
  58. #include <SANE.h>
  59. #include <CursorCtl.h>
  60. int NoOptions = 0;
  61. #endif                    /* MPW */
  62. #endif                    /* MACINTOSH */
  63.  
  64. #if MSDOS
  65. #if LATTICE || MICROSOFT || TURBO
  66. #include <fcntl.h>
  67. #include <signal.h>
  68. #endif                    /* LATTICE || MICROSOFT || TURBO */
  69. #endif                    /* MSDOS */
  70.  
  71. #if MVS || VM
  72. #if SASC
  73. #include <lcsignal.h>
  74. #else                    /* SASC */
  75. #include <signal.h>
  76. #endif                    /* SASC */
  77. #endif                    /* MVS || VM */
  78.  
  79. #if OS2
  80. #include <fcntl.h>
  81. #include <signal.h>
  82. #endif                    /* OS2 */
  83.  
  84. #if UNIX
  85. #include <signal.h>
  86. #endif                    /* UNIX */
  87.  
  88. #if VMS
  89. #include <signal.h>
  90. #include <types.h>
  91. #endif                    /* VMS */
  92.  
  93. static char icodebuf[BUFSIZ];
  94.  
  95. /*
  96.  * End of operating-system specific code.
  97.  */
  98.  
  99. #ifdef IconAlloc
  100. #define malloc mem_alloc
  101. #endif                    /* IconAlloc */
  102.  
  103. #ifndef MaxHeader
  104. #define MaxHeader MaxHdr
  105. #endif                    /* MaxHeader */
  106.  
  107. /*
  108.  * A number of important variables follow.
  109.  */
  110.  
  111. static struct b_coexpr *mainhead;    /* &main */
  112. extern struct errtab errtab[];        /* error numbers and messages */
  113.  
  114. #ifdef TraceBack
  115. extern struct b_proc *opblks[];
  116. extern word lastop;            /* last op-code */
  117. extern dptr xargp;
  118. extern word xnargs;            /* number of arguments */
  119.  
  120. #endif                    /* TraceBack */
  121.  
  122.  
  123. #ifdef EvalTrace
  124. word lineno = 0;            /* source line number */
  125. word colmno = 0;            /* source column number */
  126. #endif                    /* EvalTrace */
  127.  
  128. #ifdef DumpIstream
  129. FILE *imons;
  130. #endif                    /* DumpIstream */
  131.  
  132. #ifdef DumpIcount
  133. #define MaxIcode 100
  134. FILE *imonc;
  135. long icode[MaxIcode];
  136. #endif                    /* DumpIcount */
  137.  
  138.  
  139. #ifdef WATERLOO_C_V3_0
  140. extern int *cw3defect;
  141. #endif                    /* WATERLOO_C_V3_0 */
  142.  
  143. #ifdef IconCalling
  144. int IDepth = 0;                /* depth of icon_call calls */
  145. int call_error = 0;            /* called procedure not found */
  146. int interp_status;            /* interpreter status */
  147. #endif                    /* IconCalling */
  148.  
  149. int set_up = 0;                /* initialization switch */
  150. int k_level = 0;            /* &level */
  151. int k_errornumber = 0;            /* &errornumber */
  152. char *k_errortext = "";            /* &errortext */
  153. struct descrip k_errorvalue;        /* &errorvalue */
  154. struct descrip k_main;            /* &main */
  155. char *code;                /* interpreter code buffer */
  156. word *records;                /* pointer to record procedure blocks */
  157. word *ftabp;                /* pointer to record/field table */
  158. dptr fnames, efnames;            /* pointer to field names */
  159. dptr globals, eglobals;            /* pointer to global variables */
  160. dptr gnames, egnames;            /* pointer to global variable names */
  161. dptr statics, estatics;            /* pointer to static variables */
  162. char *strcons;                /* pointer to string constant table */
  163. struct ipc_fname *filenms, *efilenms;    /* pointer to ipc/file name table */
  164. struct ipc_line *ilines, *elines;    /* pointer to ipc/line number table */
  165.  
  166. #ifdef TallyOpt
  167. word tallybin[16];            /* counters for tallying */
  168. int tallyopt = 0;            /* want tally results output? */
  169. #endif                    /* TallyOpt */
  170.  
  171. word mstksize = MStackSize;        /* initial size of main stack */
  172. word stksize = StackSize;        /* co-expression stack size */
  173. struct b_coexpr *stklist;        /* base of co-expression block list */
  174.  
  175. word statsize = MaxStatSize;        /* size of static region */
  176. word statincr = MaxStatSize/4;        /* increment for static region */
  177. char *statbase = NULL;            /* start of static space */
  178. char *statend;                /* end of static space */
  179. char *statfree;                /* static space free pointer */
  180.  
  181. word ssize = MaxStrSpace;        /* initial string space size (bytes) */
  182. char *strbase;                /* start of string space */
  183. char *strend;                /* end of string space */
  184. char *strfree;                /* string space free pointer */
  185. char *currend = NULL;            /* current end of memory region */
  186.  
  187. word abrsize = MaxAbrSize;        /* initial size of allocated block
  188.                        region (bytes) */
  189. char *blkbase;                /* start of block region */
  190. char *blkend;                /* end of allocated blocks */
  191. char *blkfree;                /* block region free pointer */
  192.  
  193. #ifdef FixedRegions
  194. word qualsize = QualLstSize;        /* size of quallist for fixed regions */
  195. #endif                    /* FixedRegions */
  196.  
  197. uword statneed;                /* stated need for static space */
  198. uword strneed;                /* stated need for string space */
  199. uword blkneed;                /* stated need for block space */
  200.  
  201. int dodump;                /* if nonzero, core dump on error */
  202. int noerrbuf;                /* if nonzero, do not buffer stderr */
  203.  
  204. struct descrip k_current;        /* current expression stack pointer */
  205. struct descrip maps2;            /* second cached argument of map */
  206. struct descrip maps3;            /* third cached argument of map */
  207.  
  208. int ntended = 0;            /* number of active tended descrips */
  209.  
  210. #ifdef ExecImages
  211. int dumped = 0;                /* non-zero if reloaded from dump */
  212. #endif                    /* ExecImages */
  213.  
  214. word *stack;                /* Interpreter stack */
  215. word *stackend;             /* End of interpreter stack */
  216.  
  217.  
  218.  
  219. /*
  220.  * Initial icode sequence. This is used to invoke the main procedure with one
  221.  *  argument.  If main returns, the Op_Quit is executed.
  222.  */
  223. word istart[3];
  224. int mterm = Op_Quit;
  225.  
  226. #ifdef IconCalling
  227. int fterm = Op_FQuit;
  228. #endif                    /* IconCalling */
  229.  
  230. #ifndef IconCalling
  231.  
  232.  
  233. novalue main(argc, argv)
  234.  
  235. int argc;
  236. char **argv;
  237.    {
  238.    int i, slen;
  239.  
  240. #if SASC
  241.    quiet(1);                    /* suppress C library diagnostics */
  242. #endif                    /* SASC */
  243.  
  244.    ipc.opnd = NULL;
  245.  
  246. #if VMS
  247.    redirect(&argc, argv, 0);
  248. #endif                    /* VMS */
  249.  
  250.    /*
  251.     * Setup Icon interface.  It's done this way to avoid duplication
  252.     *  of code, since the same thing has to be done if calling Icon
  253.     *  is enabled.  See istart.c.
  254.     */
  255.  
  256. #ifdef CRAY
  257.    argv[0] = "iconx";
  258. #endif                    /* CRAY */
  259.  
  260.    icon_setup(argc, argv, &i);
  261.    while (i--) {            /* skip option arguments */
  262.       argc--;
  263.       argv++;
  264.       }
  265.  
  266.    if (!argc) 
  267.       error("no icode file specified");
  268.    /*
  269.     * Call icon_init with the name of the icode file to execute.    [[I?]]
  270.     */
  271.  
  272.  
  273.    icon_init(argv[1]);
  274.  
  275.    /*
  276.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  277.     *    icode segment, and clear the gfp.
  278.     */
  279.    stackend = stack + mstksize/WordSize;
  280.    sp = stack + Wsizeof(struct b_coexpr);
  281.    ipc.opnd = istart;
  282.    *ipc.op++ = Op_Invoke;                /*    [[I?]] */
  283.    *ipc.opnd++ = 1;
  284.  
  285. #ifdef WATERLOO_C_V3_0
  286.    /*
  287.     *  Workaround for compiler bug.
  288.     */
  289.    cw3defect = ipc.op;
  290.    *cw3defect = Op_Quit;
  291. #else                    /* WATERLOO_C_V3_0 */
  292.    *ipc.op = Op_Quit;
  293. #endif                    /* WATERLOO_C_V3_0 */
  294.  
  295.    ipc.opnd = istart;
  296.    gfp = 0;
  297.  
  298.    /*
  299.     * Set up expression frame marker to contain execution of the
  300.     *  main procedure.  If failure occurs in this context, control
  301.     *  is transferred to mterm, the address of an Op_Quit.
  302.     */
  303.    efp = (struct ef_marker *)(sp);
  304.    efp->ef_failure.op = &mterm;
  305.    efp->ef_gfp = 0;
  306.    efp->ef_efp = 0;
  307.    efp->ef_ilevel = 1;
  308.    sp += Wsizeof(*efp) - 1;
  309.  
  310.    pfp = 0;
  311.    ilevel = 0;
  312.  
  313.    /*
  314.     * The first global variable holds the value of "main".  If it
  315.     *  is not of type procedure, this is noted as run-time error 117.
  316.     *  Otherwise, this value is pushed on the stack.
  317.     */
  318.    if (globals[0].dword != D_Proc)
  319.       fatalerr(-117, NULL);
  320.    PushDesc(globals[0]);
  321.  
  322.    /*
  323.     * Main is to be invoked with one argument, a list of the command
  324.     *  line arguments.    The command line arguments are pushed on the
  325.     *  stack as a series of descriptors and llist is called to create
  326.     *  the list.  The null descriptor first pushed serves as Arg0 for
  327.     *  Ollist and receives the result of the computation.
  328.     */
  329.    PushNull;
  330.    argp = (dptr)(sp - 1);
  331.    for (i = 2; i < argc; i++) {
  332.       slen = strlen(argv[i]);
  333.       strreq((word)slen);
  334.       PushVal(slen);
  335.       PushAVal(alcstr(argv[i],(word)slen));
  336.       }
  337.  
  338.    Ollist(argc - 2, argp);
  339.  
  340.    sp = (word *)argp + 1;
  341.    argp = 0;
  342.  
  343.    set_up = 1;            /* post fact that iconx is initialized */
  344.  
  345.    /*
  346.     * Start things rolling by calling interp.  This call to interp
  347.     *  returns only if an Op_Quit is executed.    If this happens,
  348.     *  c_exit() is called to wrap things up.
  349.     */
  350.  
  351. #ifdef CoProcesses
  352.    codisp();    /* start up co-expr dispatcher, which will call interp */
  353. #else                    /* CoProcesses */
  354.    interp(0,(dptr)NULL);                        /*      [[I?]] */
  355. #endif                    /* CoProcesses */
  356.  
  357.    c_exit(NormalExit);
  358. }
  359. #endif                    /* IconCalling */
  360.  
  361. #ifdef IconCalling
  362. dptr icon_call(pname, argc, dargv)
  363. char *pname;
  364. int argc;
  365. dptr dargv;
  366. {
  367.    int i;
  368.    dptr retdesc;
  369.    struct descrip pd;
  370.  
  371.    if (IDepth == 0)
  372.       {
  373.       /*
  374.        * Perform first-time initializations.
  375.        *  Point sp at word after b_coexpr block for &main, point ipc at initial
  376.        *  icode segment, and clear the gfp.
  377.        */
  378.       stackend = stack + mstksize/WordSize;
  379.       sp = stack + Wsizeof(struct b_coexpr);
  380.       sp--;   /* point at last thing on stack, not beyond it */
  381.  
  382.       interp_status = 0;
  383.       argp = 0;
  384.       pfp = 0;
  385.       ilevel = 0;
  386.       }
  387.  
  388.    /*
  389.     *  Point sp at word after b_coexpr block for &main, point ipc at initial
  390.     *    icode segment, and clear the gfp.
  391.     */
  392.    ipc.opnd = istart;
  393.    *ipc.op++ = Op_Invoke;
  394.    *ipc.opnd++ = argc;            /* number of arguments for call */
  395.  
  396. #ifdef WATERLOO_C_V3_0
  397.    /*
  398.     *  Workaround for compiler bug.
  399.     */
  400.    cw3defect = ipc.op;
  401.    *cw3defect = Op_Quit;
  402. #else                    /* WATERLOO_C_V3_0 */
  403.    *ipc.op = Op_Quit;
  404. #endif                    /* WATERLOO_C_V3_0 */
  405.  
  406.    ipc.opnd = istart;
  407.    gfp = 0;
  408.  
  409.    /*
  410.     * Set up expression frame marker to contain execution of the
  411.     *  main procedure.    If failure occurs in this context, control
  412.     *  is transferred to fterm, the address of an Op_FQuit.
  413.     */
  414.    efp = (struct ef_marker *)(sp + 1);
  415.    efp->ef_failure.op = &fterm;     /* signals a failure to interp */
  416.    efp->ef_gfp = 0;
  417.    efp->ef_efp = 0;
  418.    efp->ef_ilevel = ilevel + 1;
  419.    sp += Wsizeof(*efp);
  420.  
  421.    /*
  422.     * "main" is no longer the default starting procedure.
  423.     *  Use procedure named pname as the main (starting) procedure.
  424.     */
  425.    if (getvar(pname,&pd) == Failure) {
  426.       fprintf(stderr, "Icon function/procedure \"%s\" not found\n", pname);
  427.       fflush(stderr);
  428.       call_error = 1;
  429.       return (dptr)NULL;
  430.       }
  431.    DeRef(pd);            /* get value (can't fail) */
  432.  
  433.    /*
  434.     * Must be of type procedure.
  435.     */
  436.    if ((pd.dword != D_Proc)) { 
  437.       if (strcmp(pname,"main") == 0 && (pfp == 0))
  438.          fatalerr(-117, NULL);
  439.       else {
  440.          if (pfp == 0)
  441.             fatalerr(-106, NULL);
  442.          else
  443.             fatalerr(106, NULL);
  444.          }
  445.       }
  446.  
  447.    PushDesc(pd);
  448.  
  449.    /*
  450.     * The input arguments are pushed on the stack as a series
  451.     *  of descriptors and the indicated procedure.  The procedure descriptor
  452.     *  is overwritten with the result of the call.
  453.     */
  454.    for (i = 0; i < argc; i++) {           /* i = 0, instead of 2 */
  455.       PushDesc(dargv[i]);
  456.       }
  457.  
  458. /* Pass on value of argp to current invocation.  This will be 0 by
  459.  *  default on the first action, and the value of the current argp on
  460.  *  subsequent invocations.
  461.  */
  462.  
  463.    /*
  464.     * Start things rolling by calling interp.  This call to interp
  465.     *  returns only if an Op_Quit is executed.    If this happens,
  466.     *  return the result of main. (Used to c_exit here).
  467.     */
  468.    IDepth++;
  469.  
  470. #ifdef CoProcesses
  471.    codisp();        /* start up co-expr dispatcher, which calls interp */
  472. #else                    /* CoProcesses */
  473.    interp(0,(dptr)NULL);
  474. #endif                    /* CoProcesses */
  475.  
  476.    IDepth--;
  477.    if (interp_status == A_Pfail_uw)
  478.        return (dptr)NULL;        /* failure no value */
  479.    else                    /* NOTE: suspension not identified */
  480.        {
  481.        retdesc = (dptr)(sp - 1);
  482.        sp = (word *) efp - 1;
  483.        return retdesc;             /* success, return top sp */
  484.        }
  485.  
  486. }
  487. #endif                     /* IconCalling */
  488.  
  489. novalue icon_setup(argc,argv,ip)
  490. int argc;
  491. char **argv;
  492. int *ip;
  493.    {
  494.  
  495. #ifdef TallyOpt
  496.    extern int tallyopt;
  497. #endif                    /* TallyOpt */
  498.  
  499.    *ip = 0;            /* number of arguments processed */
  500.  
  501. #ifdef ExecImages
  502.    if (dumped) {
  503.       /*
  504.        * This is a restart of a dumped interpreter.  Normally, argv[0] is
  505.        *  iconx, argv[1] is the icode file, and argv[2:(argc-1)] are the
  506.        *  arguments to pass as a list to main().  For a dumped interpreter
  507.        *  however, argv[0] is the executable binary, and the first argument
  508.        *  for main() is argv[1].  The simplest way to handle this is to
  509.        *  back up argv to point at argv[-1] and increment argc, giving the
  510.        *  illusion of an additional argument at the head of the list.  Note
  511.        *  that this argument is never referenced.
  512.        */
  513.       argv--;
  514.       argc++;
  515.       (*ip)--;
  516.       }
  517. #endif                    /* ExecImages */
  518.  
  519. #ifdef MaxLevel
  520.    maxilevel = 0;
  521.    maxplevel = 0;
  522.    maxsp = 0;
  523. #endif                    /* MaxLevel */
  524.  
  525. #ifdef DumpIstream
  526.    imons = fopen("icodes.mon",WriteText);
  527.    if (imons == NULL) {
  528.       fprintf(stderr,"cannot open icodes.mon\n");
  529.       fflush(stderr);
  530.       abort();
  531.       }
  532. #endif                    /* DumpIstream */
  533.  
  534. #ifdef DumpIcount
  535.    imonc = fopen("icodec.mon",WriteText);
  536.    if (imonc == NULL) {
  537.       fprintf(stderr,"cannot open icodec.mon\n");
  538.       fflush(stderr);
  539.       abort();
  540.       }
  541. #endif                    /* DumpIcount */
  542.  
  543. #if MACINTOSH
  544. #if MPW
  545.    InitCursorCtl(NULL);
  546.    /*
  547.     * To support the icode and iconx interpreter bundled together in
  548.     * the same file, we might have to use this code file as the icode
  549.     * file, too.  We do this if the command name is not 'iconx'.
  550.     */
  551.    {
  552.    char *p,*q,c,fn[6];
  553.  
  554.    /*
  555.     * Isolate the filename from the path.
  556.     */
  557.    q = strrchr(*argv,':');
  558.    if (q == NULL)
  559.        q = *argv;
  560.    else
  561.        ++q;
  562.    /*
  563.     * See if it's the real iconx -- case independent compare.
  564.     */
  565.    p = fn;
  566.    if (strlen(q) == 5)
  567.       while (c = *q++) *p++ = tolower(c);
  568.    *p = '\0';
  569.    if (strcmp(fn,"iconx") != 0) {
  570.      /*
  571.       * This technique of shifting arguments relies on the fact that
  572.       * argv[0] is never referenced, since this will make it invalid.
  573.       */
  574.       --argv;
  575.       ++argc;
  576.       /*
  577.        * We don't want to look for any command line options in this
  578.        * case.  They could interfere with options for the icon
  579.        * program.
  580.        */
  581.       NoOptions = 1;
  582.       }
  583.    }
  584. #endif                    /* MPW */
  585. #endif                                  /* MACINTOSH */
  586.  
  587. /*
  588.  * Handle command-line options.
  589. */
  590.  
  591. /*
  592.  * Handle command line options.
  593. */
  594. #if MACINTOSH && MPW
  595.    if (!NoOptions)
  596.    while (!NoOptions && argv[1] != 0 && *argv[1] == '-' ) {
  597. #else                    /* MACINTOSH && MPW */
  598.    while ( argv[1] != 0 && *argv[1] == '-' ) {
  599. #endif                    /* MACINTOSH && MPW */
  600.       switch ( *(argv[1]+1) ) {
  601.  
  602. #ifdef TallyOpt
  603.     /*
  604.      * Set tallying flag if -T option given
  605.      */
  606.     case 'T':
  607.         tallyopt = 1;
  608.         break;
  609. #endif                    /* TallyOpt */
  610.  
  611.       /*
  612.        * Set stderr to new file if -e option is given.
  613.        */
  614.      case 'e': {
  615.         char *p;
  616.         if ( *(argv[1]+2) != '\0' )
  617.            p = argv[1]+2;
  618.         else {
  619.            argv++;
  620.            argc--;
  621.                (*ip)++;
  622.            p = argv[1];
  623.            if ( !p )
  624.           error("no file name given for redirection of &errout");
  625.            }
  626.         if ( *p == '-' ) { /* let - be stdout */
  627. /*
  628.  * The following code is operating-system dependent [@imain.02].  Redirect
  629.  *  stderr to stdout.
  630.  */
  631.  
  632. #if PORT
  633.    /* may not be possible */
  634. Deliberate Syntax Error
  635. #endif                    /* PORT */
  636.  
  637. #if ARM
  638.    /* Sorry, cannot do this */
  639. #endif                    /* ARM */
  640.  
  641. #if AMIGA
  642. #if AZTEC_C
  643.         /*
  644.          * Try the same hack as above for Manx and cross fingers.
  645.          * If it doesn't work, try trick used for HIGH_C, below.
  646.          */
  647.         stderr->_unit  = stdout->_unit;
  648.         stderr->_flags = stdout->_flags;
  649. #endif                    /* AZTEC C */
  650. #if LATTICE
  651.                /*
  652.                 * The following code is for Lattice 4.0.  It was different
  653.                 *  for Lattice 3.10 and probably won't work for other
  654.                 *  C compilers.
  655.                 */
  656.            stderr->_file = 1;
  657.            stderr->_flag = stdout->_flag;
  658. #endif                    /* LATTICE */
  659. #endif                    /* AMIGA */
  660.  
  661. #if ATARI_ST || MSDOS || OS2 || VMS
  662.                dup2(fileno(stdout),fileno(stderr));
  663. #endif                    /* ATARI_ST || MSDOS || OS2 ... */
  664.  
  665. #if HIGHC_386
  666.            /*
  667.             * Don't like doing this, but it seems to work.
  668.             */
  669.            setbuf(stdout,NULL);
  670.            setbuf(stderr,NULL);
  671.            stderr->_fd = stdout->_fd;        
  672. #endif                    /* HIGHC_386 */
  673.  
  674. #if MACINTOSH
  675. #if LSC
  676.    /* cannot do */
  677. #endif                    /* LSC */
  678. #if MPW
  679.                close(fileno(stderr));
  680.                dup(fileno(stdout));
  681. #endif                    /* MPW */
  682. #endif                                  /* MACINTOSH */
  683.  
  684. #if MVS || VM
  685.                /* Cannot do. */
  686. #endif                    /* MVS || VM */
  687.  
  688. #if UNIX
  689.                /*
  690.                 * This relies on the way UNIX assigns file numbers.
  691.                 */
  692.                close(fileno(stderr));
  693.                dup(fileno(stdout));
  694. #endif                    /* UNIX */
  695.  
  696. /*
  697.  * End of operating-system specific code.
  698.  */
  699.  
  700.             }
  701.          else    /* redirecting to named file */
  702.             if (freopen(p, "w", stderr) == NULL)
  703.                syserr("Unable to redirect &errout\n");
  704.         break;
  705.         }
  706.         }
  707.     argc--;
  708.         (*ip)++;
  709.     argv++;
  710.       }
  711.    }
  712.  
  713. /*
  714.  * icon_init - initialize memory and prepare for Icon execution.
  715.  */
  716.  
  717. novalue icon_init(name)
  718. char *name;
  719.    {
  720.    int n;
  721.    struct header hdr;
  722.    FILE *fname = NULL;
  723.    word cbread, longread();
  724.    extern struct astkblk *alcactiv();
  725.  
  726.    /*
  727.     * Catch floating point traps and memory faults.
  728.     */
  729.  
  730. /*
  731.  * The following code is operating-system dependent [@imain.03].  Set traps.
  732.  */
  733.  
  734. #if PORT
  735.    /* probably needs something */
  736. Deliberate Syntax Error
  737. #endif                    /* PORT */
  738.  
  739. #if AMIGA
  740.    signal(SIGFPE,fpetrap);
  741. #endif                    /* AMIGA */
  742.  
  743. #if ARM
  744.    signal(SIGFPE, (void (*)(int))fpetrap);
  745.    signal(SIGSEGV, (void (*)(int))segvtrap);
  746. #endif                    /* ARM */
  747.  
  748. #if ATARI_ST
  749. #endif                    /* ATARI_ST */
  750.  
  751. #if HIGHC_386
  752.    /* signals not supported */
  753. #endif                    /* HIGHC_386 */
  754.  
  755. #if MACINTOSH
  756. #if MPW
  757.    /* This is equivalent to SIGFPE signal in the Standard Apple
  758.       Numeric Environment (SANE) */
  759.    {
  760.    environment e;
  761.    getenvironment(&e);
  762. #ifdef mc68881
  763.       e.FPCR |= CURUNDERFLOW|CUROVERFLOW|CURDIVBYZERO;
  764. #else                    /* mc68881 */
  765.       e |= UNDERFLOW|OVERFLOW|DIVBYZERO;
  766. #endif                    /* mc68881 */
  767.    setenvironment(e);
  768. #ifdef mc68881
  769.       {
  770.       static trapvector tv =
  771.          {fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap};
  772.       settrapvector(&tv);
  773.       }
  774. #else                    /* mc6881 */
  775.       sethaltvector((haltvector)fpetrap);
  776. #endif                    /* mc6881 */
  777.    }
  778. #endif                    /* MPW */
  779. #endif                    /* MACINTOSH */
  780.  
  781. #if MSDOS
  782. #if LATTICE || MICROSOFT || TURBO
  783.    signal(SIGFPE, fpetrap);
  784. #endif                    /* LATTICE || MICROSOFT || TURBO */
  785. #endif                    /* MSDOS */
  786.  
  787. #if MVS || VM
  788. #if SASC
  789.    cosignal(SIGFPE, fpetrap);           /* catch in all coprocs */
  790.    cosignal(SIGSEGV, segvtrap);
  791. #endif                    /* SASC */
  792. #ifdef WATERLOO_C_V3_0
  793.    /* Note that the following is the same as SIGFPE except that it
  794.       doesn't capture significance exceptions (caused when ever
  795.       a floating point register is loaded with a 0.0 */
  796.    signal(( _FLOAT_UNDER + _FLOAT_OVER + _FLOAT_DIVIDE), fpetrap);
  797. #endif                    /* WATERLOO_C_V3_0 */
  798. #endif                                  /* MVS || VM */
  799.  
  800. #if OS2
  801.    signal(SIGFPE, fpetrap);
  802.    signal(SIGSEGV, segvtrap);
  803. #endif                    /* OS2 */
  804.  
  805. #if UNIX || VMS
  806.    signal(SIGSEGV, segvtrap);
  807. #ifdef PYRAMID
  808.    {
  809.    struct sigvec a;
  810.  
  811.    a.sv_handler = fpetrap;
  812.    a.sv_mask = 0;
  813.    a.sv_onstack = 0;
  814.    sigvec(SIGFPE, &a, 0);
  815.    sigsetmask(1 << SIGFPE);
  816.    }
  817. #else                    /* PYRAMID */
  818.    signal(SIGFPE, fpetrap);
  819. #endif                    /* PYRAMID */
  820. #endif                    /* UNIX || VMS */
  821.  
  822. /*
  823.  * End of operating-system specific code.
  824.  */
  825.  
  826. #ifdef ExecImages
  827.    /*
  828.     * If reloading from a dumped out executable, skip most of init and
  829.     *  just set up the buffer for stderr and do the timing initializations.
  830.     */
  831.    if (dumped)
  832.        goto btinit;
  833. #endif                    /* ExecImages */
  834.  
  835.    /*
  836.     * Initialize data that can't be intialized statically.
  837.     */
  838.  
  839.    datainit();
  840.  
  841.    /*
  842.     * Open the icode file and read the header.        [[I?]]
  843.     */
  844.  
  845.    if (!name)
  846.       error("no interpreter file supplied");
  847.  
  848.    /*
  849.     * Try adding the suffix if the file name doesn't end in it.
  850.     */
  851.    n = strlen(name);
  852.    if (n <= 4 || (strcmp(name+n-4,IcodeSuffix) != 0)
  853.    && strcmp(name+n-4,IcodeASuffix) != 0) {
  854.       char tname[100];
  855.       if (strlen(name) + 5 > 100)
  856.          error("icode file name too long");
  857.       strcpy(tname,name);
  858.  
  859. #if MVS                 /* for any compiler which allows PDS members */
  860.    {
  861.       char *p;
  862.       if (p = index(name, '(')) {
  863.          tname[p-name] = '\0';
  864.       }
  865. #endif                    /* MVS */
  866.  
  867. #ifdef WATERLOO_C_V3_0
  868.       strcat(tname," ICX * (BIN");
  869.       fname = fopen(tname,ReadText);
  870. #else                                   /* WATERLOO_C_V3_0 */
  871.       strcat(tname,IcodeSuffix);
  872. #if MVS
  873.       if (p) strcat(tname,p);
  874.    }
  875. #endif                    /* MVS */
  876.       fname = fopen(tname,ReadBinary);
  877. #endif                                  /* WATERLOO_C_V3_0 */
  878.       }
  879.  
  880.    if (fname == NULL)                /* try the name as given */
  881.  
  882. #ifdef WATERLOO_C_V3_0
  883.       {
  884.       /*
  885.        *  Prevent interpretation of \n in binary files.
  886.        */
  887.       char tname[100];
  888.       strcpy(tname,name);
  889.       strcat(tname," (BIN");
  890.       fname = fopen(tname,ReadText);
  891.       }
  892. #else                    /* WATERLOO_C_V3_0 */
  893.       fname = fopen(name,ReadBinary);
  894. #endif                    /* WATERLOO_C_V3_0 */
  895.  
  896.    if (fname == NULL)
  897.       error("cannot open interpreter file");
  898.  
  899.    setbuf(fname,icodebuf);
  900.  
  901. #ifdef Header
  902.    if (fseek(fname, (long)MaxHeader, 0) == -1)
  903.       error("can't read interpreter file header");
  904. #endif                    /* Header */
  905.  
  906.    if (fread((char *)&hdr, sizeof(char), sizeof(hdr), fname) != sizeof(hdr))
  907.       error("can't read interpreter file header");
  908.  
  909.  
  910.    k_trace = hdr.trace;
  911.  
  912.  
  913. #ifdef EnvVars
  914.    /*
  915.     * Examine the environment and make appropriate settings.    [[I?]]
  916.     */
  917.    envset();
  918. #endif                    /* EnvVars */
  919.  
  920.    /*
  921.     * Convert stack sizes from words to bytes.
  922.     */
  923.  
  924. #ifndef SCO_XENIX
  925.    stksize *= WordSize;
  926.    mstksize *= WordSize;
  927. #else                    /* SCO_XENIX */
  928.    /*
  929.     * This is a work-around for bad generated code for *= (as above)
  930.     *  produced by the SCO XENIX C Compiler for the large memory model.
  931.     *  It relies on the fact that WordSize is 4.
  932.     */
  933.    stksize += stksize;
  934.    stksize += stksize;
  935.    mstksize += mstksize;
  936.    mstksize += mstksize;
  937. #endif                    /* SCO_XENIX */
  938.  
  939. #if IntBits == 16
  940.    if (mstksize > MaxBlock)
  941.       fatalerr(-316, NULL);
  942.    if (stksize > MaxBlock)
  943.       fatalerr(-318, NULL);
  944. #endif                    /* IntBits == 16 */
  945.  
  946.    /*
  947.     * Allocate memory for various regions.
  948.     */
  949.    initalloc(hdr.hsize);
  950.  
  951.    /*
  952.     * Establish pointers to icode data regions.        [[I?]]
  953.     */
  954.  
  955.    records = (word *)(code + hdr.records);
  956.    ftabp = (word *)(code + hdr.ftab);
  957.    fnames = (dptr)(code + hdr.fnames);
  958.    globals = efnames = (dptr)(code + hdr.globals);
  959.    gnames = eglobals = (dptr)(code + hdr.gnames);
  960.    statics = egnames = (dptr)(code + hdr.statics);
  961.    estatics = (dptr)(code + hdr.filenms);
  962.    filenms = (struct ipc_fname *)estatics;
  963.    efilenms = (struct ipc_fname *)(code + hdr.linenums);
  964.    ilines = (struct ipc_line *)efilenms;
  965.    elines = (struct ipc_line *)(code + hdr.strcons);
  966.    strcons = (char *)elines;
  967.  
  968.    /*
  969.     * Allocate stack and initialize &main.
  970.     */
  971.  
  972.    stack = (word *)malloc((msize)mstksize);
  973.    if (stack == NULL)
  974.       fatalerr(-303, NULL);
  975.    mainhead = (struct b_coexpr *)stack;
  976.    mainhead->title = T_Coexpr;
  977.  
  978. #ifdef Coexpr
  979.    mainhead->es_actstk = alcactiv();
  980.    if (mainhead->es_actstk == NULL)
  981.       fatalerr(0, NULL);
  982.    if (pushact(mainhead, mainhead) == Error)
  983.       fatalerr(0, NULL);
  984. #endif                    /* Coexpr */
  985.  
  986.    mainhead->id = 1;
  987.    mainhead->size = 1;            /* pretend main() does an activation */
  988.  
  989.    mainhead->freshblk = nulldesc;    /* &main has no refresh block. */
  990.                     /*  This really is a bug. */
  991.  
  992.    /*
  993.     * Point &main at the co-expression block for the main procedure and set
  994.     *  k_current, the pointer to the current co-expression, to &main.
  995.     */
  996.    k_main.dword = D_Coexpr;
  997.    BlkLoc(k_main) = (union block *) mainhead;
  998.    k_current = k_main;
  999.    
  1000.    /*
  1001.     * Read the interpretable code and data into memory.
  1002.     */
  1003.  
  1004.    if ((cbread = longread(code, sizeof(char), (long)hdr.hsize, fname)) !=
  1005.       hdr.hsize) {
  1006.       fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n",
  1007.     (long)hdr.hsize,(long)cbread);
  1008.       error("can't read interpreter code");
  1009.       }
  1010.    fclose(fname);
  1011.  
  1012. /*
  1013.  * Make sure the version number of the icode matches the interpreter version.
  1014.  */
  1015.  
  1016.    if (strcmp((char *)hdr.config,IVersion)) {
  1017.       fprintf(stderr,"icode version mismatch\n");
  1018.       fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config);
  1019.       fprintf(stderr,"\texpected version: %s\n",IVersion);
  1020.       error("cannot run");
  1021.       }
  1022.  
  1023.    /*
  1024.     * Resolve references from icode to run-time system.
  1025.     */
  1026.    resolve();
  1027.  
  1028. #ifdef ExecImages
  1029. btinit:
  1030. #endif                    /* ExecImages */
  1031.  
  1032. /*
  1033.  * The following code is operating-system dependent [@imain.04].  Allocate and
  1034.  *  assign a buffer to stderr if possible.
  1035.  */
  1036.  
  1037. #if PORT
  1038.    /* probably nothing */
  1039. Deliberate Syntax Error
  1040. #endif                    /* PORT */
  1041.  
  1042. #if AMIGA || HIGHC_386 || MVS || VM
  1043.    /* not done */
  1044. #endif                    /* AMIGA */
  1045.  
  1046. #if ARM || ATARI_ST || MACINTOSH || UNIX || MSDOS || OS2 || VMS
  1047.  
  1048.    if (noerrbuf)
  1049.       setbuf(stderr, NULL);
  1050.    else {
  1051.       char *buf;
  1052.       
  1053.       buf = (char *)malloc((msize)BUFSIZ);
  1054.       if (buf == NULL)
  1055.         fatalerr(-305, NULL);
  1056.       setbuf(stderr, buf);
  1057.       }
  1058. #endif                    /* ARM || ATARI_ST || MACINTOSH || UNIX ... */
  1059.  
  1060. /*
  1061.  * End of operating-system specific code.
  1062.  */
  1063.  
  1064. #ifdef MemMon
  1065.    /*
  1066.     * Initialize the memory monitoring system, if configured.
  1067.     */
  1068.    MMInit(name);
  1069. #endif                    /* MemMon */
  1070.  
  1071. #ifdef EvalTrace
  1072.    /*
  1073.     * Initialize evaluation tracing system
  1074.     */
  1075.    TRInit(name);
  1076. #endif                    /* EvalTrace */
  1077.  
  1078.    /*
  1079.     * Start timing execution.
  1080.     */
  1081.  
  1082.    millisec();
  1083.    }
  1084.  
  1085. /*
  1086.  * Service routines related to getting things started.
  1087.  */
  1088.  
  1089. /*
  1090.  * resolve - perform various fix-ups on the data read from the icode
  1091.  *  file.
  1092.  */
  1093. novalue resolve()
  1094.    {
  1095.    register word i;
  1096.    register struct b_proc *pp;
  1097.    register dptr dp;
  1098.    extern Omkrec();
  1099.    extern int ftsize;
  1100.  
  1101.    extern struct b_proc *functab[];
  1102.  
  1103.    /*
  1104.     * Scan the global variable array for procedures and fill in appropriate
  1105.     *  addresses.
  1106.     */
  1107.    for (dp = globals; dp < eglobals; dp++) {
  1108.       if ((*dp).dword != D_Proc)
  1109.          continue;
  1110.  
  1111.       /*
  1112.        * The second word of the descriptor for procedure variables tells
  1113.        *  where the procedure is.  Negative values are used for built-in
  1114.        *  procedures and positive values are used for Icon procedures.
  1115.        */
  1116.       i = IntVal(*dp);
  1117.  
  1118.       if (i < 0) {
  1119.          /*
  1120.           * *dp names a built-in function, negate i and use it as an index
  1121.           *  into functab to get the location of the procedure block.
  1122.           */
  1123.          i = -i;
  1124.          if (i > ftsize) {
  1125.             *dp = nulldesc;        /* undefined, set to &null */
  1126.             continue;
  1127.             }
  1128.          BlkLoc(*dp) = (union block *)functab[i-1];
  1129.          }
  1130.       else {
  1131.  
  1132.          /*
  1133.           * *dp names an Icon procedure or a record.  i is an offset to
  1134.           *  location of the procedure block in the code section.  Point
  1135.           *  pp at the block and replace BlkLoc(*dp).
  1136.           */
  1137.          pp = (struct b_proc *)(code + i);
  1138.          BlkLoc(*dp) = (union block *)pp;
  1139.  
  1140.          /*
  1141.           * Relocate the address of the name of the procedure.
  1142.           */
  1143.          StrLoc(pp->pname) = strcons + (uword)StrLoc(pp->pname);
  1144.          if (pp->ndynam == -2)
  1145.             /*
  1146.              * This procedure is a record constructor.    Make its entry point
  1147.              *    be the entry point of Omkrec().
  1148.              */
  1149.             pp->entryp.ccode = Omkrec;
  1150.          else {
  1151.             /*
  1152.              * This is an Icon procedure.  Relocate the entry point and
  1153.              *    the names of the parameters, locals, and static variables.
  1154.              */
  1155.             pp->entryp.icode = code + pp->entryp.ioff;
  1156.             for (i = 0; i < abs((int)pp->nparam)+pp->ndynam+pp->nstatic; i++)
  1157.                StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]);
  1158.             }
  1159.  
  1160. #ifndef BoundFunctions
  1161.          }
  1162. #endif                    /* BoundFunctions */
  1163.  
  1164.       }
  1165.  
  1166.    /*
  1167.     * Relocate the names of the fields.
  1168.     */
  1169.  
  1170.    for (dp = fnames; dp < efnames; dp++)
  1171.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  1172.  
  1173.    /*
  1174.     * Relocate the names of the global variables.
  1175.     */
  1176.    for (dp = gnames; dp < egnames; dp++)
  1177.       StrLoc(*dp) = strcons + (uword)StrLoc(*dp);
  1178.  
  1179.    }
  1180.  
  1181. #ifdef EnvVars
  1182. /*
  1183.  * Check for environment variables that Icon uses and set system
  1184.  *  values as is appropriate.
  1185.  */
  1186. novalue envset()
  1187.    {
  1188.    register char *p;
  1189.  
  1190.    if ((p = getenv(NOERRBUF)) != NULL)
  1191.       noerrbuf++;
  1192.    env_int(TRACE, &k_trace, 0, (uword)0);
  1193.    env_int(COEXPSIZE, &stksize, 1, (uword)MaxUnsigned);
  1194.    env_int(STRSIZE, &ssize, 1, (uword)MaxBlock);
  1195.    env_int(HEAPSIZE, &abrsize, 1, (uword)MaxBlock);
  1196.    env_int(BLOCKSIZE, &abrsize, 1, (uword)MaxBlock);    /* synonym */
  1197.    env_int(BLKSIZE, &abrsize, 1, (uword)MaxBlock);    /* synonym */
  1198.    env_int(STATSIZE, &statsize, 1, (uword)MaxBlock);
  1199.    env_int(STATINCR, &statincr, 1, (uword)MaxBlock);
  1200.    env_int(MSTKSIZE, &mstksize, 1, (uword)MaxUnsigned);
  1201.  
  1202. #ifdef FixedRegions
  1203.    env_int(QLSIZE, &qualsize, 1, (uword)MaxBlock);
  1204. #endif                    /* FixedRegions */
  1205.  
  1206. /*
  1207.  * The following code is operating-system dependent [@imain.05].  Check any
  1208.  *  system-dependent environment variables.
  1209.  */
  1210.  
  1211. #if PORT
  1212.    /* nothing to do */
  1213. Deliberate Syntax Error
  1214. #endif                    /* PORT */
  1215.  
  1216. #if AMIGA
  1217.    if ((p = getenv("CHECKBREAK")) != NULL)
  1218.       chkbreak++;
  1219. #endif                    /* AMIGA */
  1220.  
  1221. #if ARM || ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || MVS || OS2 || UNIX || VM
  1222.    /* nothing to do */
  1223. #endif                    /* ARM || ATARI_ST || HIGHC_386 || ... */
  1224.  
  1225. #if VMS
  1226.    {
  1227.       extern word memsize;
  1228.       env_int("MAXMEM", &memsize, 1, MaxBlock);
  1229.    }
  1230. #endif                    /* VMS */
  1231.  
  1232. /*
  1233.  * End of operating-system specific code.
  1234.  */
  1235.  
  1236.    if ((p = getenv(ICONCORE)) != NULL && *p != '\0') {
  1237.  
  1238. /*
  1239.  * The following code is operating-system dependent [@imain.06].  Set trap to
  1240.  *  give dump on abnormal termination if ICONCORE is set.
  1241.  */
  1242.  
  1243. #if PORT
  1244.    /* can't handle */
  1245. Deliberate Syntax Error
  1246. #endif                    /* PORT */
  1247.  
  1248. #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH
  1249.    /* can't handle */
  1250. #endif                    /* AMIGA || ATARI_ST || ... */
  1251.  
  1252. #if MSDOS
  1253. #if LATTICE || TURBO
  1254.       signal(SIGFPE, SIG_DFL);
  1255. #endif                    /* LATTICE || TURBO */
  1256. #endif                    /* MSDOS */
  1257.  
  1258. #if MVS || VM
  1259.       /* Really nothing to do. */
  1260. #endif                    /* MVS || VM */
  1261.  
  1262. #if ARM || OS2
  1263.       signal(SIGSEGV, SIG_DFL);
  1264.       signal(SIGFPE, SIG_DFL);
  1265. #endif                    /* ARM || OS2 */
  1266.  
  1267. #if UNIX || VMS
  1268.       signal(SIGSEGV, SIG_DFL);
  1269. #endif                    /* UNIX || VMS */
  1270.  
  1271. /*
  1272.  * End of operating-system specific code.
  1273.  */
  1274.       dodump++;
  1275.       }
  1276.    }
  1277.  
  1278. static novalue env_err(msg, name, val)
  1279. char *msg;
  1280. char *name;
  1281. char *val;
  1282. {
  1283.    char msg_buf[100];
  1284.  
  1285.    strncpy(msg_buf, msg, 99);
  1286.    strncat(msg_buf, ": ", 99 - strlen(msg_buf));
  1287.    strncat(msg_buf, name, 99 - strlen(msg_buf));
  1288.    strncat(msg_buf, "=", 99 - strlen(msg_buf));
  1289.    strncat(msg_buf, val, 99 - strlen(msg_buf));
  1290.    error(msg_buf);
  1291. }
  1292.  
  1293. /*
  1294.  * env_int - get the value of an integer-valued environment variable.
  1295.  */
  1296. novalue env_int(name, variable, non_neg, limit)
  1297. char *name;
  1298. word *variable;
  1299. int non_neg;
  1300. uword limit;
  1301. {
  1302.    char *value;
  1303.    char *s;
  1304.    register uword n = 0;
  1305.    register uword d;
  1306.    int sign = 1;
  1307.  
  1308.    if ((value = getenv(name)) == NULL || *value == '\0')
  1309.       return;
  1310.  
  1311.    s = value;
  1312.    if (*s == '-') {
  1313.       if (non_neg)
  1314.          env_err("environment variable out of range", name, value);
  1315.       sign = -1;
  1316.       ++s;
  1317.       }
  1318.    else if (*s == '+')
  1319.       ++s;
  1320.    while (isdigit(*s)) {
  1321.       d = *s++ - '0';
  1322.       /*
  1323.        * See if 10 * n + d > limit, but do it so there can be no overflow.
  1324.        */
  1325.       if ((d > (uword)(limit / 10 - n) * 10 + limit % 10) && (limit > 0))
  1326.      env_err("environment variable out of range", name, value);
  1327.       n = n * 10 + d;
  1328.       }
  1329.    if (*s != '\0')
  1330.       env_err("environment variable not numeric", name, value);
  1331.    *variable = sign * n;
  1332. }
  1333. #endif                    /* EnvVars */
  1334.  
  1335. /*
  1336.  * Termination routines.
  1337.  */
  1338.  
  1339. /*
  1340.  * Produce run-time error 204 on floating-point traps.
  1341.  */
  1342.  
  1343. novalue fpetrap()
  1344.    {
  1345.    fatalerr(-204, NULL);
  1346.    }
  1347.  
  1348. /*
  1349.  * Produce run-time error 320 on ^C interrupts. Not used at present,
  1350.  *  since malfunction may occur during traceback.
  1351.  */
  1352. novalue inttrap()
  1353.    {
  1354.    fatalerr(-320, NULL);
  1355.    }
  1356.  
  1357. /*
  1358.  * Produce run-time error 302 on segmentation faults.
  1359.  */
  1360. novalue segvtrap()
  1361.    {
  1362.    fatalerr(-302, NULL);
  1363.    }
  1364.  
  1365. #if MVS || VM
  1366. novalue fixtrap()
  1367.    {
  1368.    fatalerror(-203, NULL);
  1369.    }
  1370. #endif                    /* MVS || VM */
  1371.  
  1372. /*
  1373.  * error - print error message s; used only in startup code.
  1374.  */
  1375. novalue error(s)
  1376. char *s;
  1377.    {
  1378.  
  1379.  
  1380.    fprintf(stderr, "error in startup code\n%s\n", s);
  1381.  
  1382.    fflush(stderr);
  1383.    if (dodump)
  1384.       abort();
  1385.    c_exit(ErrorExit);
  1386.    }
  1387.  
  1388. /*
  1389.  * syserr - print s as a system error.
  1390.  */
  1391. novalue syserr(s)
  1392. char *s;
  1393.    {
  1394.  
  1395.    
  1396.    if (pfp != 0)
  1397.       fprintf(stderr, "System error at line %ld in %s\n%s\n",
  1398.          (long)findline(ipc.opnd), findfile(ipc.opnd), s);
  1399.    else
  1400.       fprintf(stderr, "System error in startup code\n%s\n", s);
  1401.  
  1402.    fflush(stderr);
  1403.    if (dodump)
  1404.       abort();
  1405.    c_exit(ErrorExit);
  1406.    }
  1407.  
  1408. /*
  1409.  * runerr - print message corresponding to error |n|;  if n > 0,
  1410.  *  print it as the offending value.
  1411.  */
  1412.  
  1413. novalue runerr(n, v)
  1414.  
  1415. register int n;
  1416. dptr v;
  1417.    {
  1418.    register struct errtab *p;
  1419.  
  1420.    if (n != 0) {
  1421.       k_errornumber = n;
  1422.       if (n > 0)
  1423.          k_errorvalue = *v;
  1424.       else
  1425.          k_errorvalue = nulldesc;
  1426.       }
  1427.  
  1428.    /*
  1429.     * Take absolute value of error number
  1430.     */
  1431.    n = (k_errornumber > 0 ? k_errornumber : -k_errornumber);
  1432.  
  1433.    k_errortext = "";
  1434.    for (p = errtab; p->err_no > 0; p++)
  1435.       if (p->err_no == n) {
  1436.          k_errortext = p->errmsg;
  1437.          break;
  1438.          }
  1439.  
  1440.  
  1441.    if (pfp != 0) {
  1442.       if (k_error == 0) {
  1443.          fprintf(stderr, "Run-time error %d\nFile %s; Line %ld\n",
  1444.             n, findfile(ipc.opnd), (long)findline(ipc.opnd));
  1445.          }
  1446.       else {
  1447.          k_error--;
  1448.          return;
  1449.          }
  1450.       }
  1451.    else
  1452.       fprintf(stderr, "Run-time error %d in startup code\n", n);
  1453.    fprintf(stderr, "%s\n", k_errortext);
  1454.  
  1455.    if (k_errornumber > 0) {
  1456.       fprintf(stderr, "offending value: ");
  1457.       outimage(stderr, &k_errorvalue, 0);
  1458.       putc('\n', stderr);
  1459.       }
  1460.    fflush(stderr);
  1461.  
  1462. #ifdef MemMon
  1463.    {
  1464.       char buf[40];
  1465.       sprintf(buf,"Run-time error %d: ",n);
  1466.       MMTerm(buf,k_errortext);
  1467.    }
  1468. #endif                /* MemMon */
  1469.  
  1470. #ifdef EvalTrace
  1471.    {
  1472.       char buf[40];
  1473.       sprintf(buf,"Run-time error %d: ",n);
  1474.       TRTerm(buf,k_errortext);
  1475.    }
  1476. #endif                /* EvalTrace */
  1477.  
  1478. #ifdef TraceBack
  1479.    if (pfp == 0) {        /* skip if start-up problem */
  1480.       if (dodump)
  1481.          abort();
  1482.       c_exit(ErrorExit);
  1483.       }
  1484.  
  1485.    {
  1486.    struct pf_marker *origpfp = pfp;
  1487.    dptr arg;
  1488.    struct b_proc *cproc;
  1489.    inst cipc;
  1490.  
  1491.    fprintf(stderr, "Trace back:\n");
  1492.  
  1493.    /*
  1494.     * Chain back through the procedure frame markers, looking for the
  1495.     *  first one, while building a foward chain of pointers through
  1496.     *  the expression frame pointers.
  1497.     */
  1498.  
  1499.    for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) {
  1500.       (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp;
  1501.       }
  1502.  
  1503.    /* Now start from the base procedure frame marker, producing a listing
  1504.     *  of the procedure calls up through the last one.
  1505.     */
  1506.  
  1507.    while (pfp) {
  1508.       arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1];
  1509.       cproc = (struct b_proc *)BlkLoc(arg[0]);    
  1510.       /*
  1511.        * The ipc in the procedure frame points after the "invoke n".
  1512.        */
  1513.       cipc = pfp->pf_ipc;
  1514.       --cipc.opnd;
  1515.       --cipc.op;
  1516.  
  1517.       xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd),
  1518.          findfile(cipc.opnd));
  1519.       /*
  1520.        * On the last call, show both the call and the offending expression.
  1521.        */
  1522.       if (pfp == origpfp) {
  1523.          ttrace();
  1524.          break;
  1525.          }
  1526.  
  1527.       pfp = (struct pf_marker *)(pfp->pf_efp);
  1528.       }
  1529.    }
  1530. #endif                     /* TraceBack */
  1531.  
  1532.  
  1533.    if (dodump)
  1534.       abort();
  1535.    c_exit(ErrorExit);
  1536.    }
  1537.  
  1538. /*
  1539.  * c_exit(i) - flush all buffers and exit with status i.
  1540.  */
  1541. novalue c_exit(i)
  1542. int i;
  1543. {
  1544.  
  1545. #ifdef MemMon
  1546.    MMTerm("","");
  1547. #endif                    /* MemMon */
  1548.  
  1549. #ifdef EvalTrace
  1550.    TRTerm("","");
  1551. #endif                    /* EvalTrace */
  1552.  
  1553. #ifdef TallyOpt
  1554.    {
  1555.    int j;
  1556.  
  1557.    if (tallyopt) {
  1558.       fprintf(stderr,"tallies: ");
  1559.       for (j=0; j<16; j++)
  1560.          fprintf(stderr," %ld", (long)tallybin[j]);
  1561.          fprintf(stderr,"\n");
  1562.          }
  1563.       }
  1564. #endif                    /* TallyOpt */
  1565.  
  1566.  
  1567.    exit(i);
  1568. }
  1569.  
  1570. /*
  1571.  * err() is called if an erroneous situation occurs in the virtual
  1572.  *  machine code.  It is typed as int to avoid declaration problems
  1573.  *  elsewhere.
  1574.  */
  1575. int err()
  1576. {
  1577.    syserr("call to 'err'\n");
  1578.    return 1;        /* unreachable; make compilers happy */
  1579. }
  1580.  
  1581. novalue fatalerr(n, v)
  1582. int n;
  1583. dptr v;
  1584.    {
  1585.    k_error = 0;
  1586.    runerr(n, v);
  1587.    }
  1588.  
  1589. novalue datainit()
  1590.    {
  1591.  
  1592.    /*
  1593.     * Initializations that cannot be performed statically (at least for
  1594.     * some compilers).                    [[I?]]
  1595.     */
  1596.  
  1597.    k_errout.fd = stderr;
  1598.    k_errout.fname.dword = 7;
  1599.    StrLoc(k_errout.fname) = "&errout";
  1600.    k_errout.status = Fs_Write;
  1601.  
  1602.    k_input.fd = stdin;
  1603.    k_input.fname.dword = 6;
  1604.    StrLoc(k_input.fname) = "&input";
  1605.    k_input.status = Fs_Read;
  1606.  
  1607.    k_output.fd = stdout;
  1608.    k_output.fname.dword = 7;
  1609.    StrLoc(k_output.fname) = "&output";
  1610.    k_output.status = Fs_Write;
  1611.  
  1612.    IntVal(tvky_pos.kyval) = 1;
  1613.    StrLen(tvky_pos.kyname) = 4;
  1614.    StrLoc(tvky_pos.kyname) = "&pos";
  1615.  
  1616.    IntVal(tvky_ran.kyval) = 0;
  1617.    StrLen(tvky_ran.kyname) = 7;
  1618.    StrLoc(tvky_ran.kyname) = "&random";
  1619.  
  1620.    StrLen(tvky_sub.kyval) = 0;
  1621.    StrLoc(tvky_sub.kyval) = "";
  1622.    StrLen(tvky_sub.kyname) = 8;
  1623.    StrLoc(tvky_sub.kyname) = "&subject";
  1624.  
  1625.    IntVal(tvky_trc.kyval) = 0;
  1626.    StrLen(tvky_trc.kyname) = 6;
  1627.    StrLoc(tvky_trc.kyname) = "&trace";
  1628.  
  1629.    IntVal(tvky_err.kyval) = 0;
  1630.    StrLen(tvky_err.kyname) = 6;
  1631.    StrLoc(tvky_err.kyname) = "&error";
  1632.  
  1633.  
  1634.    StrLen(blank) = 1;
  1635.    StrLoc(blank) = " ";
  1636.    StrLen(emptystr) = 0;
  1637.    StrLoc(emptystr) = "";
  1638.    BlkLoc(errout) = (union block *) &k_errout;
  1639.    BlkLoc(input) = (union block *) &k_input;
  1640.    StrLen(lcase) = 26;
  1641.    StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz";
  1642.    StrLen(letr) = 1;
  1643.    StrLoc(letr) = "r";
  1644.    IntVal(nulldesc) = 0;
  1645.    k_errorvalue = nulldesc;
  1646.    IntVal(onedesc) = 1;
  1647.    StrLen(ucase) = 26;
  1648.    StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  1649.    IntVal(zerodesc) = 0;
  1650.  
  1651.    maps2 = nulldesc;
  1652.    maps3 = nulldesc;
  1653.  
  1654. #ifdef MultipleRuns
  1655.  
  1656.    mstksize = MStackSize;        /* initial size of main stack */
  1657.    stksize = StackSize;            /* co-expression stack size */
  1658.    ssize = MaxStrSpace;            /* initial string space size (bytes) */
  1659.    abrsize = MaxAbrSize;        /* initial size of allocated block
  1660.                          region (bytes) */                                    
  1661. #ifdef FixedRegions
  1662.    qualsize = QualLstSize;        /* size of quallist for fixed regions */
  1663. #endif                    /* FixedRegions */
  1664.  
  1665.    ntended = 0;                /* number of active tended descrips */
  1666.    dodump = 0;                /* produce dump on error */
  1667.    mterm = Op_Quit;
  1668.  
  1669. #ifdef IconCalling
  1670.    fterm = Op_FQuit;
  1671. #endif                    /* IconCalling */
  1672.  
  1673. #ifdef ExecImages
  1674.    dumped = 0;                /* This is a dumped image. */
  1675. #endif                    /* ExecImages */
  1676.  
  1677.                     /* In module interp.c:    */
  1678.    pfp = 0;                /* Procedure frame pointer */
  1679.    sp = NULL;                /* Stack pointer */
  1680.  
  1681.  
  1682.                     /* In module rmemmgt.c:    */
  1683.    coexp_ser = 2;
  1684.    list_ser = 1;
  1685.    set_ser = 1;
  1686.    table_ser = 1;
  1687.  
  1688.    coll_stat = 0;
  1689.    coll_str = 0;
  1690.    coll_blk = 0;
  1691.    coll_tot = 0;
  1692.    
  1693.  
  1694. #endif                    /* MultipleRuns */
  1695.    }
  1696.  
  1697.