File: ProcType.m3 Last modified on Tue May 23 15:25:57 PDT 1995 by kalsow modified on Thu Dec 5 17:23:39 PST 1991 by muller
MODULE; IMPORT M3, M3ID, CG, Expr, Type, TypeRep, Value, Scope, Target; IMPORT Formal, UserProc, Token, Ident, CallExpr, Word, Error; IMPORT ESet, TipeMap, TipeDesc, ErrType, M3Buf, Variable, OpenArrayType; FROM Scanner IMPORT Match, GetToken, cur; TYPE P = Type.T BRANDED "ProcType.T" OBJECT methods : CallExpr.MethodList; formals : Scope.T; nFormals : INTEGER; result : Type.T; raises : ESet.T; callConv : CG.CallingConvention; OVERRIDES check := Check; check_align:= CheckAlign; isEqual := EqualChk; isSubtype := Subtyper; compile := Compiler; initCost := InitCoster; initValue := TypeRep.InitToZeros; mapper := GenMap; gen_desc := GenDesc; fprint := FPrinter; END; PROCEDURE ProcType Parse (): Type.T = VAR callConv := Target.DefaultCall; BEGIN IF (cur.token = Token.T.tCALLCONV) THEN callConv := Target.FindConvention (M3ID.ToText (cur.id)); GetToken (); (* tCALLCONV *) Match (Token.T.tENDPRAGMA); END; Match (Token.T.tPROCEDURE); RETURN ParseSignature (M3ID.NoID, callConv); END Parse; CONST FormalStart = Token.Set {Token.T.tVALUE, Token.T.tVAR, Token.T.tREADONLY, Token.T.tIDENT, Token.T.tUNUSED}; PROCEDUREParseSignature (name: M3ID.T; cc: CG.CallingConvention): Type.T = TYPE TK = Token.T; VAR p: P; BEGIN p := Create (Scope.PushNew (FALSE, name)); p.callConv := cc; Match (TK.tLPAREN); WHILE (cur.token IN FormalStart) DO ParseFormal (p); IF (cur.token # TK.tSEMI) THEN EXIT END; GetToken (); (* ; *) END; Match (TK.tRPAREN); IF (cur.token = TK.tCOLON) THEN GetToken (); (* : *) p.result := Type.Parse (); END; IF (cur.token = TK.tRAISES) THEN p.raises := ESet.ParseRaises (); END; Scope.PopNew (); RETURN p; END ParseSignature; PROCEDUREParseFormal (p: P; ) = TYPE TK = Token.T; VAR j, n : INTEGER; obj : Value.T; formal : Formal.Info; BEGIN formal.mode := Formal.Mode.mVALUE; formal.type := NIL; formal.dfault := NIL; formal.trace := NIL; formal.unused := (cur.token = TK.tUNUSED); IF (formal.unused) THEN GetToken (); (*UNUSED*) Match (TK.tENDPRAGMA); END; IF (cur.token = TK.tVALUE) THEN formal.mode := Formal.Mode.mVALUE; GetToken (); (* VALUE *) ELSIF (cur.token = TK.tVAR) THEN formal.mode := Formal.Mode.mVAR; GetToken (); (* VAR *) ELSIF (cur.token = TK.tREADONLY) THEN formal.mode := Formal.Mode.mCONST; GetToken (); (* READONLY *) END; n := Ident.ParseList (); IF (cur.token = TK.tCOLON) THEN GetToken (); (* : *) formal.type := Type.Parse (); END; IF (cur.token = TK.tEQUAL) THEN Error.Msg ("default value must begin with \':=\'"); cur.token := TK.tASSIGN; END; IF (cur.token = TK.tASSIGN) THEN GetToken (); (* := *) formal.dfault := Expr.Parse (); END; formal.trace := Variable.ParseTrace (); IF (formal.type = NIL) AND (formal.dfault = NIL) THEN Error.ID (Ident.stack[Ident.top - 1], "formals must have a type or default value"); END; j := Ident.top - n; FOR i := 0 TO n - 1 DO formal.name := Ident.stack [j + i]; formal.offset := p.nFormals; obj := Formal.New (formal); obj.origin := Ident.offset[j + i]; Scope.Insert (obj); INC (p.nFormals); END; DEC (Ident.top, n); END ParseFormal; VAR unnamed: M3ID.T := M3ID.NoID; PROCEDUREMethodSigAsProcSig (sig, objType: Type.T): Type.T = VAR pProc : P; f, v : Value.T; formal : Formal.Info; pMethod := Reduce (sig); BEGIN IF (pMethod = NIL) THEN RETURN ErrType.T END; pProc := Create (Scope.PushNew (FALSE, M3ID.NoID)); pProc.nFormals := pMethod.nFormals + 1; pProc.result := pMethod.result; pProc.raises := pMethod.raises; pProc.callConv := pMethod.callConv; (* insert the "self" formal *) IF (unnamed = M3ID.NoID) THEN unnamed := M3ID.Add ("_self_") END; formal.name := unnamed; formal.offset := 0; formal.mode := Formal.Mode.mVALUE; formal.type := objType; formal.dfault := NIL; formal.trace := NIL; formal.unused := FALSE; Scope.Insert (Formal.New (formal)); (* copy the remaining formals *) v := Scope.ToList (pMethod.formals); WHILE (v # NIL) DO Formal.Split (v, formal); INC (formal.offset); f := Formal.New (formal); f.origin := v.origin; Scope.Insert (f); v := v.next; END; Scope.PopNew (); RETURN pProc; END MethodSigAsProcSig; PROCEDURECreate (s: Scope.T): P = VAR p := NEW (P); BEGIN TypeRep.Init (p, Type.Class.Procedure); p.methods := UserProc.Methods; p.formals := s; p.nFormals := 0; p.result := NIL; p.raises := NIL; p.callConv := Target.DefaultCall; RETURN p; END Create; PROCEDURECheck (p: P) = VAR hash : INTEGER; v : Value.T; formal : Formal.Info; cs := M3.OuterCheckState; BEGIN (* look up each of the named exceptions *) ESet.TypeCheck (p.raises); (* add the exceptions to the hash value *) hash := ESet.Hash (p.raises); (* finish my hash value *) v := Scope.ToList (p.formals); WHILE (v # NIL) DO Formal.Split (v, formal); hash := Word.Plus (Word.Times (hash, 23), M3ID.Hash (formal.name)); hash := Word.Plus (Word.Times (hash, 37), ORD (formal.mode)); v := v.next; END; hash := Word.Plus (hash, p.callConv.m3cg_id); p.info.size := Target.Address.size; p.info.min_size := Target.Address.size; p.info.alignment := Target.Address.align; p.info.mem_type := CG.Type.Addr; p.info.stk_type := CG.Type.Addr; p.info.class := Type.Class.Procedure; p.info.isTraced := FALSE; p.info.isEmpty := FALSE; p.info.isSolid := TRUE; p.info.hash := hash; INC (Type.recursionDepth); (*------------------------------------*) p.checked := TRUE; Scope.TypeCheck (p.formals, cs); IF (p.result # NIL) THEN p.result := Type.Check (p.result); IF OpenArrayType.Is (p.result) THEN Error.Msg ("procedures may not return open arrays"); END; END; DEC (Type.recursionDepth); (*------------------------------------*) END Check; PROCEDURECheckAlign (<*UNUSED*> p: P; offset: INTEGER): BOOLEAN = BEGIN RETURN (offset MOD Target.Address.align = 0); END CheckAlign; PROCEDURECompiler (p: P) = VAR n_formals, n_raises: INTEGER; v: Value.T; result_id: CG.TypeUID; BEGIN IF (p.result = NIL) THEN result_id := 0; ELSE Type.Compile (p.result); result_id := Type.GlobalUID (p.result); IF LargeResult (p.result) THEN result_id := 0 END; END; v := Scope.ToList (p.formals); n_formals := 0; WHILE (v # NIL) DO Formal.EmitDeclaration (v, TRUE, FALSE); INC (n_formals); v := v.next; END; n_raises := ESet.EmitTypes (p.raises); CG.Declare_proctype (Type.GlobalUID (p), n_formals, result_id, n_raises, p.callConv); v := Scope.ToList (p.formals); WHILE (v # NIL) DO Formal.EmitDeclaration (v, FALSE, FALSE); v := v.next; END; ESet.EmitNames (p.raises); END Compiler; PROCEDUREIsCompatible (procSig, objectType, methodSig: Type.T): BOOLEAN = VAR p := Reduce (procSig); q := Reduce (methodSig); BEGIN IF (p = NIL) OR (q = NIL) THEN RETURN FALSE END; IF (p.nFormals # q.nFormals + 1) THEN RETURN FALSE END; IF (p.callConv.m3cg_id # q.callConv.m3cg_id) THEN RETURN FALSE END; IF (p.result = NIL) AND (q.result = NIL) THEN (* ok *) ELSIF NOT Type.IsEqual (p.result, q.result, NIL) THEN RETURN FALSE; END; IF NOT FirstArgOK (p.formals, objectType) THEN RETURN FALSE END; IF NOT FormalsMatch (p.formals, q.formals, FALSE, FALSE, NIL) THEN RETURN FALSE; END; RETURN ESet.IsSubset (p.raises, q.raises); END IsCompatible; PROCEDUREFirstArgOK (s: Scope.T; t: Type.T): BOOLEAN = VAR v := Scope.ToList (s); formal: Formal.Info; BEGIN WHILE (v # NIL) DO Formal.Split (v, formal); IF (formal.offset = 0) THEN RETURN (formal.mode = Formal.Mode.mVALUE) AND Type.IsSubtype (t, formal.type); END; v := v.next; END; RETURN FALSE; END FirstArgOK; PROCEDUREEqualChk (a: P; t: Type.T; x: Type.Assumption): BOOLEAN = VAR b: P := t; BEGIN IF (a.methods # b.methods) THEN RETURN FALSE END; IF (a.nFormals # b.nFormals) THEN RETURN FALSE END; IF (a.callConv.m3cg_id # b.callConv.m3cg_id) THEN RETURN FALSE END; IF (a.result = NIL) AND (b.result = NIL) THEN (* ok *) ELSIF NOT Type.IsEqual (a.result, b.result, x) THEN RETURN FALSE; END; IF NOT FormalsMatch (a.formals, b.formals, TRUE, TRUE, x) THEN RETURN FALSE; END; RETURN ESet.IsEqual (a.raises, b.raises); END EqualChk; PROCEDURESubtyper (a: P; t: Type.T): BOOLEAN = VAR b: P; BEGIN IF (t.info.class # Type.Class.Procedure) THEN RETURN FALSE END; b := t; IF (a.nFormals # b.nFormals) THEN RETURN FALSE END; IF (a.callConv.m3cg_id # b.callConv.m3cg_id) THEN RETURN FALSE END; IF (a.result = NIL) AND (b.result = NIL) THEN (* ok *) ELSIF NOT Type.IsEqual (a.result, b.result, NIL) THEN RETURN FALSE; END; IF NOT FormalsMatch (a.formals, b.formals, FALSE, TRUE, NIL) THEN RETURN FALSE; END; RETURN ESet.IsSubset (a.raises, b.raises); END Subtyper; PROCEDUREFormalsMatch (a, b: Scope.T; strict, useFirst: BOOLEAN; x: Type.Assumption): BOOLEAN = VAR va, vb : Value.T; ia, ib : Formal.Info; e1, e2 : Expr.T; BEGIN va := Scope.ToList (a); vb := Scope.ToList (b); IF (NOT useFirst) THEN IF (va = NIL) THEN RETURN FALSE END; va := va.next; END; WHILE (va # NIL) AND (vb # NIL) DO Formal.Split (va, ia); Formal.Split (vb, ib); IF (ia.mode # ib.mode) THEN RETURN FALSE END; IF NOT Type.IsEqual (ia.type, ib.type, x) THEN RETURN FALSE END; IF (strict) THEN IF (ia.name # ib.name) THEN RETURN FALSE END; e1 := Expr.ConstValue (ia.dfault); e2 := Expr.ConstValue (ib.dfault); IF NOT Expr.IsEqual (e1, e2, x) THEN RETURN FALSE END; END; va := va.next; vb := vb.next; END; RETURN (va = NIL) AND (vb = NIL); END FormalsMatch; PROCEDUREReduce (t: Type.T): P = BEGIN IF (t = NIL) THEN RETURN NIL END; IF (t.info.class = Type.Class.Named) THEN t := Type.Strip (t) END; IF (t.info.class # Type.Class.Procedure) THEN RETURN NIL END; RETURN t; END Reduce; PROCEDUREIs (t: Type.T): BOOLEAN = BEGIN RETURN (Reduce (t) # NIL); END Is; PROCEDUREResult (t: Type.T): Type.T = VAR p := Reduce (t); BEGIN IF (p # NIL) THEN RETURN p.result; ELSE RETURN ErrType.T; END; END Result; PROCEDURECGResult (t: Type.T): CG.Type = VAR p := Reduce (t); BEGIN IF (p = NIL) OR (p.result = NIL) THEN RETURN CG.Type.Void; ELSIF NOT LargeResult (p.result) THEN RETURN Type.CGType (p.result, in_memory := TRUE); (*** 2/27/96 WKK: in_memory = TRUE => so that Win32 code generator can convert register return values to their full 32-bit width! ***) ELSIF p.callConv.standard_structs THEN RETURN CG.Type.Void; ELSE RETURN CG.Type.Struct; END; END CGResult; PROCEDURELargeResult (t: Type.T): BOOLEAN = BEGIN RETURN Type.IsStructured (t); END LargeResult; PROCEDURENFormals (t: Type.T): INTEGER = VAR p := Reduce (t); v: Value.T; n: INTEGER; BEGIN IF (p = NIL) THEN RETURN 0 END; v := Scope.ToList (p.formals); n := 0; WHILE (v # NIL) DO v := v.next; INC (n); END; IF (p.result # NIL) AND LargeResult (p.result) THEN INC (n); (* large results are passed as an extra VAR parameter *) END; RETURN n; END NFormals; PROCEDUREFormals (t: Type.T): Value.T = VAR p := Reduce (t); BEGIN IF (p # NIL) THEN RETURN Scope.ToList (p.formals); ELSE RETURN NIL; END; END Formals; PROCEDURERaises (t: Type.T): M3.ExSet = VAR p := Reduce (t); BEGIN IF (p # NIL) THEN RETURN p.raises; ELSE RETURN NIL; END; END Raises; PROCEDUREMethods (t: Type.T): CallExpr.MethodList = VAR p := Reduce (t); BEGIN IF (p # NIL) THEN RETURN p.methods; ELSE RETURN NIL; END; END Methods; PROCEDURECallConv (t: Type.T): CG.CallingConvention = VAR p := Reduce (t); BEGIN IF (p # NIL) THEN RETURN p.callConv; ELSE RETURN NIL; END; END CallConv; PROCEDURENew (result: Type.T; f0, f1, f2, f3: Value.T := NIL): Type.T = VAR p: P; BEGIN p := Create (Scope.PushNew (FALSE, M3ID.NoID)); IF (f0 # NIL) THEN Scope.Insert (f0); INC (p.nFormals); END; IF (f1 # NIL) THEN Scope.Insert (f1); INC (p.nFormals); END; IF (f2 # NIL) THEN Scope.Insert (f2); INC (p.nFormals); END; IF (f3 # NIL) THEN Scope.Insert (f3); INC (p.nFormals); END; p.result := result; Scope.PopNew (); RETURN p; END New; PROCEDURESetMethods (t: Type.T; m: CallExpr.MethodList) = BEGIN NARROW (t, P).methods := m; END SetMethods; PROCEDUREInitCoster (<*UNUSED*> p: P; zeroed: BOOLEAN): INTEGER = BEGIN IF (zeroed) THEN RETURN 0 ELSE RETURN 1 END; END InitCoster; PROCEDUREGenMap (<*UNUSED*> p: P; offset, size: INTEGER; refs_only: BOOLEAN) = BEGIN <*ASSERT size = Target.Address.size*> IF NOT refs_only THEN TipeMap.Add (offset, TipeMap.Op.Proc, 0); END; END GenMap; PROCEDUREGenDesc (p: P) = BEGIN EVAL TipeDesc.AddO (TipeDesc.Op.Proc, p); END GenDesc; PROCEDUREFPrinter (p: P; VAR x: M3.FPInfo) = VAR v: Value.T; n: INTEGER; BEGIN M3Buf.PutText (x.buf, "PROC("); IF (p.callConv.m3cg_id # 0) THEN M3Buf.PutText (x.buf, "<*CC="); M3Buf.PutInt (x.buf, p.callConv.m3cg_id); M3Buf.PutText (x.buf, "*>"); END; (* count the nodes *) v := Scope.ToList (p.formals); n := 0; WHILE (v # NIL) DO INC (n, Value.AddFPTag (v, x)); v := v.next; END; M3Buf.PutChar (x.buf, ')'); IF (p.result # NIL) THEN M3Buf.PutText (x.buf, " => ?"); INC (n) END; INC (n, ESet.AddFPTag (p.raises, x)); x.n_nodes := n; IF (n <= NUMBER (x.nodes)) THEN v := Scope.ToList (p.formals); n := 0; WHILE (v # NIL) DO n := Value.AddFPEdges (v, x, n); v := v.next; END; IF (p.result # NIL) THEN x.nodes[n] := p.result; INC (n); END; n := ESet.AddFPEdges (p.raises, x, n); ELSE x.others := NEW (REF ARRAY OF Type.T, n); v := Scope.ToList (p.formals); n := 0; WHILE (v # NIL) DO n := Value.AddFPEdges (v, x, n); v := v.next; END; IF (p.result # NIL) THEN x.others[n] := p.result; INC (n); END; n := ESet.AddFPEdges (p.raises, x, n); END; END FPrinter; BEGIN END ProcType.