Copyright (C) 1994, Digital Equipment Corp.File: TypeCaseStmt.m3
MODULE; IMPORT M3ID, CG, Expr, Stmt, StmtRep, Type, Variable, Scope; IMPORT Error, Token, Null, ObjectAdr, RefType, Scanner; IMPORT Host, Reff, Target, M3RT, Tracer; FROM Scanner IMPORT Match, MatchID, GetToken, Fail, cur; TYPE P = Stmt.T OBJECT expr : Expr.T; cases : Case; complete : BOOLEAN; hasElse : BOOLEAN; elseBody : Stmt.T; OVERRIDES check := Check; compile := Compile; outcomes := GetOutcome; END; TYPE Case = REF RECORD origin : INTEGER; next : Case; nTags : INTEGER; tags : TypeList; var : Variable.T; scope : Scope.T; stmt : Stmt.T; END; TYPE TypeList = REF ARRAY OF Type.T; PROCEDURE TypeCaseStmt Parse (): Stmt.T = TYPE TK = Token.T; VAR p: P; bar: BOOLEAN; BEGIN p := NEW (P); StmtRep.Init (p); p.cases := NIL; p.complete := FALSE; p.hasElse := FALSE; p.elseBody := NIL; Match (TK.tTYPECASE); p.expr := Expr.Parse (); Match (TK.tOF); bar := (cur.token = TK.tBAR); IF (bar) THEN GetToken ()(* | *) END; LOOP IF (cur.token = TK.tELSE) THEN EXIT END; IF (cur.token = TK.tEND) THEN EXIT END; bar := FALSE; ParseCase (p); IF (cur.token # TK.tBAR) THEN EXIT END; bar := TRUE; GetToken (); (* | *) END; ReverseCases (p); IF (bar) THEN Fail ("missing case"); END; IF (cur.token = TK.tELSE) THEN GetToken (); (* ELSE *) p.hasElse := TRUE; p.elseBody := Stmt.Parse (); END; Match (TK.tEND); RETURN p; END Parse; PROCEDUREParseCase (p: P) = TYPE TK = Token.T; VAR c: Case; id: M3ID.T; trace: Tracer.T; BEGIN c := NEW (Case); c.origin := Scanner.offset; c.next := p.cases; p.cases := c; c.var := NIL; c.scope := NIL; c.stmt := NIL; c.nTags := 0; c.tags := NEW (TypeList, 2); LOOP IF (c.nTags > LAST (c.tags^)) THEN ExpandTags (c) END; c.tags[c.nTags] := Type.Parse (); INC (c.nTags); IF (cur.token # TK.tCOMMA) THEN EXIT END; GetToken (); (* , *) END; IF (cur.token = TK.tLPAREN) THEN GetToken (); (* ( *) id := MatchID (); trace := Variable.ParseTrace (); c.var := Variable.New (id, FALSE); c.scope := Scope.New1 (c.var); Variable.BindTrace (c.var, trace); Variable.BindType (c.var, c.tags[0], indirect := FALSE, readonly := FALSE, needs_init := FALSE, open_array_ok := FALSE); Match (TK.tRPAREN); Match (TK.tIMPLIES); c.stmt := Stmt.Parse (); Scope.PopNew (); ELSE Match (TK.tIMPLIES); c.stmt := Stmt.Parse (); END; END ParseCase; PROCEDUREExpandTags (c: Case) = VAR new, old: TypeList; BEGIN old := c.tags; new := NEW (TypeList, 2 * NUMBER (old^)); FOR i := 0 TO LAST (old^) DO new[i] := old[i] END; c.tags := new; END ExpandTags; PROCEDUREReverseCases (p: P) = VAR c1, c2, c3: Case; BEGIN c1 := p.cases; c3 := NIL; WHILE (c1 # NIL) DO c2 := c1.next; c1.next := c3; c3 := c1; c1 := c2; END; p.cases := c3; END ReverseCases; PROCEDURECheck (p: P; VAR cs: Stmt.CheckState) = VAR t: Type.T; c: Case; BEGIN Expr.TypeCheck (p.expr, cs); t := Type.Base (Expr.TypeOf (p.expr)); IF (NOT Type.IsSubtype (t, Reff.T)) AND (NOT Type.IsSubtype (t, ObjectAdr.T)) THEN Error.Msg ("typecase selector must be a REF or OBJECT type"); END; (* check each of the cases *) p.complete := p.hasElse; c := p.cases; WHILE (c # NIL) DO IF CheckCase (c, t, cs) THEN p.complete := TRUE END; c := c.next; END; Stmt.TypeCheck (p.elseBody, cs); IF (NOT p.complete) THEN Scanner.offset := p.origin; Error.Warn (1, "TYPECASE statement may not handle all cases"); END; END Check; PROCEDURECheckCase (c: Case; exprType: Type.T; VAR cs: Stmt.CheckState): BOOLEAN = VAR t, u: Type.T; complete: BOOLEAN; zz: Scope.T; BEGIN (* check the labels *) complete := FALSE; u := c.tags[0]; FOR i := 0 TO c.nTags - 1 DO t := Type.Check (c.tags[i]); c.tags[i] := t; IF (c.scope # NIL) AND (NOT Type.IsEqual (t, u, NIL)) THEN Scanner.offset := c.origin; Error.Msg ("type labels are incompatible"); END; IF NOT Type.IsSubtype (t, exprType) THEN (***** AND (NOT Type.IsSubtype (exprType, t)) THEN******) Scanner.offset := c.origin; Error.Msg ("type label incompatible with case expression"); END; complete := complete OR Type.IsSubtype (exprType, t); END; (* check the body *) IF (c.scope # NIL) THEN zz := Scope.Push (c.scope); Scope.TypeCheck (c.scope, cs); Stmt.TypeCheck (c.stmt, cs); Scope.WarnUnused (c.scope); Scope.Pop (zz); ELSE Stmt.TypeCheck (c.stmt, cs); END; RETURN complete; END CheckCase; PROCEDURECompile (p: P): Stmt.Outcomes = VAR c: Case; ref: CG.Var; tc: CG.Val; i: INTEGER; oc: Stmt.Outcomes; foundForSure := FALSE; l_null := CG.Next_label (); l_base := CG.Next_label (CntCases (p.cases)); l_else := CG.Next_label (); l_exit := CG.Next_label (); ref_type := Type.Base (Expr.TypeOf (p.expr)); BEGIN (* capture the ref *) Type.Compile (ref_type); Expr.Prep (p.expr); Expr.Compile (p.expr); ref := CG.Declare_local (M3ID.NoID, Target.Address.size, Target.Address.align, CG.Type.Addr, Type.GlobalUID (ref_type), in_memory := FALSE, up_level := FALSE, f := CG.Never); CG.Store_addr (ref); (* check for NIL *) CG.Load_addr (ref); CG.Load_nil (); CG.If_eq (l_null, CG.Type.Addr, CG.Maybe); (* capture the ref's typecode *) CG.Load_addr (ref); CG.Ref_to_typecode (); tc := CG.Pop (); (* compile the tests *) c := p.cases; i := 0; WHILE (c # NIL) DO foundForSure := CompileCaseTest (p, c, tc, l_base + i); IF foundForSure THEN IF (c.next # NIL) THEN UnreachableCases (c.next) END; c := NIL; ELSE c := c.next; END; INC (i); END; IF NOT foundForSure THEN CG.Jump (l_else) END; CG.Free (tc); (* compile the case bodies *) oc := Stmt.Outcomes {}; CG.Set_label (l_null); c := p.cases; i := 0; WHILE (c # NIL) DO oc := oc + CompileCaseBody (c, ref, l_base + i, l_exit); c := c.next; INC (i); END; (* generate the else clause *) IF foundForSure THEN IF (p.elseBody # NIL) THEN Scanner.offset := p.elseBody.origin; Error.Warn (1, "unreachable ELSE in TYPECASE"); END; ELSE CG.Set_label (l_else); IF (p.hasElse) THEN oc := oc + Stmt.Compile (p.elseBody); ELSIF (NOT p.complete) AND (Host.doTCaseChk) THEN CG.Typecase_fault (); END; END; CG.Set_label (l_exit); RETURN oc; END Compile; PROCEDURECntCases (c: Case): INTEGER = VAR n := 0; BEGIN WHILE (c # NIL) DO INC (n); c := c.next END; RETURN n; END CntCases; PROCEDURECompileCaseTest (p: P; c: Case; tc: CG.Val; label: CG.Label): BOOLEAN = VAR t, u: Type.T; skip: CG.Label; BEGIN CG.Gen_location (c.origin); u := Expr.TypeOf (p.expr); FOR i := 0 TO c.nTags - 1 DO t := c.tags[i]; IF Type.IsEqual (t, Null.T, NIL) THEN (* nothing to do; we have already generated a goto tc0 if the expr is NIL *) ELSIF Type.IsSubtype (u, t) THEN (* the test succedes statically! *) CG.Jump (label); RETURN TRUE; ELSIF RefType.Is (t) THEN CG.Push (tc); Type.LoadInfo (t, M3RT.TC_typecode); CG.If_eq (label, CG.Type.Int, CG.Maybe); ELSE skip := CG.Next_label (); CG.Push (tc); Type.LoadInfo (t, M3RT.TC_typecode); CG.If_lt (skip, CG.Type.Int, CG.Maybe); CG.Push (tc); Type.LoadInfo (t, M3RT.TC_lastSubTypeTC); CG.If_le (label, CG.Type.Int, CG.Maybe); CG.Set_label (skip); END; END; RETURN FALSE; END CompileCaseTest; PROCEDURECompileCaseBody (c: Case; ref: CG.Var; label, exit: CG.Label): Stmt.Outcomes = VAR oc: Stmt.Outcomes; zz: Scope.T; BEGIN CG.Gen_location (c.origin); CG.Set_label (label); IF (c.scope # NIL) THEN zz := Scope.Push (c.scope); Scope.Enter (c.scope); Scope.InitValues (c.scope); Variable.LoadLValue (c.var); CG.Load_addr (ref); CG.Store_indirect (CG.Type.Addr, 0, Target.Address.size); Variable.ScheduleTrace (c.var); oc := Stmt.Compile (c.stmt); IF (Stmt.Outcome.FallThrough IN oc) THEN CG.Jump (exit); END; (* for the debugger's sake, this Jump should be inside the scope *) Scope.Exit (c.scope); Scope.Pop (zz); ELSE oc := Stmt.Compile (c.stmt); IF (Stmt.Outcome.FallThrough IN oc) THEN CG.Jump (exit); END; END; RETURN oc; END CompileCaseBody; PROCEDUREUnreachableCases (c: Case) = VAR save: INTEGER; BEGIN save := Scanner.offset; WHILE (c # NIL) DO Scanner.offset := c.origin; Error.Warn (1, "unreachable case"); c := c.next; END; Scanner.offset := save; END UnreachableCases; PROCEDUREGetOutcome (p: P): Stmt.Outcomes = VAR c: Case; oc := Stmt.Outcomes {}; BEGIN c := p.cases; WHILE (c # NIL) DO oc := oc + Stmt.GetOutcome (c.stmt); c := c.next; END; IF (p.hasElse) THEN oc := oc + Stmt.GetOutcome (p.elseBody) END; RETURN oc; END GetOutcome; BEGIN END TypeCaseStmt.