File: Formal.m3 Last modified on Tue May 23 15:42:16 PDT 1995 by kalsow modified on Fri Nov 9 20:39:07 1990 by muller
MODULE--------------------------------------------------- actual typechecking ---; IMPORT M3, M3ID, CG, Value, ValueRep, Type, Error, Expr, ProcType; IMPORT KeywordExpr, OpenArrayType, RefType, CheckExpr; IMPORT ArrayType, Host, NarrowExpr, M3Buf, Tracer; IMPORT Procedure, UserProc, Target, M3RT; TYPE T = Value.T BRANDED OBJECT offset : INTEGER; tipe : Type.T; dfault : Expr.T; refType : Type.T; cg_type : CG.TypeUID; mode : Mode; kind : Type.Class; trace : Tracer.T; OVERRIDES typeCheck := Check; set_globals := SetGlobals; load := Load; declare := ValueRep.Never; const_init := ValueRep.NoInit; need_init := ValueRep.Never; lang_init := Compile; user_init := ValueRep.NoInit; toExpr := ValueRep.NoExpr; toType := ValueRep.NoType; typeOf := TypeOf; base := ValueRep.Self; add_fp_tag := AddFPTag; fp_type := TypeOf; END; TYPE ArgSlot = RECORD formal : T; actual : Expr.T; name : M3ID.T; matched : BOOLEAN; errored : BOOLEAN; END; PROCEDURE Formal NewBuiltin (name: TEXT; offset: INTEGER; type: Type.T; mode: Mode): Value.T = VAR t := NEW (T); BEGIN ValueRep.Init (t, M3ID.Add (name), Value.Class.Formal); t.readonly := FALSE; t.offset := offset; t.mode := mode; t.tipe := type; t.dfault := NIL; t.unused := FALSE; t.kind := Type.Class.Error; t.refType := NIL; t.cg_type := 0; t.trace := NIL; RETURN t; END NewBuiltin; PROCEDURENew (READONLY info: Info): Value.T = VAR t := NEW (T); BEGIN ValueRep.Init (t, info.name, Value.Class.Formal); t.readonly := (info.mode = Mode.mCONST); t.offset := info.offset; t.mode := info.mode; t.tipe := info.type; t.dfault := info.dfault; t.unused := info.unused; t.kind := Type.Class.Error; t.refType := NIL; t.cg_type := 0; t.trace := info.trace; RETURN t; END New; PROCEDURESplit (formal: Value.T; VAR info: Info) = VAR t: T := formal; BEGIN info.name := t.name; info.offset := t.offset; info.mode := t.mode; info.type := TypeOf (t); info.dfault := t.dfault; info.unused := t.unused; info.trace := t.trace; END Split; PROCEDUREEmitDeclaration (formal: Value.T; types_only, param: BOOLEAN) = VAR t : T := formal; type : Type.T; mtype : CG.Type; size : CG.Size; align : CG.Alignment; info : Type.Info; BEGIN IF (types_only) THEN type := TypeOf (t); Type.Compile (type); t.cg_type := Type.GlobalUID (type); IF (t.mode # Mode.mVALUE) OR (t.refType # NIL) THEN t.cg_type := CG.Declare_indirect (t.cg_type); Type.Compile (t.refType); END; ELSIF (param) THEN type := TypeOf (t); IF (t.mode = Mode.mVALUE) AND (t.refType = NIL) THEN EVAL Type.CheckInfo (type, info); size := info.size; align := info.alignment; mtype := info.mem_type; ELSE size := Target.Address.size; align := Target.Address.align; mtype := CG.Type.Addr; END; EVAL CG.Declare_param (t.name, size, align, mtype, t.cg_type, in_memory := FALSE, up_level := FALSE, f := CG.Maybe); ELSE CG.Declare_formal (t.name, t.cg_type); END; END EmitDeclaration; PROCEDUREHasClosure (formal: Value.T): BOOLEAN = BEGIN TYPECASE formal OF | NULL => RETURN FALSE; | T(t) => RETURN (t.mode # Mode.mVAR) AND ((t.kind = Type.Class.Procedure) OR ProcType.Is (Type.Base (TypeOf (t)))); ELSE RETURN FALSE; END; END HasClosure; PROCEDURERefOpenArray (formal: Value.T; VAR ref: Type.T): BOOLEAN = BEGIN TYPECASE formal OF | NULL => RETURN FALSE; | T(t) => ref := t.refType; RETURN (ref # NIL); ELSE RETURN FALSE; END; END RefOpenArray; PROCEDURETypeOf (t: T): Type.T = BEGIN IF (t.tipe = NIL) THEN t.tipe := Expr.TypeOf (t.dfault) END; RETURN t.tipe; END TypeOf; PROCEDURECheck (t: T; VAR cs: Value.CheckState) = VAR info: Type.Info; BEGIN t.tipe := Type.CheckInfo (TypeOf (t), info); t.kind := info.class; IF (info.class = Type.Class.Packed) THEN EVAL Type.CheckInfo (Type.Base (t.tipe), info); t.kind := info.class; END; IF (t.dfault # NIL) THEN Expr.TypeCheck (t.dfault, cs); IF (t.mode = Mode.mVAR) THEN Error.ID (t.name, "VAR parameters cannot have defaults"); END; IF NOT Type.IsAssignable (t.tipe, Expr.TypeOf (t.dfault)) THEN Error.ID (t.name, "default is not assignable to formal"); END; IF (Expr.ConstValue (t.dfault) = NIL) THEN Error.ID (t.name, "default is not constant"); END; (* NOTE: we don't save the constant-folded version of the default, otherwise we'd loose references to large named constants. *) END; IF (t.mode = Mode.mVALUE) AND OpenArrayType.Is (Type.Base (t.tipe)) THEN t.refType := RefType.New (t.tipe, traced := TRUE, brand := NIL); t.refType := Type.Check (t.refType); END; END Check; PROCEDURELoad (t: T) = BEGIN IF (t.dfault = NIL) THEN Error.ID (t.name, "formal has no default value"); END; Expr.Prep (t.dfault); Expr.Compile (t.dfault); END Load; PROCEDURECompile (t: T) = BEGIN Type.Compile (t.tipe); Type.Compile (t.refType); IF (t.dfault # NIL) THEN Type.Compile (Expr.TypeOf (t.dfault)); END; END Compile; PROCEDURESetGlobals (<*UNUSED*> t: T) = BEGIN (* Type.SetGlobals (t.tipe); *) (* Type.SetGlobals (t.refType); *) (* IF (t.dfault # NIL) THEN Type.SetGlobals (Expr.TypeOf (t.dfault)) END; *) END SetGlobals; PROCEDUREAddFPTag (t: T; VAR x: M3.FPInfo): CARDINAL = CONST Tags = ARRAY Mode OF TEXT { "VALUE ", "VAR ", "READONLY "}; BEGIN ValueRep.FPStart (t, x, Tags[t.mode], 0, global := FALSE); IF (t.dfault # NIL) THEN M3Buf.PutText (x.buf, " := "); Expr.GenFPLiteral (t.dfault, x.buf); END; RETURN 1; END AddFPTag;
PROCEDURE----------------------------------------------------------- caller code ---CheckArgs (VAR cs : Value.CheckState; VAR actuals : Expr.List; formals : Value.T; proc : Expr.T): BOOLEAN = VAR slots: ARRAY [0..19] OF ArgSlot; v: Value.T; n: INTEGER; BEGIN v := formals; n := 0; WHILE (v # NIL) DO INC (n); v := v.next; END; IF (n <= NUMBER (slots)) THEN RETURN DoCheckArgs (cs, actuals, formals, n, slots, proc); ELSE RETURN DoCheckArgs (cs, actuals, formals, n, NEW (REF ARRAY OF ArgSlot, n)^, proc); END; END CheckArgs; PROCEDUREDoCheckArgs (VAR cs : Value.CheckState; VAR actuals : Expr.List; formals : Value.T; nFormals : INTEGER; VAR slots : ARRAY OF ArgSlot; proc : Expr.T): BOOLEAN = VAR j : INTEGER; e, value : Expr.T; index, elt, t, te : Type.T; posOK, ok : BOOLEAN; name : M3ID.T; tt : T; BEGIN ok := TRUE; IF (nFormals < NUMBER (actuals^)) THEN Error.Msg ("too many actual parameters" & ProcName (proc)); ok := FALSE; END; (* initialize the argument list *) tt := formals; WHILE (tt # NIL) DO WITH z = slots[tt.offset] DO z.formal := tt; z.actual := tt.dfault; z.matched := FALSE; z.errored := FALSE; z.name := tt.name; END; tt := tt.next; END; (* bind the parameters *) posOK := TRUE; FOR i := 0 TO MIN (LAST (actuals^) , nFormals -1) DO e := actuals[i]; IF KeywordExpr.Split (e, name, value) THEN posOK := FALSE; e := value; j := 0; LOOP IF (j >= nFormals) THEN Error.ID (name, "unknown parameter"); ok := FALSE; j := i; EXIT; END; IF (slots[j].name = name) THEN EXIT END; INC (j); END; ELSE IF (NOT posOK) THEN Error.Msg ("positional parameters must precede keyword parameters" & ProcName (proc)); ok := FALSE; END; j := i; END; WITH z = slots[j] DO IF (z.matched) THEN Err (z, "parameter already specified"); ok := FALSE; END; z.matched := TRUE; z.actual := e; END; END; (* check for any unspecified parameters *) FOR i := 0 TO nFormals - 1 DO IF (slots[i].actual # NIL) THEN slots[i].matched := TRUE END; IF NOT slots[i].matched THEN Err (slots[i], "parameter not specified"); ok := FALSE; END; END; (* typecheck each binding *) FOR i := 0 TO nFormals - 1 DO e := slots[i].actual; tt := slots[i].formal; IF (e # NIL) AND (tt # NIL) THEN (* we've got both a formal and an actual *) Expr.TypeCheck (e, cs); (* try to fold scalar constant values *) (* NOTE: if we fold named structured constants, we lose the names and hence generate code to build the value... *) IF NOT Type.IsStructured (tt.tipe) THEN value := Expr.ConstValue (e); IF (value # NIL) THEN e := value; slots[i].actual := e END; END; te := Expr.TypeOf (e); t := tt.tipe; CASE tt.mode OF | Mode.mVALUE => IF NOT Type.IsAssignable (t, te) THEN Err (slots[i], "incompatible types"); ok := FALSE; END; | Mode.mVAR => IF NOT Expr.IsDesignator (e) THEN Err (slots[i], "VAR actual must be a designator"); ok := FALSE; ELSIF NOT Expr.IsWritable (e, traced := TRUE) THEN Err (slots[i], "VAR actual must be writable"); ok := FALSE; ELSIF Type.IsEqual (t, te, NIL) THEN Expr.NeedsAddress (e); ELSIF ArrayType.Split (t, index, elt) AND Type.IsAssignable (t, te) THEN Expr.NeedsAddress (e); ELSE Err (slots[i], "incompatible types"); ok := FALSE; END; | Mode.mCONST => IF NOT Type.IsAssignable (t, te) THEN Err (slots[i], "incompatible types"); ok := FALSE; ELSIF NOT Expr.IsDesignator (e) THEN (* we'll make a copy when it's generated *) ELSIF Type.IsEqual (t, te, NIL) THEN Expr.NeedsAddress (e); ELSE (* Type.IsAssignable (t, te) *) (* we'll make a copy when it's generated *) END; END; (*case*) (* check to see if this value needs an implicit NARROW, which may generate a nested procedure call... *) IF (ok) AND Host.doNarrowChk AND ((tt.kind = Type.Class.Ref) OR (tt.kind = Type.Class.Object) OR (tt.kind = Type.Class.Opaque)) THEN IF NOT Type.IsSubtype (te, t) THEN (* This reference value needs an implicit NARROW *) e := NarrowExpr.New (e, t); slots[i].actual := e; Expr.TypeCheck (e, cs); END; END; END; (* if got actual & formal *) END; (* for *) IF (NOT ok) THEN RETURN FALSE END; (* no more possible errors => build the new argument list *) IF (NUMBER (actuals^) # nFormals) THEN actuals := NEW (Expr.List, nFormals) END; FOR i := 0 TO nFormals - 1 DO actuals[i] := slots[i].actual END; RETURN TRUE; END DoCheckArgs; PROCEDUREErr (VAR slot: ArgSlot; msg: TEXT) = BEGIN IF (NOT slot.errored) THEN Error.ID (slot.name, msg); slot.errored := TRUE; END; END Err; PROCEDUREProcName (proc: Expr.T): TEXT = VAR v: Value.T; BEGIN IF (proc # NIL) AND UserProc.IsProcedureLiteral (proc, v) THEN RETURN ": " & Value.GlobalName (v, dots := TRUE, with_module := TRUE); ELSE RETURN ""; END; END ProcName;
PROCEDUREPrepArg (formal: Value.T; actual: Expr.T) = VAR t: T := formal; BEGIN CASE t.mode OF | Mode.mVALUE => Expr.Prep (actual); | Mode.mVAR => Expr.PrepLValue (actual, traced := TRUE); | Mode.mCONST => IF NOT Type.IsEqual (t.tipe, Expr.TypeOf (actual), NIL) THEN Expr.Prep (actual); ELSIF Expr.IsDesignator (actual) THEN Expr.PrepLValue (actual, traced := FALSE); ELSE (* non-designator, same type *) Expr.Prep (actual); END; END; END PrepArg; PROCEDUREEmitArg (proc: Expr.T; formal: Value.T; actual: Expr.T) = VAR t: T := formal; is_struct := FALSE; info: Type.Info; BEGIN CASE t.kind OF | Type.Class.Error, Type.Class.Named, Type.Class.Packed => <*ASSERT FALSE*> | Type.Class.Integer, Type.Class.Enum, Type.Class.Subrange, Type.Class.Longint => GenOrdinal (t, actual); | Type.Class.Real, Type.Class.Longreal, Type.Class.Extended => GenFloat (t, actual); | Type.Class.Ref, Type.Class.Object, Type.Class.Opaque => GenReference (t, actual); | Type.Class.Procedure => GenProcedure (t, actual, proc); | Type.Class.Record => GenRecord (t, actual); is_struct := TRUE; | Type.Class.Set => GenSet (t, actual); is_struct := Type.IsStructured (t.tipe); | Type.Class.Array => GenArray (t, actual); is_struct := TRUE; | Type.Class.OpenArray => GenArray (t, actual); is_struct := FALSE; END; IF (t.mode # Mode.mVALUE) THEN CG.Pop_param (CG.Type.Addr) ELSIF (is_struct) THEN EVAL Type.CheckInfo (t.tipe, info); CG.Pop_struct (info.size, info.alignment); ELSE (* by-value scalar *) CG.Pop_param (Type.CGType (t.tipe, in_memory := TRUE)); END; IF (t.mode = Mode.mVAR) THEN Expr.NoteWrite (actual); END; END EmitArg; PROCEDUREGenOrdinal (t: T; actual: Expr.T) = VAR min, max: Target.Int; (** constant := Expr.ConstValue (actual); **) BEGIN (*** -- we can't fold constant actuals since they may have been precompiled and have allocated temporaries that still need to be freed .... IF (constant # NIL) THEN actual := constant END; ***) EVAL Type.GetBounds (t.tipe, min, max); CASE t.mode OF | Mode.mVALUE => CheckExpr.EmitChecks (actual, min, max, CG.RuntimeError.ValueOutOfRange); | Mode.mVAR => Expr.CompileAddress (actual, traced := TRUE); | Mode.mCONST => IF NOT Type.IsEqual (t.tipe, Expr.TypeOf (actual), NIL) THEN CheckExpr.EmitChecks (actual, min, max, CG.RuntimeError.ValueOutOfRange); GenCopy (t.tipe); ELSIF Expr.IsDesignator (actual) THEN Expr.CompileAddress (actual, traced := FALSE); ELSE (* non-designator, same type *) Expr.Compile (actual); GenCopy (t.tipe); END; END; END GenOrdinal; PROCEDUREGenFloat (t: T; actual: Expr.T) = BEGIN CASE t.mode OF | Mode.mVALUE => Expr.Compile (actual); | Mode.mVAR => Expr.CompileAddress (actual, traced := TRUE); | Mode.mCONST => IF Expr.IsDesignator (actual) THEN Expr.CompileAddress (actual, traced := FALSE); ELSE Expr.Compile (actual); GenCopy (t.tipe); END; END; END GenFloat; PROCEDUREGenReference (t: T; actual: Expr.T) = VAR t_actual := Expr.TypeOf (actual); BEGIN CASE t.mode OF | Mode.mVALUE => Expr.Compile (actual); | Mode.mVAR => Expr.CompileAddress (actual, traced := TRUE); | Mode.mCONST => IF NOT Type.IsEqual (t.tipe, t_actual, NIL) THEN Expr.Compile (actual); GenCopy (t.tipe); ELSIF Expr.IsDesignator (actual) THEN Expr.CompileAddress (actual, traced := FALSE); ELSE Expr.Compile (actual); GenCopy (t.tipe); END; END; END GenReference; PROCEDUREGenProcedure (t: T; actual: Expr.T; proc: Expr.T) = BEGIN CASE t.mode OF | Mode.mVALUE => Expr.Compile (actual); GenClosure (actual, proc); | Mode.mVAR => Expr.CompileAddress (actual, traced := TRUE); | Mode.mCONST => IF Expr.IsDesignator (actual) THEN Expr.CompileAddress (actual, traced := FALSE); ELSE Expr.Compile (actual); GenClosure (actual, proc); GenCopy (t.tipe); END; END; END GenProcedure; PROCEDUREGenClosure (actual: Expr.T; proc: Expr.T) = VAR tmp: CG.Var; proc_v: Value.T; n_elts: INTEGER; ASIZE := Target.Address.size; BEGIN IF RequiresClosure (actual, proc_v) THEN (* actual is a nested procedure literal passed by value *) IF IsExternalProcedure (proc) THEN Error.Warn (1, "passing nested procedure to external procedure"); END; (* allocate space for the closure *) n_elts := (M3RT.CL_SIZE + ASIZE - 1) DIV ASIZE; tmp := CG.Declare_temp (M3RT.CL_SIZE, Target.Address.align, CG.Type.Struct, in_memory := TRUE); (* and fill it in *) CG.Store_addr (tmp, M3RT.CL_proc); CG.Load_intt (M3RT.CL_marker_value); CG.Store_int (Target.Integer.cg_type, tmp, M3RT.CL_marker); Procedure.LoadStaticLink (proc_v); CG.Store_addr (tmp, M3RT.CL_frame); CG.Load_addr_of_temp (tmp, 0, Target.Address.align); END; END GenClosure; PROCEDURERequiresClosure (e: Expr.T; VAR proc: Value.T): BOOLEAN = BEGIN RETURN UserProc.IsProcedureLiteral (e, proc) AND Procedure.IsNested (proc); END RequiresClosure; PROCEDUREIsExternalProcedure (e: Expr.T): BOOLEAN = VAR proc: Value.T; BEGIN RETURN UserProc.IsProcedureLiteral (e, proc) AND Value.IsExternal (proc); END IsExternalProcedure; PROCEDUREGenRecord (t: T; actual: Expr.T) = BEGIN (* <* ASSERT Type.IsEqual (t.tipe, Expr.TypeOf (actual), NIL) *> *) CASE t.mode OF | Mode.mVALUE => Expr.Compile (actual); | Mode.mVAR => Expr.CompileAddress (actual, traced := TRUE); | Mode.mCONST => IF Expr.IsDesignator (actual) THEN Expr.CompileAddress (actual, traced := FALSE); ELSE Expr.Compile (actual); (* not needed because of the ASSERT above: GenCopy (t.tipe); *) END; END; END GenRecord; PROCEDUREGenSet (t: T; actual: Expr.T) = BEGIN <* ASSERT Type.IsEqual (t.tipe, Expr.TypeOf (actual), NIL) *> CASE t.mode OF | Mode.mVALUE => Expr.Compile (actual); | Mode.mVAR => Expr.CompileAddress (actual, traced := TRUE); | Mode.mCONST => IF Expr.IsDesignator (actual) THEN Expr.CompileAddress (actual, traced := FALSE); ELSIF Type.IsStructured (t.tipe) THEN Expr.Compile (actual); (* not needed because of the ASSERT above: GenCopy (t.tipe); *) ELSE (* small, non-designator set *) Expr.Compile (actual); GenCopy (t.tipe); END; END; END GenSet; PROCEDUREGenArray (t: T; actual: Expr.T) = VAR t_actual := Expr.TypeOf (actual); BEGIN CASE t.mode OF | Mode.mVALUE => Expr.Compile (actual); ReshapeArray (t.tipe, t_actual); | Mode.mVAR => Expr.CompileAddress (actual, traced := TRUE); ReshapeArray (t.tipe, t_actual); | Mode.mCONST => IF NOT Type.IsEqual (t.tipe, t_actual, NIL) THEN Expr.Compile (actual); ReshapeArray (t.tipe, t_actual); ELSIF Expr.IsDesignator (actual) THEN Expr.CompileAddress (actual, traced := FALSE); ELSE Expr.Compile (actual); END; END; END GenArray; PROCEDUREReshapeArray (tlhs, trhs: Type.T) = VAR d_lhs, d_rhs: INTEGER; index, elt: Type.T; tmp: CG.Var; rhs: CG.Val; b: BOOLEAN; BEGIN IF Type.IsEqual (tlhs, trhs, NIL) THEN RETURN END; d_lhs := OpenArrayType.OpenDepth (tlhs); d_rhs := OpenArrayType.OpenDepth (trhs); IF (d_lhs = d_rhs) THEN RETURN END; (* capture the actual *) rhs := CG.Pop (); IF (d_lhs > d_rhs) THEN (* build a bigger dope vector *) tmp := OpenArrayType.DeclareTemp (tlhs); (* copy the data pointer *) CG.Push (rhs); IF (d_rhs > 0) THEN CG.Open_elt_ptr (Target.Byte) END; CG.Store_addr (tmp, M3RT.OA_elt_ptr); (* fill in the sizes *) FOR i := 0 TO d_lhs-1 DO b := ArrayType.Split (trhs, index, elt); <*ASSERT b*> IF (index = NIL) THEN CG.Push (rhs); CG.Open_size (i); ELSE CG.Load_integer (Target.Integer.cg_type, Type.Number (index)); END; CG.Store_int (Target.Integer.cg_type, tmp, M3RT.OA_sizes + i * Target.Integer.pack); trhs := elt; END; (* leave the result *) CG.Load_addr_of_temp (tmp, 0, Target.Address.align); ELSE <*ASSERT d_lhs < d_rhs *> (* check some array bounds; don't build a smaller dope vector just reuse the existing one! *) tlhs := OpenArrayType.OpenType (tlhs); FOR i := d_lhs TO d_rhs - 1 DO b := ArrayType.Split (tlhs, index, elt); <*ASSERT b*> <*ASSERT index # NIL*> CG.Push (rhs); CG.Open_size (i); CG.Load_integer (Target.Integer.cg_type, Type.Number (index)); CG.Check_eq (Target.Integer.cg_type, CG.RuntimeError.IncompatibleArrayShape); END; (* leave the old dope vector as the result *) CG.Push (rhs); IF (d_lhs <= 0) THEN CG.Open_elt_ptr (Target.Byte); END; CG.Force (); END; CG.Free (rhs); END ReshapeArray; PROCEDUREGenCopy (type: Type.T) = VAR info: Type.Info; tmp: CG.Var; id: CG.TypeUID; BEGIN EVAL Type.CheckInfo (type, info); id := Type.GlobalUID (type); IF Type.IsStructured (type) THEN tmp := CG.Declare_local (M3ID.NoID, info.size, info.alignment, CG.Type.Struct, id, in_memory := TRUE, up_level := FALSE, f := CG.Never); CG.Load_addr_of (tmp, 0, info.alignment); CG.Swap (); CG.Copy (info.size, overlap := FALSE); ELSE tmp := CG.Declare_local (M3ID.NoID, info.size, info.alignment, info.mem_type, id, in_memory := TRUE, up_level := FALSE, f := CG.Never); CG.Store (tmp, 0, info.size, info.alignment, info.stk_type); END; CG.Load_addr_of (tmp, 0, info.alignment); END GenCopy; BEGIN END Formal.