(* Copyright (C) 1992, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* File: Procedure.m3                                          *)
(* Last Modified On Tue Sep 22 12:30:03 PDT 1992 by kalsow     *)
(*      Modified On Thu Dec  5 17:21:10 PST 1991 by muller     *)

MODULE Procedure;

IMPORT M3, Value, ValueRep, String, Type, Scope, Error, Host;
IMPORT ProcType, Emit, Formal, Stmt, BlockStmt, Marker, Coverage;
IMPORT CallExpr, Token, Void, MBuf, Variable, Temp, Module;
IMPORT Scanner, Decl, ESet, Reel, Frame, Fault, ProcExpr, Expr;
FROM Scanner IMPORT GetToken, Match, Match1, 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;
        result       : Variable.T;
        hasBody      : BOOLEAN;
        do_inline    : BOOLEAN;
        defined      : BOOLEAN;
	builtin      : BOOLEAN;
	active       : BOOLEAN;  (* => body currently being expanded *)
        needs_raises : BOOLEAN;
        fails        : ESet.T;
      OVERRIDES
        typeCheck   := Check;
	class       := MyClass;
        fingerprint := FPrinter;
        load        := Load;
        write       := WriteName;
        declare0    := Declarer;
        declare1    := Compile;
	toExpr      := ToExpr;
	toType      := ValueRep.NoType;
        typeOf      := TypeOf;
      END;

VAR
  resultName  : String.T := NIL;
  all         : T := NIL;
  level       := 0;

PROCEDURE Reset () =
  BEGIN
    all := NIL;
    level := 0;
  END Reset;

