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

(* File: Formal.m3                                             *)
(* Last modified on Tue May 22 07:30:39 1990 by muller         *)
(*      modified on Sat Feb 10 21:30:30 1990 by kalsow         *)


MODULE Formal;

IMPORT Value, ValueRep, Type, String, Error, Expr, ProcType;
IMPORT KeywordExpr, AssignStmt, Int, Wr, Fmt;
IMPORT OpenArrayExpr, ArrayType, Temp, Text;

CONST
  MaxArgs = 99;

TYPE
  T = Value.T BRANDED OBJECT 
        offset  : INTEGER;
        mode    : Mode;
        tipe    : Type.T;
        default : Expr.T;
     METHODS
        bind        := Bind;
        typeCheck   := Check;
	class       := MyClass;
        fingerprint := FPrinter;
        load        := Load;
        write       := ValueRep.NoWriter;
        select      := ValueRep.NoDuplicates;
        declare0    := Declarer;
        declare1    := Compile;
        needsDecl   := ValueRep.Never;
	toExpr      := ValueRep.NoExpr;
	toType      := ValueRep.NoType;
      END;

TYPE
  ArgSlot = RECORD
    formal  : T;
    actual  : Expr.T;
    matched : BOOLEAN;
  END;

PROCEDURE Create (name: String.T): T =
  VAR t: T;
  BEGIN
    t := NEW (T);
    ValueRep.Init (t, name);
    t.offset  := 0;
    t.mode    := Mode.mVALUE;
    t.tipe    := NIL;
    t.default := NIL;
    RETURN t;
  END Create;

PROCEDURE New (name: String.T;  m: Mode;  offset: INTEGER;  type: Type.T;
               default: Expr.T;  unused: BOOLEAN := FALSE): Value.T =
  VAR t: T;
  BEGIN
    t := Create (name);
    t.readonly := (m = Mode.mCONST);
    t.offset   := offset;
    t.mode     := m;
    t.tipe     := type;
    t.default  := default;
    t.unused   := unused;
    RETURN t;
  END New;

PROCEDURE Split (formal: Value.T;  VAR offset: INTEGER;  VAR m: Mode;
                 VAR type: Type.T;  VAR default: Expr.T;
                 VAR unused: BOOLEAN): BOOLEAN =
  BEGIN
    TYPECASE formal OF
    | NULL => RETURN FALSE;

    | T(t) => m       := t.mode;
              offset  := t.offset;
              type    := t.tipe;
	      default := t.default;
              unused  := t.unused;
	      RETURN TRUE;

    ELSE RETURN FALSE;
    END;
  END Split;

PROCEDURE HasClosure (formal: Value.T): BOOLEAN =
  BEGIN
    TYPECASE formal OF
    | NULL => RETURN FALSE;
    | T(t) => RETURN (t.mode = Mode.mVALUE) AND ProcType.Is(Type.Base(t.tipe));
    ELSE RETURN FALSE;
    END;
  END HasClosure;

