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

(* File: New.m3                                                *)
(* Last Modified On Tue Jun 30 09:01:48 PDT 1992 By kalsow     *)
(*      Modified On Fri Jan 25 08:10:52 1991 By muller         *)

MODULE New;

IMPORT CallExpr, Expr, Type, Procedure, Error, Void, String, Value;
IMPORT RefType, ObjectType, OpaqueType, ArrayType, KeywordExpr, Emit;
IMPORT Field, Method, Int, ProcType, AssignStmt, OpenArrayType, Target;
IMPORT Scope, RecordType, Temp, TypeExpr, Null, Revelation, Frame;

VAR Z: CallExpr.MethodList;

PROCEDURE TypeOf (<*UNUSED*> proc: Expr.T; VAR args: Expr.List): Type.T =
  VAR t: Type.T;
  BEGIN
    IF NOT TypeExpr.Split (args[0], t) THEN  t := Null.T;
    ELSIF RefType.Is (t)    THEN (* ok *)
    ELSIF ObjectType.Is (t) THEN (* sleazy bug!!  ignore method overrides *)
    ELSIF OpaqueType.Is (t) THEN (* sleazy bug!!  ignore method overrides *)
    ELSE  t := Null.T;
    END;
    RETURN t;
  END TypeOf;

PROCEDURE Check (<*UNUSED*> proc: Expr.T; VAR args: Expr.List;  VAR cs: Expr.CheckState): Type.T =
  VAR t, r: Type.T;
  BEGIN
    IF KeywordExpr.Is (args[0]) THEN
      Error.Msg ("NEW: keyword bindings not allowed for type");
    END;
    IF NOT TypeExpr.Split (args[0], t) THEN
      Error.Msg ("NEW must be applied to a reference type");
      t := Null.T;
    ELSIF (RefType.Split (t, r)) THEN
      CheckRef (r, args, cs);
    ELSIF (ObjectType.Is (t)) THEN
      r := CheckObject (t, args, cs);
      IF (r # t) THEN
        args[0] := TypeExpr.New (r);
        Expr.TypeCheck (args[0], cs);
        t := r;
      END;
    ELSIF (OpaqueType.Is (t)) THEN
      r := CheckOpaque (t, args, cs);
      IF (r # t) THEN
        args[0] := TypeExpr.New (r);
        Expr.TypeCheck (args[0], cs);
        t := r;
      END;
    ELSE
      Error.Msg ("NEW must be applied to a reference type");
    END;
    RETURN t;
  END Check;

PROCEDURE CheckRef (r: Type.T; args: Expr.List;  VAR cs: Expr.CheckState) =
  VAR index, elt: Type.T; fields: Scope.T;
  BEGIN
    IF (r = NIL) OR Type.IsEqual (r, Void.T, NIL) THEN
     Error.Msg("cannot NEW an open reference type (REFANY, ADDRESS, or NULL)");
    ELSIF Type.IsEmpty (r) THEN
      Error.Msg ("cannot allocate variables of empty types");
    ELSIF ArrayType.Split (r, index, elt) AND (index = NIL) THEN
      CheckOpenArray (r, args);
    ELSIF RecordType.Split (r, fields) THEN
      CheckRecord (r, args, cs);
    ELSIF (NUMBER (args^) > 1) THEN
      Error.Msg ("too many arguments to NEW");
    END;
  END CheckRef;

PROCEDURE CheckOpenArray (r: Type.T; args: Expr.List) =
  VAR x, elt: Type.T;
  BEGIN
    FOR i := 1 TO LAST (args^) DO
      x := Type.Base (Expr.TypeOf (args[i]));
      IF KeywordExpr.Is (args[i]) THEN
        Error.Msg ("NEW: not a procedure; keyword bindings not allowed for array dimensions");
      END;
      IF  NOT Type.IsEqual (x, Int.T, NIL) THEN
        Error.Int (i, "argument must be an integer");
      ELSIF (NOT OpenArrayType.Split (r, elt)) THEN
        Error.Int (i, "too many dimensions specified");
      ELSE (* ok *)
        r := elt;
      END;
    END;
    IF OpenArrayType.Is (r) THEN
      Error.Msg ("not enough dimensions specified");
    END;
  END CheckOpenArray;

PROCEDURE CheckRecord (t: Type.T; args: Expr.List;  VAR cs: Expr.CheckState) =
  VAR
    x: Type.T;
    key: String.T;
    value: Expr.T;
    field: Value.T;
    sig: Type.T;
    offset: INTEGER;
    expr: Expr.T;
  BEGIN
    FOR i := 1 TO LAST (args^) DO
      x := Expr.TypeOf (args[i]);
      IF  NOT KeywordExpr.Split (args[i], key, value) THEN
        Error.Msg ("extra arguments must include keywords");
      ELSIF NOT RecordType.LookUp (t, key, field) THEN
        Error.Str (key, "unknown record field");
      ELSIF NOT Field.Split (field, offset, sig) THEN
        Error.Str (key, "undefined field?");
      ELSIF NOT Type.IsAssignable (sig, x) THEN
        Error.Str (key, "value is not assignable to field");
      ELSE
        expr := AssignStmt.CheckRHS (sig, value, cs);
        IF (expr # value) THEN
	  args[i] := KeywordExpr.New (key, expr);
	  Expr.TypeCheck (args[i], cs);
        END;
        x := Expr.TypeOf (args[i]);
      END;
    END;
  END CheckRecord;

PROCEDURE CheckObject (t: Type.T;  args: Expr.List;  VAR cs: Expr.CheckState): Type.T =
  VAR
    x: Type.T;
    key: String.T;
    value: Expr.T;
    field: Value.T;
    visible: Type.T;
    sig: Type.T;
    offset: INTEGER;
    expr: Expr.T;
    override: BOOLEAN;
    newType: Type.T := NIL;
    fields: Scope.T;
    overrides: Scope.T;
    zz: Scope.T;
    method: Value.T;
  BEGIN
    (* first pass, remove the method overrides & build a new object type *)
    FOR i := 1 TO LAST (args^) DO
      x := Expr.TypeOf (args[i]);
      IF KeywordExpr.Split (args[i], key, value)
        AND ObjectType.LookUp (t, key, field, visible)
        AND Method.Split (field, offset, override, sig) THEN
        IF (newType = NIL) THEN
          fields := Scope.PushNew (FALSE, NIL); Scope.PopNew ();
          overrides := Scope.PushNew (FALSE, NIL); Scope.PopNew ();
          newType := ObjectType.New (t, Type.IsTraced(t),NIL,fields,overrides);
        END;
        zz := Scope.Push (overrides);
          method := Method.New (key, 0, newType, NIL, value);
          Method.NoteOverride (method, field);
        Scope.Pop (zz);
      END;
    END;

    IF (newType # NIL) THEN
      Type.Check (newType);
      t := newType;
    END;

    (* second pass, do the checking *)
    FOR i := 1 TO LAST (args^) DO
      x := Expr.TypeOf (args[i]);
      IF NOT KeywordExpr.Split (args[i], key, value) THEN
        Error.Msg ("extra arguments must include keywords");
      ELSIF NOT ObjectType.LookUp (t, key, field, visible) THEN
        Error.Str (key, "unknown object field or method");
      ELSIF Method.Split (field, offset, override, sig) THEN
        IF NOT ProcType.IsCompatible (x, t, sig) THEN
          Error.Str (key, "procedure is not compatible with method");
        END;
        args[i] := NIL;
      ELSIF Field.Split (field, offset, sig) THEN
        IF NOT Type.IsAssignable (sig, x) THEN
          Error.Str (key, "value is not assignable to field");
        ELSE
          expr := AssignStmt.CheckRHS (sig, value, cs);
          IF (expr # value) THEN
	    args[i] := KeywordExpr.New (key, expr);
	    Expr.TypeCheck (args[i], cs);
          END;
          x := Expr.TypeOf (args[i]);
        END;
      ELSE
        Error.Str (key, "undefined?");
      END;
    END;

    RETURN t;
  END CheckObject;

PROCEDURE CheckOpaque (t: Type.T; args: Expr.List;  VAR cs: Expr.CheckState): Type.T =
  (* we already know that t is not an object, so we only need to
     check for a full revelation that says it's a REF *)
  VAR x := Revelation.LookUp (t);  r: Type.T;
  BEGIN
    IF (x = NIL) THEN
      Error.Msg ("cannot apply NEW to non-object, opaque types");
    ELSIF RefType.Split (x, r) THEN
      (* full revelation => t is a REF *)
      CheckRef (r, args, cs);
    ELSE
      Error.Msg ("cannot apply NEW to this type");
    END;
    RETURN t;
  END CheckOpaque;

PROCEDURE Compile (<*UNUSED*> proc: Expr.T; args: Expr.List): Temp.T =
  VAR t, r: Type.T; x: Temp.T;
  BEGIN
    VAR b: BOOLEAN := TypeExpr.Split (args[0], t);
    BEGIN <* ASSERT b *> END;
    Type.Compile (t);
    IF (RefType.Split (t, r)) THEN x := GenRef (t, Type.Strip (r), args);
    ELSIF (ObjectType.Is (t)) THEN x := GenObject (t, args);
    ELSIF (OpaqueType.Is (t)) THEN x := GenOpaque (t, args);
    ELSE Error.Msg ("NEW must be applied to a variable of a reference type");
    END;
    RETURN x;
  END Compile;

PROCEDURE GenRef (t, r: Type.T; args: Expr.List): Temp.T =
  CONST fmt = ARRAY BOOLEAN OF TEXT {"_UNEW (@_TC);\n", "_TNEW (@_TC);\n"};
  VAR index, elt: Type.T;  traced: BOOLEAN;  fields: Scope.T;  result: Temp.T;
  BEGIN
    traced := Type.IsTraced (t);
    IF ArrayType.Split (r, index, elt) AND (index = NIL) THEN
      result := GenOpenArray (t, r, traced, args);
    ELSIF RecordType.Split (r, fields) THEN
      result := GenRecord (t, r, traced, args);
    ELSE
      result := Temp.AllocEmpty (t);
      Emit.OpT ("@ = ", result);
      Emit.OpF ("(@) ", t);
      Emit.OpF (fmt[traced], t)
    END;
    RETURN result;
  END GenRef;

PROCEDURE GenOpenArray(t, r: Type.T; traced: BOOLEAN; args: Expr.List): Temp.T=
  CONST fmt = ARRAY BOOLEAN OF TEXT {"_UNEWA (@_TC, &_sizes);\n",
                                     "_TNEWA (@_TC, &_sizes);\n"};
  VAR
    x: Type.T;
    n: INTEGER;
    tmp: Temp.T;
    prefix: String.Stack;
    block, block2: INTEGER;
  BEGIN
    (* get the final element type *)
    x := OpenArrayType.OpenType (r);

    (* allocate the local variables *)
    n := LAST (args^);
    Frame.PushBlock (block, 3 + n);
    Emit.OpF ("@* _ptr;\n", r);
    Emit.OpI ("struct {int *elts; int nb_dims; int dim[@];} _sizes;\n", n);
    Emit.OpI ("_sizes.elts = _sizes.dim; _sizes.nb_dims = @;\n", n);
    FOR i := 1 TO n DO
      tmp := Expr.Compile (args[i]);
      Emit.OpI ("_sizes.dim[@] = ", i - 1);
      Emit.OpT ("@;\n", tmp);
      Temp.Free (tmp);
    END;

    (* allocate the storage *)
    Emit.OpF ("_ptr = (@*) ", r);
    Emit.OpF (fmt[traced], t);

    (* initialize the array elements *)
    IF (Type.InitCost (x, TRUE) > 0) THEN
      Frame.PushBlock (block2, 3);
      Emit.Op   ("register int _index;\n");
      Emit.OpFF ("@* _aelt = (@*) _ptr->elts;\n", x, x);
      Emit.Op   ("int *_sz = _ptr->size;\n");
      Emit.Op   ("for (_index = 0; _index < ");
      FOR i := 1 TO n DO Emit.OpI ("_sz[@] * ", i - 1) END;
      Emit.Op ("1; _aelt++, _index++) {\001\n");
      prefix.top := 1;
      prefix.stk[0] := String.Add ("(*_aelt)");
      Type.InitVariable (x, TRUE, prefix);
      Emit.Op ("\002}\n");
      Frame.PopBlock (block2);
    END;

    (* give the user his object *)
    tmp := Temp.AllocEmpty (t);
    Emit.OpT ("@ = ", tmp);
    Emit.OpF ("(@) _ptr;\n", t);
    Frame.PopBlock (block);
    RETURN tmp;
  END GenOpenArray;

PROCEDURE GenRecord (t, r: Type.T; traced: BOOLEAN; args: Expr.List): Temp.T =
  CONST fmt = ARRAY BOOLEAN OF TEXT {"_UNEW (@_TC);\n", "_TNEW (@_TC);\n"};
  VAR
    x, f: Type.T;
    key: String.T;
    value: Expr.T;
    tmp: Temp.T;
    v: Value.T;
    block: INTEGER;
  BEGIN
    (* allocate the record's storage *)
    Frame.PushBlock (block, 1);
    Emit.OpFF ("register @* _ptr = (@*) ", r, r);
    Emit.OpF  (fmt [traced], t);

    (* do the user specified initialization *)
    FOR i := 1 TO LAST (args^) DO
      x := Expr.TypeOf (args[i]);
      VAR b: BOOLEAN := KeywordExpr.Split (args[i], key, value);
      BEGIN <* ASSERT b *> END;
      tmp := Expr.Compile (value);
      EVAL RecordType.LookUp (r, key, v);
      Emit.OpS ("_ptr->@ = ", Value.CName (v));
      f := Value.TypeOf (v);
      IF (Type.Name (f) # Type.Name (x)) THEN Emit.OpF ("(@)", f) END;
      Emit.OpT ("@;\n", tmp);
      Temp.Free (tmp);
    END;

    (* finally, give the object to the user *)
    tmp := Temp.AllocEmpty (t);
    Emit.OpT ("@ = ", tmp);
    Emit.OpF ("(@) _ptr;\n", t);
    Frame.PopBlock (block);
    RETURN tmp;
  END GenRecord;

PROCEDURE GenObject (t: Type.T;  args: Expr.List): Temp.T =
  CONST fmt = ARRAY BOOLEAN OF TEXT{"_UNEWOBJ (@_TC);\n","_TNEWOBJ (@_TC);\n"};
  VAR
    x: Type.T;
    key: String.T;
    value: Expr.T;
    field: Value.T;
    visible: Type.T;
    ftype: Type.T;
    offset: INTEGER;
    tmp: Temp.T;
    block: INTEGER;
    obj_offset: INTEGER;
  BEGIN
    (* allocate the object's storage *)
    Frame.PushBlock (block, 1);
    Emit.Op  ("_ADDRESS _ptr = (_ADDRESS)");
    Emit.OpF (fmt [Type.IsTraced (t)], t);

    (* do the user specified initialization *)
    FOR i := 1 TO LAST (args^) DO
      IF (args[i] # NIL) THEN
        x := Expr.TypeOf (args[i]);
        VAR b: BOOLEAN := KeywordExpr.Split (args[i], key, value);
        BEGIN <* ASSERT b *> END;
        VAR b: BOOLEAN := ObjectType.LookUp (t, key, field, visible);
        BEGIN <* ASSERT b *> END;
        tmp := Expr.Compile (value);
        Field.SplitX (field, offset, ftype);
        obj_offset := ObjectType.FieldOffset (visible);
        Emit.OpF ("((@_fields*)(_ptr+", visible);
        IF (obj_offset < 0)
          THEN Emit.OpF ("@_TC->dataOffset", visible);
          ELSE Emit.OpI ("@", obj_offset DIV Target.CHARSIZE);
        END;
        Emit.OpS ("))->@ = ", Value.CName (field));
        IF (Type.Name (ftype) # Type.Name (x)) THEN Emit.OpF("(@)", ftype) END;
        Emit.OpT ("@;\n", tmp);
        Temp.Free (tmp);
      END;
    END;

    (* finally, give the object to the user *)
    tmp := Temp.AllocEmpty (t);
    Emit.OpT ("@ = ", tmp);
    Emit.OpF ("(@) _ptr;\n", t);
    Frame.PopBlock (block);
    RETURN tmp;
  END GenObject;

PROCEDURE GenOpaque (t: Type.T; args: Expr.List): Temp.T =
  VAR x := Revelation.LookUp (t);  r: Type.T;  result: Temp.T;
  BEGIN
    IF (x = NIL) THEN
      <* ASSERT FALSE *>
    ELSIF RefType.Split (x, r) THEN
      (* full revelation => t is a REF *)
      result := GenRef (x, Type.Strip (r), args);
    ELSE
      <* ASSERT FALSE *>
    END;
    RETURN result;
  END GenOpaque;

PROCEDURE NoteWrites (<*UNUSED*> proc: Expr.T;  <*UNUSED*> args: Expr.List) =
  BEGIN
    (* skip, there's no named variable to trace *)
  END NoteWrites;

PROCEDURE Initialize () =
  BEGIN
    Z := CallExpr.NewMethodList (1, LAST (INTEGER), TRUE, TRUE, NIL,
                                 TypeOf, Check, Compile, CallExpr.NoValue,
                                 CallExpr.IsNever, (* writable *)
                                 CallExpr.IsNever, (* designator *)
                                 NoteWrites);
    Procedure.Define ("NEW", Z, TRUE);
  END Initialize;

BEGIN
END New.