home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / src / runtime / interp.r < prev    next >
Text File  |  2002-01-18  |  51KB  |  2,040 lines
  1. #if !COMPILER
  2. /*
  3.  * File: interp.r
  4.  *  The interpreter proper.
  5.  */
  6.  
  7. #include "../h/opdefs.h"
  8.  
  9. extern fptr fncentry[];
  10.  
  11.  
  12. /*
  13.  * Prototypes for static functions.
  14.  */
  15. #ifdef EventMon
  16. static struct ef_marker *vanq_bound (struct ef_marker *efp_v,
  17.                                       struct gf_marker *gfp_v);
  18. static void           vanq_proc (struct ef_marker *efp_v,
  19.                                      struct gf_marker *gfp_v);
  20. #endif                    /* EventMon */
  21.  
  22. /*
  23.  * The following code is operating-system dependent [@interp.01]. Declarations.
  24.  */
  25.  
  26. #if PORT
  27. Deliberate Syntax Error
  28. #endif                    /* PORT */
  29.  
  30. #if AMIGA
  31. #if LATTICE
  32. extern int chkbreak;
  33. #endif                    /* LATTICE */
  34. #endif                    /* AMIGA */
  35.  
  36. #if ARM || MACINTOSH || MSDOS || OS2 || UNIX || VMS
  37.    /* nothing needed */
  38. #endif                    /* ARM || ... */
  39.  
  40. /*
  41.  * End of operating-system specific code.
  42.  */
  43.  
  44. #ifndef MultiThread
  45. word lastop;            /* Last operator evaluated */
  46. #endif                    /* MultiThread */
  47.  
  48. /*
  49.  * Istate variables.
  50.  */
  51. struct ef_marker *efp;        /* Expression frame pointer */
  52. struct gf_marker *gfp;        /* Generator frame pointer */
  53. inst ipc;            /* Interpreter program counter */
  54. word *sp = NULL;        /* Stack pointer */
  55.  
  56.  
  57. #ifdef EventMon
  58. extern union {            /* clock ticker -- keep in sync w/ fmonitor.r */
  59.    unsigned short s[16];    /* 16 counters */
  60.    unsigned long l[8];        /* 8 longs are easier to check */
  61. } ticker;
  62. extern unsigned long oldtick;    /* previous sum of the two longs */
  63. #endif                    /* EventMon */
  64.  
  65.  
  66. int ilevel;            /* Depth of recursion in interp() */
  67. struct descrip value_tmp;    /* list argument to Op_Apply */
  68. struct descrip eret_tmp;    /* eret value during unwinding */
  69.  
  70. int coexp_act;            /* last co-expression action */
  71.  
  72. #ifndef MultiThread
  73. dptr xargp;
  74. word xnargs;
  75. #endif                    /* MultiThread */
  76.  
  77. /*
  78.  * Macros for use inside the main loop of the interpreter.
  79.  */
  80.  
  81. #ifdef EventMon
  82. #define E_Misc    -1
  83. #define E_Operator 0
  84. #define E_Function 1
  85. #endif                    /* EventMon */
  86.  
  87. /*
  88.  * Setup_Op sets things up for a call to the C function for an operator.
  89.  *  InterpEVValD expands to nothing if EventMon is not defined.
  90.  */
  91. #begdef Setup_Op(nargs)
  92. #ifdef EventMon
  93.    lastev = E_Operator;
  94.    value_tmp.dword = D_Proc;
  95.    value_tmp.vword.bptr = (union block *)&op_tbl[lastop - 1];
  96.    InterpEVValD(&value_tmp, E_Ocall);
  97. #endif                    /* EventMon */
  98.    rargp = (dptr)(rsp - 1) - nargs;
  99.    xargp = rargp;
  100.    ExInterp;
  101. #enddef                    /* Setup_Op */
  102.  
  103. /*
  104.  * Setup_Arg sets things up for a call to the C function.
  105.  *  It is the same as Setup_Op, except the latter is used only
  106.  *  operators.
  107.  */
  108. #begdef Setup_Arg(nargs)
  109. #ifdef EventMon
  110.    lastev = E_Misc;
  111. #endif                    /* EventMon */
  112.    rargp = (dptr)(rsp - 1) - nargs;
  113.    xargp = rargp;
  114.    ExInterp;
  115. #enddef                    /* Setup_Arg */
  116.  
  117. #begdef Call_Cond
  118.    if ((*(optab[lastop]))(rargp) == A_Resume) {
  119. #ifdef EventMon
  120.      InterpEVVal((word)-1, E_Ofail);
  121. #endif                    /* EventMon */
  122.      goto efail_noev;
  123.    }
  124.    rsp = (word *) rargp + 1;
  125. #ifdef EventMon
  126.    goto return_term;
  127. #else                    /* EventMon */
  128.    break;
  129. #endif                    /* EventMon */
  130. #enddef                    /* Call_Cond */
  131.  
  132. /*
  133.  * Call_Gen - Call a generator. A C routine associated with the
  134.  *  current opcode is called. When it when it terminates, control is
  135.  *  passed to C_rtn_term to deal with the termination condition appropriately.
  136.  */
  137. #begdef Call_Gen
  138.    signal = (*(optab[lastop]))(rargp);
  139.    goto C_rtn_term;
  140. #enddef                    /* Call_Gen */
  141.  
  142. /*
  143.  * GetWord fetches the next icode word.  PutWord(x) stores x at the current
  144.  * icode word.
  145.  */
  146. #define GetWord (*ipc.opnd++)
  147. #define PutWord(x) ipc.opnd[-1] = (x)
  148. #define GetOp (word)(*ipc.op++)
  149. #define PutOp(x) ipc.op[-1] = (x)
  150.  
  151. /*
  152.  * DerefArg(n) dereferences the nth argument.
  153.  */
  154. #define DerefArg(n)   Deref(rargp[n])
  155.  
  156. /*
  157.  * For the sake of efficiency, the stack pointer is kept in a register
  158.  *  variable, rsp, in the interpreter loop.  Since this variable is
  159.  *  only accessible inside the loop, and the global variable sp is used
  160.  *  for the stack pointer elsewhere, rsp must be stored into sp when
  161.  *  the context of the loop is left and conversely, rsp must be loaded
  162.  *  from sp when the loop is reentered.  The macros ExInterp and EntInterp,
  163.  *  respectively, handle these operations.  Currently, this register/global
  164.  *  scheme is only used for the stack pointer, but it can be easily extended
  165.  *  to other variables.
  166.  */
  167.  
  168. #define ExInterp    sp = rsp;
  169. #define EntInterp    rsp = sp;
  170.  
  171. /*
  172.  * Inside the interpreter loop, PushDesc, PushNull, PushAVal, and
  173.  *  PushVal use rsp instead of sp for efficiency.
  174.  */
  175.  
  176. #undef PushDesc
  177. #undef PushNull
  178. #undef PushVal
  179. #undef PushAVal
  180. #define PushDesc(d)   {*++rsp=((d).dword); *++rsp=((d).vword.integr);}
  181. #define PushNull   {*++rsp = D_Null; *++rsp = 0;}
  182. #define PushVal(v)   {*++rsp = (word)(v);}
  183.  
  184. /*
  185.  * The following code is operating-system dependent [@interp.02].  Define
  186.  *  PushAVal for computers that store longs and pointers differently.
  187.  */
  188.  
  189. #if PORT
  190. #define PushAVal(x) PushVal(x)
  191. Deliberate Syntax Error
  192. #endif                    /* PORT */
  193.  
  194. #if AMIGA || ARM || MACINTOSH || UNIX || VMS
  195. #define PushAVal(x) PushVal(x)
  196. #endif                    /* AMIGA || ARM || ... */
  197.  
  198. #if MSDOS || OS2
  199. #if HIGHC_386 || ZTC_386 || INTEL_386 || WATCOM || BORLAND_386 || SCCX_MX
  200. #define PushAVal(x) PushVal(x)
  201. #else                    /* HIGHC_386 || ZTC_386 || ... */
  202. #define PushAVal(x) {rsp++; \
  203.                stkword.stkadr = (char *)(x); \
  204.                *rsp = stkword.stkint; \
  205.                }
  206. #endif                    /* HIGH_386 || ZTC_386 || ... */
  207. #endif                    /* MSDOS || OS2 */
  208.  
  209. /*
  210.  * End of operating-system specific code.
  211.  */
  212.  
  213.  
  214. /*
  215.  * The main loop of the interpreter.
  216.  */
  217. int interp(fsig,cargp)
  218. int fsig;
  219. dptr cargp;
  220.    {
  221.    register word opnd;
  222.    register word *rsp;
  223.    register dptr rargp;
  224.    register struct ef_marker *newefp;
  225.    register struct gf_marker *newgfp;
  226.    register word *wd;
  227.    register word *firstwd, *lastwd;
  228.    word *oldsp;
  229.    int type, signal, args;
  230.    extern int (*optab[])();
  231.    extern int (*keytab[])();
  232.    struct b_proc *bproc;
  233. #ifdef EventMon
  234.    int lastev = E_Misc;
  235. #endif                    /* EventMon */
  236.  
  237. #ifdef TallyOpt
  238.    extern word tallybin[];
  239. #endif                    /* TallyOpt */
  240.  
  241. #ifdef EventMon
  242.    EVVal(fsig, E_Intcall);
  243.    EVVal(DiffPtrs(sp, stack), E_Stack);
  244. #endif                    /* EventMon */
  245.  
  246. #ifndef MultiThread
  247.    /*
  248.     * Make a stab at catching interpreter stack overflow.  This does
  249.     * nothing for invocation in a co-expression other than &main.
  250.     */
  251.    if (BlkLoc(k_current) == BlkLoc(k_main) &&
  252.       ((char *)sp + PerilDelta) > (char *)stackend)
  253.          fatalerr(301, NULL);
  254. #endif                    /* MultiThread */
  255.  
  256. #ifdef Polling
  257.    if (!pollctr--) {
  258.       pollctr = pollevent();
  259.       if (pollctr == -1) fatalerr(141, NULL);
  260.       }
  261. #endif                    /* Polling */
  262.  
  263.    ilevel++;
  264.  
  265.    EntInterp;
  266.  
  267. #ifdef EventMon
  268.    switch (fsig) {
  269.    case G_Csusp:
  270.    case G_Fsusp:
  271.    case G_Osusp:
  272.       value_tmp = *(dptr)(rsp - 1);    /* argument */
  273.       Deref(value_tmp);
  274.       InterpEVValD(&value_tmp,
  275.            (fsig == G_Fsusp)?E_Fsusp:(fsig == G_Osusp?E_Osusp:E_Bsusp));
  276. #else                    /* EventMon */
  277.    if (fsig == G_Csusp) {
  278. #endif                    /* EventMon */
  279.  
  280.       oldsp = rsp;
  281.  
  282.       /*
  283.        * Create the generator frame.
  284.        */
  285.       newgfp = (struct gf_marker *)(rsp + 1);
  286.       newgfp->gf_gentype = fsig;
  287.       newgfp->gf_gfp = gfp;
  288.       newgfp->gf_efp = efp;
  289.       newgfp->gf_ipc = ipc;
  290.       rsp += Wsizeof(struct gf_smallmarker);
  291.  
  292.       /*
  293.        * Region extends from first word after the marker for the generator
  294.        *  or expression frame enclosing the call to the now-suspending
  295.        *  routine to the first argument of the routine.
  296.        */
  297.       if (gfp != 0) {
  298.      if (gfp->gf_gentype == G_Psusp)
  299.         firstwd = (word *)gfp + Wsizeof(*gfp);
  300.      else
  301.         firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker);
  302.      }
  303.       else
  304.      firstwd = (word *)efp + Wsizeof(*efp);
  305.       lastwd = (word *)cargp + 1;
  306.  
  307.       /*
  308.        * Copy the portion of the stack with endpoints firstwd and lastwd
  309.        *  (inclusive) to the top of the stack.
  310.        */
  311.       for (wd = firstwd; wd <= lastwd; wd++)
  312.      *++rsp = *wd;
  313.       gfp = newgfp;
  314.       }
  315. /*
  316.  * Top of the interpreter loop.
  317.  */
  318.  
  319.    for (;;) {
  320.  
  321. #ifdef EventMon
  322. #if UNIX
  323.       if (ticker.l[0] + ticker.l[1] + ticker.l[2] + ticker.l[3] +
  324.       ticker.l[4] + ticker.l[5] + ticker.l[6] + ticker.l[7] != oldtick)
  325.      InterpEVTick();
  326. #endif                    /* UNIX */
  327.  
  328.    /*
  329.     * Location change events are generated by checking to see if the opcode
  330.     *  has changed indices in the "line number" (now line + column) table;
  331.     *  "straight line" forward code does not require a binary search to find
  332.     *  the new location; instead, a pointer is simply incremented.
  333.     *  Further optimization here is planned.
  334.     */
  335.    if (!is:null(curpstate->eventmask) && (
  336.        Testb((word)E_Loc, curpstate->eventmask) ||
  337.        Testb((word)E_Line, curpstate->eventmask)
  338.        )) {
  339.  
  340.       if (InRange(code, ipc.opnd, ecode)) {
  341.     uword ipc_offset = DiffPtrs((char *)ipc.opnd, (char *)code);
  342.     uword size;
  343.     word temp_no;
  344.     if (!current_line_ptr ||
  345.         current_line_ptr->ipc > ipc_offset ||
  346.         current_line_ptr[1].ipc <= ipc_offset) {
  347. #ifdef LineCodes
  348. #ifdef Polling
  349.             if (!pollctr--) {
  350.            ExInterp;
  351.                pollctr = pollevent();
  352.            EntInterp;
  353.            if (pollctr == -1) fatalerr(141, NULL);
  354.            }
  355. #endif                    /* Polling */
  356. #endif                /* LineCodes */
  357.  
  358.  
  359.         if(current_line_ptr &&
  360.            current_line_ptr + 2 < elines &&
  361.            current_line_ptr[1].ipc < ipc_offset &&
  362.            ipc_offset < current_line_ptr[2].ipc) {
  363.            current_line_ptr ++;
  364.            }
  365.         else {
  366.            current_line_ptr = ilines;
  367.            size = DiffPtrs((char *)elines, (char *)ilines) /
  368.           sizeof(struct ipc_line *);
  369.            while (size > 1) {
  370.           if (ipc_offset >= current_line_ptr[size>>1].ipc) {
  371.              current_line_ptr = ¤t_line_ptr[size>>1];
  372.              size -= (size >> 1);
  373.              }
  374.           else {
  375.              size >>= 1;
  376.              }
  377.           }
  378.            }
  379.         linenum = current_line_ptr->line;
  380.             temp_no = linenum & 65535;
  381.             if ((lastline & 65535) != temp_no) {
  382.                if (Testb((word)E_Line, curpstate->eventmask))
  383.                      if (temp_no)
  384.                         InterpEVVal(temp_no, E_Line);
  385.            }
  386.         if (lastline != linenum) {
  387.            lastline = linenum;
  388.            if (Testb((word)E_Loc, curpstate->eventmask) &&
  389.            current_line_ptr->line >> 16)
  390.           InterpEVVal(current_line_ptr->line, E_Loc);
  391.            }
  392.         }
  393.     }
  394.       }
  395. #endif                    /* EventMon */
  396.  
  397.       lastop = GetOp;        /* Instruction fetch */
  398.  
  399. #ifdef StackPic
  400.       ExInterp;
  401.       stkdump((int)lastop);
  402.       EntInterp;
  403. #endif                    /* StackPic */
  404.  
  405. /*
  406.  * The following code is operating-system dependent [@interp.03].  Check
  407.  *  for external event.
  408.  */
  409. #if PORT
  410. Deliberate Syntax Error
  411. #endif                    /* PORT */
  412.  
  413. #if AMIGA
  414. #if LATTICE
  415.       ExInterp;
  416.       if (chkbreak > 0)
  417.      chkabort();            /* check for CTRL-C or CTRL-D break */
  418.       EntInterp;
  419. #endif                    /* LATTICE */
  420. #endif                    /* AMIGA */
  421.  
  422. #if ARM || MSDOS || OS2 || UNIX || VMS
  423.    /* nothing to do */
  424. #endif                    /* ARM || ... */
  425.  
  426. #if MACINTOSH
  427. #if MPW
  428.    {
  429.       #define CursorCheckInterval 800 /* virtual machine instructions */
  430.       void RotateTheCursor(void);
  431.       static short cursorcount = 1;
  432.       if (--cursorcount == 0) {
  433.      RotateTheCursor();
  434.      cursorcount = CursorCheckInterval;
  435.      }
  436.    }
  437. #endif                    /* MPW */
  438. #endif                    /* MACINTOSH */
  439.  
  440. /*
  441.  * End of operating-system specific code.
  442.  */
  443.  
  444. #ifdef EventMon
  445.       /*
  446.        * If we've asked for ALL opcode events, or specifically for this one
  447.        * generate an MT-style event.
  448.        */
  449.       if ((!is:null(curpstate->eventmask) &&
  450.        Testb((word)E_Opcode, curpstate->eventmask)) &&
  451.       (is:null(curpstate->opcodemask) ||
  452.        Testb((word)lastop, curpstate->opcodemask))) {
  453.      ExInterp;
  454.      MakeInt(lastop, &(curpstate->parent->eventval));
  455.      actparent(E_Opcode);
  456.      EntInterp
  457.      }
  458. #endif                    /* EventMon */
  459.  
  460.       switch ((int)lastop) {        /*
  461.                  * Switch on opcode.  The cases are
  462.                  * organized roughly by functionality
  463.                  * to make it easier to find things.
  464.                  * For some C compilers, there may be
  465.                  * an advantage to arranging them by
  466.                  * likelihood of selection.
  467.                  */
  468.  
  469.                 /* ---Constant construction--- */
  470.  
  471.      case Op_Cset:        /* cset */
  472.         PutOp(Op_Acset);
  473.         PushVal(D_Cset);
  474.         opnd = GetWord;
  475.         opnd += (word)ipc.opnd;
  476.         PutWord(opnd);
  477.         PushAVal(opnd);
  478.         break;
  479.  
  480.      case Op_Acset:        /* cset, absolute address */
  481.         PushVal(D_Cset);
  482.         PushAVal(GetWord);
  483.         break;
  484.  
  485.      case Op_Int:        /* integer */
  486.         PushVal(D_Integer);
  487.         PushVal(GetWord);
  488.         break;
  489.  
  490.      case Op_Real:        /* real */
  491.         PutOp(Op_Areal);
  492.         PushVal(D_Real);
  493.         opnd = GetWord;
  494.         opnd += (word)ipc.opnd;
  495.         PushAVal(opnd);
  496.         PutWord(opnd);
  497.         break;
  498.  
  499.      case Op_Areal:        /* real, absolute address */
  500.         PushVal(D_Real);
  501.         PushAVal(GetWord);
  502.         break;
  503.  
  504.      case Op_Str:        /* string */
  505.         PutOp(Op_Astr);
  506.         PushVal(GetWord)
  507.         opnd = (word)strcons + GetWord;
  508.         PutWord(opnd);
  509.         PushAVal(opnd);
  510.         break;
  511.  
  512.      case Op_Astr:        /* string, absolute address */
  513.         PushVal(GetWord);
  514.         PushAVal(GetWord);
  515.         break;
  516.  
  517.                 /* ---Variable construction--- */
  518.  
  519.      case Op_Arg:        /* argument */
  520.         PushVal(D_Var);
  521.         PushAVal(&glbl_argp[GetWord + 1]);
  522.         break;
  523.  
  524.      case Op_Global:    /* global */
  525.         PutOp(Op_Aglobal);
  526.         PushVal(D_Var);
  527.         opnd = GetWord;
  528.         PushAVal(&globals[opnd]);
  529.         PutWord((word)&globals[opnd]);
  530.         break;
  531.  
  532.      case Op_Aglobal:    /* global, absolute address */
  533.         PushVal(D_Var);
  534.         PushAVal(GetWord);
  535.         break;
  536.  
  537.      case Op_Local:        /* local */
  538.         PushVal(D_Var);
  539.         PushAVal(&pfp->pf_locals[GetWord]);
  540.         break;
  541.  
  542.      case Op_Static:    /* static */
  543.         PutOp(Op_Astatic);
  544.         PushVal(D_Var);
  545.         opnd = GetWord;
  546.         PushAVal(&statics[opnd]);
  547.         PutWord((word)&statics[opnd]);
  548.         break;
  549.  
  550.      case Op_Astatic:    /* static, absolute address */
  551.         PushVal(D_Var);
  552.         PushAVal(GetWord);
  553.         break;
  554.  
  555.  
  556.                 /* ---Operators--- */
  557.  
  558.                 /* Unary operators */
  559.  
  560.      case Op_Compl:        /* ~e */
  561.      case Op_Neg:        /* -e */
  562.      case Op_Number:    /* +e */
  563.      case Op_Refresh:    /* ^e */
  564.      case Op_Size:        /* *e */
  565.         Setup_Op(1);
  566.         DerefArg(1);
  567.         Call_Cond;
  568.  
  569.      case Op_Value:        /* .e */
  570.             Setup_Op(1);
  571.             DerefArg(1);
  572.             Call_Cond;
  573.  
  574.      case Op_Nonnull:    /* \e */
  575.      case Op_Null:        /* /e */
  576.         Setup_Op(1);
  577.         Call_Cond;
  578.  
  579.      case Op_Random:    /* ?e */
  580.         PushNull;
  581.         Setup_Op(2)
  582.         Call_Cond
  583.  
  584.                 /* Generative unary operators */
  585.  
  586.      case Op_Tabmat:    /* =e */
  587.         Setup_Op(1);
  588.         DerefArg(1);
  589.         Call_Gen;
  590.  
  591.      case Op_Bang:        /* !e */
  592.         PushNull;
  593.         Setup_Op(2);
  594.         Call_Gen;
  595.  
  596.                 /* Binary operators */
  597.  
  598.      case Op_Cat:        /* e1 || e2 */
  599.      case Op_Diff:        /* e1 -- e2 */
  600.      case Op_Div:        /* e1 / e2 */
  601.      case Op_Inter:        /* e1 ** e2 */
  602.      case Op_Lconcat:    /* e1 ||| e2 */
  603.      case Op_Minus:        /* e1 - e2 */
  604.      case Op_Mod:        /* e1 % e2 */
  605.      case Op_Mult:        /* e1 * e2 */
  606.      case Op_Power:        /* e1 ^ e2 */
  607.      case Op_Unions:    /* e1 ++ e2 */
  608.      case Op_Plus:        /* e1 + e2 */
  609.      case Op_Eqv:        /* e1 === e2 */
  610.      case Op_Lexeq:        /* e1 == e2 */
  611.      case Op_Lexge:        /* e1 >>= e2 */
  612.      case Op_Lexgt:        /* e1 >> e2 */
  613.      case Op_Lexle:        /* e1 <<= e2 */
  614.      case Op_Lexlt:        /* e1 << e2 */
  615.      case Op_Lexne:        /* e1 ~== e2 */
  616.      case Op_Neqv:        /* e1 ~=== e2 */
  617.      case Op_Numeq:        /* e1 = e2 */
  618.      case Op_Numge:        /* e1 >= e2 */
  619.      case Op_Numgt:        /* e1 > e2 */
  620.      case Op_Numle:        /* e1 <= e2 */
  621.      case Op_Numne:        /* e1 ~= e2 */
  622.      case Op_Numlt:        /* e1 < e2 */
  623.         Setup_Op(2);
  624.         DerefArg(1);
  625.         DerefArg(2);
  626.         Call_Cond;
  627.  
  628.      case Op_Asgn:        /* e1 := e2 */
  629.         Setup_Op(2);
  630.         Call_Cond;
  631.  
  632.      case Op_Swap:        /* e1 :=: e2 */
  633.         PushNull;
  634.         Setup_Op(3);
  635.         Call_Cond;
  636.  
  637.      case Op_Subsc:        /* e1[e2] */
  638.         PushNull;
  639.         Setup_Op(3);
  640.         Call_Cond;
  641.                 /* Generative binary operators */
  642.  
  643.      case Op_Rasgn:        /* e1 <- e2 */
  644.         Setup_Op(2);
  645.         Call_Gen;
  646.  
  647.      case Op_Rswap:        /* e1 <-> e2 */
  648.         PushNull;
  649.         Setup_Op(3);
  650.         Call_Gen;
  651.  
  652.                 /* Conditional ternary operators */
  653.  
  654.      case Op_Sect:        /* e1[e2:e3] */
  655.         PushNull;
  656.         Setup_Op(4);
  657.         Call_Cond;
  658.                 /* Generative ternary operators */
  659.  
  660.      case Op_Toby:        /* e1 to e2 by e3 */
  661.         Setup_Op(3);
  662.         DerefArg(1);
  663.         DerefArg(2);
  664.         DerefArg(3);
  665.         Call_Gen;
  666.  
  667.          case Op_Noop:        /* no-op */
  668.  
  669. #ifdef LineCodes
  670. #ifdef Polling
  671.             if (!pollctr--) {
  672.            ExInterp;
  673.                pollctr = pollevent();
  674.            EntInterp;
  675.            if (pollctr == -1) fatalerr(141, NULL);
  676.            }
  677. #endif                    /* Polling */
  678.  
  679.  
  680. #endif                /* LineCodes */
  681.  
  682.             break;
  683.  
  684.  
  685.          case Op_Colm:        /* source column number */
  686.             {
  687. #ifdef EventMon
  688.             word loc;
  689.             column = GetWord;
  690.             loc = column;
  691.             loc <<= (WordBits >> 1);    /* column in high-order part */
  692.             loc += linenum;
  693.             InterpEVVal(loc, E_Loc);
  694. #endif                    /* EventMon */
  695.             break;
  696.             }
  697.  
  698.          case Op_Line:        /* source line number */
  699.  
  700. #ifdef LineCodes
  701. #ifdef Polling
  702.             if (!pollctr--) {
  703.            ExInterp;
  704.                pollctr = pollevent();
  705.            EntInterp;
  706.            if (pollctr == -1) fatalerr(141, NULL);
  707.            }
  708. #endif                    /* Polling */
  709.  
  710.  
  711. #endif                /* LineCodes */
  712.  
  713. #ifdef EventMon
  714.             linenum = GetWord;
  715.             lastline = linenum;
  716. #endif                    /* EventMon */
  717.  
  718.             break;
  719.  
  720.                 /* ---String Scanning--- */
  721.  
  722.      case Op_Bscan:        /* prepare for scanning */
  723.         PushDesc(k_subject);
  724.         PushVal(D_Integer);
  725.         PushVal(k_pos);
  726.         Setup_Arg(2);
  727.  
  728.         signal = Obscan(2,rargp);
  729.  
  730.         goto C_rtn_term;
  731.  
  732.      case Op_Escan:        /* exit from scanning */
  733.         Setup_Arg(1);
  734.  
  735.         signal = Oescan(1,rargp);
  736.  
  737.         goto C_rtn_term;
  738.  
  739.                 /* ---Other Language Operations--- */
  740.  
  741.          case Op_Apply: {    /* apply */
  742.             union block *bp;
  743.             int i, j;
  744.  
  745.             value_tmp = *(dptr)(rsp - 1);    /* argument */
  746.             Deref(value_tmp);
  747.             switch (Type(value_tmp)) {
  748.                case T_List: {
  749.                   rsp -= 2;                /* pop it off */
  750.                   bp = BlkLoc(value_tmp);
  751.                   args = (int)bp->list.size;
  752.  
  753. #ifndef MultiThread
  754.                  /*
  755.                   * Make a stab at catching interpreter stack overflow.
  756.                   * This does nothing for invocation in a co-expression other
  757.                   * than &main.
  758.                   */
  759.                  if (BlkLoc(k_current) == BlkLoc(k_main) &&
  760.                     ((char *)sp + args * sizeof(struct descrip) >
  761.                        (char *)stackend))
  762.                           fatalerr(301, NULL);
  763. #endif                    /* MultiThread */
  764.  
  765.                   for (bp = bp->list.listhead;
  766. #ifdef ListFix
  767.                BlkType(bp) == T_Lelem;
  768. #else                    /* ListFix */
  769.                bp != NULL;
  770. #endif                    /* ListFix */
  771.                      bp = bp->lelem.listnext) {
  772.                         for (i = 0; i < bp->lelem.nused; i++) {
  773.                            j = bp->lelem.first + i;
  774.                            if (j >= bp->lelem.nslots)
  775.                               j -= bp->lelem.nslots;
  776.                            PushDesc(bp->lelem.lslots[j])
  777.                            }
  778.                         }
  779.           goto invokej;
  780.           }
  781.  
  782.                case T_Record: {
  783.                   rsp -= 2;        /* pop it off */
  784.                   bp = BlkLoc(value_tmp);
  785.                   args = bp->record.recdesc->proc.nfields;
  786.                   for (i = 0; i < args; i++) {
  787.                      PushDesc(bp->record.fields[i])
  788.                      }
  789.                   goto invokej;
  790.                   }
  791.  
  792.                default: {        /* illegal type for invocation */
  793.  
  794.                   xargp = (dptr)(rsp - 3);
  795.                   err_msg(126, &value_tmp);
  796.                   goto efail;
  797.                   }
  798.                }
  799.         }
  800.  
  801.      case Op_Invoke: {    /* invoke */
  802.             args = (int)GetWord;
  803. invokej:
  804.         {
  805.             int nargs;
  806.         dptr carg;
  807.  
  808.         ExInterp;
  809.         type = invoke(args, &carg, &nargs);
  810.         EntInterp;
  811.  
  812.         if (type == I_Fail)
  813.            goto efail_noev;
  814.         if (type == I_Continue)
  815.            break;
  816.         else {
  817.  
  818.                rargp = carg;        /* valid only for Vararg or Builtin */
  819.  
  820. #ifdef Polling
  821.            /*
  822.         * Do polling here
  823.         */
  824.            pollctr >>= 1;
  825.                if (!pollctr) {
  826.               ExInterp;
  827.                   pollctr = pollevent();
  828.               EntInterp;
  829.               if (pollctr == -1) fatalerr(141, NULL);
  830.               }
  831. #endif                    /* Polling */
  832.  
  833. #ifdef EventMon
  834.            lastev = E_Function;
  835.            InterpEVValD(rargp, E_Fcall);
  836. #endif                    /* EventMon */
  837.  
  838.            bproc = (struct b_proc *)BlkLoc(*rargp);
  839.  
  840. #ifdef FncTrace
  841.                typedef int (*bfunc2)(dptr, struct descrip *);
  842. #endif                    /* FncTrace */
  843.  
  844.  
  845.            /* ExInterp not needed since no change since last EntInterp */
  846.            if (type == I_Vararg) {
  847.               int (*bfunc)();
  848.                   bfunc = bproc->entryp.ccode;
  849.  
  850. #ifdef FncTrace
  851.                   signal = (*bfunc)(nargs, rargp, &(procs->pname));
  852. #else                    /* FncTrace */
  853.           signal = (*bfunc)(nargs,rargp);
  854. #endif                    /* FncTrace */
  855.  
  856.                   }
  857.            else
  858.                   {
  859.                   int (*bfunc)();
  860.                   bfunc = bproc->entryp.ccode;
  861.  
  862. #ifdef FncTrace
  863.                   signal = (*(bfunc2)bfunc)(rargp, &(bproc->pname));
  864. #else                    /* FncTrace */
  865.           signal = (*bfunc)(rargp);
  866. #endif                    /* FncTrace */
  867.                   }
  868.  
  869. #ifdef FncTrace
  870.                if (k_ftrace) {
  871.                   k_ftrace--;
  872.                   if (signal == A_Failure)
  873.                      failtrace(&(bproc->pname));
  874.                   else
  875.                      rtrace(&(bproc->pname),rargp);
  876.                   }
  877. #endif                    /* FncTrace */
  878.  
  879.            goto C_rtn_term;
  880.            }
  881.         }
  882.         }
  883.  
  884.      case Op_Keywd:        /* keyword */
  885.  
  886.             PushNull;
  887.             opnd = GetWord;
  888.             Setup_Arg(0);
  889.  
  890.         signal = (*(keytab[(int)opnd]))(rargp);
  891.         goto C_rtn_term;
  892.  
  893.      case Op_Llist:        /* construct list */
  894.         opnd = GetWord;
  895.  
  896. #ifdef EventMon
  897.             lastev = E_Operator;
  898.             value_tmp.dword = D_Proc;
  899.             value_tmp.vword.bptr = (union block *)&mt_llist;
  900.             InterpEVValD(&value_tmp, E_Ocall);
  901.             rargp = (dptr)(rsp - 1) - opnd;
  902.             xargp = rargp;
  903.             ExInterp;
  904. #else                    /* EventMon */
  905.         Setup_Arg(opnd);
  906. #endif                    /* EventMon */
  907.  
  908.         {
  909.         int i;
  910.         for (i=1;i<=opnd;i++)
  911.                DerefArg(i);
  912.         }
  913.  
  914.         signal = Ollist((int)opnd,rargp);
  915.  
  916.         goto C_rtn_term;
  917.  
  918.                 /* ---Marking and Unmarking--- */
  919.  
  920.      case Op_Mark:        /* create expression frame marker */
  921.         PutOp(Op_Amark);
  922.         opnd = GetWord;
  923.         opnd += (word)ipc.opnd;
  924.         PutWord(opnd);
  925.         newefp = (struct ef_marker *)(rsp + 1);
  926.         newefp->ef_failure.opnd = (word *)opnd;
  927.         goto mark;
  928.  
  929.      case Op_Amark:        /* mark with absolute fipc */
  930.         newefp = (struct ef_marker *)(rsp + 1);
  931.         newefp->ef_failure.opnd = (word *)GetWord;
  932. mark:
  933.         newefp->ef_gfp = gfp;
  934.         newefp->ef_efp = efp;
  935.         newefp->ef_ilevel = ilevel;
  936.         rsp += Wsizeof(*efp);
  937.         efp = newefp;
  938.         gfp = 0;
  939.         break;
  940.  
  941.      case Op_Mark0:        /* create expression frame with 0 ipl */
  942. mark0:
  943.         newefp = (struct ef_marker *)(rsp + 1);
  944.         newefp->ef_failure.opnd = 0;
  945.         newefp->ef_gfp = gfp;
  946.         newefp->ef_efp = efp;
  947.         newefp->ef_ilevel = ilevel;
  948.         rsp += Wsizeof(*efp);
  949.         efp = newefp;
  950.         gfp = 0;
  951.         break;
  952.  
  953.      case Op_Unmark:    /* remove expression frame */
  954.  
  955. #ifdef EventMon
  956.         ExInterp;
  957.             vanq_bound(efp, gfp);
  958.         EntInterp;
  959. #endif                    /* EventMon */
  960.  
  961.         gfp = efp->ef_gfp;
  962.         rsp = (word *)efp - 1;
  963.  
  964.         /*
  965.          * Remove any suspended C generators.
  966.          */
  967. Unmark_uw:
  968.         if (efp->ef_ilevel < ilevel) {
  969.            --ilevel;
  970.  
  971.            ExInterp;
  972.  
  973. #ifdef EventMon
  974.            EVVal(A_Unmark_uw, E_Intret);
  975.                EVVal(DiffPtrs(sp, stack), E_Stack);
  976. #endif                    /* EventMon */
  977.  
  978.            return A_Unmark_uw;
  979.            }
  980.  
  981.         efp = efp->ef_efp;
  982.         break;
  983.  
  984.                 /* ---Suspensions--- */
  985.  
  986.      case Op_Esusp: {    /* suspend from expression */
  987.  
  988.         /*
  989.          * Create the generator frame.
  990.          */
  991.         oldsp = rsp;
  992.         newgfp = (struct gf_marker *)(rsp + 1);
  993.         newgfp->gf_gentype = G_Esusp;
  994.         newgfp->gf_gfp = gfp;
  995.         newgfp->gf_efp = efp;
  996.         newgfp->gf_ipc = ipc;
  997.         gfp = newgfp;
  998.         rsp += Wsizeof(struct gf_smallmarker);
  999.  
  1000.         /*
  1001.          * Region extends from first word after enclosing generator or
  1002.          *    expression frame marker to marker for current expression frame.
  1003.          */
  1004.         if (efp->ef_gfp != 0) {
  1005.            newgfp = (struct gf_marker *)(efp->ef_gfp);
  1006.            if (newgfp->gf_gentype == G_Psusp)
  1007.           firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  1008.            else
  1009.           firstwd = (word *)efp->ef_gfp +
  1010.              Wsizeof(struct gf_smallmarker);
  1011.         }
  1012.         else
  1013.            firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  1014.         lastwd = (word *)efp - 1;
  1015.         efp = efp->ef_efp;
  1016.  
  1017.         /*
  1018.          * Copy the portion of the stack with endpoints firstwd and lastwd
  1019.          *    (inclusive) to the top of the stack.
  1020.          */
  1021.         for (wd = firstwd; wd <= lastwd; wd++)
  1022.            *++rsp = *wd;
  1023.         PushVal(oldsp[-1]);
  1024.         PushVal(oldsp[0]);
  1025.         break;
  1026.         }
  1027.  
  1028.      case Op_Lsusp: {    /* suspend from limitation */
  1029.         struct descrip sval;
  1030.  
  1031.         /*
  1032.          * The limit counter is contained in the descriptor immediately
  1033.          *    prior to the current expression frame.    lval is established
  1034.          *    as a pointer to this descriptor.
  1035.          */
  1036.         dptr lval = (dptr)((word *)efp - 2);
  1037.  
  1038.         /*
  1039.          * Decrement the limit counter and check it.
  1040.          */
  1041.         if (--IntVal(*lval) > 0) {
  1042.            /*
  1043.         * The limit has not been reached, set up stack.
  1044.         */
  1045.  
  1046.            sval = *(dptr)(rsp - 1);    /* save result */
  1047.  
  1048.            /*
  1049.         * Region extends from first word after enclosing generator or
  1050.         *  expression frame marker to the limit counter just prior to
  1051.         *  to the current expression frame marker.
  1052.         */
  1053.            if (efp->ef_gfp != 0) {
  1054.           newgfp = (struct gf_marker *)(efp->ef_gfp);
  1055.           if (newgfp->gf_gentype == G_Psusp)
  1056.              firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  1057.           else
  1058.              firstwd = (word *)efp->ef_gfp +
  1059.             Wsizeof(struct gf_smallmarker);
  1060.           }
  1061.            else
  1062.           firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  1063.            lastwd = (word *)efp - 3;
  1064.            if (gfp == 0)
  1065.           gfp = efp->ef_gfp;
  1066.            efp = efp->ef_efp;
  1067.  
  1068.            /*
  1069.         * Copy the portion of the stack with endpoints firstwd and lastwd
  1070.         *  (inclusive) to the top of the stack.
  1071.         */
  1072.            rsp -= 2;        /* overwrite result */
  1073.            for (wd = firstwd; wd <= lastwd; wd++)
  1074.           *++rsp = *wd;
  1075.            PushDesc(sval);        /* push saved result */
  1076.            }
  1077.         else {
  1078.            /*
  1079.         * Otherwise, the limit has been reached.  Instead of
  1080.         *  suspending, remove the current expression frame and
  1081.         *  replace the limit counter with the value on top of
  1082.         *  the stack (which would have been suspended had the
  1083.         *  limit not been reached).
  1084.         */
  1085.            *lval = *(dptr)(rsp - 1);
  1086.  
  1087. #ifdef EventMon
  1088.            ExInterp;
  1089.                vanq_bound(efp, gfp);
  1090.            EntInterp;
  1091. #endif                    /* EventMon */
  1092.  
  1093.            gfp = efp->ef_gfp;
  1094.  
  1095.            /*
  1096.         * Since an expression frame is being removed, inactive
  1097.         *  C generators contained therein are deactivated.
  1098.         */
  1099. Lsusp_uw:
  1100.            if (efp->ef_ilevel < ilevel) {
  1101.           --ilevel;
  1102.           ExInterp;
  1103.  
  1104. #ifdef EventMon
  1105.                   EVVal(A_Lsusp_uw, E_Intret);
  1106.                   EVVal(DiffPtrs(sp, stack), E_Stack);
  1107. #endif                    /* EventMon */
  1108.  
  1109.           return A_Lsusp_uw;
  1110.           }
  1111.            rsp = (word *)efp - 1;
  1112.            efp = efp->ef_efp;
  1113.            }
  1114.         break;
  1115.         }
  1116.  
  1117.      case Op_Psusp: {    /* suspend from procedure */
  1118.  
  1119.         /*
  1120.          * An Icon procedure is suspending a value.  Determine if the
  1121.          *    value being suspended should be dereferenced and if so,
  1122.          *    dereference it. If tracing is on, strace is called
  1123.          *  to generate a message.  Appropriate values are
  1124.          *    restored from the procedure frame of the suspending procedure.
  1125.          */
  1126.  
  1127.         struct descrip tmp;
  1128.             dptr svalp;
  1129.         struct b_proc *sproc;
  1130.  
  1131. #ifdef EventMon
  1132.             value_tmp = *(dptr)(rsp - 1);    /* argument */
  1133.             Deref(value_tmp);
  1134.             InterpEVValD(&value_tmp, E_Psusp);
  1135. #endif                    /* EventMon */
  1136.  
  1137.         svalp = (dptr)(rsp - 1);
  1138.         if (Var(*svalp)) {
  1139.                ExInterp;
  1140.                retderef(svalp, (word *)glbl_argp, sp);
  1141.                EntInterp;
  1142.                }
  1143.  
  1144.         /*
  1145.          * Create the generator frame.
  1146.          */
  1147.         oldsp = rsp;
  1148.         newgfp = (struct gf_marker *)(rsp + 1);
  1149.         newgfp->gf_gentype = G_Psusp;
  1150.         newgfp->gf_gfp = gfp;
  1151.         newgfp->gf_efp = efp;
  1152.         newgfp->gf_ipc = ipc;
  1153.         newgfp->gf_argp = glbl_argp;
  1154.         newgfp->gf_pfp = pfp;
  1155.         gfp = newgfp;
  1156.         rsp += Wsizeof(*gfp);
  1157.  
  1158.         /*
  1159.          * Region extends from first word after the marker for the
  1160.          *    generator or expression frame enclosing the call to the
  1161.          *    now-suspending procedure to Arg0 of the procedure.
  1162.          */
  1163.         if (pfp->pf_gfp != 0) {
  1164.            newgfp = (struct gf_marker *)(pfp->pf_gfp);
  1165.            if (newgfp->gf_gentype == G_Psusp)
  1166.           firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp);
  1167.            else
  1168.           firstwd = (word *)pfp->pf_gfp +
  1169.              Wsizeof(struct gf_smallmarker);
  1170.            }
  1171.         else
  1172.            firstwd = (word *)pfp->pf_efp + Wsizeof(*efp);
  1173.         lastwd = (word *)glbl_argp - 1;
  1174.            efp = efp->ef_efp;
  1175.  
  1176.         /*
  1177.          * Copy the portion of the stack with endpoints firstwd and lastwd
  1178.          *    (inclusive) to the top of the stack.
  1179.          */
  1180.         for (wd = firstwd; wd <= lastwd; wd++)
  1181.            *++rsp = *wd;
  1182.         PushVal(oldsp[-1]);
  1183.         PushVal(oldsp[0]);
  1184.         --k_level;
  1185.         if (k_trace) {
  1186.                k_trace--;
  1187.            sproc = (struct b_proc *)BlkLoc(*glbl_argp);
  1188.            strace(&(sproc->pname), svalp);
  1189.            }
  1190.  
  1191.         /*
  1192.          * If the scanning environment for this procedure call is in
  1193.          *    a saved state, switch environments.
  1194.          */
  1195.         if (pfp->pf_scan != NULL) {
  1196.  
  1197. #ifdef EventMon
  1198.            InterpEVValD(&k_subject, E_Ssusp);
  1199. #endif                    /* EventMon */
  1200.  
  1201.            tmp = k_subject;
  1202.            k_subject = *pfp->pf_scan;
  1203.            *pfp->pf_scan = tmp;
  1204.  
  1205.            tmp = *(pfp->pf_scan + 1);
  1206.            IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1207.            k_pos = IntVal(tmp);
  1208.            }
  1209.  
  1210. #ifdef MultiThread
  1211.         /*
  1212.          * If the program state changed for this procedure call,
  1213.          * change back.
  1214.          */
  1215.         ENTERPSTATE(pfp->pf_prog);
  1216. #endif                    /* MultiThread */
  1217.  
  1218.         efp = pfp->pf_efp;
  1219.         ipc = pfp->pf_ipc;
  1220.         glbl_argp = pfp->pf_argp;
  1221.         pfp = pfp->pf_pfp;
  1222.         break;
  1223.         }
  1224.  
  1225.                 /* ---Returns--- */
  1226.  
  1227.      case Op_Eret: {    /* return from expression */
  1228.         /*
  1229.          * Op_Eret removes the current expression frame, leaving the
  1230.          *    original top of stack value on top.
  1231.          */
  1232.         /*
  1233.          * Save current top of stack value in global temporary (no
  1234.          *    danger of reentry).
  1235.          */
  1236.         eret_tmp = *(dptr)&rsp[-1];
  1237.         gfp = efp->ef_gfp;
  1238. Eret_uw:
  1239.         /*
  1240.          * Since an expression frame is being removed, inactive
  1241.          *    C generators contained therein are deactivated.
  1242.          */
  1243.         if (efp->ef_ilevel < ilevel) {
  1244.            --ilevel;
  1245.            ExInterp;
  1246.  
  1247. #ifdef EventMon
  1248.                EVVal(A_Eret_uw, E_Intret);
  1249.                EVVal(DiffPtrs(sp, stack), E_Stack);
  1250. #endif                    /* EventMon */
  1251.  
  1252.            return A_Eret_uw;
  1253.            }
  1254.         rsp = (word *)efp - 1;
  1255.         efp = efp->ef_efp;
  1256.         PushDesc(eret_tmp);
  1257.         break;
  1258.         }
  1259.  
  1260.  
  1261.      case Op_Pret: {    /* return from procedure */
  1262. #ifdef EventMon
  1263.        struct descrip oldargp;
  1264.        static struct descrip unwinder;
  1265. #endif                    /* EventMon */
  1266.  
  1267.         /*
  1268.          * An Icon procedure is returning a value.    Determine if the
  1269.          *    value being returned should be dereferenced and if so,
  1270.          *    dereference it.  If tracing is on, rtrace is called to
  1271.          *    generate a message.  Inactive generators created after
  1272.          *    the activation of the procedure are deactivated.  Appropriate
  1273.          *    values are restored from the procedure frame.
  1274.          */
  1275.         struct b_proc *rproc;
  1276.         rproc = (struct b_proc *)BlkLoc(*glbl_argp);
  1277. #ifdef EventMon
  1278.             oldargp = *glbl_argp;
  1279.         ExInterp;
  1280.             vanq_proc(efp, gfp);
  1281.         EntInterp;
  1282.         /* used to InterpEVValD(argp,E_Pret); here */
  1283. #endif                    /* EventMon */
  1284.  
  1285.         *glbl_argp = *(dptr)(rsp - 1);
  1286.         if (Var(*glbl_argp)) {
  1287.                ExInterp;
  1288.                retderef(glbl_argp, (word *)glbl_argp, sp);
  1289.                EntInterp;
  1290.                }
  1291.  
  1292.         --k_level;
  1293.         if (k_trace) {
  1294.                k_trace--;
  1295.            rtrace(&(rproc->pname), glbl_argp);
  1296.                }
  1297. Pret_uw:
  1298.         if (pfp->pf_ilevel < ilevel) {
  1299.            --ilevel;
  1300.            ExInterp;
  1301.  
  1302. #ifdef EventMon
  1303.                EVVal(A_Pret_uw, E_Intret);
  1304.                EVVal(DiffPtrs(sp, stack), E_Stack);
  1305.            unwinder = oldargp;
  1306. #endif                    /* EventMon */
  1307.  
  1308.            return A_Pret_uw;
  1309.            }
  1310.  
  1311. #ifdef EventMon
  1312.        if (!is:proc(oldargp) && is:proc(unwinder))
  1313.           oldargp = unwinder;
  1314. #endif                    /* EventMon */
  1315.         rsp = (word *)glbl_argp + 1;
  1316.         efp = pfp->pf_efp;
  1317.         gfp = pfp->pf_gfp;
  1318.         ipc = pfp->pf_ipc;
  1319.         glbl_argp = pfp->pf_argp;
  1320.         pfp = pfp->pf_pfp;
  1321.  
  1322. #ifdef MultiThread
  1323.         if (pfp)
  1324.            ENTERPSTATE(pfp->pf_prog);
  1325. #ifdef EventMon
  1326.             value_tmp = *(dptr)(rsp - 1);    /* argument */
  1327.             Deref(value_tmp);
  1328.             InterpEVValD(&value_tmp, E_Pret);
  1329. #endif                    /* EventMon */
  1330. #endif                    /* MultiThread */
  1331.         break;
  1332.         }
  1333.  
  1334.                 /* ---Failures--- */
  1335.  
  1336.      case Op_Efail:
  1337. efail:
  1338. #ifdef EventMon
  1339.             InterpEVVal((word)-1, E_Efail);
  1340. #endif                    /* EventMon */
  1341. efail_noev:
  1342.         /*
  1343.          * Failure has occurred in the current expression frame.
  1344.          */
  1345.         if (gfp == 0) {
  1346.            /*
  1347.         * There are no suspended generators to resume.
  1348.         *  Remove the current expression frame, restoring
  1349.         *  values.
  1350.         *
  1351.         * If the failure ipc is 0, propagate failure to the
  1352.         *  enclosing frame by branching back to efail.
  1353.         *  This happens, for example, in looping control
  1354.         *  structures that fail when complete.
  1355.         */
  1356.  
  1357. #ifdef MultiThread
  1358.           if (efp == 0) {
  1359.          break;
  1360.              }
  1361. #endif                    /* MultiThread */
  1362.  
  1363.            ipc = efp->ef_failure;
  1364.            gfp = efp->ef_gfp;
  1365.            rsp = (word *)efp - 1;
  1366.            efp = efp->ef_efp;
  1367.  
  1368.            if (ipc.op == 0)
  1369.           goto efail;
  1370.            break;
  1371.            }
  1372.  
  1373.         else {
  1374.            /*
  1375.         * There is a generator that can be resumed.  Make
  1376.         *  the stack adjustments and then switch on the
  1377.         *  type of the generator frame marker.
  1378.         */
  1379.            struct descrip tmp;
  1380.            register struct gf_marker *resgfp = gfp;
  1381.  
  1382.            type = (int)resgfp->gf_gentype;
  1383.  
  1384.            if (type == G_Psusp) {
  1385.           glbl_argp = resgfp->gf_argp;
  1386.           if (k_trace) {    /* procedure tracing */
  1387.                      k_trace--;
  1388.              ExInterp;
  1389.              atrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname));
  1390.              EntInterp;
  1391.              }
  1392.           }
  1393.            ipc = resgfp->gf_ipc;
  1394.            efp = resgfp->gf_efp;
  1395.            gfp = resgfp->gf_gfp;
  1396.            rsp = (word *)resgfp - 1;
  1397.            if (type == G_Psusp) {
  1398.           pfp = resgfp->gf_pfp;
  1399.  
  1400.           /*
  1401.            * If the scanning environment for this procedure call is
  1402.            *  supposed to be in a saved state, switch environments.
  1403.            */
  1404.           if (pfp->pf_scan != NULL) {
  1405.              tmp = k_subject;
  1406.              k_subject = *pfp->pf_scan;
  1407.              *pfp->pf_scan = tmp;
  1408.  
  1409.              tmp = *(pfp->pf_scan + 1);
  1410.              IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1411.              k_pos = IntVal(tmp);
  1412.  
  1413. #ifdef EventMon
  1414.              InterpEVValD(&k_subject, E_Sresum);
  1415. #endif                    /* EventMon */
  1416.              }
  1417.  
  1418. #ifdef MultiThread
  1419.           /*
  1420.            * Enter the program state of the resumed frame
  1421.            */
  1422.           ENTERPSTATE(pfp->pf_prog);
  1423. #endif                    /* MultiThread */
  1424.  
  1425.           ++k_level;        /* adjust procedure level */
  1426.           }
  1427.  
  1428.            switch (type) {
  1429.  
  1430. #ifdef EventMon
  1431.           case G_Fsusp:
  1432.                      InterpEVVal((word)0, E_Fresum);
  1433.              --ilevel;
  1434.              ExInterp;
  1435.                      EVVal(A_Resume, E_Intret);
  1436.                      EVVal(DiffPtrs(sp, stack), E_Stack);
  1437.              return A_Resume;
  1438.  
  1439.           case G_Osusp:
  1440.                      InterpEVVal((word)0, E_Oresum);
  1441.              --ilevel;
  1442.              ExInterp;
  1443.                      EVVal(A_Resume, E_Intret);
  1444.                      EVVal(DiffPtrs(sp, stack), E_Stack);
  1445.              return A_Resume;
  1446. #endif                    /* EventMon */
  1447.  
  1448.           case G_Csusp:
  1449.                      InterpEVVal((word)0, E_Eresum);
  1450.              --ilevel;
  1451.              ExInterp;
  1452. #ifdef EventMon
  1453.                      EVVal(A_Resume, E_Intret);
  1454.                      EVVal(DiffPtrs(sp, stack), E_Stack);
  1455. #endif                    /* EventMon */
  1456.              return A_Resume;
  1457.  
  1458.           case G_Esusp:
  1459.                      InterpEVVal((word)0, E_Eresum);
  1460.              goto efail_noev;
  1461.  
  1462.           case G_Psusp:        /* resuming a procedure */
  1463.                      InterpEVValD(glbl_argp, E_Presum);
  1464.              break;
  1465.           }
  1466.  
  1467.            break;
  1468.            }
  1469.  
  1470.      case Op_Pfail: {    /* fail from procedure */
  1471.  
  1472. #ifdef EventMon
  1473.         ExInterp;
  1474.             vanq_proc(efp, gfp);
  1475.             EVValD(glbl_argp, E_Pfail);
  1476.         EntInterp;
  1477. #endif                    /* EventMon */
  1478.  
  1479.         /*
  1480.          * An Icon procedure is failing.  Generate tracing message if
  1481.          *    tracing is on.    Deactivate inactive C generators created
  1482.          *    after activation of the procedure.  Appropriate values
  1483.          *    are restored from the procedure frame.
  1484.          */
  1485.  
  1486.         --k_level;
  1487.         if (k_trace) {
  1488.                k_trace--;
  1489.            failtrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname));
  1490.                }
  1491. Pfail_uw:
  1492.  
  1493.         if (pfp->pf_ilevel < ilevel) {
  1494.            --ilevel;
  1495.            ExInterp;
  1496. #ifdef EventMon
  1497.                EVVal(A_Pfail_uw, E_Intret);
  1498.                EVVal(DiffPtrs(sp, stack), E_Stack);
  1499. #endif                    /* EventMon */
  1500.            return A_Pfail_uw;
  1501.            }
  1502.         efp = pfp->pf_efp;
  1503.         gfp = pfp->pf_gfp;
  1504.         ipc = pfp->pf_ipc;
  1505.         glbl_argp = pfp->pf_argp;
  1506.         pfp = pfp->pf_pfp;
  1507.  
  1508. #ifdef MultiThread
  1509.         /*
  1510.          * Enter the program state of the procedure being reentered.
  1511.          * A NULL pfp indicates the program is complete.
  1512.          */
  1513.         if (pfp) {
  1514.            ENTERPSTATE(pfp->pf_prog);
  1515.            }
  1516. #endif                    /* MultiThread */
  1517.  
  1518.         goto efail_noev;
  1519.         }
  1520.                 /* ---Odds and Ends--- */
  1521.  
  1522.      case Op_Ccase:        /* case clause */
  1523.         PushNull;
  1524.         PushVal(((word *)efp)[-2]);
  1525.         PushVal(((word *)efp)[-1]);
  1526.         break;
  1527.  
  1528.      case Op_Chfail:    /* change failure ipc */
  1529.         opnd = GetWord;
  1530.         opnd += (word)ipc.opnd;
  1531.         efp->ef_failure.opnd = (word *)opnd;
  1532.         break;
  1533.  
  1534.      case Op_Dup:        /* duplicate descriptor */
  1535.         PushNull;
  1536.         rsp[1] = rsp[-3];
  1537.         rsp[2] = rsp[-2];
  1538.         rsp += 2;
  1539.         break;
  1540.  
  1541.      case Op_Field:        /* e1.e2 */
  1542.         PushVal(D_Integer);
  1543.         PushVal(GetWord);
  1544.         Setup_Arg(2);
  1545.  
  1546.         signal = Ofield(2,rargp);
  1547.  
  1548.         goto C_rtn_term;
  1549.  
  1550.      case Op_Goto:        /* goto */
  1551.         PutOp(Op_Agoto);
  1552.         opnd = GetWord;
  1553.         opnd += (word)ipc.opnd;
  1554.         PutWord(opnd);
  1555.         ipc.opnd = (word *)opnd;
  1556.         break;
  1557.  
  1558.      case Op_Agoto:        /* goto absolute address */
  1559.         opnd = GetWord;
  1560.         ipc.opnd = (word *)opnd;
  1561.         break;
  1562.  
  1563.      case Op_Init:        /* initial */
  1564.         *--ipc.op = Op_Goto;
  1565.         opnd = sizeof(*ipc.op) + sizeof(*rsp);
  1566.         opnd += (word)ipc.opnd;
  1567.         ipc.opnd = (word *)opnd;
  1568.         break;
  1569.  
  1570.      case Op_Limit:        /* limit */
  1571.         Setup_Arg(0);
  1572.  
  1573.         if (Olimit(0,rargp) == A_Resume) {
  1574.  
  1575.            /*
  1576.         * limit has failed here; could generate an event for it,
  1577.         *  but not an Ofail since limit is not an operator and
  1578.         *  no Ocall was ever generated for it.
  1579.         */
  1580.            goto efail_noev;
  1581.            }
  1582.         else {
  1583.            /*
  1584.         * limit has returned here; could generate an event for it,
  1585.         *  but not an Oret since limit is not an operator and
  1586.         *  no Ocall was ever generated for it.
  1587.         */
  1588.            rsp = (word *) rargp + 1;
  1589.            }
  1590.         goto mark0;
  1591.  
  1592. #ifdef TallyOpt
  1593.      case Op_Tally:        /* tally */
  1594.         tallybin[GetWord]++;
  1595.         break;
  1596. #endif                    /* TallyOpt */
  1597.  
  1598.      case Op_Pnull:        /* push null descriptor */
  1599.         PushNull;
  1600.         break;
  1601.  
  1602.      case Op_Pop:        /* pop descriptor */
  1603.         rsp -= 2;
  1604.         break;
  1605.  
  1606.      case Op_Push1:        /* push integer 1 */
  1607.         PushVal(D_Integer);
  1608.         PushVal(1);
  1609.         break;
  1610.  
  1611.      case Op_Pushn1:    /* push integer -1 */
  1612.         PushVal(D_Integer);
  1613.         PushVal(-1);
  1614.         break;
  1615.  
  1616.      case Op_Sdup:        /* duplicate descriptor */
  1617.         rsp += 2;
  1618.         rsp[-1] = rsp[-3];
  1619.         rsp[0] = rsp[-2];
  1620.         break;
  1621.  
  1622.                     /* ---Co-expressions--- */
  1623.  
  1624.      case Op_Create:    /* create */
  1625.  
  1626. #ifdef Coexpr
  1627.         PushNull;
  1628.         Setup_Arg(0);
  1629.         opnd = GetWord;
  1630.         opnd += (word)ipc.opnd;
  1631.  
  1632.         signal = Ocreate((word *)opnd, rargp);
  1633.  
  1634.         goto C_rtn_term;
  1635. #else                    /* Coexpr */
  1636.         err_msg(401, NULL);
  1637.         goto efail;
  1638. #endif                    /* Coexpr */
  1639.  
  1640.      case Op_Coact: {    /* @e */
  1641.  
  1642. #ifndef Coexpr
  1643.             err_msg(401, NULL);
  1644.             goto efail;
  1645. #else                                        /* Coexpr */
  1646.             struct b_coexpr *ncp;
  1647.             dptr dp;
  1648.  
  1649.             ExInterp;
  1650.             dp = (dptr)(sp - 1);
  1651.             xargp = dp - 2;
  1652.  
  1653.             Deref(*dp);
  1654.             if (dp->dword != D_Coexpr) {
  1655.                err_msg(118, dp);
  1656.                goto efail;
  1657.                }
  1658.  
  1659.             ncp = (struct b_coexpr *)BlkLoc(*dp);
  1660.  
  1661.             signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3));
  1662.             EntInterp;
  1663.             if (signal == A_Resume)
  1664.                goto efail_noev;
  1665.             else
  1666.                rsp -= 2;
  1667. #endif                    /* Coexpr */
  1668.             break;
  1669.         }
  1670.  
  1671.      case Op_Coret: {    /* return from co-expression */
  1672.  
  1673. #ifndef Coexpr
  1674.             syserr("co-expression return, but co-expressions not implemented");
  1675. #else                                        /* Coexpr */
  1676.             struct b_coexpr *ncp;
  1677.  
  1678.             ExInterp;
  1679.             ncp = popact((struct b_coexpr *)BlkLoc(k_current));
  1680.  
  1681.             ++BlkLoc(k_current)->coexpr.size;
  1682.             co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1);
  1683.             EntInterp;
  1684. #endif                    /* Coexpr */
  1685.             break;
  1686.  
  1687.         }
  1688.  
  1689.      case Op_Cofail: {    /* fail from co-expression */
  1690.  
  1691. #ifndef Coexpr
  1692.             syserr("co-expression failure, but co-expressions not implemented");
  1693. #else                                        /* Coexpr */
  1694.             struct b_coexpr *ncp;
  1695.  
  1696.             ExInterp;
  1697.             ncp = popact((struct b_coexpr *)BlkLoc(k_current));
  1698.  
  1699.             co_chng(ncp, NULL, NULL, A_Cofail, 1);
  1700.             EntInterp;
  1701. #endif                    /* Coexpr */
  1702.             break;
  1703.  
  1704.         }
  1705.          case Op_Quit:        /* quit */
  1706.  
  1707.  
  1708.         goto interp_quit;
  1709.  
  1710.  
  1711.      default: {
  1712.         char buf[50];
  1713.  
  1714.         sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n",
  1715.                (long)lastop, lastop);
  1716.         syserr(buf);
  1717.         }
  1718.      }
  1719.      continue;
  1720.  
  1721. C_rtn_term:
  1722.      EntInterp;
  1723.  
  1724.      switch (signal) {
  1725.  
  1726.         case A_Resume:
  1727. #ifdef EventMon
  1728.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1729.           InterpEVVal((word)-1,
  1730.                   ((lastev == E_Function)? E_Ffail : E_Ofail));
  1731.           lastev = E_Misc;
  1732.           }
  1733. #endif                    /* EventMon */
  1734.            goto efail_noev;
  1735.  
  1736.         case A_Unmark_uw:        /* unwind for unmark */
  1737. #ifdef EventMon
  1738.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1739.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1740.           lastev = E_Misc;
  1741.           }
  1742. #endif                    /* EventMon */
  1743.            goto Unmark_uw;
  1744.  
  1745.         case A_Lsusp_uw:        /* unwind for lsusp */
  1746. #ifdef EventMon
  1747.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1748.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1749.           lastev = E_Misc;
  1750.           }
  1751. #endif                    /* EventMon */
  1752.            goto Lsusp_uw;
  1753.  
  1754.         case A_Eret_uw:        /* unwind for eret */
  1755. #ifdef EventMon
  1756.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1757.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1758.           lastev = E_Misc;
  1759.           }
  1760. #endif                    /* EventMon */
  1761.            goto Eret_uw;
  1762.  
  1763.         case A_Pret_uw:        /* unwind for pret */
  1764. #ifdef EventMon
  1765.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1766.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1767.           lastev = E_Misc;
  1768.           }
  1769. #endif                    /* EventMon */
  1770.            goto Pret_uw;
  1771.  
  1772.         case A_Pfail_uw:        /* unwind for pfail */
  1773. #ifdef EventMon
  1774.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1775.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1776.           lastev = E_Misc;
  1777.           }
  1778. #endif                    /* EventMon */
  1779.            goto Pfail_uw;
  1780.         }
  1781.  
  1782.      rsp = (word *)rargp + 1;    /* set rsp to result */
  1783.  
  1784. #ifdef EventMon
  1785. return_term:
  1786.          value_tmp = *(dptr)(rsp - 1);    /* argument */
  1787.          Deref(value_tmp);
  1788.          if ((lastev == E_Function) || (lastev == E_Operator)) {
  1789.         InterpEVValD(&value_tmp, ((lastev == E_Function) ? E_Fret:E_Oret));
  1790.         lastev = E_Misc;
  1791.         }
  1792. #endif                    /* EventMon */
  1793.  
  1794.      continue;
  1795.      }
  1796.  
  1797. interp_quit:
  1798.    --ilevel;
  1799.    if (ilevel != 0)
  1800.       syserr("interp: termination with inactive generators.");
  1801.    /*NOTREACHED*/
  1802.    return 0;    /* avoid gcc warning */
  1803.    }
  1804.  
  1805. #ifdef StackPic
  1806. /*
  1807.  * The following code is operating-system dependent [@interp.04].
  1808.  *  Diagnostic stack pictures for debugging/monitoring.
  1809.  */
  1810.  
  1811. #if PORT
  1812. Deliberate Syntax Error
  1813. #endif                    /* PORT */
  1814.  
  1815. #if AMIGA || MACINTOSH || VMS
  1816.    /* not included */
  1817. #endif                    /* AMIGA || ... */
  1818.  
  1819. #if ARM
  1820. void stkdump(op)
  1821.    int op;
  1822.    {
  1823.    word *stk;
  1824.    word *i;
  1825.    stk = (word *)BlkLoc(k_current);
  1826.    stk += Wsizeof(struct b_coexpr);
  1827.    fprintf(stderr,">  stack:  %.8x\n", (word)stk);
  1828.    fprintf(stderr,">  sp:     %.8x\n", (word)sp);
  1829.    fprintf(stderr,">  pfp:    %.8x\n", (word)pfp);
  1830.    fprintf(stderr,">  efp:    %.8x\n", (word)efp);
  1831.    fprintf(stderr,">  gfp:    %.8x\n", (word)gfp);
  1832.    fprintf(stderr,">  ipc:    %.8x\n", (word)ipc.op);
  1833.    fprintf(stderr,">  argp:   %.8x\n", (word)glbl_argp);
  1834.    fprintf(stderr,">  ilevel: %.8x\n", (word)ilevel);
  1835.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1836.    for (i = stk; i <= (word *)sp; i++)
  1837.       fprintf(stderr,"> %.8x\n",(word)*i);
  1838.    fprintf(stderr,"> ----------\n");
  1839.    fflush(stderr);
  1840.    }
  1841. #endif                    /* ARM */
  1842.  
  1843. #if MSDOS || OS2
  1844. #if MICROSOFT || TURBO || BORLAND_286 || BORLAND_386
  1845. void stkdump(op)
  1846.    int op;
  1847.    {
  1848.    word far *stk;
  1849.    word far *i;
  1850.    stk = (word far *)BlkLoc(k_current);
  1851.    stk += Wsizeof(struct b_coexpr);
  1852.    fprintf(stderr,">  stack:  %08lx\n", (word)stk);
  1853.    fprintf(stderr,">  sp:     %08lx\n", (word)sp);
  1854.    fprintf(stderr,">  pfp:    %08lx\n", (word)pfp);
  1855.    fprintf(stderr,">  efp:    %08lx\n", (word)efp);
  1856.    fprintf(stderr,">  gfp:    %08lx\n", (word)gfp);
  1857.    fprintf(stderr,">  ipc:    %08lx\n", (word)ipc.op);
  1858.    fprintf(stderr,">  argp:   %08lx\n", (word)glbl_argp);
  1859.    fprintf(stderr,">  ilevel: %08lx\n", (word)ilevel);
  1860.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1861.    for (i = stk; i <= (word far *)sp; i++)
  1862.       fprintf(stderr,"> %08lx\n",(word)*i);
  1863.    fprintf(stderr,"> ----------\n");
  1864.    fflush(stderr);
  1865.    }
  1866. #endif                    /* MICROSOFT || TURBO ... */
  1867. #endif                    /* MSDOS || OS2 */
  1868.  
  1869. #if UNIX || VMS
  1870. void stkdump(op)
  1871.    int op;
  1872.    {
  1873.    word *i;
  1874.    fprintf(stderr,"\001stack: %lx\n",(long)(stack + Wsizeof(struct b_coexpr)));
  1875.    fprintf(stderr,"\001pfp: %lx\n",(long)pfp);
  1876.    fprintf(stderr,"\001efp: %lx\n",(long)efp);
  1877.    fprintf(stderr,"\001gfp: %lx\n",(long)gfp);
  1878.    fprintf(stderr,"\001ipc: %lx\n",(long)ipc.op);
  1879.    fprintf(stderr,"\001argp: %lx\n",(long)glbl_argp);
  1880.    fprintf(stderr,"\001ilevel: %lx\n",(long)ilevel);
  1881.    fprintf(stderr,"\001op: \%d\n",(int)op);
  1882.    for (i = stack + Wsizeof(struct b_coexpr); i <= sp; i++)
  1883.       fprintf(stderr,"\001%lx\n",*i);
  1884.    fprintf(stderr,"\001----------\n");
  1885.    fflush(stderr);
  1886.    }
  1887. #endif                    /* UNIX || VMS */
  1888.  
  1889. /*
  1890.  * End of operating-system specific code.
  1891.  */
  1892. #endif                    /* StackPic */
  1893.  
  1894. #ifdef EventMon
  1895. /*
  1896.  * vanq_proc - monitor the removal of suspended operations from within
  1897.  *   a procedure.
  1898.  */
  1899. static void vanq_proc(efp_v, gfp_v)
  1900. struct ef_marker *efp_v;
  1901. struct gf_marker *gfp_v;
  1902.    {
  1903.  
  1904.    if (is:null(curpstate->eventmask))
  1905.       return;
  1906.  
  1907.    /*
  1908.     * Go through all the bounded expression of the procedure.
  1909.     */
  1910.    while ((efp_v = vanq_bound(efp_v, gfp_v)) != NULL) {
  1911.       gfp_v = efp_v->ef_gfp;
  1912.       efp_v = efp_v->ef_efp;
  1913.       }
  1914.    }
  1915.  
  1916. /*
  1917.  * vanq_bound - monitor the removal of suspended operations from
  1918.  *   the current bounded expression and return the expression frame
  1919.  *   pointer for the bounded expression.
  1920.  */
  1921. static struct ef_marker *vanq_bound(efp_v, gfp_v)
  1922. struct ef_marker *efp_v;
  1923. struct gf_marker *gfp_v;
  1924.    {
  1925.  
  1926.    if (is:null(curpstate->eventmask))
  1927.       return efp_v;
  1928.  
  1929.    while (gfp_v != 0) {        /* note removal of suspended operations */
  1930.       switch ((int)gfp_v->gf_gentype) {
  1931.          case G_Psusp:
  1932.             EVValD(gfp_v->gf_argp, E_Prem);
  1933.             break;
  1934.      /* G_Fsusp and G_Osusp handled in-line during unwinding */
  1935.          case G_Esusp:
  1936.             EVVal((word)0, E_Erem);
  1937.             break;
  1938.          }
  1939.  
  1940.       if (((int)gfp_v->gf_gentype) == G_Psusp) {
  1941.          vanq_proc(gfp_v->gf_efp, gfp_v->gf_gfp);
  1942.          efp_v = gfp_v->gf_pfp->pf_efp;           /* efp before the call */
  1943.          gfp_v = gfp_v->gf_pfp->pf_gfp;           /* gfp before the call */
  1944.          }
  1945.       else {
  1946.          efp_v = gfp_v->gf_efp;
  1947.          gfp_v = gfp_v->gf_gfp;
  1948.          }
  1949.       }
  1950.  
  1951.    return efp_v;
  1952.    }
  1953. #endif                    /* EventMon */
  1954.  
  1955. #ifdef MultiThread
  1956. /*
  1957.  * activate some other co-expression from an arbitrary point in
  1958.  * the interpreter.
  1959.  */
  1960. int mt_activate(tvalp,rslt,ncp)
  1961. dptr tvalp, rslt;
  1962. register struct b_coexpr *ncp;
  1963. {
  1964.    register struct b_coexpr *ccp = (struct b_coexpr *)BlkLoc(k_current);
  1965.    int first, rv;
  1966.  
  1967.    dptr savedtvalloc = NULL;
  1968.    /*
  1969.     * Set activator in new co-expression.
  1970.     */
  1971.    if (ncp->es_actstk == NULL) {
  1972.       Protect(ncp->es_actstk = alcactiv(), { err_msg(0, NULL); exit(1); });
  1973.       /*
  1974.        * If no one ever explicitly activates this co-expression, fail to
  1975.        * the implicit activator.
  1976.        */
  1977.       ncp->es_actstk->arec[0].activator = ccp;
  1978.       first = 0;
  1979.       }
  1980.    else
  1981.       first = 1;
  1982.  
  1983.    if(ccp->tvalloc) {
  1984.      if (InRange(blkbase,ccp->tvalloc,blkfree)) {
  1985.        fprintf(stderr,
  1986.            "Multiprogram garbage collection disaster in mt_activate()!\n");
  1987.        fflush(stderr);
  1988.        exit(1);
  1989.      }
  1990.      savedtvalloc = ccp->tvalloc;
  1991.    }
  1992.  
  1993.    rv = co_chng(ncp, tvalp, rslt, A_MTEvent, first);
  1994.  
  1995.    if ((savedtvalloc != NULL) && (savedtvalloc != ccp->tvalloc)) {
  1996.       fprintf(stderr,"averted co-expression disaster in activate\n");
  1997.       ccp->tvalloc = savedtvalloc;
  1998.       }
  1999.  
  2000.    /*
  2001.     * flush any accumulated ticks
  2002.     */
  2003. #ifdef EventMon
  2004. #if UNIX
  2005.    if (ticker.l[0] + ticker.l[1] + ticker.l[2] + ticker.l[3] +
  2006.        ticker.l[4] + ticker.l[5] + ticker.l[6] + ticker.l[7] != oldtick) {
  2007.       word sum, nticks;
  2008.  
  2009.       oldtick = ticker.l[0] + ticker.l[1] + ticker.l[2] + ticker.l[3] +
  2010.        ticker.l[4] + ticker.l[5] + ticker.l[6] + ticker.l[7];
  2011.       sum = ticker.s[0] + ticker.s[1] + ticker.s[2] + ticker.s[3] +
  2012.      ticker.s[4] + ticker.s[5] + ticker.s[6] + ticker.s[7] +
  2013.         ticker.s[8] + ticker.s[9] + ticker.s[10] + ticker.s[11] +
  2014.            ticker.s[12] + ticker.s[13] + ticker.s[14] + ticker.s[15];
  2015.       nticks = sum - oldsum;
  2016.       oldsum = sum;
  2017.       }
  2018. #endif                    /* UNIX */
  2019. #endif                    /* EventMon */
  2020.  
  2021.    return rv;
  2022. }
  2023.  
  2024.  
  2025. /*
  2026.  * activate the "&parent" co-expression from anywhere, if there is one
  2027.  */
  2028. void actparent(event)
  2029. int event;
  2030.    {
  2031.    struct progstate *parent = curpstate->parent;
  2032.  
  2033.    StrLen(parent->eventcode) = 1;
  2034.    StrLoc(parent->eventcode) = (char *)&allchars[event & 0xFF];
  2035.    mt_activate(&(parent->eventcode), NULL,
  2036.            (struct b_coexpr *)curpstate->parent->Mainhead);
  2037.    }
  2038. #endif                    /* MultiThread */
  2039. #endif                    /* !COMPILER */
  2040.