MODULE; IMPORT JunoAST, JunoASTUtils, StackTbl, JunoUnparse, JunoCompileErr; IMPORT JunoRT; IMPORT Atom, AtomRefTbl; IMPORT Wr, Fmt, Stdio; FROM Thread IMPORT Alerted; <* FATAL Wr.Failure, Alerted *> REVEAL T = AtomRefTbl.Default BRANDED "JunoScope.T" OBJECT parent: T := NIL; END; REVEAL Entity = BRANDED "Entity" OBJECT END; Temp = LocalValue BRANDED "Temp" OBJECT END; Arg = LocalParam BRANDED "Arg" OBJECT END; Const = Value BRANDED "Const" OBJECT END; Var = Value BRANDED "Var" OBJECT END; Pred = PredCode BRANDED "Pred" OBJECT END; Func = PredCode BRANDED "Func" OBJECT END; Proc = ProcCode BRANDED "Proc" OBJECT END; Mod = Unit BRANDED "ModEntity" OBJECT END; PROCEDURE JunoScope New (p: T; size: CARDINAL := 1): T = BEGIN RETURN NEW(T, parent := p).init(size) END New; PROCEDUREParent (scp: T): T = BEGIN RETURN scp.parent END Parent; PROCEDURESetParent (scp, parent: T) = BEGIN scp.parent := parent END SetParent; PROCEDURELookup (scp: T; id: Atom.T; localOnly := FALSE): Entity = VAR ref: REFANY; BEGIN WHILE scp # NIL DO IF scp.get(id, ref) THEN RETURN NARROW(ref, Entity) ELSIF localOnly THEN EXIT ELSE scp := scp.parent END END; RETURN NIL; END Lookup; PROCEDURELookupQId ( scp: T; qid: JunoAST.QId; VAR (*OUT*) unit: Entity): Entity = BEGIN IF qid.id0 = JunoAST.NilId THEN unit := NIL; RETURN Lookup(scp, qid.id1) ELSE unit := Lookup(scp, qid.id0); TYPECASE unit OF NULL => RETURN NIL | Mod(m) => RETURN Lookup(m.public_scp, qid.id1) ELSE RETURN NIL END END END LookupQId; PROCEDURENames (scp: T): REF ARRAY OF Atom.T = VAR it := scp.iterate(); key: Atom.T; dummy: REFANY; res := NEW(REF ARRAY OF Atom.T, scp.size()); i := 0; BEGIN WHILE it.next(key, dummy) DO res[i] := key; INC(i) END; RETURN res END Names; PROCEDURELocalArgs (scp: T; kinds: SET OF ArgKind): JunoAST.IdList = VAR it := scp.iterate(); key: Atom.T; value: REFANY; res := NEW(JunoAST.IdList); BEGIN WHILE it.next(key, value) DO TYPECASE value OF Arg (arg) => IF arg.kind IN kinds THEN VAR link := NEW(JunoAST.IdLink, id := key, index := arg.offset, next := res.head); BEGIN res.head := link; INC(res.size) END END ELSE (* SKIP *) END; END; RETURN res END LocalArgs; PROCEDUREBind (scp: T; id: Atom.T; e: Entity) RAISES {NameClash} = VAR dummy: REFANY; BEGIN IF NOT scp.get(id, dummy) THEN EVAL scp.put(id, e) ELSE RAISE NameClash END END Bind; PROCEDURERebind (scp: T; id: Atom.T; e: Entity) = BEGIN EVAL scp.put(id, e) END Rebind; PROCEDUREUnbind (scp: T; id: Atom.T): Entity RAISES { NotFound } = VAR res: REFANY; BEGIN IF NOT scp.delete(id, res) THEN RAISE NotFound END; RETURN NARROW(res, Entity) END Unbind; CONST Tab = 2; PROCEDUREIndent (wr: Wr.T; indent: CARDINAL) = BEGIN WHILE indent > 0 DO Wr.PutChar(wr, ' '); DEC(indent) END END Indent; PROCEDUREDebug (scp: T; level: CARDINAL := 0) = BEGIN Print(Stdio.stderr, scp, level, 2) END Debug; PROCEDUREPrintEntity (wr: Wr.T; ent: Entity; level, indent: CARDINAL) = PROCEDURE PrintInt(wr: Wr.T; field: TEXT; val: INTEGER; in: CARDINAL) = BEGIN Indent(wr, in); Wr.PutText(wr, field & " = " & Fmt.Int(val) & "\n"); END PrintInt; PROCEDURE PrintArgKind(wr: Wr.T; field: TEXT; val: ArgKind; in: CARDINAL) = BEGIN Indent(wr, in); Wr.PutText(wr, field & " = "); CASE val OF | ArgKind.Out => Wr.PutText(wr, "OUT\n") | ArgKind.InOut => Wr.PutText(wr, "INOUT\n") | ArgKind.In => Wr.PutText(wr, "IN\n") END END PrintArgKind; PROCEDURE PrintExpr(wr: Wr.T; field: TEXT; e: JunoAST.Expr; in: CARDINAL) = BEGIN Indent(wr, in); Wr.PutText(wr, field & " = "); JunoUnparse.Expr(wr, e, LAST(INTEGER), indent := 0); Wr.PutChar(wr, '\n'); END PrintExpr; PROCEDURE PrintScope(wr: Wr.T; field: TEXT; val: T; in: CARDINAL) = BEGIN Indent(wr, in); Wr.PutText(wr, field); IF level > 0 THEN Wr.PutText(wr, " =\n"); Print(wr, val, level - 1, in + Tab) ELSE Wr.PutText(wr, " (elided)\n") END END PrintScope; (* PrintEntity *) BEGIN TYPECASE ent OF <* NOWARN *> | Temp (e) => Wr.PutText(wr, "Temp\n"); PrintInt(wr, "Offset", e.offset, indent) | Arg (e) => Wr.PutText(wr, "Arg\n"); PrintInt(wr, "Offset", e.offset, indent); PrintArgKind(wr, "Kind", e.kind, indent) | Const (e) => Wr.PutText(wr, "CONST\n"); PrintInt(wr, "Index", e.index, indent); PrintExpr(wr, "Init", e.init, indent) | Var (e) => Wr.PutText(wr, "VAR\n"); PrintInt(wr, "Index", e.index, indent); IF e.init # JunoAST.NilExpr THEN PrintExpr(wr, "Init", e.init, indent) END | Pred (e) => Wr.PutText(wr, "PREDICATE\n"); PrintInt(wr, "Index", e.index, indent); PrintInt(wr, "In-Cnt", e.in_cnt, indent); PrintScope(wr, "Argument Scope", e.formals, indent); | Func (e) => Wr.PutText(wr, "FUNCTION\n"); PrintInt(wr, "Index", e.index, indent); PrintInt(wr, "In-Cnt", e.in_cnt, indent); PrintScope(wr, "Argument Scope", e.formals, indent); | Proc (e) => Wr.PutText(wr, "PROCEDURE\n"); PrintInt(wr, "Index", e.index, indent); PrintInt(wr, "In-Cnt", e.in_cnt, indent); PrintInt(wr, "InOut-Cnt", e.inout_cnt, indent); PrintInt(wr, "Out-Cnt", e.out_cnt, indent); PrintScope(wr, "Argument Scope", e.formals, indent); | Mod (e) => Wr.PutText(wr, "MODULE\n"); PrintScope(wr, "Public Scope", e.public_scp, indent); PrintScope(wr, "Private Scope", e.scp, indent); END END PrintEntity; PROCEDURENewPred (pred: JunoAST.PredDecl; mod: JunoAST.Id): Pred RAISES {JunoCompileErr.Error} = VAR tbl := NEW(StackTbl.T).init(); header := pred.header; slot := JunoRT.GetCodeIndex(JunoRT.ProcAttr{ mod, header.name, JunoRT.Sig{0, 0, header.ins.size}}); BEGIN RETURN NEW(Pred, index := slot, body := pred.body, tbl := tbl, formals := ArgScope(tbl, header, header.ins, NIL, NIL), in_cnt := header.ins.size, normal_form := NIL) END NewPred; PROCEDURENewFunc (func: JunoAST.FuncDecl; mod: JunoAST.Id): Func RAISES {JunoCompileErr.Error} = VAR tbl := NEW(StackTbl.T).init(); header := func.header; slot := JunoRT.GetCodeIndex(JunoRT.ProcAttr{ mod, header.name, JunoRT.Sig{1, 0, header.ins.size}}); outs := JunoASTUtils.NewIdList(header.result, index := -(header.ins.size + 1)); BEGIN RETURN NEW(Func, index := slot, body := func.body, tbl := tbl, formals := ArgScope(tbl, header, header.ins, NIL, outs), in_cnt := header.ins.size, normal_form := NIL) END NewFunc; PROCEDURENewProc (proc: JunoAST.ProcDecl; mod: JunoAST.Id): Proc RAISES {JunoCompileErr.Error} = VAR tbl := NEW(StackTbl.T).init(); header := proc.header; slot := JunoRT.GetCodeIndex(JunoRT.ProcAttr{mod, header.name, JunoRT.Sig{header.outs.size, header.inouts.size, header.ins.size}}); BEGIN RETURN NEW(Proc, index := slot, body := proc.body, formals := ArgScope(tbl, header, header.ins, header.inouts, header.outs), in_cnt := header.ins.size, inout_cnt := header.inouts.size, out_cnt := header.outs.size, tbl := tbl) END NewProc; PROCEDUREArgScope ( tbl: StackTbl.T; header: JunoAST.Header; ins, inouts, outs: JunoAST.IdList): T RAISES {JunoCompileErr.Error} =
Return a newJunoScope.T
containing oneJunoScope.Arg
for each formal in the listsins
,inouts
, andouts
. This procedure has the side-effect of assigning each formal an index according totbl.next_formal
; it also adds the formals totbl
. The indices are assigned first toins
, then toinouts
, and finally toouts
, but within each group, indices are assigned in reverse order. Therefore, iftbl
is a newly initialized table, the indices start at -1 and decrease from right to left in the order in which the arguments appear in the declaration. For example, in the declaration:
PROCEDURE a,b := (c,d):P(e,f)the arguments are assigned indices as follows: f => -1, e => -2, d => -3, c => -4, b => -5, and a => -6.Raises
JunoCompileErr.Error
with argument ASTheader
in the event that the same name is used for more than one formal in the header.
VAR res := New(NIL); PROCEDURE AddArgs(ids: JunoAST.IdLink; kind: ArgKind) RAISES {NameClash} = (* IMPLEMENTATION: Use recursion to add arguments in reverse order. *) BEGIN IF ids # NIL THEN AddArgs(ids.next, kind); Bind(res, ids.id, NEW(Arg, kind := kind, offset := tbl.next_formal)); ids.index := tbl.next_formal; StackTbl.PushFormal(tbl, ids.id) END END AddArgs; BEGIN TRY AddArgs(ins.head, ArgKind.In); IF inouts # NIL THEN AddArgs(inouts.head, ArgKind.InOut) END; IF outs # NIL THEN AddArgs(outs.head, ArgKind.Out) END EXCEPT NameClash => JunoCompileErr.Raise( "This declaration contains duplicate formal names", header) END; RETURN res END ArgScope; BEGIN END JunoScope.