/* * The intepreter proper. */ #include "..\h\config.h" #include "..\h\rt.h" #include "rproto.h" #include "..\h\opdefs.h" extern fptr fncentry[]; #ifdef DumpIstream extern FILE *imons; #endif /* DumpIstream */ #ifdef DumpIcount extern FILE *imonc; #endif /* DumpIcount */ /* * The following code is operating-system dependent [@interp.01]. Declarations * and include files. */ #if PORT Deliberate Syntax Error #endif /* PORT */ #if ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS /* nothing needed */ #endif /* ATARI_ST || ... */ #if AMIGA #include #include extern int chkbreak; #endif /* AMIGA */ #if MACINTOSH #if MPW #include #define CURSORINTERVAL 1000 #endif MPW #endif /* MACINTOSH */ /* * End of operating-system specific code. */ #ifdef EvalTrace extern word lineno; /* source line number */ extern word colmno; /* source column number */ #endif /* EvalTrace */ /* * Istate variables. */ struct pf_marker *pfp = 0; /* Procedure frame pointer */ struct ef_marker *efp; /* Expression frame pointer */ struct gf_marker *gfp; /* Generator frame pointer */ inst ipc; /* Interpreter program counter */ dptr argp; /* Pointer to argument zero */ word *sp = NULL; /* Stack pointer */ #ifdef WATERLOO_C_V3_0 int *cw3defect; #endif /* WATERLOO_C_V3_0 */ #ifdef IconCalling extern int interp_status; /* interpreter status */ extern int IDepth; /* depth of icon_call */ #endif /* IconCalling */ #ifdef Polling extern int pollctr; #endif /* Polling */ int ilevel; /* Depth of recursion in interp() */ word lastop; /* Last operator evaluated */ struct descrip list_tmp; /* list argument to Op_Apply */ #ifdef MaxLevel int maxilevel; /* Maximum ilevel */ int maxplevel; /* Maximum &level */ word *maxsp; /* Maximum interpreter sp */ #endif /* MaxLevel */ /* * Descriptor to hold result for eret across potential interp unwinding. */ struct descrip eret_tmp; /* * Last co-expression action. */ int coexp_act; #ifdef TraceBack dptr xargp; word xnargs; #endif /* TraceBack */ /* * Macros for use inside the main loop of the interpreter. */ /* * Setup_Op sets things up for a call to the C function for an operator. */ #ifdef TraceBack #define Setup_Op(nargs) \ rargp = (dptr)(rsp - 1) - nargs; \ xargp = rargp; \ ExInterp; #else /* TraceBack */ #define Setup_Op(nargs) \ rargp = (dptr)(rsp - 1) - nargs; \ ExInterp; #endif /* TraceBack */ #define Call_Cond if ((*(optab[lastop]))(rargp) == A_Failure) goto efail; \ else \ rsp = (word *) rargp + 1; /* * Call_Gen - Call a generator. A C routine associated with the * current opcode is called. When it when it terminates, control is * passed to C_rtn_term to deal with the termination condition appropriately. */ #define Call_Gen signal = (*(optab[lastop]))(rargp); \ goto C_rtn_term; /* * GetWord fetches the next icode word. PutWord(x) stores x at the current * icode word. */ #define GetWord (*ipc.opnd++) #define PutWord(x) ipc.opnd[-1] = (x) #define GetOp (word)(*ipc.op++) #define PutOp(x) ipc.op[-1] = (x) /* * DerefArg(n) dereferences the nth argument. */ #define DerefArg(n) if (DeRef(rargp[n]) == Error) {\ runerr(0, NULL);\ goto efail;} /* * For the sake of efficiency, the stack pointer is kept in a register * variable, rsp, in the interpreter loop. Since this variable is * only accessible inside the loop, and the global variable sp is used * for the stack pointer elsewhere, rsp must be stored into sp when * the context of the loop is left and conversely, rsp must be loaded * from sp when the loop is reentered. The macros ExInterp and EntInterp, * respectively, handle these operations. Currently, this register/global * scheme is only used for the stack pointer, but it can be easily extended * to other variables. */ #define ExInterp sp = rsp; #define EntInterp rsp = sp; /* * Inside the interpreter loop, PushDesc, PushNull, PushAVal, and * PushVal use rsp instead of sp for efficiency. */ #undef PushDesc #undef PushNull #undef PushVal #undef PushAVal #define PushDesc(d) {*++rsp=((d).dword); *++rsp=((d).vword.integr);} #define PushNull {*++rsp = D_Null; *++rsp = 0;} #define PushVal(v) {*++rsp = (word)(v);} /* * The following code is operating-system dependent [@interp.02]. Define * PushAVal for computers that store longs and pointers differently. */ #if PORT #define PushAVal(x) PushVal(x) Deliberate Syntax Error #endif /* PORT */ #if MSDOS || OS2 #define PushAVal(x) {rsp++; \ stkword.stkadr = (char *)(x); \ *rsp = stkword.stkint; \ } #endif /* MSDOS || OS2 */ #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || UNIX || VM || VMS #define PushAVal(x) PushVal(x) #endif /* AMIGA || ATARI_ST || HIGHC_386 ... */ /* * End of operating-system specific code. */ /* * The main loop of the interpreter. */ int interp(fsig,cargp) int fsig; dptr cargp; { register word opnd; register word *rsp; register dptr rargp; register struct ef_marker *newefp; register struct gf_marker *newgfp; register word *wd; register word *firstwd, *lastwd; word *oldsp; int type, signal, args; extern int (*optab[])(); extern struct astkblk *alcactiv(); extern char *strcons; struct b_proc *bproc; #ifdef TallyOpt extern word tallybin[]; #endif /* TallyOpt */ /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. */ if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(-301, NULL); #ifdef Polling pollctr--; if (!pollctr) pollctr = pollevent(); #endif /* Polling */ ilevel++; #ifdef MaxLevel if (ilevel > maxilevel) maxilevel = ilevel; #endif /* MaxLevel */ EntInterp; if (fsig == G_Csusp) { oldsp = rsp; /* * Create the generator frame. */ newgfp = (struct gf_marker *)(rsp + 1); newgfp->gf_gentype = G_Csusp; newgfp->gf_gfp = gfp; newgfp->gf_efp = efp; newgfp->gf_ipc = ipc; rsp += Wsizeof(struct gf_smallmarker); /* * Region extends from first word after the marker for the generator * or expression frame enclosing the call to the now-suspending * routine to the first argument of the routine. */ if (gfp != 0) { if (gfp->gf_gentype == G_Psusp) firstwd = (word *)gfp + Wsizeof(*gfp); else firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)efp + Wsizeof(*efp); lastwd = (word *)cargp + 1; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; gfp = newgfp; } /* * Top of the interpreter loop. */ for (;;) { #ifdef MaxLevel if (sp > maxsp) maxsp = sp; #endif /* MaxLevel */ lastop = GetOp; /* Instruction fetch */ #ifdef StackPic ExInterp; stkdump((int)lastop); EntInterp; #endif /* StackPic */ #ifdef DumpIstream putc((char)lastop,imons); #endif /* DumpIstream */ #ifdef DumpIcount if (lastop > MaxIcode) { fprintf(stderr,"Unexpected large opcode = %d\n",lastop); fflush(stderr); abort; } icode[lastop]++; #endif /* DumpIcount */ /* * The following code is operating-system dependent [@interp.03]. Check * for external event. */ #if PORT Deliberate Syntax Error #endif /* PORT */ #if AMIGA ExInterp; if (chkbreak > 0) chkabort(); /* check for CTRL-C or CTRL-D break */ EntInterp; #endif /* AMIGA */ #if ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS /* nothing to do */ #endif /* ATARI_ST || HIGHC_386 ... */ #if MACINTOSH #if MPW { static short cursorcount = CURSORINTERVAL; if (--cursorcount == 0) { RotateCursor(0); cursorcount = CURSORINTERVAL; } } #endif /* MPW */ #endif /* MACINTOSH */ /* * End of operating-system specific code. */ switch ((int)lastop) { /* * Switch on opcode. The cases are * organized roughly by functionality * to make it easier to find things. * For some C compilers, there may be * an advantage to arranging them by * likelihood of selection. */ /* ---Constant construction--- */ case Op_Cset: /* cset */ PutOp(Op_Acset); PushVal(D_Cset); opnd = GetWord; opnd += (word)ipc.opnd; PutWord(opnd); PushAVal(opnd); break; case Op_Acset: /* cset, absolute address */ PushVal(D_Cset); PushAVal(GetWord); break; case Op_Int: /* integer */ PushVal(D_Integer); PushVal(GetWord); break; case Op_Real: /* real */ PutOp(Op_Areal); PushVal(D_Real); opnd = GetWord; opnd += (word)ipc.opnd; PushAVal(opnd); PutWord(opnd); break; case Op_Areal: /* real, absolute address */ PushVal(D_Real); PushAVal(GetWord); break; case Op_Str: /* string */ PutOp(Op_Astr); PushVal(GetWord) #ifdef CRAY opnd = (word)(strcons + GetWord); #else /* CRAY */ opnd = (word)strcons + GetWord; #endif /* CRAY */ PutWord(opnd); PushAVal(opnd); break; case Op_Astr: /* string, absolute address */ PushVal(GetWord); PushAVal(GetWord); break; /* ---Variable construction--- */ case Op_Arg: /* argument */ PushVal(D_Var); PushAVal(&argp[GetWord + 1]); break; case Op_Global: /* global */ PutOp(Op_Aglobal); PushVal(D_Var); opnd = GetWord; PushAVal(&globals[opnd]); PutWord((word)&globals[opnd]); break; case Op_Aglobal: /* global, absolute address */ PushVal(D_Var); PushAVal(GetWord); break; case Op_Local: /* local */ PushVal(D_Var); PushAVal(&pfp->pf_locals[GetWord]); break; case Op_Static: /* static */ PutOp(Op_Astatic); PushVal(D_Var); opnd = GetWord; PushAVal(&statics[opnd]); PutWord((word)&statics[opnd]); break; case Op_Astatic: /* static, absolute address */ PushVal(D_Var); PushAVal(GetWord); break; /* ---Operators--- */ /* Unary operators */ case Op_Compl: /* ~e */ case Op_Neg: /* -e */ case Op_Number: /* +e */ case Op_Refresh: /* ^e */ case Op_Size: /* *e */ Setup_Op(1); DerefArg(1); Call_Cond; break; case Op_Value: /* .e */ case Op_Nonnull: /* \e */ case Op_Null: /* /e */ Setup_Op(1); Call_Cond; break; case Op_Random: /* ?e */ PushNull; Setup_Op(2) Call_Cond break; /* Generative unary operators */ case Op_Tabmat: /* =e */ Setup_Op(1); DerefArg(1); Call_Gen; case Op_Bang: /* !e */ PushNull; Setup_Op(2); Call_Gen; /* Binary operators */ case Op_Cat: /* e1 || e2 */ case Op_Diff: /* e1 -- e2 */ case Op_Div: /* e1 / e2 */ case Op_Inter: /* e1 ** e2 */ case Op_Lconcat: /* e1 ||| e2 */ case Op_Minus: /* e1 - e2 */ case Op_Mod: /* e1 % e2 */ case Op_Mult: /* e1 * e2 */ case Op_Power: /* e1 ^ e2 */ case Op_Unions: /* e1 ++ e2 */ case Op_Plus: /* e1 + e2 */ case Op_Eqv: /* e1 === e2 */ case Op_Lexeq: /* e1 == e2 */ case Op_Lexge: /* e1 >>= e2 */ case Op_Lexgt: /* e1 >> e2 */ case Op_Lexle: /* e1 <<= e2 */ case Op_Lexlt: /* e1 << e2 */ case Op_Lexne: /* e1 ~== e2 */ case Op_Neqv: /* e1 ~=== e2 */ case Op_Numeq: /* e1 = e2 */ case Op_Numge: /* e1 >= e2 */ case Op_Numgt: /* e1 > e2 */ case Op_Numle: /* e1 <= e2 */ case Op_Numne: /* e1 ~= e2 */ case Op_Numlt: /* e1 < e2 */ Setup_Op(2); DerefArg(1); DerefArg(2); Call_Cond; break; case Op_Asgn: /* e1 := e2 */ Setup_Op(2); DerefArg(2); Call_Cond; break; case Op_Swap: /* e1 :=: e2 */ PushNull; Setup_Op(3); Call_Cond; break; case Op_Subsc: /* e1[e2] */ PushNull; Setup_Op(3); DerefArg(2); Call_Cond; break; /* Generative binary operators */ case Op_Rasgn: /* e1 <- e2 */ Setup_Op(2); DerefArg(2); Call_Gen; case Op_Rswap: /* e1 <-> e2 */ PushNull; Setup_Op(3); Call_Gen; /* Conditional ternary operators */ case Op_Sect: /* e1[e2:e3] */ PushNull; Setup_Op(4); DerefArg(2); DerefArg(3); Call_Cond; break; /* Generative ternary operators */ case Op_Toby: /* e1 to e2 by e3 */ Setup_Op(3); DerefArg(1); DerefArg(2); DerefArg(3); Call_Gen; #ifdef LineCodes case Op_Noop: /* no-op */ #ifdef Polling pollctr--; if (!pollctr) pollctr = pollevent(); #endif /* Polling */ break; #endif /* LineCodes */ #ifdef EvalTrace case Op_Colm: /* source column number */ colmno = GetWord; break; case Op_Line: /* source line number */ lineno = GetWord; break; #endif /* EvalTrace */ /* ---String Scanning--- */ case Op_Bscan: /* prepare for scanning */ PushDesc(k_subject); PushVal(D_Integer); PushVal(k_pos); Setup_Op(2); signal = Obscan(2,rargp); goto C_rtn_term; case Op_Escan: /* exit from scanning */ Setup_Op(1); signal = Oescan(1,rargp); goto C_rtn_term; /* ---Other Language Operations--- */ case Op_Apply: { /* apply */ { union block *bp; int i, j; list_tmp = *(dptr)(rsp - 1); /* argument */ DeRef(list_tmp); if (list_tmp.dword != D_List) { /* be sure it's a list */ xargp = (dptr)(rsp - 3); runerr(108, &list_tmp); goto efail; } rsp -= 2; /* pop it off */ bp = BlkLoc(list_tmp); args = (int)bp->list.size; for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) { for (i = 0; i < bp->lelem.nused; i++) { j = bp->lelem.first + i; if (j >= bp->lelem.nslots) j -= bp->lelem.nslots; PushDesc(bp->lelem.lslots[j]) } } goto invokej; } } case Op_Invoke: { /* invoke */ args = (int)GetWord; invokej: { int nargs; dptr carg; ExInterp; type = invoke(args, &carg, &nargs); rargp = carg; EntInterp; #ifdef MaxLevel if (k_level > maxplevel) maxplevel = k_level; #endif /* MaxLevel */ if (type == I_Fail) goto efail; if (type == I_Continue) break; else { int (*bfunc)(); bproc = (struct b_proc *)BlkLoc(*rargp); bfunc = bproc->entryp.ccode; /* ExInterp not needed since no change since last EntInterp */ if (type == I_Vararg) signal = (*bfunc)(nargs,rargp); else signal = (*bfunc)(rargp); goto C_rtn_term; } } break; } case Op_Keywd: /* keyword */ PushVal(D_Integer); PushVal(GetWord); Setup_Op(0); signal = Okeywd(0,rargp); goto C_rtn_term; case Op_Llist: /* construct list */ opnd = GetWord; Setup_Op(opnd); signal = Ollist((int)opnd,rargp); goto C_rtn_term; /* ---Marking and Unmarking--- */ case Op_Mark: /* create expression frame marker */ PutOp(Op_Amark); opnd = GetWord; opnd += (word)ipc.opnd; PutWord(opnd); newefp = (struct ef_marker *)(rsp + 1); newefp->ef_failure.opnd = (word *)opnd; goto mark; case Op_Amark: /* mark with absolute fipc */ newefp = (struct ef_marker *)(rsp + 1); newefp->ef_failure.opnd = (word *)GetWord; mark: newefp->ef_gfp = gfp; newefp->ef_efp = efp; newefp->ef_ilevel = ilevel; rsp += Wsizeof(*efp); efp = newefp; gfp = 0; break; case Op_Mark0: /* create expression frame with 0 ipl */ mark0: newefp = (struct ef_marker *)(rsp + 1); newefp->ef_failure.opnd = 0; newefp->ef_gfp = gfp; newefp->ef_efp = efp; newefp->ef_ilevel = ilevel; rsp += Wsizeof(*efp); efp = newefp; gfp = 0; break; case Op_Unmark: /* remove expression frame */ gfp = efp->ef_gfp; rsp = (word *)efp - 1; /* * Remove any suspended C generators. */ Unmark_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; return A_Unmark_uw; } efp = efp->ef_efp; break; /* ---Suspensions--- */ case Op_Esusp: { /* suspend from expression */ /* * Create the generator frame. */ oldsp = rsp; newgfp = (struct gf_marker *)(rsp + 1); newgfp->gf_gentype = G_Esusp; newgfp->gf_gfp = gfp; newgfp->gf_efp = efp; newgfp->gf_ipc = ipc; gfp = newgfp; rsp += Wsizeof(struct gf_smallmarker); /* * Region extends from first word after enclosing generator or * expression frame marker to marker for current expression frame. */ if (efp->ef_gfp != 0) { newgfp = (struct gf_marker *)(efp->ef_gfp); if (newgfp->gf_gentype == G_Psusp) firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp); else firstwd = (word *)efp->ef_gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)efp->ef_efp + Wsizeof(*efp); lastwd = (word *)efp - 1; efp = efp->ef_efp; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; PushVal(oldsp[-1]); PushVal(oldsp[0]); break; } case Op_Lsusp: { /* suspend from limitation */ struct descrip sval; /* * The limit counter is contained in the descriptor immediately * prior to the current expression frame. lval is established * as a pointer to this descriptor. */ dptr lval = (dptr)((word *)efp - 2); /* * Decrement the limit counter and check it. */ if (--IntVal(*lval) > 0) { /* * The limit has not been reached, set up stack. */ sval = *(dptr)(rsp - 1); /* save result */ /* * Region extends from first word after enclosing generator or * expression frame marker to the limit counter just prior to * to the current expression frame marker. */ if (efp->ef_gfp != 0) { newgfp = (struct gf_marker *)(efp->ef_gfp); if (newgfp->gf_gentype == G_Psusp) firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp); else firstwd = (word *)efp->ef_gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)efp->ef_efp + Wsizeof(*efp); lastwd = (word *)efp - 3; if (gfp == 0) gfp = efp->ef_gfp; efp = efp->ef_efp; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ rsp -= 2; /* overwrite result */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; PushDesc(sval); /* push saved result */ } else { /* * Otherwise, the limit has been reached. Instead of * suspending, remove the current expression frame and * replace the limit counter with the value on top of * the stack (which would have been suspended had the * limit not been reached). */ *lval = *(dptr)(rsp - 1); gfp = efp->ef_gfp; /* * Since an expression frame is being removed, inactive * C generators contained therein are deactivated. */ Lsusp_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; return A_Lsusp_uw; } rsp = (word *)efp - 1; efp = efp->ef_efp; } break; } case Op_Psusp: { /* suspend from procedure */ /* * An Icon procedure is suspending a value. Determine if the * value being suspended should be dereferenced and if so, * dereference it. If tracing is on, strace is called * to generate a message. Appropriate values are * restored from the procedure frame of the suspending procedure. */ struct descrip tmp; struct descrip sval, *svalp; struct b_proc *sproc; svalp = (dptr)(rsp - 1); sval = *svalp; if (Var(sval)) { word *loc; if (Tvar(sval)) { if (sval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(sval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto ps_noderef; } else loc = (word *)VarLoc(sval) + Offset(sval); if (InRange(BlkLoc(k_current),loc,rsp)) if (DeRef(*svalp) == Error) { runerr(0, NULL); goto efail; } } ps_noderef: /* * Create the generator frame. */ oldsp = rsp; newgfp = (struct gf_marker *)(rsp + 1); newgfp->gf_gentype = G_Psusp; newgfp->gf_gfp = gfp; newgfp->gf_efp = efp; newgfp->gf_ipc = ipc; newgfp->gf_argp = argp; newgfp->gf_pfp = pfp; gfp = newgfp; rsp += Wsizeof(*gfp); /* * Region extends from first word after the marker for the * generator or expression frame enclosing the call to the * now-suspending procedure to Arg0 of the procedure. */ if (pfp->pf_gfp != 0) { newgfp = (struct gf_marker *)(pfp->pf_gfp); if (newgfp->gf_gentype == G_Psusp) firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp); else firstwd = (word *)pfp->pf_gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)pfp->pf_efp + Wsizeof(*efp); lastwd = (word *)argp - 1; efp = efp->ef_efp; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; PushVal(oldsp[-1]); PushVal(oldsp[0]); --k_level; if (k_trace) { k_trace--; sproc = (struct b_proc *)BlkLoc(*argp); strace(&(sproc->pname), svalp); } /* * If the scanning environment for this procedure call is in * a saved state, switch environments. */ if (pfp->pf_scan != NULL) { tmp = k_subject; k_subject = *pfp->pf_scan; *pfp->pf_scan = tmp; tmp = *(pfp->pf_scan + 1); IntVal(*(pfp->pf_scan + 1)) = k_pos; k_pos = IntVal(tmp); } efp = pfp->pf_efp; ipc = pfp->pf_ipc; argp = pfp->pf_argp; pfp = pfp->pf_pfp; break; } /* ---Returns--- */ case Op_Eret: { /* return from expression */ /* * Op_Eret removes the current expression frame, leaving the * original top of stack value on top. */ /* * Save current top of stack value in global temporary (no * danger of reentry). */ eret_tmp = *(dptr)&rsp[-1]; gfp = efp->ef_gfp; Eret_uw: /* * Since an expression frame is being removed, inactive * C generators contained therein are deactivated. */ if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; return A_Eret_uw; } rsp = (word *)efp - 1; efp = efp->ef_efp; PushDesc(eret_tmp); break; } case Op_Pret: { /* return from procedure */ /* * An Icon procedure is returning a value. Determine if the * value being returned should be dereferenced and if so, * dereference it. If tracing is on, rtrace is called to * generate a message. Inactive generators created after * the activation of the procedure are deactivated. Appropriate * values are restored from the procedure frame. */ struct descrip rval; struct b_proc *rproc = (struct b_proc *)BlkLoc(*argp); *argp = *(dptr)(rsp - 1); rval = *argp; if (Var(rval)) { word *loc; if (Tvar(rval)) { if (rval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(rval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto pr_noderef; } else loc = (word *)VarLoc(rval) + Offset(rval); if (InRange(BlkLoc(k_current),loc,rsp)) if (DeRef(*argp) == Error) { runerr(0, NULL); goto efail; } } pr_noderef: --k_level; if (k_trace) { k_trace--; rtrace(&(rproc->pname), argp); } Pret_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; return A_Pret_uw; } rsp = (word *)argp + 1; efp = pfp->pf_efp; gfp = pfp->pf_gfp; ipc = pfp->pf_ipc; argp = pfp->pf_argp; pfp = pfp->pf_pfp; break; } /* ---Failures--- */ case Op_Efail: efail: /* * Failure has occurred in the current expression frame. */ if (gfp == 0) { /* * There are no suspended generators to resume. * Remove the current expression frame, restoring * values. * * If the failure ipc is 0, propagate failure to the * enclosing frame by branching back to efail. * This happens, for example, in looping control * structures that fail when complete. */ ipc = efp->ef_failure; gfp = efp->ef_gfp; rsp = (word *)efp - 1; efp = efp->ef_efp; if (ipc.op == 0) goto efail; break; } else { /* * There is a generator that can be resumed. Make * the stack adjustments and then switch on the * type of the generator frame marker. */ struct descrip tmp; register struct gf_marker *resgfp = gfp; type = (int)resgfp->gf_gentype; if (type == G_Psusp) { argp = resgfp->gf_argp; if (k_trace) { /* procedure tracing */ k_trace--; ExInterp; atrace(&(((struct b_proc *)BlkLoc(*argp))->pname)); EntInterp; } } ipc = resgfp->gf_ipc; efp = resgfp->gf_efp; gfp = resgfp->gf_gfp; rsp = (word *)resgfp - 1; if (type == G_Psusp) { pfp = resgfp->gf_pfp; /* * If the scanning environment for this procedure call is * supposed to be in a saved state, switch environments. */ if (pfp->pf_scan != NULL) { tmp = k_subject; k_subject = *pfp->pf_scan; *pfp->pf_scan = tmp; tmp = *(pfp->pf_scan + 1); IntVal(*(pfp->pf_scan + 1)) = k_pos; k_pos = IntVal(tmp); } ++k_level; /* adjust procedure level */ } switch (type) { case G_Csusp: { --ilevel; ExInterp; return A_Resumption; break; } case G_Esusp: goto efail; case G_Psusp: break; } break; } case Op_Pfail: /* fail from procedure */ /* * An Icon procedure is failing. Generate tracing message if * tracing is on. Deactivate inactive C generators created * after activation of the procedure. Appropriate values * are restored from the procedure frame. */ --k_level; if (k_trace) { k_trace--; failtrace(&(((struct b_proc *)BlkLoc(*argp))->pname)); } Pfail_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; return A_Pfail_uw; } efp = pfp->pf_efp; gfp = pfp->pf_gfp; ipc = pfp->pf_ipc; argp = pfp->pf_argp; pfp = pfp->pf_pfp; goto efail; /* ---Odds and Ends--- */ case Op_Ccase: /* case clause */ PushNull; PushVal(((word *)efp)[-2]); PushVal(((word *)efp)[-1]); break; case Op_Chfail: /* change failure ipc */ opnd = GetWord; opnd += (word)ipc.opnd; efp->ef_failure.opnd = (word *)opnd; break; case Op_Dup: /* duplicate descriptor */ PushNull; rsp[1] = rsp[-3]; rsp[2] = rsp[-2]; rsp += 2; break; case Op_Field: /* e1.e2 */ PushVal(D_Integer); PushVal(GetWord); Setup_Op(2); signal = Ofield(2,rargp); goto C_rtn_term; case Op_Goto: /* goto */ PutOp(Op_Agoto); opnd = GetWord; opnd += (word)ipc.opnd; PutWord(opnd); ipc.opnd = (word *)opnd; break; case Op_Agoto: /* goto absolute address */ opnd = GetWord; ipc.opnd = (word *)opnd; break; case Op_Init: /* initial */ #ifdef WATERLOO_C_V3_0 cw3defect = ipc.op; cw3defect--; ipc.op = cw3defect; *cw3defect = Op_Goto; #else /* WATERLOO_C_V3_0 */ *--ipc.op = Op_Goto; #endif /* WATERLOO_C_V3_0 */ #ifdef CRAY opnd = (sizeof(*ipc.op) + sizeof(*rsp))/8; #else /* CRAY */ opnd = sizeof(*ipc.op) + sizeof(*rsp); #endif /* CRAY */ opnd += (word)ipc.opnd; ipc.opnd = (word *)opnd; break; case Op_Limit: /* limit */ Setup_Op(0); if (Olimit(0,rargp) == A_Failure) goto efail; else rsp = (word *) rargp + 1; goto mark0; #ifdef TallyOpt case Op_Tally: /* tally */ tallybin[GetWord]++; break; #endif /* TallyOpt */ case Op_Pnull: /* push null descriptor */ PushNull; break; case Op_Pop: /* pop descriptor */ rsp -= 2; break; case Op_Push1: /* push integer 1 */ PushVal(D_Integer); PushVal(1); break; case Op_Pushn1: /* push integer -1 */ PushVal(D_Integer); PushVal(-1); break; case Op_Sdup: /* duplicate descriptor */ rsp += 2; rsp[-1] = rsp[-3]; rsp[0] = rsp[-2]; break; /* ---Co-expressions--- */ case Op_Create: /* create */ #ifdef Coexpr PushNull; Setup_Op(0); opnd = GetWord; opnd += (word)ipc.opnd; signal = Ocreate((word *)opnd, rargp); goto C_rtn_term; #else /* Coexpr */ runerr(-401, NULL); goto efail; #endif /* Coexpr */ case Op_Coact: { /* @e */ #ifndef Coexpr runerr(-401, NULL); goto efail; #else /* Coexpr */ register struct b_coexpr *ccp, *ncp; dptr dp, tvalp; struct descrip tval; int first; ExInterp; dp = (dptr)(sp - 1); #ifdef TraceBack xargp = dp - 2; #endif /* TraceBack */ if (DeRef(*dp) == Error) { runerr(0, NULL); goto efail; } if (dp->dword != D_Coexpr) { runerr(118, dp); goto efail; } ccp = (struct b_coexpr *)BlkLoc(k_current); ncp = (struct b_coexpr *)BlkLoc(*dp); /* * Dereference the transmited value if needed. */ tval = *(dptr)(sp - 3); if (Var(tval)) { word *loc; if (Tvar(tval)) { if (tval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(tval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto ca_noderef; } else loc = (word *)VarLoc(tval) + Offset(tval); if (InRange(ccp,loc,sp)) if (DeRef(tval) == Error) { runerr(0, NULL); goto efail; } } ca_noderef: /* * Set activator in new co-expression. */ if (ncp->es_actstk == NULL) { ncp->es_actstk = alcactiv(); if (ncp->es_actstk == NULL) { runerr(0, NULL); goto efail; } first = 0; } else first = 1; if (pushact(ncp, ccp) == Error) { runerr(0, NULL); goto efail; } if (k_trace) { k_trace--; coacttrace(ccp, ncp); } /* * Save Istate of current co-expression. */ ccp->es_pfp = pfp; ccp->es_argp = argp; ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; ccp->tvalloc = (dptr)(sp - 3); /* * Establish Istate for new co-expression. */ pfp = ncp->es_pfp; argp = ncp->es_argp; efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; if (tvalp = ncp->tvalloc) { ncp->tvalloc = NULL; *tvalp = tval; } BlkLoc(k_current) = (union block *)ncp; coexp_act = A_Coact; coswitch(ccp->cstate,ncp->cstate,first); EntInterp; if (coexp_act == A_Cofail) goto efail; else rsp -= 2; break; #endif /* Coexpr */ } case Op_Coret: { /* return from co-expression */ #ifndef Coexpr runerr(-401, NULL); /* can't happen? */ goto efail; #else /* Coexpr */ register struct b_coexpr *ccp, *ncp; struct descrip rval, *rvalp; ExInterp; ccp = (struct b_coexpr *)BlkLoc(k_current); /* * Dereference the returned value if needed. */ rval = *(dptr)&sp[-1]; if (Var(rval)) { word *loc; if (Tvar(rval)) { if (rval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(rval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto cr_noderef; } else loc = (word *)VarLoc(rval) + Offset(rval); if (InRange(ccp,loc,sp)) if (DeRef(rval) == Error) { runerr(0, NULL); goto efail; } } cr_noderef: ccp->size++; ncp = popact(ccp); ncp->tvalloc = NULL; rvalp = (dptr)(&ncp->es_sp[-3]); *rvalp = rval; if (k_trace) { k_trace--; corettrace(ccp,ncp); } /* * Save Istate of current co-expression. */ ccp->es_pfp = pfp; ccp->es_argp = argp; ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; /* * Establish Istate for new co-expression. */ pfp = ncp->es_pfp; argp = ncp->es_argp; efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; BlkLoc(k_current) = (union block *)ncp; coexp_act = A_Coret; coswitch(ccp->cstate, ncp->cstate,1); break; #endif /* Coexpr */ } case Op_Cofail: { /* fail from co-expression */ #ifndef Coexpr runerr(-401, NULL); /* can't happen? */ goto efail; #else /* Coexpr */ register struct b_coexpr *ccp, *ncp; ExInterp; ccp = (struct b_coexpr *)BlkLoc(k_current); ncp = popact(ccp); if (k_trace) { k_trace--; cofailtrace(ccp, ncp); } ncp->tvalloc = NULL; /* * Save Istate of current co-expression. */ ccp->es_pfp = pfp; ccp->es_argp = argp; ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; /* * Establish Istate for new co-expression. */ pfp = ncp->es_pfp; argp = ncp->es_argp; efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; BlkLoc(k_current) = (union block *)ncp; coexp_act = A_Cofail; coswitch(ccp->cstate, ncp->cstate,1); EntInterp; break; #endif /* Coexpr */ } case Op_Quit: /* quit */ #ifdef IconCalling ExInterp; /* restores stack pointer for icon_call */ interp_status = A_Pret_uw; #endif /* IconCalling */ goto interp_quit; #ifdef IconCalling case Op_FQuit: /* failing quit */ ExInterp; /* restores stack pointer for icon_call */ interp_status = A_Pfail_uw; goto interp_quit; #endif /* IconCalling */ default: { char buf[50]; sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", (long)lastop, lastop); syserr(buf); } } continue; C_rtn_term: EntInterp; switch (signal) { case A_Failure: goto efail; case A_Unmark_uw: /* unwind for unmark */ goto Unmark_uw; case A_Lsusp_uw: /* unwind for lsusp */ goto Lsusp_uw; case A_Eret_uw: /* unwind for eret */ goto Eret_uw; case A_Pret_uw: /* unwind for pret */ goto Pret_uw; case A_Pfail_uw: /* unwind for pfail */ goto Pfail_uw; } rsp = (word *)rargp + 1; /* set rsp to result */ continue; } interp_quit: --ilevel; #ifdef MaxLevel fprintf(stderr,"maximum &level = %d\n",maxplevel); fprintf(stderr,"maximum ilevel = %d\n",maxilevel); fprintf(stderr,"maximum sp = %d\n",(long)maxsp - (long)stack); fflush(stderr); #endif /* MaxLevel */ #ifdef DumpIcount { int i; for (i = 0; i <= MaxIcode; i++) fprintf(imonc,"\%d\n",icode[i]); fflush(imonc); } #endif /* DumpIcount */ #ifndef IconCalling if (ilevel != 0) syserr("interp: termination with inactive generators."); #else if (IDepth == 0 && ilevel != 0) syserr("interp(call in): termination with inactive generators"); #endif /* IconCalling */ } #ifdef StackPic /* * The following code is operating-system dependent [@interp.04]. * Diagnostic stack pictures for debugging/monitoring. */ #if PORT Deliberate Syntax Error #endif /* PORT */ #if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || VM || VMS /* not included */ #endif /* AMIGA || ATARI_ST || ... */ #if MSDOS || OS2 novalue stkdump(op) int op; { word far *stk; word far *i; stk = (word far *)BlkLoc(k_current); stk += Wsizeof(struct b_coexpr); fprintf(stderr,"> stack: %08lx\n", (word)stk); fprintf(stderr,"> sp: %08lx\n", (word)sp); fprintf(stderr,"> pfp: %08lx\n", (word)pfp); fprintf(stderr,"> efp: %08lx\n", (word)efp); fprintf(stderr,"> gfp: %08lx\n", (word)gfp); fprintf(stderr,"> ipc: %08lx\n", (word)ipc.op); fprintf(stderr,"> argp: %08lx\n", (word)argp); fprintf(stderr,"> ilevel: %08lx\n", (word)ilevel); fprintf(stderr,"> op: %d\n", (int)op); for (i = stk; i <= (word far *)sp; i++) fprintf(stderr,"> %08lx\n",(word)*i); fprintf(stderr,"> ----------\n"); fflush(stderr); } #endif /* MSDOS || OS2 */ #if UNIX || VMS novalue stkdump(op) int op; { word *i; fprintf(stderr,"\001stack: %lx\n",(long)(stack + Wsizeof(struct b_coexpr))); fprintf(stderr,"\001pfp: %lx\n",(long)pfp); fprintf(stderr,"\001efp: %lx\n",(long)efp); fprintf(stderr,"\001gfp: %lx\n",(long)gfp); fprintf(stderr,"\001ipc: %lx\n",(long)ipc.op); fprintf(stderr,"\001argp: %lx\n",(long)argp); fprintf(stderr,"\001ilevel: %lx\n",(long)ilevel); fprintf(stderr,"\001op: \%d\n",(int)op); for (i = stack + Wsizeof(struct b_coexpr); i <= sp; i++) fprintf(stderr,"\001%lx\n",*i); fprintf(stderr,"\001----------\n"); fflush(stderr); } #endif /* UNIX || VMS */ /* * End of operating-system specific code. */ #endif /* StackPic */