/* * Execute a program via direct parse tree interpretation. See 451 Notes for * discussion. Note the similarity here with the type checker -- they're both * basically a recursive parse tree traversal. This particular version of the * interpreter does not do type checking, assuming that it has already been * performed in a previous pass. An interp with runtime type checking may be * forthcoming. */ #include #include #include "std-macros.h" #include "parse-tree.h" #include "tokens.h" #include "sym.h" #include "sym-aux.h" #include "type-preds.h" #include "type.h" #include "str.h" #include "interp.h" #include "list.h" #include "vlist.h" /* * Jmp_buf used for fatal runtime errors, such as nil pointer ref. */ static jmp_buf RuntimeError; /* * Top-level interpreter function, called with a stmt sequence to interpret. */ ValueStruct interp(t) nodep t; /* t is a pointer to a stmtlist */ { ExitStatus status = OKStatus; Symtab *st = CurSymtab; /* * Check for the empty stmt list. */ if (t == null) return; /* * Use setjmp to catch fatal runtime errors, such as nil pointer ref. */ if (not (status = setjmp(RuntimeError))) interpStmts(t); if (status != OKStatus) { error("Execution terminated abnormally.\n"); ReInitInterp(); } } /* * Evaluate a stmt sequence using a typical switch. */ void interpStmts(t) nodep t; { nodep s; ValueStruct v1, v2; for (s = t; s; s = s->components.stmt.next) { ChkBreak(s); switch (s->header.name) { case 0: break; case YASSMNT: v1 = designator(s->components.stmt.kind.assmnt.var); v2 = interpExpr(s->components.stmt.kind.assmnt.expr); doAssmnt(v1,v2,true,s); break; case YIF: doIf(s); break; case YWHILE: doWhile(s); break; case YRETURN: doReturn(s); break; } } } /* * Eval an expr. */ ValueStruct interpExpr(t) nodep t; { ValueStruct v1,v2,v3; if (not t) return null; switch (t->header.kind) { case UNOP_NODE: // copied switch t->header.name from case BINOP_NODE since // lists were being IDd as UNOP_NODEs // NOTE: // It could be the case that the lists are not supposed to be // UNOP_NODEs in the first place. switch (t->header.name) { case '[': return doDesignator(t); case '.': return doDesignator(t); case '^': return doDesignator(t); case ']': return doListConstructor(t); case '}': /** THIS IS NEW! interpx **/ return doTupleConstructor(t); } v1 = interpExpr(t->components.expr.left_operand); switch (t->header.name) { case YUNYPLUS: return doUnyPlus(v1); case YUNYMINUS: return doUnyMinus(v1); case YNOT: return doNot(v1); case '#': return doLen(v1); } break; case BINOP_NODE: switch (t->header.name) { case '[': return doDesignator(t); case '.': return doDesignator(t); case '^': return doDesignator(t); case YDOTDOT: return doDotDot(t); } v1 = interpExpr(t->components.expr.left_operand); v2 = interpExpr(t->components.expr.right_operand); switch (t->header.name) { case '=': return doEq(v1, v2); case YNEQ: return doNotEq(v1, v2); case '<': return doLess(v1, v2); case '>': return doGreater(v1, v2); case YLEQ: return doLessEq(v1, v2); case YGEQ: return doGreaterEq(v1, v2); case '+': return doPlus(v1, v2); case '-': return doMinus(v1, v2); case '*': return doMult(v1, v2); case YDIV: return doDiv(v1, v2); case YMOD: return doMod(v1, v2); case '/': return doRealDiv(v1, v2); case YAND: return doAnd(v1, v2); case YOR: return doOr(v1, v2); case YXOR: return doXOr(v1, v2); case YIMPLIES: return doImplies(v1, v2); case YIFF: return doIff(v1, v2); case YIN: return doIn(v1, v2); } case PROC_CALL_NODE: return doProcCall(t); case ATOM_NODE: switch (t->header.name) { SymtabEntry *sym; nodep t1; char *vaddr; case Yident: if (t->components.atom.next) { sym = QuickLookupQid(t); if (t->header.attachment.n1->components.atom.next) return doDesignator(t->header.attachment.n1); } else sym = Lookup(t->components.atom.val.text); /* * Next check necessary in case of bogus banging at the * interactive prompt. */ if (not sym) longjmp(RuntimeError, NilPointerStatus); switch (sym->Class) { case C_Var: case C_Parm: v1 = MakeVal(RVAL, sym->Type); vaddr = GetAddr(sym); v1->val.IntVal = 0; /* Clear out int part so chars * can be ints in for loops. */ if (v1->tag == StructTag) memcpy((char *) &(v1->val), &vaddr, v1->size); /* bcopy(&vaddr, (char *) &(v1->val), v1->size);*/ else memcpy((char *) &(v1->val), vaddr, v1->size); /* bcopy(vaddr, (char *) &(v1->val), v1->size);*/ break; case C_Const: /* PSC 05/03/2008: problem here since constants can be * more than just integers; especially for me, Bools. * FYI the bool constants' values are stored as ints. */ v1 = MakeVal(RVAL, sym->Type); vaddr = (char *) &(sym->Info.Consta.val->val.LVal); /* The assignment below may not be Kosher, since we're * directly assigning an IntVal to a BoolVal. This is C, * though, right? */ if (sym->Type == BoolType) v1->val.BoolVal = sym->Info.Consta.val->val.IntVal; else v1->val.IntVal = 0; /* Clear out int part so chars * can be ints in for loops. */ if (v1->tag == StructTag) memcpy((char *) &(v1->val), &vaddr, v1->size); /* bcopy(&vaddr, (char *) &(v1->val), v1->size);*/ else memcpy((char *) &(v1->val), vaddr, v1->size); /* bcopy(vaddr, (char *) &(v1->val), v1->size);*/ break; case C_Enum: v1 = MakeVal(RVAL, sym->Type); v1->val.IntVal = sym->Info.Enum.Value; break; case C_Proc: if (t1 = sym->Info.Proc.FType) v1 = MakeVal(RVAL, sym->Info.Proc.FType); else { /* * This else is the case of a built-in proc for * which no FType has been built. We can * MakeVal with NilType since it doesnt matter * what the type is beyond here, the reason * being that we can only be calling, given * that the type checker disallows using * built-ins as unevaluated proc values. * (Note that this comment is no where near as * important as it is long.) */ v1 = MakeVal(RVAL, NilType); //v1->tag; // <-- this does nothing; plus, niltag should be set via MakeVal } v1->val.ProcVal = sym; break; case C_Type: v1 = MakeVal(RVAL, sym->Type); v1->tag = TypeTag; break; } return v1; case Yinteger: v1 = MakeVal(RVAL, IntType); v1->val.IntVal = t->components.atom.val.integer; return v1; case Yreal: v1 = MakeVal(RVAL, RealType); v1->val.RealVal = t->components.atom.val.real; return v1; case Ychar: v1 = MakeVal(RVAL, CharType); v1->val.IntVal = 0; /* Clear out int part so chars can be * ints in for loops. See doFor */ v1->val.CharVal = t->components.atom.val.character; return v1; case Ystring: v1 = MakeVal(RVAL, StringType); v1->val.StringVal = NewStringQuotes(t->components.atom.val.string); return v1; } case TRINOP_NODE: v1 = interpExpr(t->components.trinop.left_operand); v2 = interpExpr(t->components.trinop.middle_operand); v3 = interpExpr(t->components.trinop.right_operand); switch (t->header.name) { case YIF: return doIfExpr(v1, v2, v3); case '[': return doArraySliceRef(v1, v2, v3); } case EXPR_LIST_NODE: return doExprSeq(t); } // end switch (t->header.kind) } /*** *** Individual evaluation routines for each kind of tree node that requires *** evaluation. ***/ /* * Interpret an expr sequence of the form * * ( e<1>; e<2>; ..., e ) * * Note that although each expression in an expression sequence will be * interpreted, the Value of an expression sequence is equal to the value * of the last expression in the sequence. */ ValueStruct doExprSeq(t) nodep t; { nodep el; ValueStruct v; if (not t) return null; for (el=t; el; el=el->components.exprlist.next) v = interpExpr(el->components.exprlist.expr); return v; } // end ValueStruct doExprSeq /* * Evaluate an assignment statement via bcopy. Note the difference in handling * of structured vs. non-structured values. For structured values, we must * deref the r-value and l-value pointers to get to the bytes we need. Note * the lack of check for null lval. A null pointer will have been detected and * long jumped from before we get here. * * Note finally the special treament of string literals on the RHS. In such * cases, type checking guarantees the the LHS will be an array of the form * "array[0..n] of char" and that n > strlen(RHS). What we do with the literal * is strcpy it into the LHS array, including the null termination. */ void doAssmnt(lval, rval, freeflag, t) ValueStruct lval; ValueStruct rval; bool freeflag; /* If true, free lval and rval on exit. */ nodep t; /* Source tree for stmt for line number only */ { /* * Do the bcopy, noting whether we have a structured, non-structured, or * string value */ switch (rval->tag) { case StructTag: memcpy(lval->val.LVal, (char *) rval->val.StructVal, rval->type->header.attachment.count); /* bcopy((char *) rval->val.StructVal, lval->val.LVal, rval->type->header.attachment.count);*/ break; /* 1feb09 gfisher: separate case for String should not be necessary, given now * String representation. Not certain about, but testing should confirm. * case StringTag: strcpy(lval->val.LVal, rval->val.StringVal); break; */ default: memcpy(lval->val.LVal, (char *) &(rval->val), rval->size); /* bcopy((char *) &(rval->val), lval->val.LVal, rval->size);*/ } /* * Free the value structs if the caller says it's OK. Otherwise, we'll * assume that the caller does the freeing. An example of when it's not OK * to free here is in the call from doFor, where the lvalue needs to be * retained until for processing is done. */ if (freeflag) { free(lval); free(rval); } } /* * Evaluate a proc call: * (1) push an activation record onto the stack, saving current display * entry at level of this proc * (2) recursively evaluate each actual parm * (3) store the value of each acutal in the location of the corresponding * formal in the act rec * (4) move the symbol table context to the called proc * (4) recursively execute the proc body * (5) pop the act rec; restore the symbol table context to what it was on * entry; restore display entry, and return the return value of the * proc, if any */ ValueStruct doProcCall(t) nodep t; /* Parse tree proc call */ { SymtabEntry *p, *fp; nodep ap, d; ValueStruct v1, v2; int i, o, so; char *saveftos; jmp_buf **jbp; /* * Evaluate proc designator. */ v1 = interpExpr(d = t->components.proccall.desig); /* * Check first if we have a cast, in which case we'll handle not as a proc * call at all. */ if (v1->tag == TypeTag) { return doCast(v1, t->components.proccall.actuals); } /* * Check next for a non-null procedure. Type checking handles everything * else but this. */ if (not (p = v1->val.ProcVal)) { lerror(t, "Attempt to call a null procedure.\n"); longjmp(RuntimeError, NilProcStatus); } /* * Check if special proc, and if so, call immediately. */ if (ChkSymFlag(p, specialProc)) return p->Info.Proc.Code.Func(t->components.proccall.actuals); /* * Push storage for act rec, based on size of parm and local storage. * Before pushing, we save the entering formals stack pointer so that it * can be restored upon exit. Note that we're using two top-of-stack * pointers here: the one in the current display entry and ftos. The "f" * in ftos stands for "formals" tos, since it points to the top of the * stack where the formals for the called proc are being bound. * * During parm binding, the display points to the top of stack in the * callING environment, while ftos points to the top of stack in the callED * environment. Once binding is accomplished, the display is moved up to * ftos, and ftos is no longer needed. */ saveftos = GetFTos(); PushActRec(o = p->Info.Proc.Symtab->Offset); /* * Evaluate each actual and store value in corresponding formal. */ for (ap = t->components.proccall.actuals, fp = p->Info.Proc.Parms, i=1; ap && fp; ap = ap->components.exprlist.next, fp = fp->Info.Parm.Link, i++) { /* * Compute address of formal, in callED environment. The callED stack * environment is pointed to by ftos. We havent yet moved into the * callED symtab environment, but we get there through the threaded * parm chain. */ v1 = MakeVal(LVAL, fp->Type); v1->val.LVal = GetFormalAddr(fp); /* * Recursively eval actual in the callING environment. The callING * stack environment is pointed to by the current display entry, which * the recursive call to inerpExpr will use via GetAddr. And as noted * above, we havent yet moved into the callED symtab environment. * * Note the different handling of call-by-val vs call-by-var parms. * For the former, we compute an r-value, for the latter an l-value. */ if (ChkSymFlag(fp, varParm)) v2 = designator(ap->components.exprlist.expr); else v2 = interpExpr(ap->components.exprlist.expr); /* * Bind per the parm discipline -- call-by-value, call-by-var, call-by * array. */ Bind(fp, v1, v2); } /* * Move the Symtab context into the called proc. */ PushSymtab(); MoveToSymtab(p->Info.Proc.Symtab); /* * Save the current display entry for this proc's level and update the * entry at this level. */ SaveDisplay(p->Level, so = (o - sizeof(char *))); /* * NOPE. * Set the normal (i.e., not-during-binding) tos pointer. This will be * used by folks who need to use the stack as a utility storage area, such * as doLoop and printf_, q.q.v. SetTos(p->Level); */ /* * Recursively execute the body of the proc. Note use of setjmp here. The * jmp_buf is put in the act rec, to be used subsequently by the longjmp in * the return stmt code, q.v. We need to put jmp_bufs on the stack, since * each recursive proc invocation needs its own copy. And we can't put jmp * bufs in a local (C) var, since the return stmt code wouldn't be able to * see it there */ if (ChkSymFlag(p, compiledProc)) v1 = p->Info.Proc.Code.Func(t); else { #ifdef Sparc jmp_buf *jbp1 = (jmp_buf *) malloc(sizeof(jmp_buf)); jbp = (jmp_buf **) StackAddr(p->Info.Proc.Offset); memcpy((char *) jbp, (char *) &jbp1, sizeof (char *)); /* bcopy((char *) &jbp1, (char *) jbp, sizeof (char *));*/ if (not (v1 = ((ValueStruct) setjmp(*jbp1)))) interpStmts(p->Info.Proc.Code.Tree); free(jbp1); #else jbp = (jmp_buf **) StackAddr(p->Info.Proc.Offset); *jbp = (jmp_buf *) malloc(sizeof(jmp_buf)); if (not (v1 = ((ValueStruct) setjmp(**jbp)))) interpStmts(p->Info.Proc.Code.Tree); free(*jbp); #endif } /* * Restore display. */ RestoreDisplay(p->Level, so); /* * Pop act rec by restoring entering ftos; restore calling symtab context. */ SetFTos(saveftos); PopSymtab(); return v1; } /* * Bind an actual value to the corresponding formal. Here are the cases to * handle: * BINDING DISCIPLINE ACTION TAKEN * ====================================================================== * call-by-val, non-struct vals bind via normal value assigment * call-by-val, struct vals bind by copying the struct val into the * act rec * call-by-var bind via assignment of the l-value ptr * call-by-array, call-by-var bind as normal call-by-var, plus set up * normalized upper array bound for easy * ref from high function * call-by-array, call-by-val bind by malloc'ing storage for a copy * of the array val, and copying into it * * Things are easier than this table looks, since most of the work for * distinguishing call-by-var vs call-by-val parms has been done already. The * key is back in doProcCall, wherein we evaluate the actual corresponding to a * var formal as an l-value instead of an r-value. Given this, the first four * cases above are all handled uniformly via regular assmnt, by either calling * do Asmmnt (1st three cases) or doing the bcopy of the pointer (4th case). * * What remains to be done here is to sort out the handling of open array * parms. * */ Bind(fp, fv, av) SymtabEntry *fp; ValueStruct fv, av; { char *caddr; int csize; /* * Open array parm. */ if (ChkSymFlag(fp, arrayParm)) { /* * Call-by-var open array parm bound just line other call-by-var. */ if (ChkSymFlag(fp, varParm)) memcpy(fv->val.LVal, (char *) &(av->val), sizeof(char *)); /* bcopy((char *) &(av->val), fv->val.LVal, sizeof(char *));*/ /* * Call-by-val open array parm requires malloc of storage, since * there's only a pointer's-worth of space on the act rec, since we * couldnt compute the actual space until runtime. After that, we * treat all open array parms as call-by-var, since what's on the stack * is a pointer. See GetAddr. * * Note here yet again special string handling. * * 1feb09 gfisher: This handlings of strings needs to be fixed per the * new String representation. Specifically, since string vals are now * just pointers, special-case handling should not be necessary. */ else { if (av->tag == StringTag) caddr = (char *) malloc(csize = strlen(av->val.StringVal)+1); else caddr = (char *) malloc(csize = av->type->header.attachment.count); memcpy(caddr, av->val.LVal, csize); /*bcopy(av->val.LVal, caddr, csize);*/ memcpy(fv->val.LVal, (char *) &caddr, sizeof(char *)); /*bcopy((char *) &caddr, fv->val.LVal, sizeof(char *));*/ } /* * To facilitate subsequent ref's to the open array parm, we * dynamically change the upper bound in the formal's type struct. In * this way, we dont need any further special-case checks for open * arrayness, except in GetAddr. * * Note (as elsewhere) the special handling of string literal type. * It's probably time to generalize this, as in making StringType an * array of char, but let's not hassle it right now unless further * problems arise (which if they do/have, you wont be reading this * right now). Hmm, that's seems a bit metaphysical. Did you really * just read that, or did you imagine it? Or perhaps you read it in * some parallel universe, but if you look again it wont be there. * What *is* the meaning of life? */ fp->Type->components.type.kind.arraytype.normalizedubval = isString(av->type) ? strlen(av->val.StringVal) - 1 : av->type->components.type.kind.arraytype.normalizedubval; /* Note that strlen - 1 means no clobberello of null terminator. */ } /* * Call-by-var parm -- bind via pointer assmnt. */ else if (ChkSymFlag(fp, varParm)) { memcpy(fv->val.LVal, (char *) &(av->val), sizeof(char *)); /*bcopy((char *) &(av->val), fv->val.LVal, sizeof(char *));*/ } /* * Call-by-val parm -- bind via doAssmnt. */ else { doAssmnt(fv, av); } } /* * Evaluate a cast. */ ValueStruct doCast(v, actuals) ValueStruct v; nodep actuals; { ValueStruct v1; /* * Next line should not happen, but somehow it does at times. Case in * point, a C-style decl, such as integer i, which somehow gets by the * parser as a syntactically legal cast. FIX THIS. */ if (not actuals) return null; v1 = interpExpr(actuals->components.exprlist.expr); v1->type = v->type; v1->tag = v->tag; return v1; } /* * Evaluate an if. */ doIf(t) nodep t; { ValueStruct v1; nodep elsif; /* * Eval the if expr and do the then if true. */ v1 = interpExpr(t->components.stmt.kind.ifstmt.expr); if (v1 and v1->val.BoolVal) { interpStmts(t->components.stmt.kind.ifstmt.thenpart); free(v1); return; } /* * Do the first elsif that's true, if any. */ for (elsif = t->components.stmt.kind.ifstmt.elsifparts; elsif; elsif = elsif->components.stmt.next) { v1 = interpExpr(t->components.stmt.kind.elsif.expr); if (v1 and v1->val.BoolVal) { interpStmts(t->components.stmt.kind.elsif.thenpart); free(v1); return; } } /* * Try the else if all else has failed. */ if (t->components.stmt.kind.ifstmt.elsepart) interpStmts(t->components.stmt.kind.ifstmt.elsepart); } /* * Evaluate a case. */ doCase(t) nodep t; { int expr; SymtabEntry *s; /* * Eval and integerize the case expr. */ expr = Integerize(interpExpr(t->components.stmt.kind.casestmt.expr)); /* * Find the case label that = expr by looking it up in the nice little hash * tab that the type checker built for us. */ if (s = LookupIn((char *)expr, t->components.stmt.kind.casestmt.symtab)) interpStmts((nodep) s->Type); else interpStmts(t->components.stmt.kind.casestmt.elsepart); } /* * Evaluate a while. */ doWhile(t) nodep t; { ValueStruct v1; while ((v1 = interpExpr( t->components.stmt.kind.whilestmt.expr))->val.BoolVal) { free(v1); interpStmts(t->components.stmt.kind.whilestmt.body); } } /* * Evaluate a repeat. */ doRepeat(t) nodep t; { ValueStruct v1; nodep b; interpStmts(b = t->components.stmt.kind.repeatstmt.body); while (not ((v1 = interpExpr( t->components.stmt.kind.repeatstmt.expr))->val.BoolVal)) { free(v1); interpStmts(b); } } /* * Evaluate a loop. Push a one-word eval blip on the stack to hold jmp_buf * that subsequent exit stmt will longjmp through. Cf. doProcCall for the * similar use of setjmp. */ doLoop(t) nodep t; { jmp_buf *jbp; /* * Malloc the jmp_buf and stick it on the stack. */ jbp = (jmp_buf *) malloc(sizeof(jmp_buf)); push(&jbp, sizeof (jmp_buf *)); /* * Do the setjmp and recursively eval the loop body. */ if (not(setjmp(*jbp))) while (true) interpStmts(t->components.stmt.kind.loopstmt.body); /* * The exit stmt, if executed, will longjmp back to here. Note that if we * dont do an exit at some point, the program is in a (possibly legitimate) * infinite loop, since the only way out of a loop is an exit. */ pop(sizeof (jmp_buf *)); free(jbp); } /* * Evaluate a for. */ doFor(t) nodep t; { ValueStruct v1,v2,v3=null; nodep byt; int byval, endval; v1 = designator(t->components.stmt.kind.forstmt.var); v2 = interpExpr(t->components.stmt.kind.forstmt.startexpr); endval = Integerize(interpExpr(t->components.stmt.kind.forstmt.endexpr)); byval = (byt = t->components.stmt.kind.forstmt.byexpr) ? Integerize(v3 = interpExpr(byt)) : 1; for (doAssmnt(v1,v2,false); IntegerizeL(v1) <= endval; doForIncr(v1, byval)) interpStmts(t->components.stmt.kind.forstmt.body); free(v1); free(v2); if (v3) free(v3); } /* * Incr a for var appropriately. */ doForIncr(forvar, byval) ValueStruct forvar; int byval; { int i; memcpy(&i, forvar->val.LVal, TypeSize(forvar->type)); /*bcopy(forvar->val.LVal, &i, TypeSize(forvar->type));*/ i += byval; bcopy(forvar->val.LVal, &i, TypeSize(forvar->type)); /*bcopy(&i, forvar->val.LVal, TypeSize(forvar->type));*/ /* * We'd like to do the following, which would be faster, but it causes BUS * (alignment error) on the Sparc, at least: * switch (forvar->tag) { case LIntTag: case IntTag: *((int *)forvar->val.LVal) += byval; return; case CharTag: *((char *)forvar->val.LVal) += byval; return; case BoolTag: *((bool *)forvar->val.LVal) += byval; return; } * */ } /* * Evaluate an exit by longjmping out to the setjmp of enclosing loop. * Typechecking gaurantees there's an enclosing loop. Cf. doReturn just below. * Note that we extract jump_buf pointer here via top. We then longjump back * to doLoop, which does the stack pop (and also frees *jbp). */ doExit(t) nodep t; { jmp_buf *jbp; memcpy(&jbp, top(), sizeof(jmp_buf *)); /*bcopy(top(), &jbp, sizeof(jmp_buf *));*/ longjmp(*jbp, null); } /* * Evaluate a return. The sweet trick is a longjmp via a jmp_buf stored in the * act rec of the currently active proc. See the corresponding setjmp in * doProcCall. Very nice. */ doReturn(t) nodep t; { ValueStruct v1; jmp_buf **jbp = (jmp_buf **) StackAddr( CurSymtab->ParentEntry->Info.Proc.Offset); v1 = interpExpr(t->components.stmt.kind.returnstmt); longjmp(**jbp, (int) v1); /* * Not: return interpExpr(t->components.stmt.kind.returnstmt); */ } /* * Evaluate a designator as an r-value. To do this, just call designator, * which produces an l-value, and deref it. Note the difference in handling * structured vs. non-structured vals. For structured values, we only copy the * pointer, not the entire value. This is safe at this point, since we have an * r-value that will not be mutated anywhere above us. This is in contrast to * binding structured values as actual parms, where we must in fact make a new * copy of the struct. */ ValueStruct doDesignator(t) nodep t; { ValueStruct v1,v2; v1 = designator(t); v2 = MakeVal(RVAL, v1->type); if ((v1->tag == StructTag) || (v1->tag == ListTag)){ memcpy((char *) &(v2->val), (char *) &(v1->val), sizeof(char *)); /*bcopy((char *) &(v1->val), (char *) &(v2->val), sizeof(char *));*/ } else { memcpy(&(v2->val), &(v1->val), v1->size); /*bcopy(v1->val.LVal, &(v2->val), v1->size);*/ } return v2; } /** ** The operator evaluation functions that follow are largely clones. They ** each just apply the C operation that is the equivalent of the corresponding ** operation in the parse tree, with a Modula-2 nuiance here and there. ** ** Note that even though type checking has already been done, we still need to ** do some type analysis here in order to make sure that values are computed ** properly. Strong typing sucks. ** **/ /* * Eval '*' */ ValueStruct doMult(v1,v2) ValueStruct v1,v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities here are int, real, longint, and longreal. */ switch (v1->tag) { case IntTag: v1->val.IntVal = v1->val.IntVal * v2->val.IntVal; free(v2); return v1; case LIntTag: v1->val.LIntVal = v1->val.LIntVal * v2->val.LIntVal; free(v2); return v1; case RealTag: v1->val.RealVal = v1->val.RealVal * v2->val.RealVal; free(v2); return v1; case LRealTag: v1->val.LRealVal = v1->val.LRealVal * v2->val.LRealVal; free(v2); return v1; } } /* * Eval '+' */ ValueStruct doPlus(v1,v2) ValueStruct v1,v2; { ValueStruct val; List* l; /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities here are int, real, longint, and longreal. */ switch (v1->tag) { case StringTag: // could be a list? if (v2->tag != ListTag) { val = MakeVal(RVAL, StringType); val->val.StringVal = (String *)StringConcat(v1->val.StringVal, v2->val.StringVal); return val; } break; case IntTag: // could be a list? if (v2->tag != ListTag) { v1->val.IntVal = v1->val.IntVal + v2->val.IntVal; free(v2); return v1; } break; case LIntTag: // could be a list? if (v2->tag != ListTag) { v1->val.LIntVal = v1->val.LIntVal + v2->val.LIntVal; free(v2); return v1; } break; case RealTag: // could be a list? if (v2->tag != ListTag) { v1->val.RealVal = v1->val.RealVal + v2->val.RealVal; free(v2); return v1; } break; case LRealTag: // could be a list? if (v2->tag != ListTag) { v1->val.LRealVal = v1->val.LRealVal + v2->val.LRealVal; free(v2); return v1; } break; } // if we get down this far, we might have some lists to deal with if ((v1->tag == ListTag) && (v2->tag == ListTag)) { val = MakeVal(RVAL, v1->type); val->val.ListVal = (List *)ConcatList(v1->val.ListVal, v2->val.ListVal); return val; } // v1 is a list then v2 must be an element, thanks to Mr. TC else if (v1->tag == ListTag) { val = MakeVal(RVAL, v1->type); l = NewList1((ListElemData*)v2); val->val.ListVal = (List *)ConcatList(v1->val.ListVal, l); return val; } // v2 is a list then v1 must be an element, thanks to Mr. TC else if (v2->tag == ListTag) { val = MakeVal(RVAL, v2->type); l = NewList1((ListElemData*)v1); val->val.ListVal = (List *)ConcatList(l, v2->val.ListVal); return val; } } // end function doPlus ValueStruct doDiv(v1,v2) ValueStruct v1, v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities are only int and long int. */ switch (v1->tag) { case IntTag: v1->val.IntVal = v1->val.IntVal / v2->val.IntVal; free(v2); return v1; case LIntTag: v1->val.LIntVal = v1->val.LIntVal / v2->val.LIntVal; free(v2); return v1; } } ValueStruct doMod(v1,v2) ValueStruct v1, v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities are only int and long int. */ switch (v1->tag) { case IntTag: v1->val.IntVal = v1->val.IntVal % v2->val.IntVal; free(v2); return v1; case LIntTag: v1->val.LIntVal = v1->val.LIntVal % v2->val.LIntVal; free(v2); return v1; } } ValueStruct doRealDiv(v1,v2) ValueStruct v1, v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possbilities here are only real and longreal. */ switch (v1->tag) { case RealTag: v1->val.RealVal = v1->val.RealVal / v2->val.RealVal; free(v2); return v1; case LRealTag: v1->val.LRealVal = v1->val.LRealVal / v2->val.LRealVal; free(v2); return v1; } } ValueStruct doMinus(v1,v2) ValueStruct v1,v2; { ValueStruct v; int pos; List* firstHalf, * lastHalf; /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities here are int, real, longint, and longreal. */ switch (v1->tag) { case IntTag: v1->val.IntVal = v1->val.IntVal - v2->val.IntVal; free(v2); return v1; case LIntTag: v1->val.LIntVal = v1->val.LIntVal - v2->val.LIntVal; free(v2); return v1; case RealTag: v1->val.RealVal = v1->val.RealVal - v2->val.RealVal; free(v2); return v1; case LRealTag: v1->val.LRealVal = v1->val.LRealVal - v2->val.LRealVal; free(v2); return v1; case ListTag: pos = InListWithFunction(v1->val.ListVal, v2, ValueListEquals); if (pos > 0) { // if the list size is 1 and we found a match, we've now got // an empty list... => nil if (ListLen(v1->val.ListVal) == 1) { v = MakeVal(RVAL, NilType); } else { v = MakeVal(RVAL, v1->type); firstHalf = SubList(v1->val.ListVal, 1, pos - 1); lastHalf = SubList(v1->val.ListVal, pos + 1, ListLen(v1->val.ListVal)); if (firstHalf && lastHalf) v->val.ListVal = (List *)ConcatList(firstHalf, lastHalf); else if (firstHalf) v->val.ListVal = firstHalf; else if (lastHalf) v->val.ListVal = lastHalf; } return v; } // if we got this far, return v1 since that means v2 wasn't contained within v1 return v1; } // end switch } // end doMinus ValueStruct doUnyPlus(v1) ValueStruct v1; { return v1; } ValueStruct doUnyMinus(v1) ValueStruct v1; { /* * Propagate null value if operand is null. */ if (v1 == null) return null; /* * The possibilities here are int, real, longint, and longreal. */ switch (v1->tag) { case IntTag: v1->val.IntVal = -v1->val.IntVal; return v1; case LIntTag: v1->val.LIntVal = -v1->val.LIntVal; return v1; case RealTag: v1->val.RealVal = -v1->val.RealVal; return v1; case LRealTag: v1->val.LRealVal = -v1->val.LRealVal; return v1; } } ValueStruct doAnd(v1,v2) ValueStruct v1,v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * Only possibility here is bool. */ v1->val.BoolVal = v1->val.BoolVal and v2->val.BoolVal; free(v2); return v1; } ValueStruct doOr(v1,v2) ValueStruct v1,v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * Only possibility here is bool. */ v1->val.BoolVal = v1->val.BoolVal or v2->val.BoolVal; return v1; } ValueStruct doXOr(v1,v2) ValueStruct v1,v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * Only possibility here is bool. */ v1->val.BoolVal = v1->val.BoolVal neq v2->val.BoolVal; return v1; } ValueStruct doImplies(v1,v2) ValueStruct v1,v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * Only possibility here is bool. */ v1->val.BoolVal = not v1->val.BoolVal or v2->val.BoolVal; return v1; } ValueStruct doIfExpr(v1,v2,v3) ValueStruct v1,v2,v3; { ValueStruct nilStruct; /* * Propagate null value if either of the first two operands is null. */ if ((v1 == null) or (v2 == null)) return null; /* * If v3 is null, treat as: * if p then q else nil * if v3 is not null, treat as: * if p then q else r. * * Note: when v3 is null and q is a boolean, then equivalent to p => q. * Otherwise, result is v2. */ if (v3 == null) { switch (v2->tag) { case BoolTag: v1->val.BoolVal = not v1->val.BoolVal or v2->val.BoolVal; return v1; default: if (v1->val.BoolVal) { return v2; } else { nilStruct = MakeVal(RVAL, NilType); return nilStruct; } } } else { return (v1->val.BoolVal) ? v2 : v3; } /* If we got this far without returning, return null */ return null; } ValueStruct doIff(v1,v2) ValueStruct v1,v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * Only possibility here is bool. */ v1->val.BoolVal = (v1->val.BoolVal == v2->val.BoolVal); return v1; } ValueStruct doNot(v1) ValueStruct v1; { /* * Propagate null value if either is operand is null. */ if (v1 == null) return null; /* * Only possibility here is bool. */ v1->val.BoolVal = not v1->val.BoolVal; return v1; } /* * Do equality. As with assignment, eq is fully polymorphic. so we must * distingish between struct and non-struct vals, and handle accrordingly. */ ValueStruct doEq(v1,v2) ValueStruct v1, v2; { /* * PSC 5/13/2008: changed bcmp calls to memcmp. * Bcmp here lets us compare any two types, so that = is fully polymorphic. * Note the chk for struct type. For these, we must chase the pointer to * the actual stored value. Cf doAssmnt. */ if (v1->tag == StructTag) /*v1->val.BoolVal = not bcmp(v1->val.StructVal, v2->val.StructVal, v1->size)*/ v1->val.BoolVal = not memcmp(v1->val.StructVal, v2->val.StructVal, v1->size); else if (v1->tag == ListTag) { v1->val.BoolVal = ListEqualsWithFunction(v1->val.ListVal, v2->val.ListVal, ValueListEquals); } else /*v1->val.BoolVal = not bcmp(&(v1->val), &(v2->val), v1->size)*/ v1->val.BoolVal = not memcmp(&(v1->val), &(v2->val), v1->size); v1->tag = BoolTag; v1->type = BoolType; v1->size = TypeSize(BoolType); free(v2); return v1; } ValueStruct doNotEq(v1,v2) ValueStruct v1, v2; { /*v1->val.BoolVal = bcmp(&(v1->val), &(v2->val), v1->size)*/ /* v1->tag = BoolTag; v1->type = BoolType; v1->size = TypeSize(BoolType); free(v2);*/ v1 = doEq(v1, v2); v1->val.BoolVal = !(v1->val.BoolVal); return v1; } /* * The four rel ops that follow are a bit of a pain given all the types that * are comparable. We just have to sort them all out. */ ValueStruct doLess(v1,v2) ValueStruct v1, v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities here are int, real, longint, longreal, bool, or char. */ switch (v1->tag) { case IntTag: v1->val.BoolVal = v1->val.IntVal < v2->val.IntVal; break; case LIntTag: v1->val.BoolVal = v1->val.LIntVal < v2->val.LIntVal; break; case RealTag: v1->val.BoolVal = v1->val.RealVal < v2->val.RealVal; break; case LRealTag: v1->val.BoolVal = v1->val.LRealVal < v2->val.LRealVal; break; case BoolTag: v1->val.BoolVal = v1->val.BoolVal < v2->val.BoolVal; break; case CharTag: v1->val.BoolVal = v1->val.CharVal < v2->val.CharVal; break; } v1->tag = BoolTag; v1->type = BoolType; v1->size = TypeSize(BoolType); free(v2); return v1; } ValueStruct doGreater(v1,v2) ValueStruct v1, v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities here are int, real, longint, longreal, bool, or char. */ switch (v1->tag) { case IntTag: v1->val.BoolVal = v1->val.IntVal > v2->val.IntVal; break; case LIntTag: v1->val.BoolVal = v1->val.LIntVal > v2->val.LIntVal; break; case RealTag: v1->val.BoolVal = v1->val.RealVal > v2->val.RealVal; break; case LRealTag: v1->val.BoolVal = v1->val.LRealVal > v2->val.LRealVal; break; case BoolTag: v1->val.BoolVal = v1->val.BoolVal > v2->val.BoolVal; break; case CharTag: v1->val.BoolVal = v1->val.CharVal > v2->val.CharVal; break; } v1->tag = BoolTag; v1->type = BoolType; v1->size = TypeSize(BoolType); free(v2); return v1; } ValueStruct doLessEq(v1,v2) ValueStruct v1, v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities here are int, real, longint, longreal, bool, char, or * set. */ switch (v1->tag) { case IntTag: v1->val.BoolVal = v1->val.IntVal <= v2->val.IntVal; break; case LIntTag: v1->val.BoolVal = v1->val.LIntVal <= v2->val.LIntVal; break; case RealTag: v1->val.BoolVal = v1->val.RealVal <= v2->val.RealVal; break; case LRealTag: v1->val.BoolVal = v1->val.LRealVal <= v2->val.LRealVal; break; case BoolTag: v1->val.BoolVal = v1->val.BoolVal <= v2->val.BoolVal; break; case CharTag: v1->val.BoolVal = v1->val.CharVal <= v2->val.CharVal; break; case SetTag: v1->val.BoolVal = SetContains(v1, v2); break; } v1->tag = BoolTag; v1->type = BoolType; v1->size = TypeSize(BoolType); free(v2); return v1; } ValueStruct doGreaterEq(v1,v2) ValueStruct v1, v2; { /* * Propagate null value if either is operand is null. */ if ((v1 == null) or (v2 == null)) return null; /* * The possibilities here are int, real, longint, longreal, bool, char, or * set. */ switch (v1->tag) { case IntTag: v1->val.IntVal = v1->val.IntVal >= v2->val.IntVal; break; case LIntTag: v1->val.LIntVal = v1->val.LIntVal >= v2->val.LIntVal; break; case RealTag: v1->val.RealVal = v1->val.RealVal >= v2->val.RealVal; break; case LRealTag: v1->val.LRealVal = v1->val.LRealVal >= v2->val.LRealVal; break; case BoolTag: v1->val.BoolVal = v1->val.BoolVal >= v2->val.BoolVal; break; case CharTag: v1->val.CharVal = v1->val.CharVal >= v2->val.CharVal; break; case SetTag: v1->val.BoolVal = SetContains(v2, v1); break; } v1->tag = BoolTag; v1->type = BoolType; v1->size = TypeSize(BoolType); free(v2); return v1; } /* * Set containment predicate. Implement by comparing bits. Viz., each bit on * in v1 must also be on in v2. v2 may have other bits on. */ bool SetContains(v1, v2) ValueStruct v1, v2; { return (((v1->val.SetVal | v2->val.SetVal) ^ v2->val.SetVal) == 0); } /* * Set membership. Implement by bit comparison. Viz., v1'th bit must be on in * v2. */ ValueStruct doIn(v1,v2) ValueStruct v1, v2; { if (v2->tag == ListTag) { v1->val.BoolVal = (InListWithFunction(v2->val.ListVal, v1, ValueListEquals) > 0); } else if ((v1->tag == StringTag) && (v2->tag == StringTag)) { v1->val.BoolVal = StringContains(v2->val.StringVal, v1->val.StringVal); } else { v1->val.BoolVal = (1 << SetNormalize(v1->val.IntVal, v2->type)) and v2->val.SetVal; } // not a list v1->tag = BoolTag; v1->type = BoolType; v1->size = TypeSize(BoolType); free(v2); return v1; } /* * Length operator. Returns length of data in v1. */ ValueStruct doLen(v1) ValueStruct v1; { int len = 0; ValueStruct v = MakeVal(RVAL, IntType); if (v1->tag == ListTag) { len = ListLen(v1->val.ListVal); } else if (v1->tag == StringTag) { len = StringLen(v1->val.StringVal); } v->val.IntVal = len; return v; } /* * Evaluate an array constructor by alloc'ing a properly sized block of storage * and assigning each elem to the sucessive operand values. */ ValueStruct doListConstructor(t) nodep t; { TypeStruct type /* Type of the array, courtesy of typechker */ = t->header.attachment.n2; ValueStruct rtn, /* Return val temp */ rval; /* Value of each elem expr */ //ListElemData* newData; /* working new data pointer */ nodep e; /* Working expr pointer */ // if we arrive here and type is undefined, return nil now if (!type) { rtn = MakeVal(RVAL, NilType); return rtn; } rtn = MakeVal(RVAL, type); rtn->val.ListVal = NewList(); for (e = t->components.expr.left_operand; e; e = e->components.exprlist.next) { // Evaluate the value expressions along the way and assign to a memory slot rval = interpExpr(e->components.exprlist.expr); PutList(rtn->val.ListVal, (ListElemData*)rval); } // end for return rtn; } /* * Evaluate an tuple constructor */ ValueStruct doTupleConstructor(t) nodep t; { ValueStruct rtn; /* Return val temp */ /** return nil since this isn't working **/ rtn = MakeVal(RVAL, NilType); /** * Approach Idea * - assign to rtn the result of MakeVal(RVAL, type of tuple within t) * - grab from the type structure... * => the # of tuple components * => the starting address of the symtab * - foreach expression in the tuple type structure * => interpExpr the expression * => assign the address of the resulting ValueStruct to symtab[] at the proper index * - return rtn * - success! */ return rtn; } /* * Evaluate an array constructor of integers when a range is provided. * For example, this function turns [ 1 .. 4 ] into a list of * [ 1, 2, 3, 4 ]. */ ValueStruct doDotDot(t) nodep t; { TypeStruct type /* Type of the array, courtesy of typechker */ = t->header.attachment.n2; ValueStruct rtn, /* Return val temp */ lower, /* lower bounds expression */ upper, /* upper bounds expression */ rval; /* Value of each elem expr */ nodep e; /* Working expr pointer */ int i; // if we arrive here and type is undefined, return nil now if (!type) { rtn = MakeVal(RVAL, NilType); return rtn; } // plan of attack: evaluate the lower and upper bounds. Assume will evaluate // properly since typechecker already did some dirty work. lower = interpExpr(t->components.binop.left_operand); upper = interpExpr(t->components.binop.right_operand); rtn = MakeVal(RVAL, type); rtn->val.ListVal = NewList(); for (i = lower->val.IntVal; i <= upper->val.IntVal; i++) { rval = MakeVal(RVAL, IntType); rval->val.IntVal = i; PutList(rtn->val.ListVal, (ListElemData*)rval); } // end for lower .. upper return rtn; } // end function doDotDot /* * Normalize a set member to its bit position within the set. If the set * element is an enum ident, there's nothing to do. If its a subrange value, * then subtract off the lower bound. */ int SetNormalize(v1, t) ValueStruct v1; TypeStruct t; { if (isSubrange(t)) return v1->val.IntVal - t->components.type.kind.subrange.lowerval; else return v1->val.IntVal; } /* * Compute the storage location designated by a designator, returning an * l-value. doDesignator above returns a designator r-value. */ ValueStruct designator(t) nodep t; { ValueStruct v1; /* * Switch on one of the three forms of designator operator (array, record, * or pointer), or the base case of a qualident. */ // pcdebug: parse-tree.h indicates that EXPR_NODE is deprecated. // should this change to UNOP_NODE or BINOP_NODE? if (t->header.kind == BINOP_NODE) { switch (t->header.name) { case '[': v1 = interpExpr(t->components.binop.left_operand); return doArrayRef(v1, t->components.binop.right_operand); case '.': v1 = designator(t->components.expr.left_operand); return RecordRef(v1, t->components.expr.right_operand); case '^': v1 = designator(t->components.expr.left_operand); return PointerRef(v1, t); } } else return QidRef(t); } /* * Returns a ValueStruct that points to the value within list desig at index. */ ValueStruct doArrayRef(desig, index) ValueStruct desig; /* L-value for the left operand. */ nodep index; /* Expr list for the right operand. */ { ValueStruct vIndex, result; // figure out the index vIndex = interpExpr(index); if (desig->tag == ListTag) { result = (ValueStruct)GetListNth(desig->val.ListVal, vIndex->val.IntVal); } else if (desig->tag == StringTag) { result = MakeVal(RVAL, StringType); result->val.StringVal = GetNthStringCharAsString(desig->val.StringVal, vIndex->val.IntVal); } return result; } // end function doArrayRef /* * Nominally returns a list of components from v1, at elements v2 .. v3. * v1 represents the list * v2 represents the lower bounds * v3 represents the upper bounds */ ValueStruct doArraySliceRef(v1, v2, v3) ValueStruct v1; ValueStruct v2; ValueStruct v3; { ValueStruct result; int i; // start building the new list result = MakeVal(RVAL, v1->type); if (v1->tag == ListTag) { result->val.ListVal = NewList(); // loop through from lower .. upper and add the elements to result for (i = v2->val.IntVal; i <= v3->val.IntVal; i++) { PutList(result->val.ListVal, GetListNth(v1->val.ListVal, i)); } } else if (v1->tag == StringTag) { result->val.StringVal = (String *)SubString(v1->val.StringVal, v2->val.IntVal, v3->val.IntVal); } return result; } // end function doArrayRef /* * Bounds check an array index. Fatal error if out of bounds. */ ChkBound(i, lbv, type, t) int i; int lbv; TypeStruct type; nodep t; { if ((i < 0) or (i > type->components.type.kind.arraytype.normalizedubval)) { lerror(t, "Array index value %d out of bounds.\n", i+lbv); longjmp(RuntimeError, ArrayBndStatus); } } /* * Compute the location designated by a record ref. Since the type checker * built record symtabs, field offset computation is just a simple lookup. */ ValueStruct RecordRef(desig, field) ValueStruct desig; /* L-value for the left operand. */ nodep field; /* Ident for the right operand. */ { SymtabEntry *f; TypeStruct type = ResolveIdentType(desig->type, null, false); f = LookupIn(field->components.atom.val.text, type->components.type.kind.record.fieldstab); desig->val.LVal += f->Info.Var.Offset; desig->type = f->Type; desig->tag = f->Type->components.type.tag; desig->size = TypeSize(f->Type); return desig; } /* * Compute the location designated by a pointer ref. We'd like it to be just a * simple deref of the C pointer, viz.: * desig->val.LVal = *((char **) desig->val.LVal) * However, as noted elsewhere in the interp (e.g., doForIncr, IntegerizeL), * alignment problems arise with such casts. Hence we do the bcopy. * * Note the handling of nil pointer value. The error message is issued and a * longjmp performed. The longjmp is used since nil pointer referencing is * quite fatal, and we need to get all the back way out to the top-level of * interp. */ ValueStruct PointerRef(desig, t) ValueStruct desig; nodep t; /* Only used in nil pointer error message. */ { memcpy(&(desig->val.LVal), desig->val.LVal, TypeSize(desig->type)); /*bcopy(desig->val.LVal, &(desig->val.LVal), TypeSize(desig->type));*/ /* * Check for a nil pointer value. It's an error if we're not at the * top-level of the designator. */ if (not desig->val.LVal) { lerror(t, "Attempt to reference through a nil pointer.\n"); longjmp(RuntimeError, NilPointerStatus); } desig->type = desig->type->components.type.kind.pointer.basetype; desig->tag = desig->type->components.type.tag; desig->size = TypeSize(desig->type); return desig; } /* * Eval a qid ref as an l-value. This is where we have to handle the syntactic * nuisance of a record ref that looks like a qid. This is an artifact of the * shift-reduce error on qid. Viz., there's no way to distinguish a qid from a * designator, so the parser picks qid. We could avoid this by having the type * checker convert qid record refs into desig trees, but it's not really that * important. * * What we're dealing with is the leading part of a designator that has '.' * operators, before we get to the '[' and '^' operators, after which we'll see * '.'s in expr nodes above in designator. Hence, we interate through the * field refs rather than recurse. */ ValueStruct QidRef(qid) nodep qid; { nodep id, ft; ValueStruct desig; SymtabEntry *sym; /* * Lookup the first (only) qid component. QuickLookupQid has already moved * us past any leading module name components in the qid, so all we're left * with is a single ident, or a record ref. * * 27oct93 bugfix: QuickLookupQid HAS NOT yet been called. Not quite sure * why I thought it had been. Anyway, it needs to be called here and now. */ sym = QuickLookupQid(qid); /* * Make the initial base lval for a designator. */ desig = MakeVal(LVAL, sym->Type); desig->val.LVal = GetAddr(sym); /* * Cruise through any fields, using RecordRef for each. This does * iteratively what is done recursively when '.'s are parsed as exprs. * Note user of header.attachment.n1 field, set to the first non-module * component of the qid, courtesy (uglyly) of QuickLookupQid. */ for (ft = qid->header.attachment.n1->components.atom.next; ft; ft = ft->components.atom.next) { desig = RecordRef(desig, ft); } return desig; } /* * Lookup a qualident through all leading modules. This is a "quick" version * of sym-aux.c:LookupQid in that this version does not need to do any legality * checks. * * A bit of a hack is used to inform the caller where the end of the leading * module qualifiers is. Viz., the header.attachment.n1 field is used to point * to the first non-module-name component of the qid sent in. */ SymtabEntry *QuickLookupQid(qid) nodep qid; { nodep ql, qr; SymtabEntry *syml, *symr; char *nl, *nr; /* * Lookup first qid component. */ syml = Lookup(nl = qid->components.atom.val.text); /* * Prepare to move into new symtab(s) by saving CurSymtab. */ PushSymtab(); /* * Move through each qid component up to the first non-module component. */ for (ql = qid, qr = qid->components.atom.next; qr; ql = qr, qr = qr->components.atom.next, syml = symr) { /* * Quit on first non-module. */ if (syml->Class != C_Module) break; /* * Move into the scope of the left operand. */ MoveToSymtab(syml->Info.Module.Symtab); /* * Lookup right oprnd. */ symr = Lookup(nr = qr->components.atom.val.text); } /* * Return the Lookup of the last qid component, threading n1 as described * above, and restoring the entering symtab. */ qid->header.attachment.n1 = ql; PopSymtab(); return syml; } /* * Compute the address of the storage bound to a variable or parm. Return a * pointer to the location. Note special handling of var vs val parms. Note * further that from GetAddr's perspective, open array parms are treated just * like var parms. The difference between open-array call-by-var vs open-array * call-by-val was handled back in Bind. */ char *GetAddr(sym) SymtabEntry *sym; { char *addr1, *addr2; if (sym->Class == C_Var) return (Display[sym->Level] + sym->Info.Var.Offset); else { if (ChkSymFlag(sym, varParm) or ChkSymFlag(sym, arrayParm)) { addr1 = Display[sym->Level] + sym->Info.Parm.Offset; memcpy(&addr2, addr1, sizeof(char *)); /*bcopy(addr1, &addr2, sizeof(char *));*/ return addr2; } else return (Display[sym->Level] + sym->Info.Parm.Offset); } } /* * Compute the static address of a global variable, given its offset. * NOTE: this is vestigial from a non-display version of the interp, but left * around for possible future use. */ char *StaticAddr(offset) int offset; { return &(StaticPool[offset]); } /* * Return the address of the stack at a given offset from the current tos. */ char *StackAddr(offset) int offset; { return &(Display[CurSymtab->Level][offset]); } /* * Compute the address of a formal parm during binding. */ char *GetFormalAddr(sym) SymtabEntry *sym; { return &(ftos[sym->Info.Parm.Offset]); } /* * Make a new value struct. Notice the distinction in the size for structured * vs non-structured values. For the former, we set the size only to the size * of the pointer to the value, not to the actual TypeSize of the value itself. * This means that we need to treat structured vals differently in accessing * and assignment. */ ValueStruct MakeVal(LorR, type) ValType LorR; TypeStruct type; { ValueStruct v; v = (ValueStruct) malloc(sizeof(Value)); v->LorR = LorR; v->tag = type->components.type.tag; v->type = type; if ((v->tag == StructTag) || (v->tag == ListTag)) { v->size = sizeof(char *); } else { v->size = TypeSize(type); } return v; } /* * Compute one of the possible tag types from a TypeStruct. Doing this will * save a bit of time during numeric expr eval. NOT CURRENTLY USED. */ ValTag ValueTag(t) TypeStruct t; { if (isIntOrCardOrSubrangeOfEither(t) or isEnum(t) or isSubrangeOfEnum(t)) return IntTag; if (isChar(t) or isSubrangeOfChar(t)) return CharTag; if (isBool(t) or isSubrangeOfBool(t)) return BoolTag; } /* * Push an act rec by incrementing ftos by the given size. */ void PushActRec(size) int size; { ftos -= size; } /* * Get the current ftos. */ char *GetFTos() { return ftos; } /* * Set the current ftos. */ void SetFTos(newtos) char *newtos; { ftos = newtos; } /* * Incr ftos by given size in bytes. */ IncrFTos(size) int size; { ftos -= size; } /* * Decr ftos by given size in bytes. */ DecrFTos(size) int size; { ftos += size; } /* * Set the normal (i.e., not-during-binding) tos pointer. This will be used by * folks who need to use the stack as a utility storage area, such as doLoop * and printf_, q.q.v. SetTos(level) int level; { tos = &Display[level]; } */ /* * Push something onto the stack, NOT during binding. Used by doLoop, e.g. */ void push(data, size) char *data; int size; { ftos -= size; memcpy(ftos, data, size); /*bcopy(data, ftos, size)*/; } /* * Pop something off the stack, NOT during binding. */ char *pop(size) int size; { char *rtnval = ftos; ftos += size; return rtnval; } /* * Return pointer to tos, NOT during binding. Used by doExit, e.g. */ char *top() { return ftos; } /* * Save Display[level] in current act rec at given offset and set * Display[level] = ftos. */ SaveDisplay(level, offset) int level, offset; { memcpy(&(ftos[offset]), (char *) &(Display[level]), sizeof(char *)); /*bcopy((char *) &(Display[level]), &(ftos[offset]), sizeof(char *));*/ Display[level] = ftos; } /* * Restore Display[level] from Display[level][offset]. */ RestoreDisplay(level, offset) { memcpy(&(Display[level]), &(Display[level][offset]), sizeof (char *)); /*bcopy(&(Display[level][offset]), &(Display[level]), sizeof (char *));*/ /* * Familiar alignment problems with this: * Display[level]= (char *) Display[level][offset]; */ } /* * Coerce an allowably numeric value struct into a plain C integer. Caveat * caller: it must be called with an integerizable type: int, card, longint, * char, bool, subrange, enum. These are the "caseable" types. */ int Integerize(v) ValueStruct v; { switch (v->tag) { case IntTag: case LIntTag: case NilTag: return v->val.IntVal; case CharTag: return (int) v->val.CharVal; case BoolTag: return (int) v->val.BoolVal; } } /* * Same as Integerize, but for an l-value. */ int IntegerizeL(v) ValueStruct v; { switch (v->tag) { case IntTag: { int i; memcpy(&i, v->val.LVal, sizeof(int)); /*bcopy(v->val.LVal, &i, sizeof(int));*/ return i; /* * We'd like to use the following here and in the three case's * below, but it causes BUS (alignment error) on the Sparc, at * least: * return (int) (*((int *)v->val.LVal)); * */ } case LIntTag: { long i; memcpy(&i, v->val.LVal, sizeof(int)); /*bcopy(v->val.LVal, &i, sizeof(int))*/; return (int) i; } case CharTag: { int i = 0; memcpy(&i, v->val.LVal, sizeof(char)); /*bcopy(v->val.LVal, &i, sizeof(char))*/; return i; } case BoolTag: { int i = 0; memcpy(&i, v->val.LVal, sizeof(bool)); /*bcopy(v->val.LVal, &i, sizeof(bool))*/; return i; } } } /* * Intialize the interpreter by allocating the static storage pool and runtime * stack. */ void InitInterp(ptree) nodep ptree; /* Parse tree of module we're about to execute. */ { /* * Enter the scope of the module we're now going to execute. */ if (ptree) { char *name; name = ptree->components.module.name->components.atom.val.text; MoveToSymtab(LookupString(name)->Info.Module.Symtab); } else MoveToSymtab(MainSymtab); InitPools(); } InitPools() { EnvirPool = (char *) calloc(ENVIRSIZE, sizeof(char)); StaticPool = (char *) calloc(STATICSIZE, sizeof(char)); Stack = (char *) calloc(STACKSIZE, sizeof(char)); Display = (char **) calloc(DISPLAYSIZE, sizeof(char *)); Display[0] = EnvirPool; Display[1] = StaticPool; ftos = &(Stack[STACKSIZE]); /* * Note that stack will grow *up* to make act rec offset computation easy. * Also, while we could compute display size by high-water mark of nesting * level, life gets difficult if the interp loads a module at runtime with * a greater nest max than before. Hence, we'll pick a safe size for the * display (50) and complain if nesting ever gets below that. */ } /* * Reinit interp after runtime error, in case we're running interactively and * need things cleaned up. */ ReInitInterp() { int i; ftos = &(Stack[STACKSIZE]); for (i = 2; i <= DISPLAYSIZE; i++) Display[i] = null; MoveToSymtab(CurProgSymtab); }