home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Interp < prev    next >
Encoding:
Text File  |  1990-07-19  |  39.6 KB  |  1,726 lines
  1. /*
  2.  * The intepreter proper.
  3.  */
  4.  
  5. #include "../h/config.h"
  6. #include "../h/rt.h"
  7. #include "rproto.h"
  8. #include "../h/opdefs.h"
  9.  
  10. extern fptr fncentry[];
  11.  
  12.  
  13. #ifdef DumpIstream
  14. extern FILE *imons;
  15. #endif                    /* DumpIstream */
  16.  
  17. #ifdef DumpIcount
  18. extern FILE *imonc;
  19. #endif                    /* DumpIcount */
  20.  
  21. /*
  22.  * The following code is operating-system dependent [@interp.01].  Declarations
  23.  *  and include files.
  24.  */
  25.  
  26. #if PORT
  27. Deliberate Syntax Error
  28. #endif                    /* PORT */
  29.  
  30. #if ARM || ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS
  31.    /* nothing needed */
  32. #endif                    /* ARM || ATARI_ST || ... */
  33.  
  34. #if AMIGA
  35. #include <fcntl.h>
  36. #include <ios1.h>
  37.  
  38. extern int chkbreak;
  39. #endif                    /* AMIGA */
  40.  
  41. #if MACINTOSH
  42. #if MPW
  43. #include <CursorCtl.h>
  44. #define CURSORINTERVAL 1000
  45. #endif                    /* MPW */
  46. #endif                                  /* MACINTOSH */
  47.  
  48. /*
  49.  * End of operating-system specific code.
  50.  */
  51.  
  52. #ifdef EvalTrace
  53. extern word lineno;        /* source line number */
  54. extern word colmno;        /* source column number */
  55. #endif                    /* EvalTrace */
  56.  
  57. /*
  58.  * Istate variables.
  59.  */
  60. struct pf_marker *pfp = 0;    /* Procedure frame pointer */
  61. struct ef_marker *efp;        /* Expression frame pointer */
  62. struct gf_marker *gfp;        /* Generator frame pointer */
  63. inst ipc;            /* Interpreter program counter */
  64. dptr argp;            /* Pointer to argument zero */
  65. word *sp = NULL;        /* Stack pointer */
  66.  
  67. #ifdef WATERLOO_C_V3_0
  68. int *cw3defect;
  69. #endif                    /* WATERLOO_C_V3_0 */
  70.  
  71. #ifdef IconCalling
  72. extern int interp_status;    /* interpreter status */
  73. extern int IDepth;        /* depth of icon_call */
  74. #endif                    /* IconCalling */
  75.  
  76. #ifdef Polling
  77. extern int pollctr;
  78. #endif                    /* Polling */
  79.  
  80.  
  81. int ilevel;            /* Depth of recursion in interp() */
  82. word lastop;            /* Last operator evaluated */
  83. struct descrip list_tmp;    /* list argument to Op_Apply */
  84.  
  85.  
  86. #ifdef MaxLevel
  87. int maxilevel;            /* Maximum ilevel */
  88. int maxplevel;            /* Maximum &level */
  89. word *maxsp;            /* Maximum interpreter sp */
  90. #endif                    /* MaxLevel */
  91.  
  92. /*
  93.  * Descriptor to hold result for eret across potential interp unwinding.
  94.  */
  95. struct descrip eret_tmp;
  96.  
  97. /*
  98.  * Last co-expression action.
  99.  */
  100. int coexp_act;
  101.  
  102. #ifdef TraceBack
  103. dptr xargp;
  104. word xnargs;
  105. #endif                    /* TraceBack */
  106.  
  107. /*
  108.  * Macros for use inside the main loop of the interpreter.
  109.  */
  110.  
  111. /*
  112.  * Setup_Op sets things up for a call to the C function for an operator.
  113.  */
  114. #ifdef TraceBack
  115. #define Setup_Op(nargs)  \
  116.    rargp = (dptr)(rsp - 1) - nargs; \
  117.    xargp = rargp; \
  118.    ExInterp;
  119. #else                    /* TraceBack */
  120. #define Setup_Op(nargs)  \
  121.    rargp = (dptr)(rsp - 1) - nargs; \
  122.    ExInterp;
  123. #endif                    /* TraceBack */
  124.  
  125.  
  126. #define Call_Cond if ((*(optab[lastop]))(rargp) == A_Failure) goto efail; \
  127.      else \
  128.      rsp = (word *) rargp + 1;
  129. /*
  130.  * Call_Gen - Call a generator. A C routine associated with the
  131.  *  current opcode is called. When it when it terminates, control is
  132.  *  passed to C_rtn_term to deal with the termination condition appropriately.
  133.  */
  134. #define Call_Gen   signal = (*(optab[lastop]))(rargp); \
  135.      goto C_rtn_term;
  136.  
  137. /*
  138.  * GetWord fetches the next icode word.  PutWord(x) stores x at the current
  139.  * icode word.
  140.  */
  141. #define GetWord (*ipc.opnd++)
  142. #define PutWord(x) ipc.opnd[-1] = (x)
  143. #define GetOp (word)(*ipc.op++)
  144. #define PutOp(x) ipc.op[-1] = (x)
  145. /*
  146.  * DerefArg(n) dereferences the nth argument.
  147.  */
  148. #define DerefArg(n)   if (DeRef(rargp[n]) == Error) {\
  149.    runerr(0, NULL);\
  150.    goto efail;}
  151.  
  152. /*
  153.  * For the sake of efficiency, the stack pointer is kept in a register
  154.  *  variable, rsp, in the interpreter loop.  Since this variable is
  155.  *  only accessible inside the loop, and the global variable sp is used
  156.  *  for the stack pointer elsewhere, rsp must be stored into sp when
  157.  *  the context of the loop is left and conversely, rsp must be loaded
  158.  *  from sp when the loop is reentered.  The macros ExInterp and EntInterp,
  159.  *  respectively, handle these operations.  Currently, this register/global
  160.  *  scheme is only used for the stack pointer, but it can be easily extended
  161.  *  to other variables.
  162.  */
  163.  
  164. #define ExInterp    sp = rsp;
  165. #define EntInterp    rsp = sp;
  166.  
  167. /*
  168.  * Inside the interpreter loop, PushDesc, PushNull, PushAVal, and
  169.  *  PushVal use rsp instead of sp for efficiency.
  170.  */
  171.  
  172. #undef PushDesc
  173. #undef PushNull
  174. #undef PushVal
  175. #undef PushAVal
  176. #define PushDesc(d)   {*++rsp=((d).dword); *++rsp=((d).vword.integr);}
  177. #define PushNull   {*++rsp = D_Null; *++rsp = 0;}
  178. #define PushVal(v)   {*++rsp = (word)(v);}
  179.  
  180. /*
  181.  * The following code is operating-system dependent [@interp.02].  Define
  182.  *  PushAVal for computers that store longs and pointers differently.
  183.  */
  184.  
  185. #if PORT
  186. #define PushAVal(x) PushVal(x)
  187. Deliberate Syntax Error
  188. #endif                    /* PORT */
  189.  
  190. #if MSDOS || OS2
  191. #define PushAVal(x) {rsp++; \
  192.                stkword.stkadr = (char *)(x); \
  193.                *rsp = stkword.stkint; \
  194.                }
  195. #endif                    /* MSDOS || OS2 */
  196.  
  197. #if AMIGA || ARM || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || UNIX || VM || VMS
  198. #define PushAVal(x) PushVal(x)
  199. #endif                    /* AMIGA || ARM || ATARI_ST || HIGHC_386 ... */
  200.  
  201. /*
  202.  * End of operating-system specific code.
  203.  */
  204.  
  205. /*
  206.  * The main loop of the interpreter.
  207.  */
  208.  
  209. int interp(fsig,cargp)
  210.  
  211. int fsig;
  212. dptr cargp;
  213.    {
  214.    register word opnd;
  215.    register word *rsp;
  216.    register dptr rargp;
  217.    register struct ef_marker *newefp;
  218.    register struct gf_marker *newgfp;
  219.    register word *wd;
  220.    register word *firstwd, *lastwd;
  221.    word *oldsp;
  222.    int type, signal, args;
  223.    extern int (*optab[])();
  224.    extern struct astkblk *alcactiv();
  225.    extern char *strcons;
  226.    struct b_proc *bproc;
  227.  
  228. #ifdef TallyOpt
  229.    extern word tallybin[];
  230. #endif                    /* TallyOpt */
  231.  
  232.  
  233.    /*
  234.     * Make a stab at catching interpreter stack overflow.  This does
  235.     * nothing for invocation in a co-expression other than &main.
  236.     */
  237.    if (BlkLoc(k_current) == BlkLoc(k_main) &&
  238.       ((char *)sp + PerilDelta) > (char *)stackend) 
  239.          fatalerr(-301, NULL);
  240.  
  241. #ifdef Polling
  242.             pollctr--;
  243.             if (!pollctr)
  244.                pollctr = pollevent();
  245. #endif                    /* Polling */
  246.  
  247.    ilevel++;
  248.  
  249. #ifdef MaxLevel
  250.    if (ilevel > maxilevel)
  251.       maxilevel = ilevel;
  252. #endif                    /* MaxLevel */
  253.  
  254.    EntInterp;
  255.    if (fsig == G_Csusp) {
  256.  
  257.  
  258.       oldsp = rsp;
  259.  
  260.       /*
  261.        * Create the generator frame.
  262.        */
  263.       newgfp = (struct gf_marker *)(rsp + 1);
  264.       newgfp->gf_gentype = G_Csusp;
  265.       newgfp->gf_gfp = gfp;
  266.       newgfp->gf_efp = efp;
  267.       newgfp->gf_ipc = ipc;
  268.       rsp += Wsizeof(struct gf_smallmarker);
  269.  
  270.       /*
  271.        * Region extends from first word after the marker for the generator
  272.        *  or expression frame enclosing the call to the now-suspending
  273.        *  routine to the first argument of the routine.
  274.        */
  275.       if (gfp != 0) {
  276.      if (gfp->gf_gentype == G_Psusp)
  277.         firstwd = (word *)gfp + Wsizeof(*gfp);
  278.      else
  279.         firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker);
  280.      }
  281.       else
  282.      firstwd = (word *)efp + Wsizeof(*efp);
  283.       lastwd = (word *)cargp + 1;
  284.  
  285.       /*
  286.        * Copy the portion of the stack with endpoints firstwd and lastwd
  287.        *  (inclusive) to the top of the stack.
  288.        */
  289.       for (wd = firstwd; wd <= lastwd; wd++)
  290.      *++rsp = *wd;
  291.       gfp = newgfp;
  292.       }
  293. /*
  294.  * Top of the interpreter loop.
  295.  */
  296.  
  297.    for (;;) {
  298.  
  299. #ifdef MaxLevel
  300.       if (sp > maxsp)
  301.      maxsp = sp;
  302. #endif                    /* MaxLevel */
  303.  
  304.       lastop = GetOp;        /* Instruction fetch */
  305.  
  306. #ifdef StackPic
  307.       ExInterp;
  308.       stkdump((int)lastop);
  309.       EntInterp;
  310. #endif                    /* StackPic */
  311.  
  312. #ifdef DumpIstream
  313.       putc((char)lastop,imons);
  314. #endif                    /* DumpIstream */
  315.  
  316. #ifdef DumpIcount
  317.       if (lastop > MaxIcode) {
  318.      fprintf(stderr,"Unexpected large opcode = %d\n",lastop);
  319.      fflush(stderr);
  320.      abort;
  321.      }
  322.       icode[lastop]++;
  323. #endif                    /* DumpIcount */
  324.  
  325. /*
  326.  * The following code is operating-system dependent [@interp.03].  Check
  327.  *  for external event.
  328.  */
  329. #if PORT
  330. Deliberate Syntax Error
  331. #endif                    /* PORT */
  332.  
  333. #if AMIGA
  334.       ExInterp;
  335.       if (chkbreak > 0)
  336.      chkabort();            /* check for CTRL-C or CTRL-D break */
  337.       EntInterp;
  338. #endif                    /* AMIGA */
  339.  
  340. #if ARM || ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS
  341.    /* nothing to do */
  342. #endif                    /* ARM || ATARI_ST || HIGHC_386 ... */
  343.  
  344. #if MACINTOSH
  345. #if MPW
  346.    {
  347.    static short cursorcount = CURSORINTERVAL;
  348.    if (--cursorcount == 0) {
  349.       RotateCursor(0);
  350.       cursorcount = CURSORINTERVAL;
  351.       }
  352.    }
  353. #endif                    /* MPW */
  354. #endif                    /* MACINTOSH */
  355.  
  356. /*
  357.  * End of operating-system specific code.
  358.  */
  359.  
  360.       switch ((int)lastop) {        /*
  361.                  * Switch on opcode.  The cases are
  362.                  * organized roughly by functionality
  363.                  * to make it easier to find things.
  364.                  * For some C compilers, there may be
  365.                  * an advantage to arranging them by
  366.                  * likelihood of selection.
  367.                  */
  368.  
  369.                 /* ---Constant construction--- */
  370.  
  371.      case Op_Cset:        /* cset */
  372.         PutOp(Op_Acset);
  373.         PushVal(D_Cset);
  374.         opnd = GetWord;
  375.         opnd += (word)ipc.opnd;
  376.         PutWord(opnd);
  377.         PushAVal(opnd);
  378.         break;
  379.  
  380.      case Op_Acset:     /* cset, absolute address */
  381.         PushVal(D_Cset);
  382.         PushAVal(GetWord);
  383.         break;
  384.  
  385.      case Op_Int:        /* integer */
  386.         PushVal(D_Integer);
  387.         PushVal(GetWord);
  388.         break;
  389.  
  390.      case Op_Real:        /* real */
  391.         PutOp(Op_Areal);
  392.         PushVal(D_Real);
  393.         opnd = GetWord;
  394.         opnd += (word)ipc.opnd;
  395.         PushAVal(opnd);
  396.         PutWord(opnd);
  397.         break;
  398.  
  399.      case Op_Areal:     /* real, absolute address */
  400.         PushVal(D_Real);
  401.         PushAVal(GetWord);
  402.         break;
  403.  
  404.      case Op_Str:        /* string */
  405.         PutOp(Op_Astr);
  406.         PushVal(GetWord)
  407.  
  408. #ifdef CRAY
  409.         opnd = (word)(strcons + GetWord);
  410. #else                    /* CRAY */
  411.         opnd = (word)strcons + GetWord;
  412. #endif                    /* CRAY */
  413.  
  414.         PutWord(opnd);
  415.         PushAVal(opnd);
  416.         break;
  417.  
  418.      case Op_Astr:        /* string, absolute address */
  419.         PushVal(GetWord);
  420.         PushAVal(GetWord);
  421.         break;
  422.  
  423.                 /* ---Variable construction--- */
  424.  
  425.      case Op_Arg:        /* argument */
  426.         PushVal(D_Var);
  427.         PushAVal(&argp[GetWord + 1]);
  428.         break;
  429.  
  430.      case Op_Global:    /* global */
  431.         PutOp(Op_Aglobal);
  432.         PushVal(D_Var);
  433.         opnd = GetWord;
  434.         PushAVal(&globals[opnd]);
  435.         PutWord((word)&globals[opnd]);
  436.         break;
  437.  
  438.      case Op_Aglobal:    /* global, absolute address */
  439.         PushVal(D_Var);
  440.         PushAVal(GetWord);
  441.         break;
  442.  
  443.      case Op_Local:     /* local */
  444.         PushVal(D_Var);
  445.         PushAVal(&pfp->pf_locals[GetWord]);
  446.         break;
  447.  
  448.      case Op_Static:    /* static */
  449.         PutOp(Op_Astatic);
  450.         PushVal(D_Var);
  451.         opnd = GetWord;
  452.         PushAVal(&statics[opnd]);
  453.         PutWord((word)&statics[opnd]);
  454.         break;
  455.  
  456.      case Op_Astatic:    /* static, absolute address */
  457.         PushVal(D_Var);
  458.         PushAVal(GetWord);
  459.         break;
  460.  
  461.  
  462.                 /* ---Operators--- */
  463.  
  464.                 /* Unary operators */
  465.  
  466.      case Op_Compl:     /* ~e */
  467.      case Op_Neg:        /* -e */
  468.      case Op_Number:    /* +e */
  469.      case Op_Refresh:    /* ^e */
  470.      case Op_Size:        /* *e */
  471.         Setup_Op(1);
  472.         DerefArg(1);
  473.         Call_Cond;
  474.         break;
  475.  
  476.      case Op_Value:     /* .e */
  477.      case Op_Nonnull:    /* \e */
  478.      case Op_Null:        /* /e */
  479.         Setup_Op(1);
  480.         Call_Cond;
  481.         break;
  482.  
  483.      case Op_Random:    /* ?e */
  484.         PushNull;
  485.         Setup_Op(2)
  486.         Call_Cond
  487.         break;
  488.  
  489.                 /* Generative unary operators */
  490.  
  491.      case Op_Tabmat:    /* =e */
  492.         Setup_Op(1);
  493.         DerefArg(1);
  494.         Call_Gen;
  495.  
  496.      case Op_Bang:        /* !e */
  497.         PushNull;
  498.         Setup_Op(2);
  499.         Call_Gen;
  500.  
  501.                 /* Binary operators */
  502.  
  503.      case Op_Cat:        /* e1 || e2 */
  504.      case Op_Diff:        /* e1 -- e2 */
  505.      case Op_Div:        /* e1 / e2 */
  506.      case Op_Inter:     /* e1 ** e2 */
  507.      case Op_Lconcat:    /* e1 ||| e2 */
  508.      case Op_Minus:     /* e1 - e2 */
  509.      case Op_Mod:        /* e1 % e2 */
  510.      case Op_Mult:        /* e1 * e2 */
  511.      case Op_Power:     /* e1 ^ e2 */
  512.      case Op_Unions:    /* e1 ++ e2 */
  513.      case Op_Plus:        /* e1 + e2 */
  514.      case Op_Eqv:        /* e1 === e2 */
  515.      case Op_Lexeq:     /* e1 == e2 */
  516.      case Op_Lexge:     /* e1 >>= e2 */
  517.      case Op_Lexgt:     /* e1 >> e2 */
  518.      case Op_Lexle:     /* e1 <<= e2 */
  519.      case Op_Lexlt:     /* e1 << e2 */
  520.      case Op_Lexne:     /* e1 ~== e2 */
  521.      case Op_Neqv:        /* e1 ~=== e2 */
  522.      case Op_Numeq:     /* e1 = e2 */
  523.      case Op_Numge:     /* e1 >= e2 */
  524.      case Op_Numgt:     /* e1 > e2 */
  525.      case Op_Numle:     /* e1 <= e2 */
  526.      case Op_Numne:     /* e1 ~= e2 */
  527.      case Op_Numlt:     /* e1 < e2 */
  528.         Setup_Op(2);
  529.         DerefArg(1);
  530.         DerefArg(2);
  531.         Call_Cond;
  532.         break;
  533.  
  534.      case Op_Asgn:        /* e1 := e2 */
  535.         Setup_Op(2);
  536.         DerefArg(2);
  537.         Call_Cond;
  538.         break;
  539.  
  540.      case Op_Swap:        /* e1 :=: e2 */
  541.         PushNull;
  542.         Setup_Op(3);
  543.         Call_Cond;
  544.         break;
  545.  
  546.      case Op_Subsc:     /* e1[e2] */
  547.         PushNull;
  548.         Setup_Op(3);
  549.         DerefArg(2);
  550.         Call_Cond;
  551.         break;
  552.                 /* Generative binary operators */
  553.  
  554.      case Op_Rasgn:     /* e1 <- e2 */
  555.         Setup_Op(2);
  556.         DerefArg(2);
  557.         Call_Gen;
  558.  
  559.      case Op_Rswap:     /* e1 <-> e2 */
  560.         PushNull;
  561.         Setup_Op(3);
  562.         Call_Gen;
  563.  
  564.                 /* Conditional ternary operators */
  565.  
  566.      case Op_Sect:        /* e1[e2:e3] */
  567.         PushNull;
  568.         Setup_Op(4);
  569.         DerefArg(2);
  570.         DerefArg(3);
  571.         Call_Cond;
  572.         break;
  573.                 /* Generative ternary operators */
  574.  
  575.      case Op_Toby:        /* e1 to e2 by e3 */
  576.         Setup_Op(3);
  577.         DerefArg(1);
  578.         DerefArg(2);
  579.         DerefArg(3);
  580.         Call_Gen;
  581.  
  582. #ifdef LineCodes
  583.          case Op_Noop:        /* no-op */
  584.  
  585. #ifdef Polling
  586.             pollctr--;
  587.             if (!pollctr)
  588.                pollctr = pollevent();
  589. #endif                    /* Polling */
  590.  
  591.  
  592.             break;
  593.  
  594. #endif                /* LineCodes */
  595.  
  596.  
  597. #ifdef EvalTrace
  598.          case Op_Colm:        /* source column number */
  599.             colmno = GetWord;
  600.             break;
  601.  
  602.          case Op_Line:        /* source line number */
  603.             lineno = GetWord;
  604.             break;
  605. #endif                    /* EvalTrace */
  606.  
  607.                 /* ---String Scanning--- */
  608.  
  609.      case Op_Bscan:     /* prepare for scanning */
  610.         PushDesc(k_subject);
  611.         PushVal(D_Integer);
  612.         PushVal(k_pos);
  613.         Setup_Op(2);
  614.  
  615.         signal = Obscan(2,rargp);
  616.  
  617.         goto C_rtn_term;
  618.  
  619.      case Op_Escan:     /* exit from scanning */
  620.         Setup_Op(1);
  621.  
  622.         signal = Oescan(1,rargp);
  623.  
  624.         goto C_rtn_term;
  625.  
  626.                 /* ---Other Language Operations--- */
  627.  
  628.  
  629.          case Op_Apply: {    /* apply */
  630.             {
  631.             union block *bp;
  632.             int i, j;
  633.  
  634.             list_tmp = *(dptr)(rsp - 1);    /* argument */
  635.             DeRef(list_tmp);
  636.             if (list_tmp.dword != D_List) {    /* be sure it's a list */
  637.                xargp = (dptr)(rsp - 3);
  638.                runerr(108, &list_tmp);
  639.                goto efail;
  640.                } 
  641.             rsp -= 2;                /* pop it off */
  642.             bp = BlkLoc(list_tmp);
  643.             args = (int)bp->list.size;
  644.             for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) {
  645.                for (i = 0; i < bp->lelem.nused; i++) {
  646.                   j = bp->lelem.first + i;
  647.                   if (j >= bp->lelem.nslots)
  648.                      j -= bp->lelem.nslots;
  649.                   PushDesc(bp->lelem.lslots[j])
  650.                   }
  651.                }
  652.             goto invokej;
  653.                }
  654.             }
  655.  
  656.      case Op_Invoke: {    /* invoke */
  657.             args = (int)GetWord;
  658. invokej:
  659.         {
  660.             int nargs;
  661.         dptr carg;
  662.  
  663.         ExInterp;
  664.         type = invoke(args, &carg, &nargs);
  665.         rargp = carg;
  666.         EntInterp;
  667.  
  668. #ifdef MaxLevel
  669.         if (k_level > maxplevel)
  670.            maxplevel = k_level;
  671. #endif                    /* MaxLevel */
  672.         if (type == I_Fail)
  673.            goto efail;
  674.         if (type == I_Continue)
  675.            break;
  676.         else {
  677.            int (*bfunc)();
  678.  
  679.            bproc = (struct b_proc *)BlkLoc(*rargp);
  680.            bfunc = bproc->entryp.ccode;
  681.  
  682.            /* ExInterp not needed since no change since last EntInterp */
  683.            if (type == I_Vararg)
  684.  
  685.           signal = (*bfunc)(nargs,rargp);
  686.  
  687.            else
  688.  
  689.           signal = (*bfunc)(rargp);
  690.  
  691.  
  692.            goto C_rtn_term;
  693.            }
  694.         }
  695.         break;
  696.         }
  697.  
  698.      case Op_Keywd:     /* keyword */
  699.         PushVal(D_Integer);
  700.         PushVal(GetWord);
  701.         Setup_Op(0);
  702.  
  703.         signal = Okeywd(0,rargp);
  704.         goto C_rtn_term;
  705.  
  706.      case Op_Llist:     /* construct list */
  707.         opnd = GetWord;
  708.         Setup_Op(opnd);
  709.  
  710.         signal = Ollist((int)opnd,rargp);
  711.         goto C_rtn_term;
  712.  
  713.                 /* ---Marking and Unmarking--- */
  714.  
  715.      case Op_Mark:        /* create expression frame marker */
  716.         PutOp(Op_Amark);
  717.         opnd = GetWord;
  718.         opnd += (word)ipc.opnd;
  719.         PutWord(opnd);
  720.         newefp = (struct ef_marker *)(rsp + 1);
  721.         newefp->ef_failure.opnd = (word *)opnd;
  722.         goto mark;
  723.  
  724.      case Op_Amark:     /* mark with absolute fipc */
  725.         newefp = (struct ef_marker *)(rsp + 1);
  726.         newefp->ef_failure.opnd = (word *)GetWord;
  727. mark:
  728.         newefp->ef_gfp = gfp;
  729.         newefp->ef_efp = efp;
  730.         newefp->ef_ilevel = ilevel;
  731.         rsp += Wsizeof(*efp);
  732.         efp = newefp;
  733.         gfp = 0;
  734.         break;
  735.  
  736.      case Op_Mark0:     /* create expression frame with 0 ipl */
  737. mark0:
  738.         newefp = (struct ef_marker *)(rsp + 1);
  739.         newefp->ef_failure.opnd = 0;
  740.         newefp->ef_gfp = gfp;
  741.         newefp->ef_efp = efp;
  742.         newefp->ef_ilevel = ilevel;
  743.         rsp += Wsizeof(*efp);
  744.         efp = newefp;
  745.         gfp = 0;
  746.         break;
  747.  
  748.      case Op_Unmark:    /* remove expression frame */
  749.         gfp = efp->ef_gfp;
  750.         rsp = (word *)efp - 1;
  751.  
  752.         /*
  753.          * Remove any suspended C generators.
  754.          */
  755. Unmark_uw:
  756.         if (efp->ef_ilevel < ilevel) {
  757.            --ilevel;
  758.            ExInterp;
  759.            return A_Unmark_uw;
  760.            }
  761.         efp = efp->ef_efp;
  762.         break;
  763.  
  764.                 /* ---Suspensions--- */
  765.  
  766.      case Op_Esusp: {    /* suspend from expression */
  767.  
  768.         /*
  769.          * Create the generator frame.
  770.          */
  771.         oldsp = rsp;
  772.         newgfp = (struct gf_marker *)(rsp + 1);
  773.         newgfp->gf_gentype = G_Esusp;
  774.         newgfp->gf_gfp = gfp;
  775.         newgfp->gf_efp = efp;
  776.         newgfp->gf_ipc = ipc;
  777.         gfp = newgfp;
  778.         rsp += Wsizeof(struct gf_smallmarker);
  779.  
  780.         /*
  781.          * Region extends from first word after enclosing generator or
  782.          *    expression frame marker to marker for current expression frame.
  783.          */
  784.         if (efp->ef_gfp != 0) {
  785.            newgfp = (struct gf_marker *)(efp->ef_gfp);
  786.            if (newgfp->gf_gentype == G_Psusp)
  787.           firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  788.            else
  789.           firstwd = (word *)efp->ef_gfp +
  790.              Wsizeof(struct gf_smallmarker);
  791.         }
  792.         else
  793.            firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  794.         lastwd = (word *)efp - 1;
  795.         efp = efp->ef_efp;
  796.  
  797.         /*
  798.          * Copy the portion of the stack with endpoints firstwd and lastwd
  799.          *    (inclusive) to the top of the stack.
  800.          */
  801.         for (wd = firstwd; wd <= lastwd; wd++)
  802.            *++rsp = *wd;
  803.         PushVal(oldsp[-1]);
  804.         PushVal(oldsp[0]);
  805.         break;
  806.         }
  807.  
  808.      case Op_Lsusp: {    /* suspend from limitation */
  809.         struct descrip sval;
  810.  
  811.         /*
  812.          * The limit counter is contained in the descriptor immediately
  813.          *    prior to the current expression frame.    lval is established
  814.          *    as a pointer to this descriptor.
  815.          */
  816.         dptr lval = (dptr)((word *)efp - 2);
  817.  
  818.         /*
  819.          * Decrement the limit counter and check it.
  820.          */
  821.         if (--IntVal(*lval) > 0) {
  822.            /*
  823.         * The limit has not been reached, set up stack.
  824.         */
  825.  
  826.            sval = *(dptr)(rsp - 1);    /* save result */
  827.  
  828.            /*
  829.         * Region extends from first word after enclosing generator or
  830.         *  expression frame marker to the limit counter just prior to
  831.         *  to the current expression frame marker.
  832.         */
  833.            if (efp->ef_gfp != 0) {
  834.           newgfp = (struct gf_marker *)(efp->ef_gfp);
  835.           if (newgfp->gf_gentype == G_Psusp)
  836.              firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
  837.           else
  838.              firstwd = (word *)efp->ef_gfp +
  839.             Wsizeof(struct gf_smallmarker);
  840.           }
  841.            else
  842.           firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
  843.            lastwd = (word *)efp - 3;
  844.            if (gfp == 0)
  845.           gfp = efp->ef_gfp;
  846.            efp = efp->ef_efp;
  847.  
  848.            /*
  849.         * Copy the portion of the stack with endpoints firstwd and lastwd
  850.         *  (inclusive) to the top of the stack.
  851.         */
  852.            rsp -= 2;        /* overwrite result */
  853.            for (wd = firstwd; wd <= lastwd; wd++)
  854.           *++rsp = *wd;
  855.            PushDesc(sval);        /* push saved result */
  856.            }
  857.         else {
  858.            /*
  859.         * Otherwise, the limit has been reached.  Instead of
  860.         *  suspending, remove the current expression frame and
  861.         *  replace the limit counter with the value on top of
  862.         *  the stack (which would have been suspended had the
  863.         *  limit not been reached).
  864.         */
  865.            *lval = *(dptr)(rsp - 1);
  866.            gfp = efp->ef_gfp;
  867.  
  868.            /*
  869.         * Since an expression frame is being removed, inactive
  870.         *  C generators contained therein are deactivated.
  871.         */
  872. Lsusp_uw:
  873.            if (efp->ef_ilevel < ilevel) {
  874.           --ilevel;
  875.           ExInterp;
  876.           return A_Lsusp_uw;
  877.           }
  878.            rsp = (word *)efp - 1;
  879.            efp = efp->ef_efp;
  880.            }
  881.         break;
  882.         }
  883.  
  884.      case Op_Psusp: {    /* suspend from procedure */
  885.         /*
  886.          * An Icon procedure is suspending a value.  Determine if the
  887.          *    value being suspended should be dereferenced and if so,
  888.          *    dereference it. If tracing is on, strace is called
  889.          *  to generate a message.  Appropriate values are
  890.          *    restored from the procedure frame of the suspending procedure.
  891.          */
  892.  
  893.         struct descrip tmp;
  894.         struct descrip sval, *svalp;
  895.         struct b_proc *sproc;
  896.  
  897.         svalp = (dptr)(rsp - 1);
  898.         sval = *svalp;
  899.         if (Var(sval)) {
  900.            word *loc;
  901.  
  902.            if (Tvar(sval)) {
  903.           if (sval.dword == D_Tvsubs) {
  904.               struct b_tvsubs *tvb;
  905.  
  906.              tvb = (struct b_tvsubs *)BlkLoc(sval);
  907.              loc = (word *)BlkLoc(tvb->ssvar);
  908.              if (!Tvar(tvb->ssvar))
  909.             loc += Offset(tvb->ssvar);
  910.              }
  911.           else
  912.              goto ps_noderef;
  913.             }
  914.            else
  915.           loc = (word *)VarLoc(sval) + Offset(sval);
  916.                   if (InRange(BlkLoc(k_current),loc,rsp))
  917.              if (DeRef(*svalp) == Error) {
  918.                 runerr(0, NULL);
  919.                 goto efail;
  920.                 }
  921.            }
  922. ps_noderef:
  923.  
  924.         /*
  925.          * Create the generator frame.
  926.          */
  927.         oldsp = rsp;
  928.         newgfp = (struct gf_marker *)(rsp + 1);
  929.         newgfp->gf_gentype = G_Psusp;
  930.         newgfp->gf_gfp = gfp;
  931.         newgfp->gf_efp = efp;
  932.         newgfp->gf_ipc = ipc;
  933.         newgfp->gf_argp = argp;
  934.         newgfp->gf_pfp = pfp;
  935.         gfp = newgfp;
  936.         rsp += Wsizeof(*gfp);
  937.  
  938.         /*
  939.          * Region extends from first word after the marker for the
  940.          *    generator or expression frame enclosing the call to the
  941.          *    now-suspending procedure to Arg0 of the procedure.
  942.          */
  943.         if (pfp->pf_gfp != 0) {
  944.            newgfp = (struct gf_marker *)(pfp->pf_gfp);
  945.            if (newgfp->gf_gentype == G_Psusp)
  946.           firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp);
  947.            else
  948.           firstwd = (word *)pfp->pf_gfp +
  949.              Wsizeof(struct gf_smallmarker);
  950.            }
  951.         else
  952.            firstwd = (word *)pfp->pf_efp + Wsizeof(*efp);
  953.         lastwd = (word *)argp - 1;
  954.            efp = efp->ef_efp;
  955.  
  956.         /*
  957.          * Copy the portion of the stack with endpoints firstwd and lastwd
  958.          *    (inclusive) to the top of the stack.
  959.          */
  960.         for (wd = firstwd; wd <= lastwd; wd++)
  961.            *++rsp = *wd;
  962.         PushVal(oldsp[-1]);
  963.         PushVal(oldsp[0]);
  964.         --k_level;
  965.         if (k_trace) {
  966.                k_trace--;
  967.            sproc = (struct b_proc *)BlkLoc(*argp);
  968.            strace(&(sproc->pname), svalp);
  969.            }
  970.  
  971.         /*
  972.          * If the scanning environment for this procedure call is in
  973.          *    a saved state, switch environments.
  974.          */
  975.         if (pfp->pf_scan != NULL) {
  976.            tmp = k_subject;
  977.            k_subject = *pfp->pf_scan;
  978.            *pfp->pf_scan = tmp;
  979.  
  980.            tmp = *(pfp->pf_scan + 1);
  981.            IntVal(*(pfp->pf_scan + 1)) = k_pos;
  982.            k_pos = IntVal(tmp);
  983.            }
  984.         efp = pfp->pf_efp;
  985.         ipc = pfp->pf_ipc;
  986.         argp = pfp->pf_argp;
  987.         pfp = pfp->pf_pfp;
  988.         break;
  989.         }
  990.  
  991.                 /* ---Returns--- */
  992.  
  993.      case Op_Eret: {    /* return from expression */
  994.         /*
  995.          * Op_Eret removes the current expression frame, leaving the
  996.          *    original top of stack value on top.
  997.          */
  998.         /*
  999.          * Save current top of stack value in global temporary (no
  1000.          *    danger of reentry).
  1001.          */
  1002.         eret_tmp = *(dptr)&rsp[-1];
  1003.         gfp = efp->ef_gfp;
  1004. Eret_uw:
  1005.         /*
  1006.          * Since an expression frame is being removed, inactive
  1007.          *    C generators contained therein are deactivated.
  1008.          */
  1009.         if (efp->ef_ilevel < ilevel) {
  1010.            --ilevel;
  1011.            ExInterp;
  1012.            return A_Eret_uw;
  1013.            }
  1014.         rsp = (word *)efp - 1;
  1015.         efp = efp->ef_efp;
  1016.         PushDesc(eret_tmp);
  1017.         break;
  1018.         }
  1019.  
  1020.      case Op_Pret: {    /* return from procedure */
  1021.         /*
  1022.          * An Icon procedure is returning a value.    Determine if the
  1023.          *    value being returned should be dereferenced and if so,
  1024.          *    dereference it.  If tracing is on, rtrace is called to
  1025.          *    generate a message.  Inactive generators created after
  1026.          *    the activation of the procedure are deactivated.  Appropriate
  1027.          *    values are restored from the procedure frame.
  1028.          */
  1029.         struct descrip rval;
  1030.         struct b_proc *rproc = (struct b_proc *)BlkLoc(*argp);
  1031.  
  1032.         *argp = *(dptr)(rsp - 1);
  1033.         rval = *argp;
  1034.         if (Var(rval)) {
  1035.            word *loc;
  1036.  
  1037.            if (Tvar(rval)) {
  1038.           if (rval.dword == D_Tvsubs) {
  1039.               struct b_tvsubs *tvb;
  1040.  
  1041.              tvb = (struct b_tvsubs *)BlkLoc(rval);
  1042.              loc = (word *)BlkLoc(tvb->ssvar);
  1043.              if (!Tvar(tvb->ssvar))
  1044.             loc += Offset(tvb->ssvar);
  1045.              }
  1046.           else
  1047.              goto pr_noderef;
  1048.           }
  1049.            else
  1050.           loc = (word *)VarLoc(rval) + Offset(rval);
  1051.                if (InRange(BlkLoc(k_current),loc,rsp))
  1052.           if (DeRef(*argp) == Error) {
  1053.              runerr(0, NULL);
  1054.              goto efail;
  1055.              }
  1056.            }
  1057.  
  1058. pr_noderef:
  1059.         --k_level;
  1060.         if (k_trace) {
  1061.                k_trace--;
  1062.            rtrace(&(rproc->pname), argp);
  1063.                }
  1064. Pret_uw:
  1065.         if (pfp->pf_ilevel < ilevel) {
  1066.            --ilevel;
  1067.            ExInterp;
  1068.            return A_Pret_uw;
  1069.            }
  1070.         rsp = (word *)argp + 1;
  1071.         efp = pfp->pf_efp;
  1072.         gfp = pfp->pf_gfp;
  1073.         ipc = pfp->pf_ipc;
  1074.         argp = pfp->pf_argp;
  1075.         pfp = pfp->pf_pfp;
  1076.         break;
  1077.         }
  1078.  
  1079.                 /* ---Failures--- */
  1080.  
  1081.      case Op_Efail:
  1082. efail:
  1083.         /*
  1084.          * Failure has occurred in the current expression frame.
  1085.          */
  1086.         if (gfp == 0) {
  1087.            /*
  1088.         * There are no suspended generators to resume.
  1089.         *  Remove the current expression frame, restoring
  1090.         *  values.
  1091.         *
  1092.         * If the failure ipc is 0, propagate failure to the
  1093.         *  enclosing frame by branching back to efail.
  1094.         *  This happens, for example, in looping control
  1095.         *  structures that fail when complete.
  1096.         */
  1097.            ipc = efp->ef_failure;
  1098.            gfp = efp->ef_gfp;
  1099.            rsp = (word *)efp - 1;
  1100.            efp = efp->ef_efp;
  1101.            if (ipc.op == 0)
  1102.           goto efail;
  1103.            break;
  1104.            }
  1105.  
  1106.         else {
  1107.            /*
  1108.         * There is a generator that can be resumed.  Make
  1109.         *  the stack adjustments and then switch on the
  1110.         *  type of the generator frame marker.
  1111.         */
  1112.            struct descrip tmp;
  1113.            register struct gf_marker *resgfp = gfp;
  1114.  
  1115.            type = (int)resgfp->gf_gentype;
  1116.  
  1117.  
  1118.            if (type == G_Psusp) {
  1119.           argp = resgfp->gf_argp;
  1120.           if (k_trace) {    /* procedure tracing */
  1121.                      k_trace--;
  1122.              ExInterp;
  1123.              atrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1124.              EntInterp;
  1125.              }
  1126.           }
  1127.            ipc = resgfp->gf_ipc;
  1128.            efp = resgfp->gf_efp;
  1129.            gfp = resgfp->gf_gfp;
  1130.            rsp = (word *)resgfp - 1;
  1131.            if (type == G_Psusp) {
  1132.           pfp = resgfp->gf_pfp;
  1133.  
  1134.           /*
  1135.            * If the scanning environment for this procedure call is
  1136.            *  supposed to be in a saved state, switch environments.
  1137.            */
  1138.           if (pfp->pf_scan != NULL) {
  1139.              tmp = k_subject;
  1140.              k_subject = *pfp->pf_scan;
  1141.              *pfp->pf_scan = tmp;
  1142.  
  1143.              tmp = *(pfp->pf_scan + 1);
  1144.              IntVal(*(pfp->pf_scan + 1)) = k_pos;
  1145.              k_pos = IntVal(tmp);
  1146.              }
  1147.           ++k_level;        /* adjust procedure level */
  1148.           }
  1149.  
  1150.            switch (type) {
  1151.  
  1152.           case G_Csusp: {
  1153.              --ilevel;
  1154.              ExInterp;
  1155.              return A_Resumption;
  1156.              break;
  1157.              }
  1158.  
  1159.           case G_Esusp:
  1160.              goto efail;
  1161.  
  1162.           case G_Psusp:
  1163.              break;
  1164.           }
  1165.  
  1166.            break;
  1167.            }
  1168.  
  1169.      case Op_Pfail:     /* fail from procedure */
  1170.         /*
  1171.          * An Icon procedure is failing.  Generate tracing message if
  1172.          *    tracing is on.    Deactivate inactive C generators created
  1173.          *    after activation of the procedure.  Appropriate values
  1174.          *    are restored from the procedure frame.
  1175.          */
  1176.         --k_level;
  1177.         if (k_trace) {
  1178.                k_trace--;
  1179.            failtrace(&(((struct b_proc *)BlkLoc(*argp))->pname));
  1180.                }
  1181. Pfail_uw:
  1182.         if (pfp->pf_ilevel < ilevel) {
  1183.            --ilevel;
  1184.            ExInterp;
  1185.            return A_Pfail_uw;
  1186.            }
  1187.         efp = pfp->pf_efp;
  1188.         gfp = pfp->pf_gfp;
  1189.         ipc = pfp->pf_ipc;
  1190.         argp = pfp->pf_argp;
  1191.         pfp = pfp->pf_pfp;
  1192.         goto efail;
  1193.  
  1194.                 /* ---Odds and Ends--- */
  1195.  
  1196.      case Op_Ccase:     /* case clause */
  1197.         PushNull;
  1198.         PushVal(((word *)efp)[-2]);
  1199.         PushVal(((word *)efp)[-1]);
  1200.         break;
  1201.  
  1202.      case Op_Chfail:    /* change failure ipc */
  1203.         opnd = GetWord;
  1204.         opnd += (word)ipc.opnd;
  1205.         efp->ef_failure.opnd = (word *)opnd;
  1206.         break;
  1207.  
  1208.      case Op_Dup:        /* duplicate descriptor */
  1209.         PushNull;
  1210.         rsp[1] = rsp[-3];
  1211.         rsp[2] = rsp[-2];
  1212.         rsp += 2;
  1213.         break;
  1214.  
  1215.      case Op_Field:     /* e1.e2 */
  1216.         PushVal(D_Integer);
  1217.         PushVal(GetWord);
  1218.         Setup_Op(2);
  1219.  
  1220.         signal = Ofield(2,rargp);
  1221.  
  1222.         goto C_rtn_term;
  1223.  
  1224.      case Op_Goto:        /* goto */
  1225.         PutOp(Op_Agoto);
  1226.         opnd = GetWord;
  1227.         opnd += (word)ipc.opnd;
  1228.         PutWord(opnd);
  1229.         ipc.opnd = (word *)opnd;
  1230.         break;
  1231.  
  1232.      case Op_Agoto:     /* goto absolute address */
  1233.         opnd = GetWord;
  1234.         ipc.opnd = (word *)opnd;
  1235.         break;
  1236.  
  1237.      case Op_Init:        /* initial */
  1238.  
  1239. #ifdef WATERLOO_C_V3_0
  1240.            cw3defect = ipc.op;
  1241.            cw3defect--;
  1242.            ipc.op = cw3defect;
  1243.            *cw3defect = Op_Goto;
  1244. #else                    /* WATERLOO_C_V3_0 */
  1245.         *--ipc.op = Op_Goto;
  1246. #endif                    /* WATERLOO_C_V3_0 */
  1247.  
  1248. #ifdef CRAY
  1249.         opnd = (sizeof(*ipc.op) + sizeof(*rsp))/8;
  1250. #else                    /* CRAY */
  1251.         opnd = sizeof(*ipc.op) + sizeof(*rsp);
  1252. #endif                    /* CRAY */
  1253.  
  1254.         opnd += (word)ipc.opnd;
  1255.         ipc.opnd = (word *)opnd;
  1256.         break;
  1257.  
  1258.      case Op_Limit:     /* limit */
  1259.         Setup_Op(0);
  1260.  
  1261.         if (Olimit(0,rargp) == A_Failure)
  1262.  
  1263.            goto efail;
  1264.         else
  1265.            rsp = (word *) rargp + 1;
  1266.         goto mark0;
  1267.  
  1268. #ifdef TallyOpt
  1269.      case Op_Tally:     /* tally */
  1270.         tallybin[GetWord]++;
  1271.         break;
  1272. #endif                    /* TallyOpt */
  1273.  
  1274.      case Op_Pnull:     /* push null descriptor */
  1275.         PushNull;
  1276.         break;
  1277.  
  1278.      case Op_Pop:        /* pop descriptor */
  1279.         rsp -= 2;
  1280.         break;
  1281.  
  1282.      case Op_Push1:     /* push integer 1 */
  1283.         PushVal(D_Integer);
  1284.         PushVal(1);
  1285.         break;
  1286.  
  1287.      case Op_Pushn1:    /* push integer -1 */
  1288.         PushVal(D_Integer);
  1289.         PushVal(-1);
  1290.         break;
  1291.  
  1292.      case Op_Sdup:        /* duplicate descriptor */
  1293.         rsp += 2;
  1294.         rsp[-1] = rsp[-3];
  1295.         rsp[0] = rsp[-2];
  1296.         break;
  1297.  
  1298.                     /* ---Co-expressions--- */
  1299.  
  1300.      case Op_Create:    /* create */
  1301.  
  1302. #ifdef Coexpr
  1303.         PushNull;
  1304.         Setup_Op(0);
  1305.         opnd = GetWord;
  1306.         opnd += (word)ipc.opnd;
  1307.  
  1308.         signal = Ocreate((word *)opnd, rargp);
  1309.  
  1310.         goto C_rtn_term;
  1311. #else                    /* Coexpr */
  1312.         runerr(-401, NULL);
  1313.         goto efail;
  1314. #endif                    /* Coexpr */
  1315.  
  1316.      case Op_Coact: {    /* @e */
  1317.  
  1318. #ifndef Coexpr
  1319.         runerr(-401, NULL);
  1320.         goto efail;
  1321. #else                    /* Coexpr */
  1322.  
  1323.         register struct b_coexpr *ccp, *ncp;
  1324.         dptr dp, tvalp;
  1325.             struct descrip tval;
  1326.         int first;
  1327.  
  1328.         ExInterp;
  1329.         dp = (dptr)(sp - 1);
  1330.  
  1331. #ifdef TraceBack
  1332.         xargp = dp - 2;
  1333. #endif                        /* TraceBack */
  1334.  
  1335.         if (DeRef(*dp) == Error) {
  1336.            runerr(0, NULL);
  1337.            goto efail;
  1338.            }
  1339.         if (dp->dword != D_Coexpr) {
  1340.         runerr(118, dp);
  1341.         goto efail;
  1342.         }
  1343.         ccp = (struct b_coexpr *)BlkLoc(k_current);
  1344.         ncp = (struct b_coexpr *)BlkLoc(*dp);
  1345.  
  1346.         /*
  1347.          * Dereference the transmited value if needed.
  1348.          */
  1349.         tval = *(dptr)(sp - 3);
  1350.         if (Var(tval)) {
  1351.            word *loc;
  1352.  
  1353.  
  1354.            if (Tvar(tval)) {
  1355.           if (tval.dword == D_Tvsubs) {
  1356.             struct b_tvsubs *tvb;
  1357.  
  1358.                      tvb = (struct b_tvsubs *)BlkLoc(tval);
  1359.                      loc = (word *)BlkLoc(tvb->ssvar);
  1360.                      if (!Tvar(tvb->ssvar))
  1361.                         loc += Offset(tvb->ssvar);
  1362.             }
  1363.           else
  1364.             goto ca_noderef;
  1365.           }
  1366.            else
  1367.           loc = (word *)VarLoc(tval) + Offset(tval);
  1368.                if (InRange(ccp,loc,sp))
  1369.           if (DeRef(tval) == Error) {
  1370.              runerr(0, NULL);
  1371.              goto efail;
  1372.              }
  1373.            }
  1374. ca_noderef:
  1375.         /*
  1376.          * Set activator in new co-expression.
  1377.          */
  1378.         if (ncp->es_actstk == NULL) {
  1379.            ncp->es_actstk = alcactiv();
  1380.            if (ncp->es_actstk == NULL) {
  1381.              runerr(0, NULL);
  1382.              goto efail;
  1383.              }
  1384.            first = 0;
  1385.            }
  1386.         else
  1387.            first = 1;
  1388.         if (pushact(ncp, ccp) == Error) {
  1389.            runerr(0, NULL);
  1390.            goto efail;
  1391.            }
  1392.  
  1393.         if (k_trace) {
  1394.                k_trace--;
  1395.            coacttrace(ccp, ncp);
  1396.                }
  1397.         /*
  1398.          * Save Istate of current co-expression.
  1399.          */
  1400.         ccp->es_pfp = pfp;
  1401.         ccp->es_argp = argp;
  1402.         ccp->es_efp = efp;
  1403.         ccp->es_gfp = gfp;
  1404.         ccp->es_ipc = ipc;
  1405.         ccp->es_sp = sp;
  1406.         ccp->es_ilevel = ilevel;
  1407.         ccp->tvalloc = (dptr)(sp - 3);
  1408.         /*
  1409.          * Establish Istate for new co-expression.
  1410.          */
  1411.         pfp = ncp->es_pfp;
  1412.         argp = ncp->es_argp;
  1413.         efp = ncp->es_efp;
  1414.         gfp = ncp->es_gfp;
  1415.         ipc = ncp->es_ipc;
  1416.         sp = ncp->es_sp;
  1417.         ilevel = (int)ncp->es_ilevel;
  1418.  
  1419.         if (tvalp = ncp->tvalloc) {
  1420.         ncp->tvalloc = NULL;
  1421.         *tvalp = tval;
  1422.         }
  1423.         BlkLoc(k_current) = (union block *)ncp;
  1424.         coexp_act = A_Coact;
  1425.         coswitch(ccp->cstate,ncp->cstate,first);
  1426.         EntInterp;
  1427.         if (coexp_act == A_Cofail)
  1428.         goto efail;
  1429.         else
  1430.         rsp -= 2;
  1431.         break;
  1432. #endif                    /* Coexpr */
  1433.         }
  1434.  
  1435.      case Op_Coret: {    /* return from co-expression */
  1436.  
  1437. #ifndef Coexpr
  1438.         runerr(-401, NULL);     /* can't happen? */
  1439.         goto efail;
  1440. #else                    /* Coexpr */
  1441.         register struct b_coexpr *ccp, *ncp;
  1442.         struct descrip rval, *rvalp;
  1443.  
  1444.         ExInterp;
  1445.         ccp = (struct b_coexpr *)BlkLoc(k_current);
  1446.  
  1447.         /*
  1448.          * Dereference the returned value if needed.
  1449.          */
  1450.         rval = *(dptr)&sp[-1];
  1451.         if (Var(rval)) {
  1452.            word *loc;
  1453.  
  1454.            if (Tvar(rval)) {
  1455.           if (rval.dword == D_Tvsubs) {
  1456.               struct b_tvsubs *tvb;
  1457.  
  1458.              tvb = (struct b_tvsubs *)BlkLoc(rval);
  1459.              loc = (word *)BlkLoc(tvb->ssvar);
  1460.              if (!Tvar(tvb->ssvar))
  1461.             loc += Offset(tvb->ssvar);
  1462.              }
  1463.           else
  1464.              goto cr_noderef;
  1465.           }
  1466.            else
  1467.           loc = (word *)VarLoc(rval) + Offset(rval);
  1468.                if (InRange(ccp,loc,sp))
  1469.           if (DeRef(rval) == Error) {
  1470.              runerr(0, NULL);
  1471.              goto efail;
  1472.              }
  1473.            }
  1474.  
  1475. cr_noderef:
  1476.         ccp->size++;
  1477.         ncp = popact(ccp);
  1478.         ncp->tvalloc = NULL;
  1479.         rvalp = (dptr)(&ncp->es_sp[-3]);
  1480.         *rvalp = rval;
  1481.         if (k_trace) {
  1482.                k_trace--;
  1483.            corettrace(ccp,ncp);
  1484.                }
  1485.  
  1486.         /*
  1487.          * Save Istate of current co-expression.
  1488.          */
  1489.         ccp->es_pfp = pfp;
  1490.         ccp->es_argp = argp;
  1491.         ccp->es_efp = efp;
  1492.         ccp->es_gfp = gfp;
  1493.         ccp->es_ipc = ipc;
  1494.         ccp->es_sp = sp;
  1495.         ccp->es_ilevel = ilevel;
  1496.         /*
  1497.          * Establish Istate for new co-expression.
  1498.          */
  1499.         pfp = ncp->es_pfp;
  1500.         argp = ncp->es_argp;
  1501.         efp = ncp->es_efp;
  1502.         gfp = ncp->es_gfp;
  1503.         ipc = ncp->es_ipc;
  1504.         sp = ncp->es_sp;
  1505.         ilevel = (int)ncp->es_ilevel;
  1506.         BlkLoc(k_current) = (union block *)ncp;
  1507.         coexp_act = A_Coret;
  1508.         coswitch(ccp->cstate, ncp->cstate,1);
  1509.         break;
  1510. #endif                    /* Coexpr */
  1511.         }
  1512.  
  1513.      case Op_Cofail: {    /* fail from co-expression */
  1514.  
  1515. #ifndef Coexpr
  1516.         runerr(-401, NULL);     /* can't happen? */
  1517.         goto efail;
  1518. #else                    /* Coexpr */
  1519.         register struct b_coexpr *ccp, *ncp;
  1520.  
  1521.         ExInterp;
  1522.         ccp = (struct b_coexpr *)BlkLoc(k_current);
  1523.         ncp = popact(ccp);
  1524.         if (k_trace) {
  1525.                k_trace--;
  1526.            cofailtrace(ccp, ncp);
  1527.                }
  1528.         ncp->tvalloc = NULL;
  1529.         /*
  1530.          * Save Istate of current co-expression.
  1531.          */
  1532.         ccp->es_pfp = pfp;
  1533.         ccp->es_argp = argp;
  1534.         ccp->es_efp = efp;
  1535.         ccp->es_gfp = gfp;
  1536.         ccp->es_ipc = ipc;
  1537.         ccp->es_sp = sp;
  1538.         ccp->es_ilevel = ilevel;
  1539.         /*
  1540.          * Establish Istate for new co-expression.
  1541.          */
  1542.         pfp = ncp->es_pfp;
  1543.         argp = ncp->es_argp;
  1544.         efp = ncp->es_efp;
  1545.         gfp = ncp->es_gfp;
  1546.         ipc = ncp->es_ipc;
  1547.         sp = ncp->es_sp;
  1548.         ilevel = (int)ncp->es_ilevel;
  1549.         BlkLoc(k_current) = (union block *)ncp;
  1550.         coexp_act = A_Cofail;
  1551.         coswitch(ccp->cstate, ncp->cstate,1);
  1552.         EntInterp;
  1553.         break;
  1554. #endif                    /* Coexpr */
  1555.  
  1556.         }
  1557.  
  1558.          case Op_Quit:        /* quit */
  1559.  
  1560. #ifdef IconCalling
  1561.             ExInterp;        /* restores stack pointer for icon_call */
  1562.         interp_status = A_Pret_uw;
  1563. #endif                     /* IconCalling */
  1564.  
  1565.         goto interp_quit;
  1566.  
  1567. #ifdef IconCalling
  1568.          case Op_FQuit:        /* failing quit */
  1569.         ExInterp;        /* restores stack pointer for icon_call */
  1570.         interp_status = A_Pfail_uw;
  1571.             goto interp_quit;
  1572. #endif                     /* IconCalling */
  1573.  
  1574.      default: {
  1575.         char buf[50];
  1576.  
  1577.         sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n",
  1578.                (long)lastop, lastop);
  1579.         syserr(buf);
  1580.         }
  1581.      }
  1582.      continue;
  1583.  
  1584. C_rtn_term:
  1585.      EntInterp;
  1586.      switch (signal) {
  1587.  
  1588.         case A_Failure:
  1589.            goto efail;
  1590.  
  1591.         case A_Unmark_uw:        /* unwind for unmark */
  1592.            goto Unmark_uw;
  1593.  
  1594.         case A_Lsusp_uw:        /* unwind for lsusp */
  1595.            goto Lsusp_uw;
  1596.  
  1597.         case A_Eret_uw:        /* unwind for eret */
  1598.            goto Eret_uw;
  1599.  
  1600.         case A_Pret_uw:        /* unwind for pret */
  1601.            goto Pret_uw;
  1602.  
  1603.         case A_Pfail_uw:        /* unwind for pfail */
  1604.            goto Pfail_uw;
  1605.         }
  1606.  
  1607.      rsp = (word *)rargp + 1;    /* set rsp to result */
  1608.      continue;
  1609.      }
  1610.  
  1611. interp_quit:
  1612.    --ilevel;
  1613. #ifdef MaxLevel
  1614.    fprintf(stderr,"maximum &level = %d\n",maxplevel);
  1615.    fprintf(stderr,"maximum ilevel = %d\n",maxilevel);
  1616.    fprintf(stderr,"maximum sp = %d\n",(long)maxsp - (long)stack);
  1617.    fflush(stderr);
  1618. #endif                    /* MaxLevel */
  1619.  
  1620. #ifdef DumpIcount
  1621.    {
  1622.    int i;
  1623.    for (i = 0; i <= MaxIcode; i++)
  1624.       fprintf(imonc,"\%d\n",icode[i]);
  1625.       fflush(imonc);
  1626.    }
  1627. #endif                    /* DumpIcount */
  1628.  
  1629. #ifndef IconCalling
  1630.    if (ilevel != 0)
  1631.       syserr("interp: termination with inactive generators.");
  1632. #else
  1633.    if (IDepth == 0 && ilevel != 0)
  1634.       syserr("interp(call in): termination with inactive generators");
  1635. #endif                    /* IconCalling */
  1636.  
  1637.  
  1638.    }
  1639.  
  1640. #ifdef StackPic
  1641. /*
  1642.  * The following code is operating-system dependent [@interp.04].
  1643.  *  Diagnostic stack pictures for debugging/monitoring.
  1644.  */
  1645.  
  1646. #if PORT
  1647. Deliberate Syntax Error
  1648. #endif                    /* PORT */
  1649.  
  1650. #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || VM || VMS
  1651.    /* not included */
  1652. #endif                    /* AMIGA || ATARI_ST || ... */
  1653.  
  1654. #if ARM
  1655. novalue stkdump(op)
  1656.    int op;
  1657.    {
  1658.    word *stk;
  1659.    word *i;
  1660.    stk = (word *)BlkLoc(k_current);
  1661.    stk += Wsizeof(struct b_coexpr);
  1662.    fprintf(stderr,">  stack:  %.8x\n", (word)stk);
  1663.    fprintf(stderr,">  sp:     %.8x\n", (word)sp);
  1664.    fprintf(stderr,">  pfp:    %.8x\n", (word)pfp);
  1665.    fprintf(stderr,">  efp:    %.8x\n", (word)efp);
  1666.    fprintf(stderr,">  gfp:    %.8x\n", (word)gfp);
  1667.    fprintf(stderr,">  ipc:    %.8x\n", (word)ipc.op);
  1668.    fprintf(stderr,">  argp:   %.8x\n", (word)argp);
  1669.    fprintf(stderr,">  ilevel: %.8x\n", (word)ilevel);
  1670.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1671.    for (i = stk; i <= (word *)sp; i++)
  1672.       fprintf(stderr,"> %.8x\n",(word)*i);
  1673.    fprintf(stderr,"> ----------\n");
  1674.    fflush(stderr);
  1675.    }
  1676. #endif                    /* ARM */
  1677.  
  1678. #if MSDOS || OS2
  1679. novalue stkdump(op)
  1680.    int op;
  1681.    {
  1682.    word far *stk;
  1683.    word far *i;
  1684.    stk = (word far *)BlkLoc(k_current);
  1685.    stk += Wsizeof(struct b_coexpr);
  1686.    fprintf(stderr,">  stack:  %08lx\n", (word)stk);
  1687.    fprintf(stderr,">  sp:     %08lx\n", (word)sp);
  1688.    fprintf(stderr,">  pfp:    %08lx\n", (word)pfp);
  1689.    fprintf(stderr,">  efp:    %08lx\n", (word)efp);
  1690.    fprintf(stderr,">  gfp:    %08lx\n", (word)gfp);
  1691.    fprintf(stderr,">  ipc:    %08lx\n", (word)ipc.op);
  1692.    fprintf(stderr,">  argp:   %08lx\n", (word)argp);
  1693.    fprintf(stderr,">  ilevel: %08lx\n", (word)ilevel);
  1694.    fprintf(stderr,">  op:     %d\n",    (int)op);
  1695.    for (i = stk; i <= (word far *)sp; i++)
  1696.       fprintf(stderr,"> %08lx\n",(word)*i);
  1697.    fprintf(stderr,"> ----------\n");
  1698.    fflush(stderr);
  1699.    }
  1700. #endif                    /* MSDOS || OS2 */
  1701.  
  1702. #if UNIX || VMS
  1703. novalue stkdump(op)
  1704.    int op;
  1705.    {
  1706.    word *i;
  1707.    fprintf(stderr,"\001stack: %lx\n",(long)(stack + Wsizeof(struct b_coexpr)));
  1708.    fprintf(stderr,"\001pfp: %lx\n",(long)pfp);
  1709.    fprintf(stderr,"\001efp: %lx\n",(long)efp);
  1710.    fprintf(stderr,"\001gfp: %lx\n",(long)gfp);
  1711.    fprintf(stderr,"\001ipc: %lx\n",(long)ipc.op);
  1712.    fprintf(stderr,"\001argp: %lx\n",(long)argp);
  1713.    fprintf(stderr,"\001ilevel: %lx\n",(long)ilevel);
  1714.    fprintf(stderr,"\001op: \%d\n",(int)op);
  1715.    for (i = stack + Wsizeof(struct b_coexpr); i <= sp; i++)
  1716.       fprintf(stderr,"\001%lx\n",*i);
  1717.    fprintf(stderr,"\001----------\n");
  1718.    fflush(stderr);
  1719.    }
  1720. #endif                    /* UNIX || VMS */
  1721.  
  1722. /*
  1723.  * End of operating-system specific code.
  1724.  */
  1725. #endif                    /* StackPic */
  1726.