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

(* File: Formal.m3                                             *)
(* Last modified on Mon Jun 29 15:37:48 PDT 1992 by kalsow     *)
(*      modified on Fri Nov  9 20:39:07 1990 by muller         *)

MODULE Formal;

IMPORT Value, ValueRep, Type, String, Error, Expr, ProcType;
IMPORT KeywordExpr, AssignStmt, MBuf, OpenArrayType, RefType;
IMPORT OpenArrayExpr, ArrayType, Temp, CopyExpr, Scope, Tracer;

TYPE
  T = Value.T BRANDED OBJECT 
        offset  : INTEGER;
        mode    : Mode;
        tipe    : Type.T;
        dfault  : Expr.T;
        refType : Type.T;
        trace   : Tracer.T;
      OVERRIDES
        typeCheck   := Check;
	class       := MyClass;
        fingerprint := FPrinter;
        load        := Load;
        write       := ValueRep.NoWriter;
        declare0    := Declarer;
        declare1    := Compile;
	toExpr      := ValueRep.NoExpr;
	toType      := ValueRep.NoType;
        typeOf      := TypeOf;
      END;

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

PROCEDURE New (READONLY info: Info): Value.T =
  VAR t := NEW (T);
  BEGIN
    ValueRep.Init (t, info.name);
    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.trace    := info.trace;
    t.refType  := NIL;
    RETURN t;
  END New;

PROCEDURE Split (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;

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 (TypeOf (t)));
    ELSE      RETURN FALSE;
    END;
  END HasClosure;

PROCEDURE RefOpenArray (formal: Value.T): Type.T =
  BEGIN
    TYPECASE formal OF
    | NULL => RETURN NIL;
    | T(t) => RETURN t.refType;
    ELSE      RETURN NIL;
    END;
  END RefOpenArray;

PROCEDURE TypeOf (t: T): Type.T =
  BEGIN
    IF (t.tipe = NIL) THEN t.tipe := Expr.TypeOf (t.dfault) END;
    RETURN t.tipe;
  END TypeOf;

PROCEDURE Check (t: T;  VAR cs: Value.CheckState) =
  BEGIN
    Type.Check (TypeOf (t));

    IF (t.dfault # NIL) THEN
      Expr.TypeCheck (t.dfault, cs);
      IF (t.mode = Mode.mVAR) THEN
        Error.Str (t.name, "VAR parameters cannot have defaults");
      END;
      IF  NOT Type.IsAssignable (t.tipe, Expr.TypeOf (t.dfault)) THEN
        Error.Str (t.name, "default is not assignable to formal");
      END;
      IF (Expr.ConstValue (t.dfault) = NIL) THEN
        Error.Str (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);
      Type.Check (t.refType);
    END;
  END Check;

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

PROCEDURE Compile (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;

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??");
    <*ASSERT FALSE*> <*NOWARN*>
  END Declarer;

PROCEDURE CheckArgs (VAR cs       : Value.CheckState;
                     VAR actuals  : Expr.List;
                READONLY formals  : ARRAY OF Value.T;
                         names    : Scope.NameList;
                         complain : BOOLEAN;
                         nFormals : INTEGER): BOOLEAN =
  VAR slots: ARRAY [0..19] OF ArgSlot;
  BEGIN
    nFormals := MIN (nFormals, NUMBER (formals));
    IF (nFormals <= NUMBER (slots)) THEN
      RETURN DoCheckArgs (cs, actuals, formals, names, complain, nFormals,
                          slots);
    ELSE
      RETURN DoCheckArgs (cs, actuals, formals, names, complain, nFormals,
                          NEW (REF ARRAY OF ArgSlot, nFormals)^);
    END;
  END CheckArgs;

PROCEDURE DoCheckArgs (VAR cs       : Value.CheckState;
                       VAR actuals  : Expr.List;
                  READONLY formals  : ARRAY OF Value.T;
                           names    : Scope.NameList;
                           complain : BOOLEAN;
                           nFormals : INTEGER;
                       VAR slots    : ARRAY OF ArgSlot): BOOLEAN =
  VAR
    j, n              : INTEGER;
    e, e0, value      : Expr.T;
    index, elt, t, te : Type.T; 
    posOK, ok         : BOOLEAN;
    name              : String.T;
    tt                : T;
    mode              : Mode;
  BEGIN
    ok := TRUE;

    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.dfault;
        z.matched := FALSE;
        z.errored := FALSE;
        IF (names = NIL)
          THEN z.name := tt.name;
          ELSE z.name := names[i];
        END;
      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].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;
      IF (e # NIL) AND (tt # NIL) THEN
        (* we've got both a formal and an actual *)
        e0   := e;
        te   := Expr.TypeOf (e);
        t    := tt.tipe;
        mode := tt.mode;
        Expr.TypeCheck (e, cs);
        n := OpenArrayType.OpenDepth (t);
        IF (n # 0) AND (n # OpenArrayType.OpenDepth (te)) THEN
          e := OpenArrayExpr.New (t, e, AssignStmt.Kind.value);
          IF e = NIL THEN
            Err (slots[i], "incompatible types");
            te := t;
          ELSE
            Expr.TypeCheck (e, cs);
            te := Expr.TypeOf (e);
          END;
        END;
        CASE 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, cs, 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, NIL) THEN
              (* Nothing to do *)
            ELSIF ArrayType.Split (t, index, elt) THEN
              e := AssignStmt.CheckRHS (t, e, cs, AssignStmt.Kind.var);
            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, cs, AssignStmt.Kind.assign);
              e := CopyExpr.New (e, t);
            ELSIF Type.IsEqual (t, te, NIL) THEN
              (* Nothing to do *)
            ELSE (* Type.IsAssignable (t, te) *)
              e := AssignStmt.CheckRHS (t, e, cs, AssignStmt.Kind.assign);
              e := CopyExpr.New (e, t);
            END;
        END; (*case*)
        IF (e # e0) THEN  Expr.TypeCheck (e, cs)  END;
        slots[i].actual := e;
      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;

PROCEDURE Err (VAR slot: ArgSlot;  msg: TEXT) =
  BEGIN
    IF (NOT slot.errored) THEN
      Error.Str (slot.name, msg);
      slot.errored := TRUE;
    END;
  END Err;

PROCEDURE FPrinter (t: T;  map: Type.FPMap;  wr: MBuf.T) =
  BEGIN
    CASE t.mode OF
    | Mode.mVALUE => MBuf.PutText (wr, "VALUE");
    | Mode.mVAR   => MBuf.PutText (wr, "VAR");
    | Mode.mCONST => MBuf.PutText (wr, "READONLY");
    END;
    MBuf.PutText (wr, " ");
    MBuf.PutInt  (wr, t.offset);
    MBuf.PutText (wr, " ");
    Type.Fingerprint (t.tipe, map, wr);
    IF (t.dfault # NIL) THEN
      MBuf.PutText (wr, " := ");
      Expr.Fingerprint (Expr.ConstValue (t.dfault), map, wr);
    END;
  END FPrinter;

BEGIN
END Formal.