(* Copyright (C) 1989, Digital Equipment Corporation *) (* All rights reserved. *) (* See the file COPYRIGHT for a full description. *) (* File: Procedure.m3 *) (* Last Modified On Tue May 15 05:40:48 1990 by muller *) (* Modified On Wed Feb 14 09:26:45 1990 by kalsow *) MODULE Procedure; IMPORT Value, ValueRep, String, Type, Scope, Error, ReturnStmt, Host; IMPORT ProcType, Emit, Expr, Formal, Stmt, BlockStmt, Marker, Coverage; IMPORT CallExpr, Token, Text, Void, Wr, Variable, Temp, Delay, Module; IMPORT Scanner, Decl; FROM Scanner IMPORT GetToken, Fail, Match, MatchID, cur; REVEAL T = Value.T BRANDED OBJECT next : T; level : INTEGER := 0; (* used only by IsNested *) peer : T; signature : Type.T; syms : Scope.T; body : Stmt.T; hasBody : BOOLEAN; inline : BOOLEAN; defined : BOOLEAN; builtin : BOOLEAN; active : BOOLEAN; (* => body currently being expanded *) result : Variable.T; METHODS bind := Bind; typeCheck := Check; class := MyClass; fingerprint := FPrinter; load := Load; write := WriteName; select := Select; declare0 := Declarer; declare1 := Compile; needsDecl := ValueRep.Always; toExpr := ValueRep.NoExpr; toType := ValueRep.NoType; END; VAR resultName : String.T := NIL; raisesLabel : String.T := NIL; all : T := NIL; level := 0; PROCEDURE ParseDecl (READONLY fail : Token.Set; att : Decl.Attributes; headerOnly : BOOLEAN := FALSE) = TYPE TK = Token.T; VAR t: T; id: String.T; BEGIN Match (TK.tPROCEDURE, fail, Token.Set {TK.tIDENT, TK.tSEMI}); id := MatchID (fail, Token.Set {TK.tLPAREN, TK.tSEMI}); t := Create (id); t.inline := att.isInline; t.unused := att.isUnused; t.obsolete := att.isObsolete; IF (att.isExternal) THEN IF (att.alias = NIL) THEN att.alias := t.name END; t.external := TRUE; t.extName := att.alias; END; t.signature := ProcType.ParseSignature (fail + Token.Set{TK.tSEMI}, id); Scope.Insert (t); IF (cur.token = TK.tEQUAL) THEN GetToken (); (* = *) IF (headerOnly) THEN Error.Str (id, "procedure declaration cannot include a body"); END; IF (att.isExternal) THEN Error.WarnStr (2, id, "external procedure cannot include a body"); t.external := FALSE; t.extName := NIL; END; t.hasBody := TRUE; t.syms := Scope.PushNew (TRUE, id, TRUE); INC (level); t.body := BlockStmt.ParseBlock (fail + Token.Set {TK.tSEMI}); DEC (level); id := MatchID (fail, Token.Set {TK.tSEMI}); IF (id # t.name) THEN Error.Str (id, "Initial name doesn\'t match final name"); END; Scope.PopNew (); ELSIF (headerOnly) OR (att.isExternal) THEN (* ok *) ELSIF (cur.token = TK.tSEMI) THEN (* try accepting the Modula-2 syntax *) Error.Str (id, "expecting \'=\' before procedure body"); GetToken (); (* ; *) t.hasBody := TRUE; t.syms := Scope.PushNew (TRUE, id); INC (level); t.body := BlockStmt.ParseBlock (fail + Token.Set {TK.tSEMI}); DEC (level); id := MatchID (fail, Token.Set {TK.tSEMI}); IF (id # t.name) THEN Error.Str (id, "Initial name doesn\'t match final name"); END; Scope.PopNew (); ELSE Error.Str (id, "procedure declaration must include a body"); END; Match (TK.tSEMI, fail, Token.Set {}); END ParseDecl; PROCEDURE IsNested (t: T): BOOLEAN = BEGIN RETURN (t # NIL) AND (t.level # 0); END IsNested; PROCEDURE Create (name: String.T): T = VAR t: T; BEGIN t := NEW (T); ValueRep.Init (t, name); t.readonly := TRUE; t.next := all; all := t; t.peer := NIL; t.signature := NIL; t.syms := NIL; t.hasBody := FALSE; t.body := NIL; t.inline := FALSE; t.external := FALSE; t.defined := FALSE; t.builtin := FALSE; t.active := FALSE; t.result := NIL; t.extName := NIL; t.level := level; RETURN t; END Create; PROCEDURE Define (name : Text.T; methods : CallExpr.MethodList; signature : Type.T := NIL) = VAR t: T; s: String.T; formals: ARRAY [0..0] OF Value.T; sig: Type.T; BEGIN IF (signature = NIL) THEN formals[0] := NIL; sig := ProcType.New (formals, NIL); ELSE sig := signature; END; ProcType.SetMethods (sig, methods); s := String.Add (name); t := Create (s); t.signature := sig; t.defined := TRUE; t.builtin := (signature = NIL); Scope.Insert (t); END Define; PROCEDURE Bind (p: T) = BEGIN IF (p.peer # NIL) THEN Value.Bind (p.peer) END; p.signature := Type.Bind (p.signature); p.type := p.signature; END Bind; PROCEDURE BindBody (p: T) = VAR objs : Scope.ValueList; n : INTEGER; v : Variable.T; type : Type.T; formals : Scope.T; BEGIN IF (p.defined) OR (NOT p.hasBody) THEN RETURN END; Coverage.NoteProcedure (p); Scope.Push (p.syms); (* create local variables for each of the formals *) formals := ProcType.Formals (p.signature); IF (formals # NIL) THEN Scope.ToList (formals, objs, n); (* this mess about Module.depth is so that this new var is not marked imported. *) VAR save := Module.depth; BEGIN Module.depth := 1; FOR i := 0 TO n - 1 DO v := Variable.NewFormal (objs[i]); Scope.Insert (v); (* identify the full names of the formal & its local variable *) objs[i].scope := v.scope; (* the variable that shadows a formal does not need to be declared *) v.declared := TRUE; END; Module.depth := save; END; END; (* create a variable for the return result *) type := ProcType.Result (p.signature); IF (type # NIL) AND (type # Void.T) THEN IF (resultName = NIL) THEN resultName := String.Add ("_result"); END; (* this mess about Module.depth is so that this new var is not marked imported. *) VAR save := Module.depth; saveOffset := Scanner.offset; BEGIN Module.depth := 1; Scanner.offset := p.origin; p.result := Variable.New (resultName, TRUE); Module.depth := save; Scanner.offset := saveOffset; END; Variable.BindType (p.result, type, FALSE, FALSE); Scope.Insert (p.result); END; (* finally, bind the scope and body *) Scope.Bind (p.syms, TRUE); Stmt.Bind (p.body); Value.Bind (p.result); IF Delay.pending THEN Delay.FinishUp () END; Scope.Pop (); END BindBody; PROCEDURE Check (p: T) = BEGIN Type.Check (p.signature); IF (p.peer # NIL) THEN Type.Check (p.peer.signature) END; END Check; PROCEDURE CheckBody (p: T) = VAR result: Type.T; BEGIN <* ASSERT p.checked *> IF (p.defined) OR (NOT p.hasBody) THEN RETURN END; IF (p.peer # NIL) THEN IF NOT Type.IsAssignable (p.peer.signature, p.signature) THEN Redefined (p); END; END; result := ProcType.Result (p.signature); Scope.Push (p.syms); (* check the local scope *) Scope.TypeCheck (p.syms, TRUE); Marker.PushProcedure (result, p.result); Stmt.TypeCheck (p.body); IF Delay.pending THEN Delay.FinishUp () END; Marker.Pop (); Scope.WarnUnused (p.syms); Scope.Pop (); END CheckBody; PROCEDURE Load (p: T): Temp.T = BEGIN IF (p.builtin) THEN Error.Str (p.name, "builtin operation is not a procedure"); END; RETURN Temp.FromValue (p); END Load; PROCEDURE WriteName (p: T) = BEGIN IF (p.extName = NIL) THEN Emit.OpN ("@", p); ELSE Emit.OpS ("@", p.extName); END; END WriteName; PROCEDURE Declarer (p: T): BOOLEAN = VAR result: Type.T; BEGIN Value.GenStorageClass (p); result := ProcType.Result (p.signature); IF ProcType.LargeResult (result) THEN Emit.Op ("void "); ELSE Emit.OpI ("t@ ", Type.Name (result)); END; WriteName (p); Emit.Op (" ();\n"); RETURN TRUE; END Declarer; PROCEDURE Compile (<*UNUSED*> p: T) = BEGIN END Compile; PROCEDURE MyClass (<*UNUSED*> t: T): Value.Class = BEGIN RETURN Value.Class.Procedure; END MyClass; PROCEDURE EmitFrameName (t: T): BOOLEAN = BEGIN RETURN Scope.EmitLocalFrameName (t.syms); END EmitFrameName; PROCEDURE GenHeaders () = VAR p: T; BEGIN ReverseList (); Emit.Op ("\n\n"); p := all; WHILE (p # NIL) DO IF (p.hasBody) THEN IF (NOT p.builtin) AND (NOT p.declared) THEN WITH tRes = ProcType.Result (p.signature) DO Value.GenStorageClass (p); IF ProcType.LargeResult (tRes) THEN Emit.Op ("void "); ELSE Emit.OpI ("t@ ", Type.Name (tRes)); END; END; WriteName (p); Emit.Op (" ();\n"); END; END; p := p.next; END; Emit.Op ("\n\n"); END GenHeaders; PROCEDURE ReverseList () = VAR p1, p2, p3: T; BEGIN p1 := all; p2 := NIL; WHILE (p1 # NIL) DO p3 := p1.next; p1.next := p2; p2 := p1; p1 := p3 END; all := p2; END ReverseList; PROCEDURE GenBodies () = VAR p: T; BEGIN p := all; WHILE (p # NIL) DO IF (p.hasBody) AND (NOT p.defined) AND (Host.toCompile = NIL OR Host.toCompile = p.name) THEN PrecompileBody (p); END; p := p.next; END; p := all; WHILE (p # NIL) DO IF (p.hasBody) AND (NOT p.defined) AND (Host.toCompile = NIL OR Host.toCompile = p.name) THEN Scanner.offset := p.origin; GenBody (p); END; p := p.next; END; END GenBodies; PROCEDURE PrecompileBody (p: T) = BEGIN ProcType.GenVar (p.signature); Scope.Push (p.syms); Marker.PushProcedure (ProcType.Result (p.signature), p.result); Stmt.Precompile (p.body); Marker.Pop (); Scope.Pop (); END PrecompileBody; PROCEDURE GenBody (p: T) = VAR i : INTEGER; nFormals : INTEGER; objs : Scope.ValueList; mode : Formal.Mode; offset : INTEGER; expr : Expr.T; type : Type.T; tresult : Type.T; formals : ARRAY [0..99] OF Value.T; oc : Stmt.Outcomes; needComa : BOOLEAN := FALSE; unused : BOOLEAN; BEGIN p.active := TRUE; Emit.Push (); Scope.Push (p.syms); tresult := ProcType.Result (p.signature); Emit.Op ("\n"); IF Host.incrementalVersion = 0 AND p.exported THEN Emit.OpI ("EXPORT t@ (*", Type.Name (tresult)); WriteName (p); Emit.Op ("_relay) () = 0;\n"); ELSIF Host.incrementalVersion > 0 AND p.exported THEN Emit.OpI ("IMPORT t@ (*", Type.Name (tresult)); WriteName (p); Emit.Op ("_relay) ();\n"); END; Value.GenStorageClass (p); IF ProcType.LargeResult (tresult) THEN Emit.Op ("void "); ELSE Emit.OpI ("t@ ", Type.Name (tresult)); END; WriteName (p); Emit.Op (" (\001"); needComa := Scope.EmitFrameName (p.syms); Scope.ToList (ProcType.Formals (p.signature), objs, nFormals); FOR i := 0 TO nFormals - 1 DO VAR b: BOOLEAN := Formal.Split (objs[i], offset, mode, type, expr, unused); BEGIN <* ASSERT b *> END; formals[offset] := objs[i]; END; FOR i := 0 TO nFormals - 1 DO IF needComa THEN Emit.Op (",\n") END; Emit.OpN ("@", formals[i]); needComa := TRUE; END; IF ProcType.LargeResult (tresult) THEN IF needComa THEN Emit.Op (",\n") END; Emit.Op ("_return"); needComa := TRUE; END; Emit.Op ("\002)\n"); Scope.EmitFrameType (p.syms); FOR i := 0 TO nFormals - 1 DO VAR b: BOOLEAN := Formal.Split (formals[i], offset, mode, type, expr, unused); BEGIN <* ASSERT b *> END; Emit.OpI ("t@ ", Type.Name (type)); IF (mode # Formal.Mode.mVALUE) THEN Emit.Op ("* ") END; Emit.OpN ("@;\n", formals[i]); formals[i].declared := TRUE; END; IF ProcType.LargeResult (tresult) THEN Emit.OpI ("t@* _return;\n", Type.Name (tresult)); END; Emit.Op ("{\n"); i := Emit.Switch (1); Temp.PushSet (); Marker.PushProcedure (tresult, p.result); IF (raisesLabel = NIL) THEN raisesLabel := String.Add ("proc_") END; Marker.StartRaises (raisesLabel, 0, p.signature); Scope.Enter (p.syms); IF Host.incrementalVersion = 0 AND p.exported THEN Emit.Op ("if ("); WriteName (p); Emit.Op ("_relay != 0) { "); IF NOT ProcType.LargeResult (tresult) AND tresult # Void.T AND tresult # NIL THEN Emit.Op ("return "); END; WriteName (p); Emit.Op ("_relay (\001"); needComa := Scope.EmitFrameName (p.syms); FOR i := 0 TO nFormals - 1 DO IF needComa THEN Emit.Op (",\n"); END; Emit.OpN ("@", formals[i]); needComa := TRUE; END; IF ProcType.LargeResult (tresult) THEN IF needComa THEN Emit.Op (",\n"); END; Emit.Op ("_return"); needComa := TRUE; END; Emit.Op ("\002);"); IF ProcType.LargeResult (tresult) OR tresult = Void.T OR tresult = NIL THEN Emit.Op (" return;"); END; Emit.Op ("};\n"); END; Emit.Op ("CHECKSTACKOVERFLOW;\n"); Coverage.CountProcedure (p); ProcType.CopyValueOpenArrayParameters (p.signature); oc := Stmt.Compile (p.body); IF (Stmt.Outcome.FallThrough IN oc) AND (NOT Type.IsEqual (tresult, Void.T)) THEN Error.WarnStr (1, p.name, "function does not return a value"); Emit.Op ("RETURNFAULT;\n"); oc := oc - Stmt.Outcomes {Stmt.Outcome.FallThrough}; END; Scope.Exit (p.syms); Marker.EndRaises (p.signature); Marker.Pop (); i := Emit.Switch (Emit.MaxStream); Emit.Op ("\002};\n"); Temp.PopSet (); Emit.Pop (); p.active := FALSE; END GenBody; PROCEDURE CanBeInlined (t: T): BOOLEAN = BEGIN RETURN (Host.inlines) AND (t # NIL) AND (t.inline) AND (t.hasBody) AND (NOT t.external) AND (NOT t.active); END CanBeInlined; PROCEDURE ExpandInline (p: T; READONLY actuals: ARRAY OF Temp.T): Temp.T = VAR nFormals : INTEGER; objs : Scope.ValueList; mode : Formal.Mode; offset : INTEGER; expr : Expr.T; type : Type.T; tresult : Type.T; formals : ARRAY [0..99] OF Value.T; oc : Stmt.Outcomes; unused : BOOLEAN; result : Temp.T; save : INTEGER; BEGIN <* ASSERT NOT p.active *> p.active := TRUE; save := Scanner.offset; Scanner.offset := p.origin; (* grab my list of formals *) Scope.ToList (ProcType.Formals (p.signature), objs, nFormals); FOR i := 0 TO nFormals - 1 DO VAR b:= Formal.Split (objs[i], offset, mode, type, expr, unused); BEGIN <* ASSERT b *> END; formals[offset] := objs[i]; END; Scope.Push (p.syms); tresult := ProcType.Result (p.signature); (* generate a temporary scope to hold the actual arguments *) Emit.OpN ("/*** begin inline @ ***/\n", p); Emit.Op ("{\001\n"); (* declare the temporaries that will hold the actuals *) FOR i := 0 TO nFormals - 1 DO EVAL Formal.Split (formals[i], offset, mode, type, expr, unused); Emit.OpI ("t@ ", Type.Name (type)); IF (mode # Formal.Mode.mVALUE) OR (ProcType.LargeResult (type)) THEN Emit.Op ("* "); END; Emit.OpI ("arg@;\n", i); END; (* assign the actuals to the temporaries *) FOR i := 0 TO nFormals - 1 DO EVAL Formal.Split (formals[i], offset, mode, type, expr, unused); Emit.OpI ("arg@ = ", i); IF (mode # Formal.Mode.mVALUE) THEN Emit.OpT ("@;\n", actuals[i]); ELSIF (ProcType.LargeResult (type)) THEN Emit.OpT ("& (@);\n", actuals[i]); ELSE Emit.OpT ("@;\n", actuals[i]); END; END; (* open the scope containing the procedure *) Emit.Op ("{\001\n"); (* generate my frame variable *) Scope.EmitFrameType (p.syms); (* declare my formal variables *) FOR i := 0 TO nFormals - 1 DO EVAL Formal.Split (formals[i], offset, mode, type, expr, unused); Emit.OpI ("t@ ", Type.Name (type)); IF (mode # Formal.Mode.mVALUE) THEN Emit.Op ("* ") END; Emit.OpN ("@;\n", formals[i]); formals[i].declared := TRUE; END; (* copy the actuals into the formals *) FOR i := 0 TO nFormals - 1 DO EVAL Formal.Split (formals[i], offset, mode, type, expr, unused); Emit.OpN ("@ = ", formals[i]); IF (mode # Formal.Mode.mVALUE) THEN Emit.OpI ("arg@;\n", i); ELSIF (ProcType.LargeResult (type)) THEN Emit.OpI ("*arg@;\n", i); ELSE Emit.OpI ("arg@;\n", i); END; END; IF (p.result # NIL) THEN result := Temp.AllocEmpty (tresult) END; Marker.PushProcedure (tresult, p.result, TRUE); IF (raisesLabel = NIL) THEN raisesLabel := String.Add ("proc_") END; Marker.StartRaises (raisesLabel, 0, p.signature); Scope.Enter (p.syms); Coverage.CountProcedure (p); oc := Stmt.Compile (p.body); IF (Stmt.Outcome.FallThrough IN oc) AND (NOT Type.IsEqual (tresult, Void.T)) THEN Emit.Op ("RETURNFAULT;\n"); oc := oc - Stmt.Outcomes {Stmt.Outcome.FallThrough}; END; Scope.Exit (p.syms); Marker.EndRaises (p.signature); Marker.Pop (); IF (p.result # NIL) THEN Emit.OpT ("@ = ", result); Emit.OpN ("@;\n", p.result); END; Emit.Op ("\002};\n"); Emit.Op ("\002};\n"); Emit.OpN ("/*** end inline @ ***/\n", p); Scanner.offset := save; p.active := FALSE; RETURN result; END ExpandInline; PROCEDURE Select (a: T; vb: Value.T): Value.T = VAR b: T; BEGIN (* make sure that 'b' is a procedure! *) TYPECASE vb OF | NULL => Redefined (a); RETURN a; | T(t) => b := t; ELSE Redefined (a); RETURN a; END; (* find and keep the one with a body *) IF (a.hasBody AND b.hasBody) THEN Redefined (a); RETURN b; ELSIF (a.hasBody) THEN IF (a.peer # NIL) THEN Redefined (a); ELSE a.peer := b; a.imported := a.imported OR b.imported; a.scope := b.scope; (* retain b's module name *) END; RETURN a; ELSIF (b.hasBody) THEN IF (b.peer # NIL) THEN Redefined (b); ELSE b.peer := a; b.imported := b.imported OR a.imported; b.scope := a.scope; (* retain a's module name *) END; RETURN b; ELSE Redefined (a); RETURN b; END; END Select; PROCEDURE Redefined (t: T) = BEGIN Error.Str (t.name, "procedure redefined"); END Redefined; PROCEDURE Signature (t: T): Type.T = BEGIN IF (t = NIL) THEN RETURN NIL END; RETURN t.signature; END Signature; PROCEDURE HasBody (t: T): BOOLEAN = BEGIN RETURN (t # NIL) AND (t.hasBody); END HasBody; PROCEDURE FPrinter (t: T; map: Type.Map; wr: Wr.T) = VAR sig: Type.T; s: String.Stack; BEGIN IF (t.peer = NIL) THEN sig := t.signature; ELSE sig := t.peer.signature; (* use the interface signature *) END; s.top := 0; Scope.NameToPrefix (t, s, FALSE); String.PutStack (wr, s); Wr.PutText (wr, " "); Type.Fingerprint (sig, map, wr); END FPrinter; BEGIN END Procedure.