PROCEDURE Bind (t: T) =
  BEGIN
    Expr.Bind (t.default);
    IF (t.tipe # NIL)
      THEN t.tipe := Type.Bind (t.tipe);
      ELSE t.tipe := Expr.TypeOf (t.default);
    END;
    t.type := t.tipe;
  END Bind;

PROCEDURE Check (t: T) =
  BEGIN
    Type.Check (t.tipe);
    IF (t.default # NIL) THEN
      Expr.TypeCheck (t.default);
      IF (t.mode = Mode.mVAR) THEN
        Error.Str (t.name,
          "must be a VALUE or READONLY parameter to have a default");
      END;
      IF  NOT Type.IsAssignable (t.tipe, Expr.TypeOf (t.default)) THEN
        Error.Str (t.name, "default is not assignable to formal");
      END;
      IF (Expr.ConstValue (t.default) = NIL) THEN
        Error.Str (t.name, "default is not constant");
      END;
    END;
  END Check;

PROCEDURE Load (t: T): Temp.T =
  BEGIN
    IF (t.default = NIL) THEN
      Error.Str (t.name, "formal has no default value");
    END;
    RETURN Expr.Compile (t.default);
  END Load;

PROCEDURE Compile (<*UNUSED*> t: T) =
  BEGIN
  END Compile;

PROCEDURE MyClass (<*UNUSED*> t: T): Value.Class =
  BEGIN
    RETURN Value.Class.Formal;
  END MyClass;

PROCEDURE Declarer (t: T): BOOLEAN =
  BEGIN
    Error.Str (t.name, "formal declaration??");
    <*NOWARN*>    <* ASSERT FALSE *>
  END Declarer;

PROCEDURE CheckArgs (VAR actuals  : Expr.List;
                         formals  : ARRAY  OF Value.T;
                         complain : BOOLEAN := TRUE;
                         nFormals : INTEGER := 99999): BOOLEAN =
  VAR
    j, n              : INTEGER;
    slots             : ARRAY [0..MaxArgs] OF ArgSlot;
    e, e0, value      : Expr.T;
    t, te             : Type.T; 
    posOK, ok         : BOOLEAN;
    name              : String.T;
    tt                : T;
  BEGIN
    ok := TRUE;
    nFormals := MIN (nFormals, NUMBER (formals));
    <* ASSERT nFormals <= MaxArgs *>

    IF (nFormals < NUMBER (actuals^)) THEN
      IF (NOT complain) THEN RETURN FALSE END;
      Error.Msg ("too many actual parameters");
      ok := FALSE;
    END;

    (* initialize the argument list *)
    FOR i := 0 TO nFormals - 1 DO
      tt := formals[i];
      WITH z = slots[tt.offset] DO
        z.formal  := tt;
        z.actual  := tt.default;
        z.matched := FALSE;
      END;
    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
            IF (NOT complain) THEN RETURN FALSE END;
            Error.Str (name, "unknown parameter");
            ok := FALSE;
            j := i;
            EXIT;
          END;
          IF (slots[j].formal.name = name) THEN EXIT END;
          INC (j);
        END;
      ELSE
        IF (NOT posOK) THEN
          IF (NOT complain) THEN RETURN FALSE END;
          Error.Msg ("positional parameters must precede keyword parameters");
          ok := FALSE;
        END;
        j := i;
      END;
      WITH z = slots[j] DO
        IF (z.matched) THEN
          IF (NOT complain) THEN RETURN FALSE END;
          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
        IF (NOT complain) THEN RETURN FALSE END;
        Err (slots[i], "parameter not specified");
        ok := FALSE;
      END;
    END;

    (* generate typecheck and fix each binding *)
    FOR i := 0 TO nFormals - 1 DO
      e  := slots[i].actual;
      tt := slots[i].formal;
      e0 := e;
      t  := tt.tipe;
      te := Expr.TypeOf (e);
      Expr.TypeCheck (e);
      n := ArrayType.OpenDepth (t);
      IF n # 0 AND n # ArrayType.OpenDepth (te) THEN
        e := OpenArrayExpr.New (t, te, e);
        Expr.Bind (e);
        Expr.TypeCheck (e);
        te := Expr.TypeOf (e);
      END;
      CASE tt.mode OF
      | Mode.mVALUE =>
          IF NOT Type.IsAssignable (t, te) THEN
            IF (NOT complain) THEN RETURN FALSE END;
            Err (slots[i], "incompatible types");
            ok := FALSE;
          ELSE (* vanilla parameter passed by value *)
            e := AssignStmt.CheckRHS (t, e, AssignStmt.Kind.value);
          END;
      | Mode.mVAR =>
          IF NOT Expr.IsDesignator (e) THEN
            IF (NOT complain) THEN RETURN FALSE END;
            Err (slots[i], "VAR actual must be a designator");
            ok := FALSE;
          ELSIF NOT Expr.IsWritable (e) THEN
            IF (NOT complain) THEN RETURN FALSE END;
            Err (slots[i], "VAR actual must be writable");
            ok := FALSE;
          ELSIF Type.IsEqual (t, te) THEN
            (* Nothing to do *)
          ELSE
            IF (NOT complain) THEN RETURN FALSE END;
            Err (slots[i], "incompatible types");
            ok := FALSE;
          END;
      | Mode.mCONST =>
          IF NOT Type.IsAssignable (t, te) THEN
            IF (NOT complain) THEN RETURN FALSE END;
            Err (slots[i], "incompatible types");
            ok := FALSE;
          ELSIF NOT Expr.IsDesignator (e) THEN
            e := AssignStmt.CheckRHS (t, e, AssignStmt.Kind.const);
          ELSIF Type.IsEqual (t, te) THEN
            (* Nothing to do *)
          ELSE (* Type.IsAssignable (t, te) *)
            e := AssignStmt.CheckRHS (t, e, AssignStmt.Kind.const);
          END;
      END; (*case*)
      IF (e # e0) THEN  Expr.Bind (e);  Expr.TypeCheck (e);  END;
      slots[i].actual := e;
    END;

    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 CheckArgs;

PROCEDURE Err (READONLY slot: ArgSlot;  msg: Text.T) =
  BEGIN
    Error.Str (slot.formal.name, msg);
  END Err;

PROCEDURE FPrinter (t: T;  map: Type.Map;  wr: Wr.T) =
  BEGIN
    CASE t.mode OF
    | Mode.mVALUE => Wr.PutText (wr, "VALUE");
    | Mode.mVAR   => Wr.PutText (wr, "VAR");
    | Mode.mCONST => Wr.PutText (wr, "READONLY");
    END;
    Wr.PutText (wr, " " & Fmt.Int (t.offset) & " ");
    Type.Fingerprint (t.tipe, map, wr);
    IF (t.default # NIL) THEN
      Wr.PutText (wr, " := ");
      Expr.Fingerprint (Expr.ConstValue (t.default), map, wr);
    END;
  END FPrinter;

BEGIN
END Formal.