(* Copyright (C) 1992, Digital Equipment Corporation *) (* All rights reserved. *) (* See the file COPYRIGHT for a full description. *) (* *) (* Last modified on Mon Feb 24 16:46:56 PST 1997 by heydon *) (* modified on Sat Oct 17 18:03:41 PDT 1992 by gnelson *) (* modified on Fri Aug 7 21:54:07 PDT 1992 by myers *) MODULE JunoAssemble; IMPORT BuiltInSlots, JunoAST, JunoCompileRep, JunoScope, JunoASTUtils AS Utils; IMPORT JunoByteCode AS BC, JunoRT, JunoRTError, JunoValue, WriteVal; IMPORT IntSeq; TYPE IntList = REF RECORD val: INTEGER; next: IntList END; LabelData = RECORD loc: INTEGER; (* location (index) of label in "code" *) refs: IntList; (* list of references (jumps) to this label *) END; VAR mu := NEW(MUTEX); loc: CARDINAL; (* current code location *) code := NEW(JunoRT.ByteStream, 1000); (* result bytestream buffer *) labelSeq := NEW(IntSeq.T).init(sizeHint := 100); TYPE Z3 = ARRAY [0..3] OF INTEGER; CONST NoLabel = 0; (* the number of an invalid label *) PROCEDURE Cmd( res: JunoCompileRep.Result; scp: JunoScope.T; temp_cnt: CARDINAL; type: CmdType): JunoRT.ByteStream = PROCEDURE Pred( pred: JunoAST.Formula; t, f: CARDINAL; tBranch: BOOLEAN) = (* Generate code for "pred" at the current location in the code stream. Generate a branch to label "t" if "pred" evaluates true, and to label "f" if "pred" evaluates false. Only generate a branch to "t" at the *end* of the stream if "tBranch" is "TRUE". The code generated to evaluate a predicate must restore the stack to its original state before branching to "t" or "f". NOTE: We do not need to handle the "JunoAST" cases "False", "And", "Or", "Not", "Exists", or "Differs", since those are eliminated by the compilation procedure "JunoCompile.Cmd.C2q". *) PROCEDURE UnaryPred(p: JunoAST.BIUPred; bc: JunoRT.ByteCode) = BEGIN Expr(p.e, f); PushByte(bc); FBranch(f); IF tBranch THEN Branch(t) END END UnaryPred; PROCEDURE Relation(p: JunoAST.Relation; bc: JunoRT.ByteCode) = BEGIN Expr(p.e1, f); IF Utils.AlwaysDefined(p.e2) THEN Expr(p.e2, f); PushByte(bc); FBranch(f); IF tBranch THEN Branch(t) END ELSE VAR popFirst := NewLabel(); BEGIN Expr(p.e2, popFirst); PushByte(bc); FBranch(f); Branch(t); SetLabelLoc(popFirst); PushByte(BC.DECSP); PushByte(1); Branch(f) END END END Relation; (* Pred *) BEGIN pred.start := loc; TYPECASE pred OF <* NOWARN *> JunoAST.True => IF tBranch THEN Branch(t) END | JunoAST.GroupedExpr (p) => Pred(p.expr, t, f, tBranch) | JunoAST.IsReal (p) => UnaryPred(p, BC.IS_REAL) | JunoAST.IsText (p) => UnaryPred(p, BC.IS_TEXT) | JunoAST.IsPair (p) => UnaryPred(p, BC.IS_PAIR) | JunoAST.IsInt (p) => UnaryPred(p, BC.IS_INT) | JunoAST.Equals (p) => Relation(p, BC.EQUAL) | JunoAST.Less (p) => Relation(p, BC.LESS) | JunoAST.AtMost (p) => Relation(p, BC.AT_MOST) | JunoAST.Cong (p) => Relation(p, BC.CONG) | JunoAST.Para (p) => Relation(p, BC.PARA) | JunoAST.Hor (p) => Relation(p, BC.HOR) | JunoAST.Ver (p) => Relation(p, BC.VER) | JunoAST.Greater (p) => Relation(NEW(JunoAST.Relation, e1 := p.e2, e2 := p.e1), BC.LESS) | JunoAST.AtLeast (p) => Relation(NEW(JunoAST.Relation, e1 := p.e2, e2 := p.e1), BC.AT_MOST) | JunoAST.Call (c) => (* Push IN's *) ExprList(c.ins, f); (* Generate CALL instruction *) PushByte(BC.CALL); PushULong(c.name.index); (* Skip past IN's *) Repeat(BC.DECSP, c.ins.size); (* Branch appropriately *) FBranch(f); IF tBranch THEN Branch(t) END END; pred.end := loc END Pred; PROCEDURE OutInout(outCnt: CARDINAL; inouts: JunoAST.ExprList) = BEGIN Repeat(BC.INCSP, outCnt); (* Leave space for OUT's *) QIdList(inouts); (* Push INOUT's *) END OutInout; PROCEDURE AfterCall(inCnt: CARDINAL; inouts: JunoAST.ExprList; uJump: BOOLEAN; label: INTEGER := NoLabel) = (* Lay down the instructions after a "JunoAST.Call" node has been assembled. Namely, write instructions to skip the SP down past the "inCnt" IN parameters and to pop the INOUT parameters into "inouts". Then, if "uJump" is TRUE, write a "UJUMP" instruction to the offset "label". On return from a user-defined function, functional procedure, or functional external procedure, the internal condition bit is set as the function was defined or not. The UBRANCH instruction tests if the condition bit was set. If it was, the instruction is a no-op; otherwise, it decrements SP past the single OUT parameter, sets the internal "undefined term" address, and branches to its argument "label". *) BEGIN Repeat(BC.DECSP, inCnt); PopQIds(inouts.head, scp); IF uJump THEN PushByte(BC.UJUMP); AddReference(label) END END AfterCall; PROCEDURE AfterProcCall(inCnt: CARDINAL; inouts, outs: JunoAST.ExprList) = BEGIN Repeat(BC.DECSP, inCnt); PopQIds(inouts.head, scp); PopQIds(outs.head, scp) END AfterProcCall; PROCEDURE Apply(outCnt, inoutCnt: CARDINAL; ins: JunoAST.ExprList; u: CARDINAL) = (* Assuming space has already been left for the OUT parameters and the INOUT parameters have been pushed on the stack, write code to assemble an "APPLY" expression with "outCnt" OUT parameters, "inoutCnt" INOUT parameters, and with IN parameters in "ins". The generated code branches to "u" in the event that the APPLY bytecode instruction is undefined or if any of the expressions in "ins" is undefined. *) BEGIN ins.start := loc; (* Push APPLY arguments except the first *) ExprListTail(ins.head.next, u, level := outCnt + inoutCnt); (* Push 1st APPLY (closure) argument *) VAR expr := ins.head.expr; BEGIN IF Utils.AlwaysDefined(expr) THEN Expr(expr, u := NoLabel) ELSE VAR def, pop := NewLabel(); BEGIN Expr(expr, pop); Branch(def); SetLabelLoc(pop); Repeat(BC.DECSP, outCnt + inoutCnt + ins.size - 1); Branch(u); SetLabelLoc(def) END END END; ins.end := loc; (* Generate APPLY instruction *) PushByte(BC.APPLY); PushUShort(outCnt); PushUShort(inoutCnt); PushUShort(ins.size - 1); AddReference(u); (* On return from "APPLY", adjust the stack pointer to account for the IN parameters in the run-time closure. *) PushByte(BC.CLDECSP) END Apply; PROCEDURE Expr(expr: JunoAST.Expr; u: CARDINAL) = (* Generate code at the current location in the code stream to place the value of "expr" on the top of the stack. Generate a branch to label "u" if any portion of the evaluation is undefined; in that case, the code must restore the stack to its original state before executing the instruction to branch to "u". *) PROCEDURE UnaryFunc(f: JunoAST.BIUFunc; bc: JunoRT.ByteCode) = BEGIN Expr(f.e, u); PushByte(bc); IF u # NoLabel THEN AddReference(u) ELSE (* this case can arise because the negation of a literal number is always defined *) StuffShort(loc, u); INC(loc, 2); END END UnaryFunc; PROCEDURE BinaryFunc( f: JunoAST.BIBFunc; bc: JunoRT.ByteCode; uArg := TRUE) = BEGIN Expr(f.e1, u); IF Utils.AlwaysDefined(f.e2) THEN Expr(f.e2, u := NoLabel); PushByte(bc); IF uArg THEN AddReference(u) END ELSE VAR popFirst, defined := NewLabel(); BEGIN Expr(f.e2, popFirst); Branch(defined); SetLabelLoc(popFirst); PushByte(BC.DECSP); PushByte(1); Branch(u); SetLabelLoc(defined); PushByte(bc); IF uArg THEN AddReference(u) END; END END END BinaryFunc; (* Expr *) BEGIN expr.start := loc; TYPECASE expr OF <* NOWARN *> | JunoAST.Number (e) => PushByte(BC.PUSHNUM); PushReal(e.val) | JunoAST.Nil => PushByte(BC.PUSHNIL) | JunoAST.Text (e) => PushByte(BC.PUSHG); PushULong(e.index) | JunoAST.QId (e) => <* ASSERT e.index # 0 *> CASE e.type OF <* NOWARN *> | JunoAST.IdType.Local => PushByte(BC.PUSHL); PushShort(e.index) | JunoAST.IdType.Const, JunoAST.IdType.Var => PushByte(BC.PUSHG); PushULong(e.index) | JunoAST.IdType.Proc => PushByte(BC.NEWCL); PushULong(e.index) | JunoAST.IdType.ExtProc => PushByte(BC.NEWEXTCL); PushULong(e.index) END | JunoAST.GroupedExpr (e) => Expr(e.expr, u) | JunoAST.UMinus (e) => UnaryFunc(e, BC.NEGATE) | JunoAST.Floor (e) => UnaryFunc(e, BC.FLOOR_) | JunoAST.Ceiling (e) => UnaryFunc(e, BC.CEILING_) | JunoAST.Round (e) => UnaryFunc(e, BC.ROUND_) | JunoAST.Abs (e) => UnaryFunc(e, BC.ABS_) | JunoAST.Sin (e) => UnaryFunc(e, BC.SIN) | JunoAST.Cos (e) => UnaryFunc(e, BC.COS) | JunoAST.Exp (e) => UnaryFunc(e, BC.EXP) | JunoAST.Ln (e) => UnaryFunc(e, BC.LN) | JunoAST.Car (e) => UnaryFunc(e, BC.CAR) | JunoAST.Cdr (e) => UnaryFunc(e, BC.CDR) | JunoAST.Plus (e) => BinaryFunc(e, BC.ADD) | JunoAST.Minus (e) => BinaryFunc(e, BC.SUBTRACT) | JunoAST.Concat (e) => BinaryFunc(e, BC.CONCAT) | JunoAST.Times (e) => BinaryFunc(e, BC.MULTIPLY) | JunoAST.Divide (e) => BinaryFunc(e, BC.DIVIDE) | JunoAST.Div (e) => BinaryFunc(e, BC.DIV_) | JunoAST.Mod (e) => BinaryFunc(e, BC.MOD_) | JunoAST.Rel (e) => BinaryFunc(e, BC.REL) | JunoAST.Max (e) => BinaryFunc(e, BC.MAX_) | JunoAST.Min (e) => BinaryFunc(e, BC.MIN_) | JunoAST.Atan (e) => BinaryFunc(e, BC.ATAN) | JunoAST.Pair (e) => BinaryFunc(e, BC.CONS, uArg := FALSE) | JunoAST.List (e) => ExprList(e.elts, u); PushByte(BC.LIST); PushUShort(e.elts.size) | JunoAST.Call (c) => IF BuiltInSlots.IsCloseProc(c.name) THEN (* CLOSE(...) *) ExprList(c.ins, u); PushByte(BC.CLOSE); PushUShort(c.ins.size - 1); AddReference(u); ELSIF BuiltInSlots.IsApplyProc(c.name) THEN (* APPLY(...) *) OutInout(1, c.inouts); Apply(1, c.inouts.size, c.ins, u); (* After the call to APPLY, the condition bit is irrelevant, since calls to user-defined procedures never fail, and since the "APPLY" bytecode automatically signals a run-time error in the event that a call to an external procedure fails. *) AfterCall(c.ins.size - 1, c.inouts, uJump := FALSE) ELSE (* User-defined function, functional procedure, or functional external procedure *) OutInout(1, c.inouts); ExprList(c.ins, u, level := 1 + c.inouts.size); (* Generate CALL instruction *) VAR uJump: BOOLEAN; BEGIN CASE c.name.type OF <* NOWARN *> | JunoAST.IdType.Func => PushByte(BC.CALL); uJump := TRUE | JunoAST.IdType.Proc => PushByte(BC.CALL); uJump := FALSE | JunoAST.IdType.ExtProc => PushByte(BC.CALLEXT); uJump := FALSE END; PushULong(c.name.index); AfterCall(c.ins.size, c.inouts, uJump := uJump, label := u) END END END; expr.end := loc END Expr; PROCEDURE QIdList(l: JunoAST.ExprList) = (* Generates code to push the qualified identifiers in "l" onto the stack. Since the evaluation of a QId is never undefined, we need not generate code to restore the stack in the event of an undefined term. It is an unchecked runtime error for "l" to contain an expression "e" such that "NOT Utils.AlwaysDefined(e)". *) VAR curr := l.head; BEGIN l.start := loc; WHILE curr # NIL DO Expr(curr.expr, u := NoLabel); curr := curr.next END; l.end := loc END QIdList; PROCEDURE ExprList(l: JunoAST.ExprList; u: CARDINAL; level: CARDINAL := 0) = (* Generate code to push the expressions in the list "l" onto the stack, branching to label "u" if any of them are undefined. In this case, the stack is restored to its original state (before the first expression of "l" was evaluated) and an additional "level" elements are then popped off the stack before branching to "u". *) BEGIN l.start := loc; ExprListTail(l.head, u, level); l.end := loc END ExprList; PROCEDURE ExprListTail( l: JunoAST.ExprLink; u: CARDINAL; level: CARDINAL) = (* Generate code to push the expressions in the list "l" onto the stack, branching to label "u" if any are undefined. However, in this case, the stack is restored to its original state, and an additional "level" elements are popped from the stack before branching to "u". We use the global "labelsSeq" as a stack of labels. We push a new label value for each expression so we know afterward how much to decrement the stack pointer for each expression. This procedure preserves the size of "labelsSeq"; we could add code to assert that here, but instead, we simply assert at the end of "JunoAssemble.Cmd" the the size of the sequence is 0. *) VAR newLabels := FALSE; pop: INTEGER; stackSz := 0; BEGIN (* Push expressions *) WHILE l # NIL DO IF Utils.AlwaysDefined(l.expr) THEN pop := NoLabel ELSIF level + stackSz = 0 THEN pop := u ELSE pop := NewLabel(); newLabels := TRUE END; labelSeq.addhi(pop); INC(stackSz); Expr(l.expr, pop); l := l.next END; (* Generate code to pop (if necessary) *) IF newLabels THEN (* write branches for each new label *) VAR end := NewLabel(); BEGIN Branch(end); WHILE stackSz > 0 DO pop := labelSeq.remhi(); DEC(stackSz); IF pop # NoLabel AND pop # u THEN SetLabelLoc(pop); Repeat(BC.DECSP, level + stackSz); Branch(u) END END; SetLabelLoc(end) END ELSE (* pop "stackSz" elements from "labelSeq" stack *) WHILE stackSz > 0 DO pop := labelSeq.remhi(); DEC(stackSz) END END END ExprListTail; PROCEDURE Cmd0( cmd: JunoAST.Cmd; h, g, u: CARDINAL; hBranch: BOOLEAN) = (* Generate code for "cmd" at the current location in the code stream. Generate a branch to label "h" on successful termination, to label "g" on a guard failure, and to label "u" on an "undefined term" run-time error. Only generate a branch to "h" at the end of the stream if "hBranch" is "TRUE". *) BEGIN cmd.start := loc; TYPECASE cmd OF <* NOWARN *> JunoAST.Skip => IF hBranch THEN Branch(h) END | JunoAST.Abort => PushByte(BC.ERROR); PushByte(ORD(JunoRTError.Code.Abort)); IF hBranch THEN Branch(h) END | JunoAST.Halt => PushByte(BC.ERROR); PushByte(ORD(JunoRTError.Code.Halt)); IF hBranch THEN Branch(h) END | JunoAST.Fail => Branch(g) | JunoAST.Assign (c) => ExprList(c.exprs, u); PopQIds(c.vars.head, scp); IF hBranch THEN Branch(h) END | JunoAST.If (c) => VAR l := NewLabel(); BEGIN Cmd0(c.body, h, l, u, hBranch := TRUE); SetLabelLoc(l); PushByte(BC.ERROR); PushByte(ORD(JunoRTError.Code.IfFailure)) END | JunoAST.Do (c) => VAR l := NewLabel(); BEGIN SetLabelLoc(l); Cmd0(c.body, l, h, u, hBranch := TRUE) END | JunoAST.Seq (c) => Cmd0Seq(c, h, g, u, hBranch) | JunoAST.Else (c) => VAR l := NewLabel(); BEGIN Cmd0(c.c1, h, l, u, hBranch := TRUE); SetLabelLoc(l); Cmd0(c.c2, h, g, u, hBranch) END | JunoAST.GroupedCmd (c) => Cmd0(c.body, h, g, u, hBranch) | JunoAST.Flip (c) => Cmd0(c.body, g, h, u, hBranch := TRUE) | JunoAST.Safe (c) => Cmd0(c.body, h, g, g, hBranch) | JunoAST.ProcCall (c) => IF BuiltInSlots.IsApplyProc(c.name) THEN (* APPLY(...) *) OutInout(c.outs.size, c.inouts); Apply(c.outs.size, c.inouts.size, c.ins, u); AfterProcCall(c.ins.size - 1, c.inouts, c.outs) ELSE (* procedure or external procedure command *) OutInout(c.outs.size, c.inouts); ExprList(c.ins, u, level := c.outs.size + c.inouts.size); (* Generate CALL instruction *) CASE c.name.type OF <* NOWARN *> | JunoAST.IdType.Proc => PushByte(BC.CALL) | JunoAST.IdType.ExtProc => PushByte(BC.CALLEXT) END; PushULong(c.name.index); AfterProcCall(c.ins.size, c.inouts, c.outs) END; IF hBranch THEN Branch(h) END | JunoAST.Query (q) => <* ASSERT q.vars.size = 0 *> (* Query of form: P?() *) Pred(q.f, h, g, tBranch := hBranch) | JunoAST.ConjQuery (q) => (* Query of form: P?(v1,...,vn) (represented by arrays) *) IF NUMBER(q.conj^) > 0 THEN (* skip "(TRUE)?(v1,...,vn)" *) PushConjVars(q.var^); PushConstraints(q.var^, q.conj^); VAR l := NewLabel(); BEGIN TBranch(l); (* Skip over OUT vars if solve failed *) Repeat(BC.DECSP, NUMBER(q.var^)); Branch(g); SetLabelLoc(l); (* Update INOUT's in "q.vars" *) PopConjVars(q.var^) END END; IF hBranch THEN Branch(h) END END; (* TYPECASE *) cmd.end := loc END Cmd0; PROCEDURE Cmd0Seq( seq: JunoAST.Seq; h, g, u: CARDINAL; hBranch: BOOLEAN) = (* Equivalent to: | | VAR l := NewLabel(); BEGIN | Cmd0(c.c1, l, g, u, hBranch := FALSE); | SetLabelLoc(l) | END; | Cmd0(c.c2, h, g, u, hBranch) | except that fewer frames are used on the stack if "seq" is a long list of semi-colon-separated commands. *) VAR curr := seq; BEGIN (* Loop down list to generate code *) LOOP VAR l := NewLabel(); BEGIN Cmd0(curr.c1, l, g, u, hBranch := FALSE); SetLabelLoc(l); END; TYPECASE curr.c2 OF JunoAST.Seq (next) => next.start := loc; curr := next ELSE EXIT END END; Cmd0(curr.c2, h, g, u, hBranch); (* Now, loop a second time to set "end" locations *) curr := seq; LOOP TYPECASE curr.c2 OF JunoAST.Seq (next) => next.end := loc; curr := next ELSE EXIT END END END Cmd0Seq; (* Cmd *) BEGIN LOCK mu DO loc := 0; InitLabelTable(); Repeat(BC.PUSHM3NIL, temp_cnt); VAR h := NewLabel(); err := NewLabel(); BEGIN CASE type OF CmdType.Pred, CmdType.Func => (* When the bodies of predicates and functions are compiled as commands, they become queries that either halt or fail. The procedure for a predicate must set the condition bit as the command halted or failed, to indicate if the predicate was true or not. The procedure for a function must also set the condition bit as the command halted or failed, to indicate if the function was defined or not. *) Cmd0(res.cmd, h, err, NoLabel, hBranch := FALSE); SetLabelLoc(h); PushByte(BC.C_ON); PushByte(BC.RET); SetLabelLoc(err); PushByte(BC.C_OFF); PushByte(BC.RET); | CmdType.Proc => (* User-defined procedures are total: they never fail. Hence, we don't need to set the condition bit at the end of the procedure. *) Cmd0(res.cmd, h, NoLabel, err, hBranch := FALSE); SetLabelLoc(h); PushByte(BC.RET); SetLabelLoc(err); PushByte(BC.ERROR); PushByte(ORD(JunoRTError.Code.UndefTerm)) END END; res.cmd.end := loc; BackPatchReferences(); <* ASSERT labelSeq.size() = 0 *> RETURN CodeCopy(); END END Cmd; PROCEDURE PushConjVars(READONLY v: JunoAST.Vars) = (* Push the "frozen" variables in "v" to the stack; push "unfrozen" variables in "v" as "NIL". To decrease the size of the output code, do run-length encoding on the "PUSHM3NIL"'s. *) VAR i := FIRST(v); nilCnt := 0; BEGIN WHILE i <= LAST(v) DO IF v[i].frozen THEN IF nilCnt > 0 THEN Repeat(BC.PUSHM3NIL, nilCnt); nilCnt := 0 END; PushByte(BC.PUSHL); PushShort(v[i].index) ELSE INC(nilCnt) END; INC(i) END; IF nilCnt > 0 THEN Repeat(BC.PUSHM3NIL, nilCnt) END END PushConjVars; PROCEDURE PopConjVars(READONLY v: JunoAST.Vars) = (* Pop the non-temporary variables in "vars" in reverse order; discard temporary variables. To decrease the size of the output code, do run-length encoding on the "DECSP"'s. *) VAR i := LAST(v); tempCnt := 0; BEGIN WHILE i >= FIRST(v) DO IF v[i].evar THEN INC(tempCnt) ELSE IF tempCnt > 0 THEN Repeat(BC.DECSP, tempCnt); tempCnt := 0 END; <* ASSERT v[i].index # 0 *> PushByte(BC.POPL); PushShort(v[i].index) END; DEC(i) END; IF tempCnt > 0 THEN Repeat(BC.DECSP, tempCnt) END END PopConjVars; PROCEDURE PushConstraints( READONLY v: JunoAST.Vars; READONLY c: JunoAST.Formulas) = VAR index := NUMBER(v); argNum := NEW(REF ARRAY OF Z3, NUMBER(c)); BEGIN FOR i := FIRST(argNum^) TO LAST(argNum^) DO ProcessLeaf1(c[i], argNum[i], v, index) END; PushByte(BC.SOLVE); PushUShort(NUMBER(v)); (* # of variables (INOUTS) *) PushUShort(index - NUMBER(v)); (* # of constants (INS) *) PushUShort(NUMBER(c)); (* # of constraints *) FOR i := FIRST(argNum^) TO LAST(argNum^) DO ProcessLeaf2(c[i], argNum[i]) END END PushConstraints; PROCEDURE ProcessLeaf1( f: JunoAST.Formula; VAR (* OUT *) z3: Z3; READONLY inouts: JunoAST.Vars; VAR (* INOUT *) index: CARDINAL) = (* Set "z3" to the canonicalized form of "f". Increment "index" by the number of knowns in "f", where an "id" is known if it does not appear in "inouts". For each such known, generate code to push its value. *) VAR j: CARDINAL := 0; PROCEDURE Atom(e: JunoAST.AtomicExpr) = BEGIN TYPECASE e OF <* NOWARN *> JunoAST.LitValue (lit) => z3[j] := index; INC(index); TYPECASE lit OF <* NOWARN *> JunoAST.Text (t) => PushByte(BC.PUSHG); PushULong(t.index) | JunoAST.Number (n) => PushByte(BC.PUSHNUM); PushReal(n.val) | JunoAST.Nil => PushByte(BC.PUSHNIL) END | JunoAST.QId (qid) => CASE qid.type OF <* NOWARN *> JunoAST.IdType.Local => VAR k := Utils.MemVars(qid, inouts); BEGIN IF k # -1 THEN (* INOUT *) z3[j] := k ELSE (* IN Local var *) z3[j] := index; INC(index); PushByte(BC.PUSHL); PushShort(qid.index) END END | JunoAST.IdType.Var, JunoAST.IdType.Const => z3[j] := index; INC(index); PushByte(BC.PUSHG); PushULong(qid.index) END END; INC(j) END Atom; BEGIN TYPECASE f OF <* NOWARN *> JunoAST.Equals (eq) => Atom(eq.e1); TYPECASE eq.e2 OF <* NOWARN *> JunoAST.AtomicExpr => Atom(eq.e2) | JunoAST.BIUFunc (e) => Atom(e.e) | JunoAST.BIBFunc (e) => Atom(e.e1); Atom(e.e2) END | JunoAST.BIUPred (e) => Atom(e.e) END END ProcessLeaf1; PROCEDURE ProcessLeaf2(f: JunoAST.Formula; READONLY z3: Z3) = BEGIN TYPECASE f OF <* NOWARN *> JunoAST.Equals (eq) => TYPECASE eq.e2 OF <* NOWARN *> | JunoAST.Pair => PushByte(BC.CONS_C); PushUShort(z3[0]); PushUShort(z3[1]); PushUShort(z3[2]); | JunoAST.Plus => PushByte(BC.SUM_C); PushUShort(z3[0]); PushUShort(z3[1]); PushUShort(z3[2]); | JunoAST.Times => PushByte(BC.PROD_C); PushUShort(z3[0]); PushUShort(z3[1]); PushUShort(z3[2]); | JunoAST.Atan => PushByte(BC.ATAN_C); PushUShort(z3[0]); PushUShort(z3[1]); PushUShort(z3[2]); | JunoAST.AtomicExpr => PushByte(BC.EQUAL_C); PushUShort(z3[0]); PushUShort(z3[1]); | JunoAST.Sin => PushByte(BC.SIN_C); PushUShort(z3[0]); PushUShort(z3[1]); | JunoAST.Cos => PushByte(BC.COS_C); PushUShort(z3[0]); PushUShort(z3[1]); | JunoAST.Exp => PushByte(BC.EXP_C); PushUShort(z3[0]); PushUShort(z3[1]); END | JunoAST.IsReal => PushByte(BC.REAL_C); PushUShort(z3[0]); | JunoAST.IsText => PushByte(BC.TEXT_C); PushUShort(z3[0]); END END ProcessLeaf2; PROCEDURE PopIds(id: JunoAST.IdLink) = (* Generate code to pop the locals indexed in "ids" in reverse order. *) BEGIN IF id # NIL THEN PopIds(id.next); <* ASSERT id.index # 0 *> PushByte(BC.POPL); PushShort(id.index) END END PopIds; PROCEDURE PopQIds(v: JunoAST.ExprLink; scp: JunoScope.T) = (* The list "v" is a list of QId's. Generate code to pop the values on the stack into the locations designated by these QId's in reverse order. It is a checked run-time error for the type of any QId in "v" not to be a local or global variable. *) BEGIN IF v # NIL THEN PopQIds(v.next, scp); VAR qid: JunoAST.QId := v.expr; BEGIN <* ASSERT qid.index # 0 *> CASE qid.type OF <* NOWARN *> | JunoAST.IdType.Local => PushByte(BC.POPL); PushShort(qid.index) | JunoAST.IdType.Var => PushByte(BC.POPG); PushULong(qid.index) END END END END PopQIds; PROCEDURE Branch(lbl: CARDINAL) = BEGIN PushByte(BC.JUMP); AddReference(lbl); END Branch; PROCEDURE TBranch(lbl: CARDINAL) = BEGIN PushByte(BC.TJUMP); AddReference(lbl); END TBranch; PROCEDURE FBranch(lbl: CARDINAL) = BEGIN PushByte(BC.FJUMP); AddReference(lbl); END FBranch; PROCEDURE PushByte(byte: JunoRT.ByteCode) = BEGIN IF loc > LAST(code^) THEN VAR new := NEW(JunoRT.ByteStream, 2 * NUMBER(code^)); BEGIN SUBARRAY(new^, 0, NUMBER(code^)) := code^; code := new END END; code[loc] := byte; INC(loc) END PushByte; <* INLINE *> PROCEDURE PushUShort(i: CARDINAL) = BEGIN WriteVal.UShort(code, loc, i) END PushUShort; <* INLINE *> PROCEDURE PushShort(i: INTEGER) = BEGIN WriteVal.Short(code, loc, i) END PushShort; <* INLINE *> PROCEDURE PushULong(i: CARDINAL) = BEGIN WriteVal.ULong(code, loc, i) END PushULong; <* INLINE *> PROCEDURE PushReal(r: JunoValue.Real) = BEGIN WriteVal.Real(code, loc, r) END PushReal; PROCEDURE Repeat(instruction: JunoRT.ByteCode; cnt: CARDINAL) = BEGIN WHILE cnt > 0 DO PushByte(instruction); WITH num = MIN(cnt, 255) DO PushByte(num); DEC(cnt, num) END END END Repeat; <* INLINE *> PROCEDURE StuffShort(at: CARDINAL; val: INTEGER) = (* Stuffs the 2-byte value "val" at locations "code[at..at+1]". *) BEGIN WriteVal.Short(code, at, val) END StuffShort; (* Label Procedures ------------------------------------------------------- *) CONST FirstLabel = 1; (* the number of the first valid label *) VAR last_label: INTEGER; (* the most-recently granted valid label *) labels := NEW(REF ARRAY OF LabelData, 500); <* INLINE *> PROCEDURE InitLabelTable() = (* Clears the label table and resets the last label number. *) BEGIN last_label := FirstLabel - 1 END InitLabelTable; PROCEDURE NewLabel(): CARDINAL = (* Returns a new, unused label. A new label has a "loc" of -1 and an empty references list. All valid label numbers are strictly positive. *) BEGIN INC(last_label); IF last_label >= NUMBER(labels^) THEN VAR newLabels := NEW(REF ARRAY OF LabelData, 2 * NUMBER(labels^)); BEGIN SUBARRAY(newLabels^, 0, NUMBER(labels^)) := labels^; labels := newLabels END END; labels[last_label].loc := -1; labels[last_label].refs := NIL; RETURN last_label END NewLabel; <* INLINE *> PROCEDURE SetLabelLoc(lbl: CARDINAL) = (* Assert that label "lbl" should be associated with index "loc" in the output "code". It is either a checked or an unchecked run-time error to set the label location of a label that was not obtained by a call to NewLabel(). *) BEGIN <* ASSERT lbl >= FirstLabel *> labels[lbl].loc := loc; END SetLabelLoc; <* INLINE *> PROCEDURE AddReference(lbl: CARDINAL) = (* Assert that the bytes at locations "code[loc..loc+1]" should eventually be back-patched to be relative offsets to label "lbl", and increment "loc" past these bytes. *) BEGIN <* ASSERT lbl >= FirstLabel *> WITH data = labels[lbl] DO data.refs := NEW(IntList, val := loc, next := data.refs) END; INC(loc, 2); END AddReference; PROCEDURE BackPatchReferences() = (* Backpatch the 2-bytes in "code" whose indices are stored in the lists "labels[FirstLabel..last_label].refs" to contain relative offsets to the corresponding label locations "labels[FirstLabel..last_label].loc". *) BEGIN FOR lbl := FirstLabel TO last_label DO VAR p := labels[lbl].refs; BEGIN WHILE p # NIL DO StuffShort(p.val, labels[lbl].loc - (p.val + 2)); p := p.next END END END END BackPatchReferences; PROCEDURE CodeCopy(): JunoRT.ByteStream = (* Return a copy of "code[0..loc-1]". *) VAR res := NEW(JunoRT.ByteStream, loc); BEGIN res^ := SUBARRAY(code^, 0, loc); RETURN res END CodeCopy; BEGIN END JunoAssemble.