home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v92.tgz / v92.tar / v92 / src / runtime / interp.r < prev    next >
Text File  |  1996-03-22  |  51KB  |  2,053 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. hidden struct ef_marker *vanq_bound Params((struct ef_marker *efp_v,
  17.                                       struct gf_marker *gfp_v));
  18. hidden novalue           vanq_proc Params((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 || ATARI_ST || MACINTOSH || MSDOS || MVS || OS2 || UNIX || VM || VMS
  37.    /* nothing needed */
  38. #endif                    /* ARM || ATARI_ST || ... */
  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 || ATARI_ST || MACINTOSH || MVS || UNIX || VM || VMS
  195. #define PushAVal(x) PushVal(x)
  196. #endif                    /* AMIGA || ARM || ATARI_ST || ... */
  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)ToAscii(E_Loc), curpstate->eventmask) ||
  337.        Testb((word)ToAscii(E_Line), curpstate->eventmask)
  338.        )) {
  339.  
  340.       if (InRange(code, ipc.opnd, records)) {
  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)ToAscii(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)ToAscii(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 || ATARI_ST || MSDOS || MVS || OS2 || UNIX || VM || VMS
  423.    /* nothing to do */
  424. #endif                    /* ARM || ATARI_ST || ... */
  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)ToAscii(E_Opcode), curpstate->eventmask)) &&
  451.       (is:null(curpstate->opcodemask) ||
  452.        Testb((word)ToAscii(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.  
  508. #ifdef CRAY
  509.         opnd = (word)(strcons + GetWord);
  510. #else                    /* CRAY */
  511.         opnd = (word)strcons + GetWord;
  512. #endif                    /* CRAY */
  513.  
  514.         PutWord(opnd);
  515.         PushAVal(opnd);
  516.         break;
  517.  
  518.      case Op_Astr:        /* string, absolute address */
  519.         PushVal(GetWord);
  520.         PushAVal(GetWord);
  521.         break;
  522.  
  523.                 /* ---Variable construction--- */
  524.  
  525.      case Op_Arg:        /* argument */
  526.         PushVal(D_Var);
  527.         PushAVal(&argp[GetWord + 1]);
  528.         break;
  529.  
  530.      case Op_Global:    /* global */
  531.         PutOp(Op_Aglobal);
  532.         PushVal(D_Var);
  533.         opnd = GetWord;
  534.         PushAVal(&globals[opnd]);
  535.         PutWord((word)&globals[opnd]);
  536.         break;
  537.  
  538.      case Op_Aglobal:    /* global, absolute address */
  539.         PushVal(D_Var);
  540.         PushAVal(GetWord);
  541.         break;
  542.  
  543.      case Op_Local:     /* local */
  544.         PushVal(D_Var);
  545.         PushAVal(&pfp->pf_locals[GetWord]);
  546.         break;
  547.  
  548.      case Op_Static:    /* static */
  549.         PutOp(Op_Astatic);
  550.         PushVal(D_Var);
  551.         opnd = GetWord;
  552.         PushAVal(&statics[opnd]);
  553.         PutWord((word)&statics[opnd]);
  554.         break;
  555.  
  556.      case Op_Astatic:    /* static, absolute address */
  557.         PushVal(D_Var);
  558.         PushAVal(GetWord);
  559.         break;
  560.  
  561.  
  562.                 /* ---Operators--- */
  563.  
  564.                 /* Unary operators */
  565.  
  566.      case Op_Compl:     /* ~e */
  567.      case Op_Neg:        /* -e */
  568.      case Op_Number:    /* +e */
  569.      case Op_Refresh:    /* ^e */
  570.      case Op_Size:        /* *e */
  571.         Setup_Op(1);
  572.         DerefArg(1);
  573.         Call_Cond;
  574.  
  575.      case Op_Value:     /* .e */
  576.             Setup_Op(1);
  577.             DerefArg(1);
  578.             Call_Cond;
  579.  
  580.      case Op_Nonnull:    /* \e */
  581.      case Op_Null:        /* /e */
  582.         Setup_Op(1);
  583.         Call_Cond;
  584.  
  585.      case Op_Random:    /* ?e */
  586.         PushNull;
  587.         Setup_Op(2)
  588.         Call_Cond
  589.  
  590.                 /* Generative unary operators */
  591.  
  592.      case Op_Tabmat:    /* =e */
  593.         Setup_Op(1);
  594.         DerefArg(1);
  595.         Call_Gen;
  596.  
  597.      case Op_Bang:        /* !e */
  598.         PushNull;
  599.         Setup_Op(2);
  600.         Call_Gen;
  601.  
  602.                 /* Binary operators */
  603.  
  604.      case Op_Cat:        /* e1 || e2 */
  605.      case Op_Diff:        /* e1 -- e2 */
  606.      case Op_Div:        /* e1 / e2 */
  607.      case Op_Inter:     /* e1 ** e2 */
  608.      case Op_Lconcat:    /* e1 ||| e2 */
  609.      case Op_Minus:     /* e1 - e2 */
  610.      case Op_Mod:        /* e1 % e2 */
  611.      case Op_Mult:        /* e1 * e2 */
  612.      case Op_Power:     /* e1 ^ e2 */
  613.      case Op_Unions:    /* e1 ++ e2 */
  614.      case Op_Plus:        /* e1 + e2 */
  615.      case Op_Eqv:        /* e1 === e2 */
  616.      case Op_Lexeq:     /* e1 == e2 */
  617.      case Op_Lexge:     /* e1 >>= e2 */
  618.      case Op_Lexgt:     /* e1 >> e2 */
  619.      case Op_Lexle:     /* e1 <<= e2 */
  620.      case Op_Lexlt:     /* e1 << e2 */
  621.      case Op_Lexne:     /* e1 ~== e2 */
  622.      case Op_Neqv:        /* e1 ~=== e2 */
  623.      case Op_Numeq:     /* e1 = e2 */
  624.      case Op_Numge:     /* e1 >= e2 */
  625.      case Op_Numgt:     /* e1 > e2 */
  626.      case Op_Numle:     /* e1 <= e2 */
  627.      case Op_Numne:     /* e1 ~= e2 */
  628.      case Op_Numlt:     /* e1 < e2 */
  629.         Setup_Op(2);
  630.         DerefArg(1);
  631.         DerefArg(2);
  632.         Call_Cond;
  633.  
  634.      case Op_Asgn:        /* e1 := e2 */
  635.         Setup_Op(2);
  636.         /* FJL DerefArg(2); */
  637.         Call_Cond;
  638.  
  639.      case Op_Swap:        /* e1 :=: e2 */
  640.         PushNull;
  641.         Setup_Op(3);
  642.         Call_Cond;
  643.  
  644.      case Op_Subsc:     /* e1[e2] */
  645.         PushNull;
  646.         Setup_Op(3);
  647.         /* FJL DerefArg(2); */
  648.         Call_Cond;
  649.                 /* Generative binary operators */
  650.  
  651.      case Op_Rasgn:     /* e1 <- e2 */
  652.         Setup_Op(2);
  653.         /* FJL DerefArg(2); */
  654.         Call_Gen;
  655.  
  656.      case Op_Rswap:     /* e1 <-> e2 */
  657.         PushNull;
  658.         Setup_Op(3);
  659.         Call_Gen;
  660.  
  661.                 /* Conditional ternary operators */
  662.  
  663.      case Op_Sect:        /* e1[e2:e3] */
  664.         PushNull;
  665.         Setup_Op(4);
  666.         /* FJL DerefArg(2); */
  667.         /* FJL DerefArg(3); */
  668.         Call_Cond;
  669.                 /* Generative ternary operators */
  670.  
  671.      case Op_Toby:        /* e1 to e2 by e3 */
  672.         Setup_Op(3);
  673.         DerefArg(1);
  674.         DerefArg(2);
  675.         DerefArg(3);
  676.         Call_Gen;
  677.  
  678.          case Op_Noop:        /* no-op */
  679.  
  680. #ifdef LineCodes
  681. #ifdef Polling
  682.             if (!pollctr--) {
  683.            ExInterp;
  684.                pollctr = pollevent();
  685.            EntInterp;
  686.            if (pollctr == -1) fatalerr(141, NULL);
  687.            }           
  688. #endif                    /* Polling */
  689.  
  690.  
  691. #endif                /* LineCodes */
  692.  
  693.             break;
  694.  
  695.  
  696.          case Op_Colm:        /* source column number */
  697.             {
  698.              word loc;
  699.  
  700. #ifdef EventMon
  701.             column = GetWord;
  702.             loc = column;
  703.             loc <<= (WordBits >> 1);        /* column in high-order part */
  704.             loc += linenum;
  705.             InterpEVVal(loc, E_Loc);
  706. #endif                    /* EventMon */
  707.  
  708.             break;
  709.             }
  710.  
  711.          case Op_Line:        /* source line number */
  712.  
  713. #ifdef LineCodes
  714. #ifdef Polling
  715.             if (!pollctr--) {
  716.            ExInterp;
  717.                pollctr = pollevent();
  718.            EntInterp;
  719.            if (pollctr == -1) fatalerr(141, NULL);
  720.            }           
  721. #endif                    /* Polling */
  722.  
  723.  
  724. #endif                /* LineCodes */
  725.  
  726. #ifdef EventMon
  727.             linenum = GetWord;
  728.             lastline = linenum;
  729. #endif                    /* EventMon */
  730.  
  731.             break;
  732.  
  733.                 /* ---String Scanning--- */
  734.  
  735.      case Op_Bscan:     /* prepare for scanning */
  736.         PushDesc(k_subject);
  737.         PushVal(D_Integer);
  738.         PushVal(k_pos);
  739.         Setup_Arg(2);
  740.  
  741.         signal = Obscan(2,rargp);
  742.  
  743.         goto C_rtn_term;
  744.  
  745.      case Op_Escan:     /* exit from scanning */
  746.         Setup_Arg(1);
  747.  
  748.         signal = Oescan(1,rargp);
  749.  
  750.         goto C_rtn_term;
  751.  
  752.                 /* ---Other Language Operations--- */
  753.  
  754.          case Op_Apply: {    /* apply */
  755.             union block *bp;
  756.             int i, j;
  757.  
  758.             value_tmp = *(dptr)(rsp - 1);    /* argument */
  759.             Deref(value_tmp);
  760.             switch (Type(value_tmp)) {
  761.                case T_List: {
  762.                   rsp -= 2;                /* pop it off */
  763.                   bp = BlkLoc(value_tmp);
  764.                   args = (int)bp->list.size;
  765.  
  766. #ifndef MultiThread
  767.                  /*
  768.                   * Make a stab at catching interpreter stack overflow.
  769.                   * This does nothing for invocation in a co-expression other
  770.                   * than &main.
  771.                   */
  772.                  if (BlkLoc(k_current) == BlkLoc(k_main) &&
  773.                     ((char *)sp + args * sizeof(struct descrip) >
  774.                        (char *)stackend))
  775.                           fatalerr(301, NULL);
  776. #endif                    /* MultiThread */
  777.  
  778.                   for (bp = bp->list.listhead; bp != NULL;
  779.                      bp = bp->lelem.listnext) {
  780.                         for (i = 0; i < bp->lelem.nused; i++) {
  781.                            j = bp->lelem.first + i;
  782.                            if (j >= bp->lelem.nslots)
  783.                               j -= bp->lelem.nslots;
  784.                            PushDesc(bp->lelem.lslots[j])
  785.                            }
  786.                         }
  787.           goto invokej;
  788.           }
  789.  
  790.                case T_Record: {
  791.                   rsp -= 2;        /* pop it off */
  792.                   bp = BlkLoc(value_tmp);
  793.                   args = bp->record.recdesc->proc.nfields;
  794.                   for (i = 0; i < args; i++) {
  795.                      PushDesc(bp->record.fields[i])
  796.                      }
  797.                   goto invokej;
  798.                   }
  799.  
  800.                default: {        /* illegal type for invocation */
  801.  
  802.                   xargp = (dptr)(rsp - 3);
  803.                   err_msg(126, &value_tmp);
  804.                   goto efail;
  805.                   }
  806.                }
  807.         }
  808.  
  809.      case Op_Invoke: {    /* invoke */
  810.             args = (int)GetWord;
  811. invokej:
  812.         {
  813.             int nargs;
  814.         dptr carg;
  815.  
  816.         ExInterp;
  817.         type = invoke(args, &carg, &nargs);
  818.         EntInterp;
  819.  
  820.         if (type == I_Fail)
  821.            goto efail_noev;
  822.         if (type == I_Continue)
  823.            break;
  824.         else {
  825.  
  826.                rargp = carg;        /* valid only for Vararg or Builtin */
  827.  
  828. #ifdef Polling
  829.            /*
  830.         * Do polling here
  831.         */
  832.            pollctr >>= 1;
  833.                if (!pollctr) {
  834.               ExInterp;
  835.                   pollctr = pollevent();
  836.               EntInterp;
  837.               if (pollctr == -1) fatalerr(141, NULL);
  838.               }           
  839. #endif                    /* Polling */
  840.  
  841. #ifdef EventMon
  842.            lastev = E_Function;
  843.            InterpEVValD(rargp, E_Fcall);
  844. #endif                    /* EventMon */
  845.  
  846.            bproc = (struct b_proc *)BlkLoc(*rargp);
  847.  
  848. #ifdef FncTrace
  849.                typedef int (*bfunc2)(dptr, struct descrip *);
  850. #endif                    /* FncTrace */
  851.  
  852.  
  853.            /* ExInterp not needed since no change since last EntInterp */
  854.            if (type == I_Vararg) {
  855.               int (*bfunc)();
  856.                   bfunc = bproc->entryp.ccode;
  857.  
  858. #ifdef FncTrace
  859.                   signal = (*bfunc)(nargs, rargp, &(procs->pname));
  860. #else                    /* FncTrace */
  861.           signal = (*bfunc)(nargs,rargp);
  862. #endif                    /* FncTrace */
  863.  
  864.                   }
  865.            else
  866.                   {
  867.                   int (*bfunc)();
  868.                   bfunc = bproc->entryp.ccode;
  869.  
  870. #ifdef FncTrace
  871.                   signal = (*(bfunc2)bfunc)(rargp, &(bproc->pname));
  872. #else                    /* FncTrace */
  873.           signal = (*bfunc)(rargp);
  874. #endif                    /* FncTrace */
  875.                   }
  876.  
  877. #ifdef FncTrace
  878.                if (k_ftrace) {
  879.                   k_ftrace--;
  880.                   if (signal == A_Failure)
  881.                      failtrace(&(bproc->pname));
  882.                   else
  883.                      rtrace(&(bproc->pname),rargp);
  884.                   }
  885. #endif                    /* FncTrace */
  886.  
  887.            goto C_rtn_term;
  888.            }
  889.         }
  890.         break;
  891.         }
  892.  
  893.      case Op_Keywd:     /* keyword */
  894.  
  895.             PushNull;
  896.             opnd = GetWord;
  897.             Setup_Arg(0);
  898.  
  899.         signal = (*(keytab[(int)opnd]))(rargp);
  900.         goto C_rtn_term;
  901.  
  902.      case Op_Llist:     /* construct list */
  903.         opnd = GetWord;
  904.  
  905. #ifdef EventMon
  906.             lastev = E_Operator;
  907.             value_tmp.dword = D_Proc;
  908.             value_tmp.vword.bptr = (union block *)&mt_llist;
  909.             InterpEVValD(&value_tmp, E_Ocall);
  910.             rargp = (dptr)(rsp - 1) - opnd;
  911.             xargp = rargp;
  912.             ExInterp;
  913. #else                    /* EventMon */
  914.         Setup_Arg(opnd);
  915. #endif                    /* EventMon */
  916.  
  917.         {
  918.         int i;
  919.         for (i=1;i<=opnd;i++)
  920.                DerefArg(i);
  921.         }
  922.  
  923.         signal = Ollist((int)opnd,rargp);
  924.  
  925.         goto C_rtn_term;
  926.  
  927.                 /* ---Marking and Unmarking--- */
  928.  
  929.      case Op_Mark:        /* create expression frame marker */
  930.         PutOp(Op_Amark);
  931.         opnd = GetWord;
  932.         opnd += (word)ipc.opnd;
  933.         PutWord(opnd);
  934.         newefp = (struct ef_marker *)(rsp + 1);
  935.         newefp->ef_failure.opnd = (word *)opnd;
  936.         goto mark;
  937.  
  938.      case Op_Amark:     /* mark with absolute fipc */
  939.         newefp = (struct ef_marker *)(rsp + 1);
  940.         newefp->ef_failure.opnd = (word *)GetWord;
  941. mark:
  942.         newefp->ef_gfp = gfp;
  943.         newefp->ef_efp = efp;
  944.         newefp->ef_ilevel = ilevel;
  945.         rsp += Wsizeof(*efp);
  946.         efp = newefp;
  947.         gfp = 0;
  948.         break;
  949.  
  950.      case Op_Mark0:     /* create expression frame with 0 ipl */
  951. mark0:
  952.         newefp = (struct ef_marker *)(rsp + 1);
  953.         newefp->ef_failure.opnd = 0;
  954.         newefp->ef_gfp = gfp;
  955.         newefp->ef_efp = efp;
  956.         newefp->ef_ilevel = ilevel;
  957.         rsp += Wsizeof(*efp);
  958.         efp = newefp;
  959.         gfp = 0;
  960.         break;
  961.  
  962.      case Op_Unmark:    /* remove expression frame */
  963.  
  964. #ifdef EventMon
  965.         ExInterp;
  966.             vanq_bound(efp, gfp);
  967.         EntInterp;
  968. #endif                    /* EventMon */
  969.  
  970.         gfp = efp->ef_gfp;
  971.         rsp = (word *)efp - 1;
  972.  
  973.         /*
  974.          * Remove any suspended C generators.
  975.          */
  976. Unmark_uw:
  977.         if (efp->ef_ilevel < ilevel) {
  978.            --ilevel;
  979.  
  980.            ExInterp;
  981.  
  982. #ifdef EventMon
  983.            EVVal(A_Unmark_uw, E_Intret);
  984.                EVVal(DiffPtrs(sp, stack), E_Stack);
  985. #endif                    /* EventMon */
  986.  
  987.            return A_Unmark_uw;
  988.            }
  989.  
  990.         efp = efp->ef_efp;
  991.         break;
  992.  
  993.                 /* ---Suspensions--- */
  994.  
  995.      case Op_Esusp: {    /* suspend from expression */
  996.  
  997.         /*
  998.          * Create the generator frame.
  999.          */
  1000.         oldsp = rsp;
  1001.         newgfp = (struct gf_marker *)(rsp + 1);
  1002.         newgfp->gf_gentype = G_Esusp;
  1003.         newgfp->gf_gfp = gfp;
  1004.         newgfp->gf_efp = efp;
  1005.         newgfp->gf_ipc = ipc;
  1006.         gfp = newgfp;
  1007.         rsp += Wsizeof(struct gf_smallmarker);
  1008.  
  1009.         /*
  1010.          * Region extends from first word after enclosing generator or
  1011.          *    expression frame marker to marker for current expression frame.
  1012.          */
  1013.         if (efp->ef_gfp != 0) {
  1014.            newgfp = (struct gf_marker *)(efp->ef_gfp);
  1015.            if (newgfp->gf_gentype == G_Psusp)
  1016.           firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  1017.            else
  1018.           firstwd = (word *)efp->ef_gfp +
  1019.              Wsizeof(struct gf_smallmarker);
  1020.         }
  1021.         else
  1022.            firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  1023.         lastwd = (word *)efp - 1;
  1024.         efp = efp->ef_efp;
  1025.  
  1026.         /*
  1027.          * Copy the portion of the stack with endpoints firstwd and lastwd
  1028.          *    (inclusive) to the top of the stack.
  1029.          */
  1030.         for (wd = firstwd; wd <= lastwd; wd++)
  1031.            *++rsp = *wd;
  1032.         PushVal(oldsp[-1]);
  1033.         PushVal(oldsp[0]);
  1034.         break;
  1035.         }
  1036.  
  1037.      case Op_Lsusp: {    /* suspend from limitation */
  1038.         struct descrip sval;
  1039.  
  1040.         /*
  1041.          * The limit counter is contained in the descriptor immediately
  1042.          *    prior to the current expression frame.    lval is established
  1043.          *    as a pointer to this descriptor.
  1044.          */
  1045.         dptr lval = (dptr)((word *)efp - 2);
  1046.  
  1047.         /*
  1048.          * Decrement the limit counter and check it.
  1049.          */
  1050.         if (--IntVal(*lval) > 0) {
  1051.            /*
  1052.         * The limit has not been reached, set up stack.
  1053.         */
  1054.  
  1055.            sval = *(dptr)(rsp - 1);    /* save result */
  1056.  
  1057.            /*
  1058.         * Region extends from first word after enclosing generator or
  1059.         *  expression frame marker to the limit counter just prior to
  1060.         *  to the current expression frame marker.
  1061.         */
  1062.            if (efp->ef_gfp != 0) {
  1063.           newgfp = (struct gf_marker *)(efp->ef_gfp);
  1064.           if (newgfp->gf_gentype == G_Psusp)
  1065.              firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  1066.           else
  1067.              firstwd = (word *)efp->ef_gfp +
  1068.             Wsizeof(struct gf_smallmarker);
  1069.           }
  1070.            else
  1071.           firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  1072.            lastwd = (word *)efp - 3;
  1073.            if (gfp == 0)
  1074.           gfp = efp->ef_gfp;
  1075.            efp = efp->ef_efp;
  1076.  
  1077.            /*
  1078.         * Copy the portion of the stack with endpoints firstwd and lastwd
  1079.         *  (inclusive) to the top of the stack.
  1080.         */
  1081.            rsp -= 2;        /* overwrite result */
  1082.            for (wd = firstwd; wd <= lastwd; wd++)
  1083.           *++rsp = *wd;
  1084.            PushDesc(sval);        /* push saved result */
  1085.            }
  1086.         else {
  1087.            /*
  1088.         * Otherwise, the limit has been reached.  Instead of
  1089.         *  suspending, remove the current expression frame and
  1090.         *  replace the limit counter with the value on top of
  1091.         *  the stack (which would have been suspended had the
  1092.         *  limit not been reached).
  1093.         */
  1094.            *lval = *(dptr)(rsp - 1);
  1095.  
  1096. #ifdef EventMon
  1097.            ExInterp;
  1098.                vanq_bound(efp, gfp);
  1099.            EntInterp;
  1100. #endif                    /* EventMon */
  1101.  
  1102.            gfp = efp->ef_gfp;
  1103.  
  1104.            /*
  1105.         * Since an expression frame is being removed, inactive
  1106.         *  C generators contained therein are deactivated.
  1107.         */
  1108. Lsusp_uw:
  1109.            if (efp->ef_ilevel < ilevel) {
  1110.           --ilevel;
  1111.           ExInterp;
  1112.  
  1113. #ifdef EventMon
  1114.                   EVVal(A_Lsusp_uw, E_Intret);
  1115.                   EVVal(DiffPtrs(sp, stack), E_Stack);
  1116. #endif                    /* EventMon */
  1117.  
  1118.           return A_Lsusp_uw;
  1119.           }
  1120.            rsp = (word *)efp - 1;
  1121.            efp = efp->ef_efp;
  1122.            }
  1123.         break;
  1124.         }
  1125.  
  1126.      case Op_Psusp: {    /* suspend from procedure */
  1127.  
  1128.         /*
  1129.          * An Icon procedure is suspending a value.  Determine if the
  1130.          *    value being suspended should be dereferenced and if so,
  1131.          *    dereference it. If tracing is on, strace is called
  1132.          *  to generate a message.  Appropriate values are
  1133.          *    restored from the procedure frame of the suspending procedure.
  1134.          */
  1135.  
  1136.         struct descrip tmp;
  1137.             dptr svalp;
  1138.         struct b_proc *sproc;
  1139.  
  1140. #ifdef EventMon
  1141.             value_tmp = *(dptr)(rsp - 1);    /* argument */
  1142.             Deref(value_tmp);
  1143.             InterpEVValD(&value_tmp, E_Psusp);
  1144. #endif                    /* EventMon */
  1145.  
  1146.         svalp = (dptr)(rsp - 1);
  1147.         if (Var(*svalp)) {
  1148.                ExInterp;
  1149.                retderef(svalp, (word *)argp, sp);
  1150.                EntInterp;
  1151.                }
  1152.  
  1153.         /*
  1154.          * Create the generator frame.
  1155.          */
  1156.         oldsp = rsp;
  1157.         newgfp = (struct gf_marker *)(rsp + 1);
  1158.         newgfp->gf_gentype = G_Psusp;
  1159.         newgfp->gf_gfp = gfp;
  1160.         newgfp->gf_efp = efp;
  1161.         newgfp->gf_ipc = ipc;
  1162.         newgfp->gf_argp = argp;
  1163.         newgfp->gf_pfp = pfp;
  1164.         gfp = newgfp;
  1165.         rsp += Wsizeof(*gfp);
  1166.  
  1167.         /*
  1168.          * Region extends from first word after the marker for the
  1169.          *    generator or expression frame enclosing the call to the
  1170.          *    now-suspending procedure to Arg0 of the procedure.
  1171.          */
  1172.         if (pfp->pf_gfp != 0) {
  1173.            newgfp = (struct gf_marker *)(pfp->pf_gfp);
  1174.            if (newgfp->gf_gentype == G_Psusp)
  1175.           firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp);
  1176.            else
  1177.           firstwd = (word *)pfp->pf_gfp +
  1178.              Wsizeof(struct gf_smallmarker);
  1179.            }
  1180.         else
  1181.            firstwd = (word *)pfp->pf_efp + Wsizeof(*efp);
  1182.         lastwd = (word *)argp - 1;
  1183.            efp = efp->ef_efp;
  1184.  
  1185.         /*
  1186.          * Copy the portion of the stack with endpoints firstwd and lastwd
  1187.          *    (inclusive) to the top of the stack.
  1188.          */
  1189.         for (wd = firstwd; wd <= lastwd; wd++)
  1190.            *++rsp = *wd;
  1191.         PushVal(oldsp[-1]);
  1192.         PushVal(oldsp[0]);
  1193.         --k_level;
  1194.         if (k_trace) {
  1195.                k_trace--;
  1196.            sproc = (struct b_proc *)BlkLoc(*argp);
  1197.            strace(&(sproc->pname), svalp);
  1198.            }
  1199.  
  1200.         /*
  1201.          * If the scanning environment for this procedure call is in
  1202.          *    a saved state, switch environments.
  1203.          */
  1204.         if (pfp->pf_scan != NULL) {
  1205.  
  1206. #ifdef EventMon
  1207.            InterpEVValD(&k_subject, E_Ssusp);
  1208. #endif                    /* EventMon */
  1209.  
  1210.            tmp = k_subject;
  1211.            k_subject = *pfp->pf_scan;
  1212.            *pfp->pf_scan = tmp;
  1213.  
  1214.            tmp = *(pfp->pf_scan + 1);
  1215.            IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1216.            k_pos = IntVal(tmp);
  1217.            }
  1218.  
  1219. #ifdef MultiThread
  1220.         /*
  1221.          * If the program state changed for this procedure call,
  1222.          * change back.
  1223.          */
  1224.         ENTERPSTATE(pfp->pf_prog);
  1225. #endif                    /* MultiThread */
  1226.  
  1227.         efp = pfp->pf_efp;
  1228.         ipc = pfp->pf_ipc;
  1229.         argp = pfp->pf_argp;
  1230.         pfp = pfp->pf_pfp;
  1231.         break;
  1232.         }
  1233.  
  1234.                 /* ---Returns--- */
  1235.  
  1236.      case Op_Eret: {    /* return from expression */
  1237.         /*
  1238.          * Op_Eret removes the current expression frame, leaving the
  1239.          *    original top of stack value on top.
  1240.          */
  1241.         /*
  1242.          * Save current top of stack value in global temporary (no
  1243.          *    danger of reentry).
  1244.          */
  1245.         eret_tmp = *(dptr)&rsp[-1];
  1246.         gfp = efp->ef_gfp;
  1247. Eret_uw:
  1248.         /*
  1249.          * Since an expression frame is being removed, inactive
  1250.          *    C generators contained therein are deactivated.
  1251.          */
  1252.         if (efp->ef_ilevel < ilevel) {
  1253.            --ilevel;
  1254.            ExInterp;
  1255.  
  1256. #ifdef EventMon
  1257.                EVVal(A_Eret_uw, E_Intret);
  1258.                EVVal(DiffPtrs(sp, stack), E_Stack);
  1259. #endif                    /* EventMon */
  1260.  
  1261.            return A_Eret_uw;
  1262.            }
  1263.         rsp = (word *)efp - 1;
  1264.         efp = efp->ef_efp;
  1265.         PushDesc(eret_tmp);
  1266.         break;
  1267.         }
  1268.  
  1269.  
  1270.      case Op_Pret: {    /* return from procedure */
  1271. #ifdef EventMon
  1272.        struct descrip oldargp;
  1273.        static struct descrip unwinder;
  1274. #endif                    /* EventMon */
  1275.  
  1276.         /*
  1277.          * An Icon procedure is returning a value.    Determine if the
  1278.          *    value being returned should be dereferenced and if so,
  1279.          *    dereference it.  If tracing is on, rtrace is called to
  1280.          *    generate a message.  Inactive generators created after
  1281.          *    the activation of the procedure are deactivated.  Appropriate
  1282.          *    values are restored from the procedure frame.
  1283.          */
  1284.         struct b_proc *rproc = (struct b_proc *)BlkLoc(*argp);
  1285. #ifdef EventMon
  1286.             oldargp = *argp;
  1287.         ExInterp;
  1288.             vanq_proc(efp, gfp);
  1289.         EntInterp;
  1290.         /* used to InterpEVValD(argp,E_Pret); here */
  1291. #endif                    /* EventMon */
  1292.  
  1293.         *argp = *(dptr)(rsp - 1);
  1294.         if (Var(*argp)) {
  1295.                ExInterp;
  1296.                retderef(argp, (word *)argp, sp);
  1297.                EntInterp;
  1298.                }
  1299.  
  1300.         --k_level;
  1301.         if (k_trace) {
  1302.                k_trace--;
  1303.            rtrace(&(rproc->pname), argp);
  1304.                }
  1305. Pret_uw:
  1306.         if (pfp->pf_ilevel < ilevel) {
  1307.            --ilevel;
  1308.            ExInterp;
  1309.  
  1310. #ifdef EventMon
  1311.                EVVal(A_Pret_uw, E_Intret);
  1312.                EVVal(DiffPtrs(sp, stack), E_Stack);
  1313.            unwinder = oldargp;
  1314. #endif                    /* EventMon */
  1315.  
  1316.            return A_Pret_uw;
  1317.            }
  1318.        
  1319. #ifdef EventMon
  1320.        if (!is:proc(oldargp) && is:proc(unwinder))
  1321.           oldargp = unwinder;
  1322. #endif                    /* EventMon */
  1323.         rsp = (word *)argp + 1;
  1324.         efp = pfp->pf_efp;
  1325.         gfp = pfp->pf_gfp;
  1326.         ipc = pfp->pf_ipc;
  1327.         argp = pfp->pf_argp;
  1328.         pfp = pfp->pf_pfp;
  1329.  
  1330. #ifdef MultiThread
  1331.         if (pfp)
  1332.            ENTERPSTATE(pfp->pf_prog);
  1333. #ifdef EventMon
  1334.             value_tmp = *(dptr)(rsp - 1);    /* argument */
  1335.             Deref(value_tmp);
  1336.             InterpEVValD(&value_tmp, E_Pret);
  1337. #endif                    /* EventMon */
  1338. #endif                    /* MultiThread */
  1339.         break;
  1340.         }
  1341.  
  1342.                 /* ---Failures--- */
  1343.  
  1344.      case Op_Efail:
  1345. efail:
  1346. #ifdef EventMon
  1347.             InterpEVVal((word)-1, E_Efail);
  1348. #endif                    /* EventMon */
  1349. efail_noev:
  1350.         /*
  1351.          * Failure has occurred in the current expression frame.
  1352.          */
  1353.         if (gfp == 0) {
  1354.            /*
  1355.         * There are no suspended generators to resume.
  1356.         *  Remove the current expression frame, restoring
  1357.         *  values.
  1358.         *
  1359.         * If the failure ipc is 0, propagate failure to the
  1360.         *  enclosing frame by branching back to efail.
  1361.         *  This happens, for example, in looping control
  1362.         *  structures that fail when complete.
  1363.         */
  1364.  
  1365. #ifdef MultiThread
  1366.           if (efp == 0) {
  1367.          break;
  1368.              }
  1369. #endif                    /* MultiThread */
  1370.  
  1371.            ipc = efp->ef_failure;
  1372.            gfp = efp->ef_gfp;
  1373.            rsp = (word *)efp - 1;
  1374.            efp = efp->ef_efp;
  1375.  
  1376.            if (ipc.op == 0)
  1377.           goto efail;
  1378.            break;
  1379.            }
  1380.  
  1381.         else {
  1382.            /*
  1383.         * There is a generator that can be resumed.  Make
  1384.         *  the stack adjustments and then switch on the
  1385.         *  type of the generator frame marker.
  1386.         */
  1387.            struct descrip tmp;
  1388.            register struct gf_marker *resgfp = gfp;
  1389.  
  1390.            type = (int)resgfp->gf_gentype;
  1391.  
  1392.            if (type == G_Psusp) {
  1393.           argp = resgfp->gf_argp;
  1394.           if (k_trace) {    /* procedure tracing */
  1395.                      k_trace--;
  1396.              ExInterp;
  1397.              atrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1398.              EntInterp;
  1399.              }
  1400.           }
  1401.            ipc = resgfp->gf_ipc;
  1402.            efp = resgfp->gf_efp;
  1403.            gfp = resgfp->gf_gfp;
  1404.            rsp = (word *)resgfp - 1;
  1405.            if (type == G_Psusp) {
  1406.           pfp = resgfp->gf_pfp;
  1407.  
  1408.           /*
  1409.            * If the scanning environment for this procedure call is
  1410.            *  supposed to be in a saved state, switch environments.
  1411.            */
  1412.           if (pfp->pf_scan != NULL) {
  1413.              tmp = k_subject;
  1414.              k_subject = *pfp->pf_scan;
  1415.              *pfp->pf_scan = tmp;
  1416.  
  1417.              tmp = *(pfp->pf_scan + 1);
  1418.              IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1419.              k_pos = IntVal(tmp);
  1420.  
  1421. #ifdef EventMon
  1422.              InterpEVValD(&k_subject, E_Sresum);
  1423. #endif                    /* EventMon */
  1424.              }
  1425.  
  1426. #ifdef MultiThread
  1427.           /*
  1428.            * Enter the program state of the resumed frame
  1429.            */
  1430.           ENTERPSTATE(pfp->pf_prog);
  1431. #endif                    /* MultiThread */
  1432.  
  1433.           ++k_level;        /* adjust procedure level */
  1434.           }
  1435.  
  1436.            switch (type) {
  1437.  
  1438. #ifdef EventMon
  1439.           case G_Fsusp:
  1440.                      InterpEVVal((word)0, E_Fresum);
  1441.              --ilevel;
  1442.              ExInterp;
  1443.                      EVVal(A_Resume, E_Intret);
  1444.                      EVVal(DiffPtrs(sp, stack), E_Stack);
  1445.              return A_Resume;
  1446.  
  1447.           case G_Osusp:
  1448.                      InterpEVVal((word)0, E_Oresum);
  1449.              --ilevel;
  1450.              ExInterp;
  1451.                      EVVal(A_Resume, E_Intret);
  1452.                      EVVal(DiffPtrs(sp, stack), E_Stack);
  1453.              return A_Resume;
  1454. #endif                    /* EventMon */
  1455.  
  1456.           case G_Csusp:
  1457.                      InterpEVVal((word)0, E_Eresum);
  1458.              --ilevel;
  1459.              ExInterp;
  1460. #ifdef EventMon
  1461.                      EVVal(A_Resume, E_Intret);
  1462.                      EVVal(DiffPtrs(sp, stack), E_Stack);
  1463. #endif                    /* EventMon */
  1464.              return A_Resume;
  1465.  
  1466.           case G_Esusp:
  1467.                      InterpEVVal((word)0, E_Eresum);
  1468.              goto efail_noev;
  1469.  
  1470.           case G_Psusp:        /* resuming a procedure */
  1471.                      InterpEVValD(argp, E_Presum);
  1472.              break;
  1473.           }
  1474.  
  1475.            break;
  1476.            }
  1477.  
  1478.      case Op_Pfail: {    /* fail from procedure */
  1479.  
  1480. #ifdef EventMon
  1481.         ExInterp;
  1482.             vanq_proc(efp, gfp);
  1483.             EVValD(argp, E_Pfail);
  1484.         EntInterp;
  1485. #endif                    /* EventMon */
  1486.  
  1487.         /*
  1488.          * An Icon procedure is failing.  Generate tracing message if
  1489.          *    tracing is on.    Deactivate inactive C generators created
  1490.          *    after activation of the procedure.  Appropriate values
  1491.          *    are restored from the procedure frame.
  1492.          */
  1493.  
  1494.         --k_level;
  1495.         if (k_trace) {
  1496.                k_trace--;
  1497.            failtrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1498.                }
  1499. Pfail_uw:
  1500.  
  1501.         if (pfp->pf_ilevel < ilevel) {
  1502.            --ilevel;
  1503.            ExInterp;
  1504. #ifdef EventMon
  1505.                EVVal(A_Pfail_uw, E_Intret);
  1506.                EVVal(DiffPtrs(sp, stack), E_Stack);
  1507. #endif                    /* EventMon */
  1508.            return A_Pfail_uw;
  1509.            }
  1510.         efp = pfp->pf_efp;
  1511.         gfp = pfp->pf_gfp;
  1512.         ipc = pfp->pf_ipc;
  1513.         argp = pfp->pf_argp;
  1514.         pfp = pfp->pf_pfp;
  1515.  
  1516. #ifdef MultiThread
  1517.         /*
  1518.          * Enter the program state of the procedure being reentered.
  1519.          * A NULL pfp indicates the program is complete.
  1520.          */
  1521.         if (pfp) {
  1522.            ENTERPSTATE(pfp->pf_prog);
  1523.            }
  1524. #endif                    /* MultiThread */
  1525.  
  1526.         goto efail_noev;
  1527.         }
  1528.                 /* ---Odds and Ends--- */
  1529.  
  1530.      case Op_Ccase:     /* case clause */
  1531.         PushNull;
  1532.         PushVal(((word *)efp)[-2]);
  1533.         PushVal(((word *)efp)[-1]);
  1534.         break;
  1535.  
  1536.      case Op_Chfail:    /* change failure ipc */
  1537.         opnd = GetWord;
  1538.         opnd += (word)ipc.opnd;
  1539.         efp->ef_failure.opnd = (word *)opnd;
  1540.         break;
  1541.  
  1542.      case Op_Dup:        /* duplicate descriptor */
  1543.         PushNull;
  1544.         rsp[1] = rsp[-3];
  1545.         rsp[2] = rsp[-2];
  1546.         rsp += 2;
  1547.         break;
  1548.  
  1549.      case Op_Field:     /* e1.e2 */
  1550.         PushVal(D_Integer);
  1551.         PushVal(GetWord);
  1552.         Setup_Arg(2);
  1553.  
  1554.         signal = Ofield(2,rargp);
  1555.  
  1556.         goto C_rtn_term;
  1557.  
  1558.      case Op_Goto:        /* goto */
  1559.         PutOp(Op_Agoto);
  1560.         opnd = GetWord;
  1561.         opnd += (word)ipc.opnd;
  1562.         PutWord(opnd);
  1563.         ipc.opnd = (word *)opnd;
  1564.         break;
  1565.  
  1566.      case Op_Agoto:     /* goto absolute address */
  1567.         opnd = GetWord;
  1568.         ipc.opnd = (word *)opnd;
  1569.         break;
  1570.  
  1571.      case Op_Init:        /* initial */
  1572.         *--ipc.op = Op_Goto;
  1573.  
  1574. #ifdef CRAY
  1575.         opnd = (sizeof(*ipc.op) + sizeof(*rsp))/8;
  1576. #else                    /* CRAY */
  1577.         opnd = sizeof(*ipc.op) + sizeof(*rsp);
  1578. #endif                    /* CRAY */
  1579.  
  1580.         opnd += (word)ipc.opnd;
  1581.         ipc.opnd = (word *)opnd;
  1582.         break;
  1583.  
  1584.      case Op_Limit:     /* limit */
  1585.         Setup_Arg(0);
  1586.  
  1587.         if (Olimit(0,rargp) == A_Resume) {
  1588.  
  1589.            /*
  1590.         * limit has failed here; could generate an event for it,
  1591.         *  but not an Ofail since limit is not an operator and
  1592.         *  no Ocall was ever generated for it.
  1593.         */
  1594.            goto efail_noev;
  1595.            }
  1596.         else {
  1597.            /*
  1598.         * limit has returned here; could generate an event for it,
  1599.         *  but not an Oret since limit is not an operator and
  1600.         *  no Ocall was ever generated for it.
  1601.         */
  1602.            rsp = (word *) rargp + 1;
  1603.            }
  1604.         goto mark0;
  1605.  
  1606. #ifdef TallyOpt
  1607.      case Op_Tally:     /* tally */
  1608.         tallybin[GetWord]++;
  1609.         break;
  1610. #endif                    /* TallyOpt */
  1611.  
  1612.      case Op_Pnull:     /* push null descriptor */
  1613.         PushNull;
  1614.         break;
  1615.  
  1616.      case Op_Pop:        /* pop descriptor */
  1617.         rsp -= 2;
  1618.         break;
  1619.  
  1620.      case Op_Push1:     /* push integer 1 */
  1621.         PushVal(D_Integer);
  1622.         PushVal(1);
  1623.         break;
  1624.  
  1625.      case Op_Pushn1:    /* push integer -1 */
  1626.         PushVal(D_Integer);
  1627.         PushVal(-1);
  1628.         break;
  1629.  
  1630.      case Op_Sdup:        /* duplicate descriptor */
  1631.         rsp += 2;
  1632.         rsp[-1] = rsp[-3];
  1633.         rsp[0] = rsp[-2];
  1634.         break;
  1635.  
  1636.                     /* ---Co-expressions--- */
  1637.  
  1638.      case Op_Create:    /* create */
  1639.  
  1640. #ifdef Coexpr
  1641.         PushNull;
  1642.         Setup_Arg(0);
  1643.         opnd = GetWord;
  1644.         opnd += (word)ipc.opnd;
  1645.  
  1646.         signal = Ocreate((word *)opnd, rargp);
  1647.  
  1648.         goto C_rtn_term;
  1649. #else                    /* Coexpr */
  1650.         err_msg(401, NULL);
  1651.         goto efail;
  1652. #endif                    /* Coexpr */
  1653.  
  1654.      case Op_Coact: {    /* @e */
  1655.  
  1656. #ifndef Coexpr
  1657.             err_msg(401, NULL);
  1658.             goto efail;
  1659. #else                                        /* Coexpr */
  1660.             struct b_coexpr *ncp;
  1661.             dptr dp;
  1662.  
  1663.             ExInterp;
  1664.             dp = (dptr)(sp - 1);
  1665.             xargp = dp - 2;
  1666.  
  1667.             Deref(*dp);
  1668.             if (dp->dword != D_Coexpr) {
  1669.                err_msg(118, dp);
  1670.                goto efail;
  1671.                }
  1672.  
  1673.             ncp = (struct b_coexpr *)BlkLoc(*dp);
  1674.  
  1675.             signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3));
  1676.             EntInterp;
  1677.             if (signal == A_Resume)
  1678.                goto efail_noev;
  1679.             else
  1680.                rsp -= 2;
  1681. #endif                    /* Coexpr */
  1682.             break;
  1683.         }
  1684.  
  1685.      case Op_Coret: {    /* return from co-expression */
  1686.  
  1687. #ifndef Coexpr
  1688.             syserr("co-expression return, but co-expressions not implemented");
  1689. #else                                        /* Coexpr */
  1690.             struct b_coexpr *ncp;
  1691.  
  1692.             ExInterp;
  1693.             ncp = popact((struct b_coexpr *)BlkLoc(k_current));
  1694.  
  1695.             ++BlkLoc(k_current)->coexpr.size;
  1696.             co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1);
  1697.             EntInterp;
  1698. #endif                    /* Coexpr */
  1699.             break;
  1700.  
  1701.         }
  1702.  
  1703.      case Op_Cofail: {    /* fail from co-expression */
  1704.  
  1705. #ifndef Coexpr
  1706.             syserr("co-expression failure, but co-expressions not implemented");
  1707. #else                                        /* Coexpr */
  1708.             struct b_coexpr *ncp;
  1709.  
  1710.             ExInterp;
  1711.             ncp = popact((struct b_coexpr *)BlkLoc(k_current));
  1712.  
  1713.             co_chng(ncp, NULL, NULL, A_Cofail, 1);
  1714.             EntInterp;
  1715. #endif                    /* Coexpr */
  1716.             break;
  1717.  
  1718.         }
  1719.          case Op_Quit:        /* quit */
  1720.  
  1721.  
  1722.         goto interp_quit;
  1723.  
  1724.  
  1725.      default: {
  1726.         char buf[50];
  1727.  
  1728.         sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n",
  1729.                (long)lastop, lastop);
  1730.         syserr(buf);
  1731.         }
  1732.      }
  1733.      continue;
  1734.  
  1735. C_rtn_term:
  1736.      EntInterp;
  1737.  
  1738.      switch (signal) {
  1739.  
  1740.         case A_Resume:
  1741. #ifdef EventMon
  1742.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1743.           InterpEVVal((word)-1,
  1744.                   ((lastev == E_Function)? E_Ffail : E_Ofail));
  1745.           lastev = E_Misc;
  1746.           }
  1747. #endif                    /* EventMon */
  1748.            goto efail_noev;
  1749.  
  1750.         case A_Unmark_uw:        /* unwind for unmark */
  1751. #ifdef EventMon
  1752.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1753.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1754.           lastev = E_Misc;
  1755.           }
  1756. #endif                    /* EventMon */
  1757.            goto Unmark_uw;
  1758.  
  1759.         case A_Lsusp_uw:        /* unwind for lsusp */
  1760. #ifdef EventMon
  1761.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1762.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1763.           lastev = E_Misc;
  1764.           }
  1765. #endif                    /* EventMon */
  1766.            goto Lsusp_uw;
  1767.  
  1768.         case A_Eret_uw:        /* unwind for eret */
  1769. #ifdef EventMon
  1770.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1771.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1772.           lastev = E_Misc;
  1773.           }
  1774. #endif                    /* EventMon */
  1775.            goto Eret_uw;
  1776.  
  1777.         case A_Pret_uw:        /* unwind for pret */
  1778. #ifdef EventMon
  1779.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1780.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1781.           lastev = E_Misc;
  1782.           }
  1783. #endif                    /* EventMon */
  1784.            goto Pret_uw;
  1785.  
  1786.         case A_Pfail_uw:        /* unwind for pfail */
  1787. #ifdef EventMon
  1788.            if ((lastev == E_Function) || (lastev == E_Operator)) {
  1789.           InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem));
  1790.           lastev = E_Misc;
  1791.           }
  1792. #endif                    /* EventMon */
  1793.            goto Pfail_uw;
  1794.         }
  1795.  
  1796.      rsp = (word *)rargp + 1;    /* set rsp to result */
  1797.  
  1798. #ifdef EventMon
  1799. return_term:
  1800.          value_tmp = *(dptr)(rsp - 1);    /* argument */
  1801.          Deref(value_tmp);
  1802.          if ((lastev == E_Function) || (lastev == E_Operator)) {
  1803.         InterpEVValD(&value_tmp, ((lastev == E_Function) ? E_Fret:E_Oret));
  1804.         lastev = E_Misc;
  1805.         }
  1806. #endif                    /* EventMon */
  1807.  
  1808.      continue;
  1809.      }
  1810.  
  1811. interp_quit:
  1812.    --ilevel;
  1813.    if (ilevel != 0)
  1814.       syserr("interp: termination with inactive generators.");
  1815.  
  1816.    }
  1817.  
  1818. #ifdef StackPic
  1819. /*
  1820.  * The following code is operating-system dependent [@interp.04].
  1821.  *  Diagnostic stack pictures for debugging/monitoring.
  1822.  */
  1823.  
  1824. #if PORT
  1825. Deliberate Syntax Error
  1826. #endif                    /* PORT */
  1827.  
  1828. #if AMIGA || ATARI_ST || MACINTOSH || MVS || VM || VMS
  1829.    /* not included */
  1830. #endif                    /* AMIGA || ATARI_ST || ... */
  1831.  
  1832. #if ARM
  1833. novalue stkdump(op)
  1834.    int op;
  1835.    {
  1836.    word *stk;
  1837.    word *i;
  1838.    stk = (word *)BlkLoc(k_current);
  1839.    stk += Wsizeof(struct b_coexpr);
  1840.    fprintf(stderr,">  stack:  %.8x\n", (word)stk);
  1841.    fprintf(stderr,">  sp:     %.8x\n", (word)sp);
  1842.    fprintf(stderr,">  pfp:    %.8x\n", (word)pfp);
  1843.    fprintf(stderr,">  efp:    %.8x\n", (word)efp);
  1844.    fprintf(stderr,">  gfp:    %.8x\n", (word)gfp);
  1845.    fprintf(stderr,">  ipc:    %.8x\n", (word)ipc.op);
  1846.    fprintf(stderr,">  argp:   %.8x\n", (word)argp);
  1847.    fprintf(stderr,">  ilevel: %.8x\n", (word)ilevel);
  1848.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1849.    for (i = stk; i <= (word *)sp; i++)
  1850.       fprintf(stderr,"> %.8x\n",(word)*i);
  1851.    fprintf(stderr,"> ----------\n");
  1852.    fflush(stderr);
  1853.    }
  1854. #endif                    /* ARM */
  1855.  
  1856. #if MSDOS || OS2
  1857. #if MICROSOFT || TURBO || BORLAND_286 || BORLAND_386
  1858. novalue stkdump(op)
  1859.    int op;
  1860.    {
  1861.    word far *stk;
  1862.    word far *i;
  1863.    stk = (word far *)BlkLoc(k_current);
  1864.    stk += Wsizeof(struct b_coexpr);
  1865.    fprintf(stderr,">  stack:  %08lx\n", (word)stk);
  1866.    fprintf(stderr,">  sp:     %08lx\n", (word)sp);
  1867.    fprintf(stderr,">  pfp:    %08lx\n", (word)pfp);
  1868.    fprintf(stderr,">  efp:    %08lx\n", (word)efp);
  1869.    fprintf(stderr,">  gfp:    %08lx\n", (word)gfp);
  1870.    fprintf(stderr,">  ipc:    %08lx\n", (word)ipc.op);
  1871.    fprintf(stderr,">  argp:   %08lx\n", (word)argp);
  1872.    fprintf(stderr,">  ilevel: %08lx\n", (word)ilevel);
  1873.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1874.    for (i = stk; i <= (word far *)sp; i++)
  1875.       fprintf(stderr,"> %08lx\n",(word)*i);
  1876.    fprintf(stderr,"> ----------\n");
  1877.    fflush(stderr);
  1878.    }
  1879. #endif                    /* MICROSOFT || TURBO ... */
  1880. #endif                    /* MSDOS || OS2 */
  1881.  
  1882. #if UNIX || VMS
  1883. novalue stkdump(op)
  1884.    int op;
  1885.    {
  1886.    word *i;
  1887.    fprintf(stderr,"\001stack: %lx\n",(long)(stack + Wsizeof(struct b_coexpr)));
  1888.    fprintf(stderr,"\001pfp: %lx\n",(long)pfp);
  1889.    fprintf(stderr,"\001efp: %lx\n",(long)efp);
  1890.    fprintf(stderr,"\001gfp: %lx\n",(long)gfp);
  1891.    fprintf(stderr,"\001ipc: %lx\n",(long)ipc.op);
  1892.    fprintf(stderr,"\001argp: %lx\n",(long)argp);
  1893.    fprintf(stderr,"\001ilevel: %lx\n",(long)ilevel);
  1894.    fprintf(stderr,"\001op: \%d\n",(int)op);
  1895.    for (i = stack + Wsizeof(struct b_coexpr); i <= sp; i++)
  1896.       fprintf(stderr,"\001%lx\n",*i);
  1897.    fprintf(stderr,"\001----------\n");
  1898.    fflush(stderr);
  1899.    }
  1900. #endif                    /* UNIX || VMS */
  1901.  
  1902. /*
  1903.  * End of operating-system specific code.
  1904.  */
  1905. #endif                    /* StackPic */
  1906.  
  1907. #ifdef EventMon
  1908. /*
  1909.  * vanq_proc - monitor the removal of suspended operations from within
  1910.  *   a procedure.
  1911.  */
  1912. static novalue vanq_proc(efp_v, gfp_v)
  1913. struct ef_marker *efp_v;
  1914. struct gf_marker *gfp_v;
  1915.    {
  1916.  
  1917.    if (is:null(curpstate->eventmask))
  1918.       return;
  1919.  
  1920.    /*
  1921.     * Go through all the bounded expression of the procedure.
  1922.     */
  1923.    while ((efp_v = vanq_bound(efp_v, gfp_v)) != NULL) {
  1924.       gfp_v = efp_v->ef_gfp;
  1925.       efp_v = efp_v->ef_efp;
  1926.       }
  1927.    }
  1928.  
  1929. /*
  1930.  * vanq_bound - monitor the removal of suspended operations from
  1931.  *   the current bounded expression and return the expression frame
  1932.  *   pointer for the bounded expression.
  1933.  */
  1934. static struct ef_marker *vanq_bound(efp_v, gfp_v)
  1935. struct ef_marker *efp_v;
  1936. struct gf_marker *gfp_v;
  1937.    {
  1938.  
  1939.    if (is:null(curpstate->eventmask))
  1940.       return efp_v;
  1941.  
  1942.    while (gfp_v != 0) {        /* note removal of suspended operations */
  1943.       switch ((int)gfp_v->gf_gentype) {
  1944.          case G_Psusp:
  1945.             EVValD(gfp_v->gf_argp, E_Prem);
  1946.             break;
  1947.      /* G_Fsusp and G_Osusp handled in-line during unwinding */
  1948.          case G_Esusp:
  1949.             EVVal((word)0, E_Erem);
  1950.             break;
  1951.          }
  1952.  
  1953.       if (((int)gfp_v->gf_gentype) == G_Psusp) {
  1954.          vanq_proc(gfp_v->gf_efp, gfp_v->gf_gfp);
  1955.          efp_v = gfp_v->gf_pfp->pf_efp;           /* efp before the call */
  1956.          gfp_v = gfp_v->gf_pfp->pf_gfp;           /* gfp before the call */
  1957.          }
  1958.       else {
  1959.          efp_v = gfp_v->gf_efp;
  1960.          gfp_v = gfp_v->gf_gfp;
  1961.          }
  1962.       }
  1963.  
  1964.    return efp_v;
  1965.    }
  1966. #endif                    /* EventMon */
  1967.  
  1968. #ifdef MultiThread
  1969. /*
  1970.  * activate some other co-expression from an arbitrary point in
  1971.  * the interpreter.
  1972.  */
  1973. int mt_activate(tvalp,rslt,ncp)
  1974. dptr tvalp, rslt;
  1975. register struct b_coexpr *ncp;
  1976. {
  1977.    register struct b_coexpr *ccp = (struct b_coexpr *)BlkLoc(k_current);
  1978.    int first, rv;
  1979.  
  1980.    dptr savedtvalloc = NULL;
  1981.    /*
  1982.     * Set activator in new co-expression.
  1983.     */
  1984.    if (ncp->es_actstk == NULL) {
  1985.       Protect(ncp->es_actstk = alcactiv(), { err_msg(0, NULL); exit(1); });
  1986.       /*
  1987.        * If no one ever explicitly activates this co-expression, fail to
  1988.        * the implicit activator.
  1989.        */
  1990.       ncp->es_actstk->arec[0].activator = ccp;
  1991.       first = 0;
  1992.       }
  1993.    else
  1994.       first = 1;
  1995.  
  1996.    if(ccp->tvalloc) {
  1997.      if (InRange(blkbase,ccp->tvalloc,blkfree)) {
  1998.        fprintf(stderr,
  1999.            "Multiprogram garbage collection disaster in mt_activate()!\n");
  2000.        fflush(stderr);
  2001.        exit(1);
  2002.      }
  2003.      savedtvalloc = ccp->tvalloc;
  2004.    }
  2005.  
  2006.    rv = co_chng(ncp, tvalp, rslt, A_MTEvent, first);
  2007.  
  2008.    if ((savedtvalloc != NULL) && (savedtvalloc != ccp->tvalloc)) {
  2009.       fprintf(stderr,"averted co-expression disaster in activate\n");
  2010.       ccp->tvalloc = savedtvalloc;
  2011.       }
  2012.  
  2013.    /*
  2014.     * flush any accumulated ticks
  2015.     */
  2016. #ifdef EventMon
  2017. #if UNIX
  2018.    if (ticker.l[0] + ticker.l[1] + ticker.l[2] + ticker.l[3] +
  2019.        ticker.l[4] + ticker.l[5] + ticker.l[6] + ticker.l[7] != oldtick) {
  2020.       word sum, nticks;
  2021.  
  2022.       oldtick = ticker.l[0] + ticker.l[1] + ticker.l[2] + ticker.l[3] +
  2023.        ticker.l[4] + ticker.l[5] + ticker.l[6] + ticker.l[7];
  2024.       sum = ticker.s[0] + ticker.s[1] + ticker.s[2] + ticker.s[3] +
  2025.      ticker.s[4] + ticker.s[5] + ticker.s[6] + ticker.s[7] +
  2026.         ticker.s[8] + ticker.s[9] + ticker.s[10] + ticker.s[11] +
  2027.            ticker.s[12] + ticker.s[13] + ticker.s[14] + ticker.s[15];
  2028.       nticks = sum - oldsum;
  2029.       oldsum = sum;
  2030.       }
  2031. #endif                    /* UNIX */
  2032. #endif                    /* EventMon */
  2033.  
  2034.    return rv;
  2035. }
  2036.  
  2037.  
  2038. /*
  2039.  * activate the "&parent" co-expression from anywhere, if there is one
  2040.  */
  2041. novalue actparent(event)
  2042. int event;
  2043.    {
  2044.    struct progstate *parent = curpstate->parent;
  2045.  
  2046.    StrLen(parent->eventcode) = 1;
  2047.    StrLoc(parent->eventcode) = (char *)&allchars[FromAscii(event)&0xFF];
  2048.    mt_activate(&(parent->eventcode), NULL,
  2049.            (struct b_coexpr *)curpstate->parent->Mainhead);
  2050.    }
  2051. #endif                    /* MultiThread */
  2052. #endif                    /* !COMPILER */
  2053.