PROCEDURE ParseDecl (READONLY fail       : Token.Set;
                              att        : Decl.Attributes;
                              headerOnly : BOOLEAN := FALSE) =
  TYPE TK = Token.T;
  VAR t: T;  id, final_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.do_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, TK.tEQUAL}, 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.Parse (fail + Token.Set {TK.tSEMI}, FALSE);
      t.fails := BlockStmt.ExtractFails (t.body);
      DEC (level);
      final_id := MatchID (fail, Token.Set {TK.tSEMI});
      IF (final_id # id) 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, TRUE);
      INC (level);
      t.body := BlockStmt.Parse (fail + Token.Set {TK.tSEMI}, FALSE);
      t.fails := BlockStmt.ExtractFails (t.body);
      DEC (level);
      final_id := MatchID (fail, Token.Set {TK.tSEMI});
      IF (final_id # id) 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;
    Match1 (TK.tSEMI, fail);
  END ParseDecl;

PROCEDURE RequiresClosure (t: T): BOOLEAN =
  BEGIN
    RETURN Scope.EmitFrameName (t.syms, TRUE);
  END RequiresClosure;

PROCEDURE IsNested (t: T): BOOLEAN =
  BEGIN
    RETURN (t # NIL) AND (t.level # 0);
  END IsNested;

PROCEDURE IsEqual (a, b: Value.T): BOOLEAN =
  VAR ta, tb: T;
  BEGIN
    a := Value.Base (a);
    b := Value.Base (b);
    IF (a = b) THEN RETURN TRUE END;
    TYPECASE a OF
    | NULL => RETURN FALSE;
    | T(t) => ta := t;
    ELSE      RETURN FALSE;
    END;
    TYPECASE b OF
    | NULL => RETURN FALSE;
    | T(t) => tb := t;
    ELSE      RETURN FALSE;
    END;
    RETURN (ta.peer = tb) OR (tb.peer = ta);
  END IsEqual;

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.do_inline    := FALSE;
    t.external     := FALSE;
    t.defined      := FALSE;
    t.builtin      := FALSE;
    t.active       := FALSE;
    t.result       := NIL;
    t.extName      := NIL;
    t.level        := level;
    t.needs_raises := TRUE;
    t.fails        := NIL;
    RETURN t;
  END Create;

PROCEDURE Define (name      : TEXT;
                  methods   : CallExpr.MethodList;
                  reserved  : BOOLEAN;
                  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);
    IF (reserved) THEN Scanner.NoteReserved (s, t) END;
  END Define;

PROCEDURE NoteExport (implv, intfv: Value.T) =
  VAR impl: T := Value.Base (implv);  intf: T := Value.Base (intfv);
  BEGIN
    IF (impl.peer # NIL) THEN
      Redefined (impl, NIL(*intf*));
    ELSIF NOT Type.IsAssignable (intf.signature, impl.signature) THEN
      Redefined (impl, NIL(*intf*));
    ELSE
      impl.peer  := intf;
      impl.scope := intf.scope; (* retain the exported module name *)
      impl.used  := TRUE;
      impl.exported := TRUE;  implv.exported := TRUE;
      impl.imported := FALSE; implv.imported := FALSE;
      intf.exported := TRUE;  intfv.exported := TRUE;
      intf.imported := FALSE; intfv.imported := FALSE;
    END;
  END NoteExport;

PROCEDURE TypeOf (p: T): Type.T =
  BEGIN
    RETURN p.signature;
  END TypeOf;

PROCEDURE Check (p: T;  VAR cs: Value.CheckState) =
  BEGIN
    Type.Check (p.signature);
    Value.TypeCheck (p.peer, cs);
    (* defer the rest to CheckBody *)
  END Check;

PROCEDURE CheckBody (p: T;  VAR cs: Value.CheckState) =
  VAR
    objs    : Scope.ValueList;
    names   : Scope.NameList;
    n       : INTEGER;
    v       : Variable.T;
    formals : Scope.T;
    result  : Type.T;
    zz      : Scope.T;
    raises  : ESet.T;
    save    : BOOLEAN;
    formal  : Formal.Info;
  BEGIN
    IF (p.defined) OR (NOT p.hasBody) THEN RETURN END;

    Coverage.NoteProcedure (p);
    zz := Scope.Push (p.syms);

      (* create local variables for each of the formals *)
      formals := ProcType.Formals (p.signature);
      IF (formals # NIL) THEN
        Scope.ToListWithAliases (formals, objs, n, names);
        VAR save := Module.depth; BEGIN
          Module.depth := 1; (* so new vars aren't marked 'imported' *)
            FOR i := 0 TO n - 1 DO
              Formal.Split (objs[i], formal);
              IF (names # NIL) THEN formal.name := names[i] END;
              v := Variable.NewFormal (objs[i], formal.name);
              Scope.Insert (v);
              Variable.BindTrace (v, formal.trace);
              (* identify the full names of the formal & its local variable *)
              objs[i].scope := v.scope;
              v.declared := TRUE; (* does not need to be declared *)
            END;
          Module.depth := save;
        END;
      END;

      (* create a variable for the return result *)
      result := ProcType.Result (p.signature);
      IF (result # NIL) AND (result # 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, result, FALSE, FALSE);
        Scope.Insert (p.result);
      END;

      raises := ProcType.Raises (p.signature);
      save := cs.raises_others;
      cs.raises_others := FALSE;
      ESet.TypeCheck (p.fails);
      ESet.Push (cs, raises, p.fails, stop := TRUE);

      p.checked := TRUE;
      INC (Type.recursionDepth);
        Scope.TypeCheck (p.syms, cs);
        Marker.PushProcedure (result, p.result);
          Stmt.TypeCheck (p.body, cs);
        Marker.Pop ();
        Scope.WarnUnused (p.syms);
      DEC (Type.recursionDepth);

      p.needs_raises := cs.raises_others;
      cs.raises_others := save;
      ESet.Pop (cs, raises, p.fails, stop := TRUE);

    Scope.Pop (zz);
  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 save: Emit.Stream;
  BEGIN
    IF (p.peer # NIL) THEN Type.Compile (p.peer.signature) END;
    Type.Compile (p.signature);
    (* try to compile the imported type first... *)

    save := Emit.Switch (Emit.Stream.ProcHeads);
      Value.GenStorageClass (p);
      Emit.OpF ("@ ", ProcType.CResult (p.signature));
      WriteName (p);
      Emit.Op (" ();\n");
    EVAL Emit.Switch (save);
    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 ToExpr (t: T): Expr.T =
  BEGIN
    RETURN ProcExpr.New (t);
  END ToExpr;

PROCEDURE EmitFrameName (t: T): BOOLEAN =
 BEGIN
   RETURN Scope.EmitLocalFrameName (t.syms);
 END EmitFrameName;

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;  save: Emit.Stream;  n: INTEGER;
  BEGIN
    ReverseList ();

    (* generate the C headers *)
    save := Emit.Switch (Emit.Stream.ProcHeads);
    p := all;
    WHILE (p # NIL) DO	
      IF (p.hasBody) AND (NOT p.builtin) AND (NOT p.declared) THEN
        EVAL Declarer (p);
      END;
      p := p.next;
    END;

    (* generate the linker registrations *)
    EVAL Emit.Switch (Emit.Stream.LinkTables);
    p := all;  n := 0;
    WHILE (p # NIL) DO	
      IF (p.hasBody) AND (NOT p.builtin) AND (NOT IsNested (p)) THEN
        IF (n = 0) THEN
          Emit.Op ("\n_PRIVATE _PROC_INFO _proc_info [] = {\n");
        END;
        GenRegistration (p);
        INC (n);
      END;
      p := p.next;
    END;
    IF (n = 0)
      THEN Emit.Op ("\003#define _proc_info 0\n");
      ELSE Emit.Op ("  { (_PROC)0, 0, 0, 0, 0 }\n};\n");
    END;

    (* finally, generate the actual procedure bodies *)
    EVAL Emit.Switch (save);
    p := all;
    WHILE (p # NIL) DO	
      IF (p.hasBody) AND (NOT p.defined) THEN
        Scanner.offset := p.origin;
        GenBody (p);
      END;
      p := p.next;
    END;
  END GenBodies;

PROCEDURE GenRegistration (p: T) =
  VAR sig: Type.T;
  BEGIN
    IF (p.peer = NIL)
      THEN sig := p.signature;
      ELSE sig := p.peer.signature;  (* use the interface signature *)
    END;
    Emit.OpN ("  { (_PROC) @, ", p);
    Emit.OpH ("0x@, \"", Type.Name (sig));
    Scope.GenName (p, dots := TRUE);
    Emit.Op  ("\", 0, 0 },\n");
  END GenRegistration;

PROCEDURE GenBody (p: T) =
  VAR
    nFormals : INTEGER;
    objs     : Scope.ValueList;
    formals  : ARRAY [0..19] OF Value.T;
    isFloat  : ARRAY [0..19] OF BOOLEAN;
  BEGIN
    Scope.ToList (ProcType.Formals (p.signature), objs, nFormals);
    IF (nFormals <= NUMBER (formals)) THEN
      DoGenBody (p, nFormals, objs, formals, isFloat);
    ELSE
      DoGenBody (p, nFormals, objs,
                 NEW (REF ARRAY OF Value.T, nFormals)^,
                 NEW (REF ARRAY OF BOOLEAN, nFormals)^);
    END;
  END GenBody;

PROCEDURE DoGenBody (p        : T;
                     nFormals : INTEGER;
                     objs     : Scope.ValueList;
                 VAR formals  : ARRAY OF Value.T;
                 VAR isFloat  : ARRAY OF BOOLEAN) =
  VAR
    tresult  : Type.T;
    oc       : Stmt.Outcomes;
    needComa : BOOLEAN := FALSE;
    zz       : Scope.T;
    label    : INTEGER;
    fallThru : BOOLEAN;
    frame    : Frame.T;
    f_info   : Formal.Info;
  BEGIN
    ESet.Declare (ProcType.Raises (p.signature));
    p.active := TRUE;
    zz := Scope.Push (p.syms);
    tresult := ProcType.Result (p.signature);

    Frame.Push (frame, 0, TRUE);

    Value.GenStorageClass (p);
    IF ProcType.LargeResult (tresult)
      THEN Emit.Op  ("_VOID ");
      ELSE Emit.OpF ("@ ", tresult);
    END;
    WriteName (p);
    Emit.Op (" (\001");

    needComa := Scope.EmitFrameName (p.syms);
    FOR i := 0 TO nFormals - 1 DO
      Formal.Split (objs[i], f_info);
      formals[f_info.offset] := objs[i];
      isFloat[f_info.offset] := (f_info.mode = Formal.Mode.mVALUE)
                            AND Type.IsEqual (f_info.type, Reel.T, NIL);
    END;
    FOR i := 0 TO nFormals - 1 DO
      IF needComa THEN Emit.Op (", ") END;
      IF (isFloat[i])
        THEN Emit.OpI ("_formal_@", i);
        ELSE Emit.OpN ("@", formals[i]);
      END;
      needComa := TRUE;
    END;
    IF ProcType.LargeResult (tresult) THEN
      IF needComa THEN Emit.Op (", ") END;
      Emit.Op ("_return"); needComa := TRUE;
    END;
    Emit.Op ("\002)\n");

    Scope.EmitFrameType (p.syms);
    FOR i := 0 TO nFormals - 1 DO
      Formal.Split (formals[i], f_info);
      Type.Compile (f_info.type);
      IF isFloat [i] THEN
        Emit.OpI ("double _formal_@;\n", i);
        INC (Frame.cur.size, 2);
      ELSE
        Emit.OpF ("@ ", f_info.type);
        IF (f_info.mode # Formal.Mode.mVALUE) THEN Emit.Op ("* ") END;
        Emit.OpN ("@;\n", formals[i]);
        IF (f_info.mode = Formal.Mode.mVALUE)
          THEN Frame.NoteDeclaration (f_info.type);
          ELSE INC (Frame.cur.size); (* an address *)
        END;
      END;
      formals[i].declared := TRUE;
    END;
    IF ProcType.LargeResult (tresult) THEN
      Emit.OpF ("@* _return;\n", tresult);
      INC (Frame.cur.size);
    END;

    Emit.Op ("{\001\n");

    (* convert the REALs back to single precision.  damn C. *)
    FOR i := 0 TO nFormals - 1 DO
      IF isFloat [i] THEN
        Formal.Split (formals[i], f_info);
        Emit.OpF ("@ ", f_info.type);
        Emit.OpN ("@ = ", formals[i]);
        Emit.OpI ("_formal_@;\n", i);
        INC (Frame.cur.size);
      END;
    END;

    Scope.Enter (p.syms);
    EVAL Emit.SwitchToBody (); Emit.Op ("\001");
    
    Marker.PushProcedure (tresult, p.result);
      label := StartRaises (p);
        Scope.InitValues (p.syms);
        Scanner.offset := BlockStmt.BodyOffset (p.body);
	Coverage.CountProcedure (p);
        ProcType.CopyValueOpenArrayParameters (p.signature);
        oc := Stmt.Compile (p.body);
        fallThru := (Stmt.Outcome.FallThrough IN oc);
        IF (fallThru) AND (NOT Type.IsEqual (tresult, Void.T, NIL)) THEN
	  Error.WarnStr (1, p.name, "function may not return a value");
          IF Host.doReturnChk THEN
            Fault.Return ();
	    oc := oc - Stmt.Outcomes {Stmt.Outcome.FallThrough};
          END;
        END;
      EndRaises (p, label, fallThru);
    Marker.Pop ();
    Scope.Exit (p.syms);

    Frame.Pop (frame);

    Scope.Pop (zz);
    p.active := FALSE;
  END DoGenBody;

PROCEDURE StartRaises (t: T): INTEGER =
  VAR raises: ESet.T;  x: INTEGER;  save: Emit.Stream;
  BEGIN
    IF (NOT Host.doRaisesChk) OR (NOT t.needs_raises) THEN RETURN 0 END;
    raises := ProcType.Raises (t.signature);
    IF ESet.RaisesAny (raises) THEN RETURN 0 END;
    x := M3.NextLabel;  INC (M3.NextLabel);
    Marker.PushRaises (x);
    IF ESet.RaisesNone (raises) THEN
      save := Emit.SwitchToDecls ();
      Emit.OpI ("_RAISES_NONE_HANDLER _h@;\n", x);
      INC (Frame.cur.size, 2);
      EVAL Emit.Switch (save);
      Emit.OpI ("_PUSH_RAISES_NONE (_h@);\001\n", x);
    ELSE
      save := Emit.SwitchToDecls ();
      Emit.OpI ("_RAISES_HANDLER _h@;\n", x);
      INC (Frame.cur.size, 3);
      EVAL Emit.Switch (save);
      Emit.OpI ("_PUSH_RAISES (_h@, ", x);
      Emit.OpI  ("_raises_@);\001\n", ESet.UID (raises));
    END;
    RETURN x;
  END StartRaises;

PROCEDURE EndRaises (t: T;  x: INTEGER;  fallThru: BOOLEAN) =
  VAR raises: ESet.T;
  BEGIN
    IF (NOT Host.doRaisesChk) OR (NOT t.needs_raises) THEN RETURN END;
    raises := ProcType.Raises (t.signature);
    IF ESet.RaisesAny (raises) THEN RETURN END;
    Marker.Pop ();
    Emit.Op ("\002");
    IF (fallThru) THEN Emit.OpI ("_CUT_TO_NEXT_HANDLER (_h@);\n", x); END;
  END EndRaises;


PROCEDURE CanBeInlined (<*UNUSED*> t: T): BOOLEAN =
  BEGIN
    RETURN FALSE;
    (**
    RETURN (Host.inlines) AND (t # NIL) AND (t.do_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 =
  BEGIN
    EVAL p;  EVAL actuals;
    <* ASSERT FALSE *>
  END ExpandInline;

PROCEDURE Redefined (t: T;  other: Value.T;) =
  VAR save: INTEGER;
  BEGIN
    save := Scanner.offset;
    IF (other = NIL)
      THEN Scanner.offset := t.origin;
      ELSE Scanner.offset := MIN (t.origin, other.origin);
    END;
    Error.Str (t.name, "procedure redefined");
    Scanner.offset := save;
  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.FPMap;  wr: MBuf.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);
    MBuf.PutText (wr, " ");
    Type.Fingerprint (sig, map, wr);
  END FPrinter;

BEGIN
END Procedure.