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

(* File: New.m3                                                *)
(* Last Modified On Thu Apr  5 03:29:16 1990 By muller         *)
(*      Modified On Mon Feb 12 09:29:56 1990 By kalsow         *)


MODULE New;

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

VAR
  Z: CallExpr.MethodList;


PROCEDURE Bind (<*UNUSED*> proc: Expr.T; args: Expr.List): Type.T =
  VAR t: Type.T;
  BEGIN
    IF TypeExpr.Split (args[0], t)
      THEN RETURN t;
      ELSE RETURN Null.T;
    END;
  END Bind;

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

PROCEDURE CheckRef (r: Type.T; args: Expr.List) =
  VAR index, elt: Type.T; fields: Scope.T;
  BEGIN
    IF (r = NIL) OR Type.IsEqual (r, Void.T) THEN
      Error.Msg ("cannot allocate an open reference type");
    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);
    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, index, elt: Type.T;
  BEGIN
    FOR i := 1 TO LAST (args^) DO
      x := Type.Base (Expr.TypeOf (args[i]));
      IF  NOT Type.IsEqual (x, Int.T) THEN
        Error.Int (i, "argument must be an integer");
      ELSIF ( NOT ArrayType.Split (r, index, elt)) OR (index # NIL) THEN
        Error.Int (i, "too many dimensions specified");
      ELSE (* ok *)
        r := elt;
      END;
    END;
    IF ArrayType.Split (r, index, elt) AND (index = NIL) THEN
      Error.Msg ("not enough dimensions specified");
    END;
  END CheckOpenArray;

PROCEDURE CheckRecord (t: Type.T; args: Expr.List) =
  VAR
    x: Type.T;
    key: String.T;
    value: Expr.T;
    field: Value.T;
    sig: Type.T;
    offset: INTEGER;
    defaultE: Expr.T;
    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, defaultE) 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);
        IF (expr # value) THEN
	  args[i] := KeywordExpr.New (key, expr);
	  Expr.Bind (args[i]);
	  Expr.TypeCheck (args[i]);
        END;
        x := Expr.TypeOf (args[i]);
      END;
    END;
  END CheckRecord;

PROCEDURE CheckObject (t: Type.T; args: Expr.List) =
  VAR
    x: Type.T;
    key: String.T;
    value: Expr.T;
    field: Value.T;
    visible: Type.T;
    opaque: Type.T;
    sig: Type.T;
    default: Value.T;
    offset: INTEGER;
    defaultE: Expr.T;
    expr: Expr.T;
    override: BOOLEAN;
  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 ObjectType.LookUp (t, key, field, visible, opaque) THEN
        Error.Str (key, "unknown object field or method");
      ELSIF Method.Split (field, override, sig, default) THEN
        IF  NOT ProcType.IsCompatible (x, t, sig) THEN
          Error.Str (key, "procedure is not compatible with method");
        END;
	IF AssignStmt.NeedsClosureCheck (value) THEN
	  args[i] := KeywordExpr.New (key, ProcCheckExpr.New (value));
	  Expr.Bind (args[i]);
	  Expr.TypeCheck (args[i]);
	END;
      ELSIF Field.Split (field, offset, sig, defaultE) THEN
        IF  NOT Type.IsAssignable (sig, x) THEN
          Error.Str (key, "value is not assignable to field");
        ELSE
          expr := AssignStmt.CheckRHS (sig, value);
          IF (expr # value) THEN
	    args[i] := KeywordExpr.New (key, expr);
	    Expr.Bind (args[i]);
	    Expr.TypeCheck (args[i]);
          END;
          x := Expr.TypeOf (args[i]);
        END;
      ELSE
        Error.Str (key, "undefined?");
      END;
    END;
  END CheckObject;

PROCEDURE CheckOpaque (t: Type.T; args: Expr.List) =
  VAR x: Type.T;
  BEGIN
    x := t;
    WHILE (OpaqueType.Is (x)) DO x := Type.Base (OpaqueType.Super (x));  END;
    IF ObjectType.Is (x) THEN
      CheckObject (t, args);
    ELSIF (NUMBER (args^) > 1) THEN
      Error.Msg ("too many arguments to NEW");
    END;
  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;
    x := Temp.AllocEmpty (t);
    IF (RefType.Split (t, r)) THEN GenRef (t, r, args, x);
    ELSIF (ObjectType.Is (t)) THEN GenObject (t, args, x);
    ELSIF (OpaqueType.Is (t)) THEN GenOpaque (t, args, x);
    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; result: Temp.T) =
  VAR index, elt: Type.T; i: INTEGER; traced: BOOLEAN; fields: Scope.T;
  BEGIN
    traced := Type.IsTraced (t);
    IF ArrayType.Split (r, index, elt) AND (index = NIL) THEN
      GenOpenArray (t, r, traced, args, result);
    ELSIF RecordType.Split (r, fields) THEN
      GenRecord (t, r, traced, args, result);
    ELSE
      i := Type.Name (t);
      Emit.OpT ("@ = ", result);
      Emit.OpI ("(t@) ", i);
      IF traced THEN Emit.Op ("T") ELSE Emit.Op ("U") END;
      Emit.OpI ("NEW (TC@);\n", i);
    END;
  END GenRef;

PROCEDURE GenOpenArray
  (t, r: Type.T; traced: BOOLEAN; args: Expr.List; result: Temp.T) =
  VAR
    x: Type.T;
    j, n: INTEGER;
    tmp: Temp.T;
    prefix: String.Stack;
  BEGIN
    (* get the final element type *)
    x := ArrayType.OpenType (r);

    (* allocate the local variables *)
    n := LAST (args^);
    Emit.Op ("{\001\n");
    Emit.OpI ("register t@* ptr;\n", Type.Name (ArrayType.OpenImpl (r)));
    Emit.OpI ("int sz[@];\n", n);
    FOR i := 1 TO n DO
      tmp := Expr.Compile (args[i]);
      Emit.OpI ("sz[@] = ", i - 1);
      Emit.OpT ("@;\n", tmp);
      Temp.Free (tmp);
    END;
    (* allocate the storage *)
    Emit.OpI ("ptr = (t@*) ", Type.Name (ArrayType.OpenImpl (r)));
    IF (traced) THEN Emit.Op ("TNEWA") ELSE Emit.Op ("UNEWA") END;
    Emit.OpII ("(TC@, @ + ", Type.Name (t), 
               (n + 1) * Target.INTSIZE DIV Target.CHARSIZE);
    FOR i := 1 TO n DO Emit.OpI ("sz[@] * ", i - 1) END;
    Emit.OpI ("@);\n", Type.Size (x) DIV Target.CHARSIZE);
    (* initialize the array's header *)
    Emit.OpI ("ptr->elts = (char*)(& ptr->size[@]);\n", n);
    FOR i := 0 TO n - 1 DO
      Emit.OpII ("ptr->size[@] = sz[@];\n", i, i)
    END;
    (* finally, initialize the array elements *)
    IF (Type.InitCost (x, TRUE) > 0) THEN
      j := Type.Name (x);
      Emit.Op ("{\001\nregister int index;\n");
      Emit.OpII ("register t@* aelt = (t@*) ptr->elts;\n", j, j);
      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\002};\n");
    END;
    (* give the user his object *)
    Emit.OpTI ("@ = (t@) ptr;\n", result, Type.Name (t));
    Emit.Op ("\002};\n");
  END GenOpenArray;

PROCEDURE GenRecord
  (t, r: Type.T; traced: BOOLEAN; args: Expr.List; result: Temp.T) =
  VAR
    x: Type.T;
    key: String.T;
    value: Expr.T;
    rName: INTEGER;
    tName: INTEGER;
    tmp: Temp.T;
  BEGIN
    rName := Type.Name (r);
    tName := Type.Name (t);
    (* allocate the record's storage *)
    Emit.OpII ("{\001\nregister t@* ptr = (t@*) ", rName, rName);
    IF (traced) THEN Emit.Op ("T") ELSE Emit.Op ("U") END;
    Emit.OpI ("NEW (TC@);\n", tName);
    (* 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);
      Emit.OpS ("ptr->_@", key);
      Emit.OpT (" = @;\n", tmp);
      Temp.Free (tmp);
    END;
    (* finally, give the object to the user *)
    Emit.OpTI ("@ = (t@) ptr;\n\002};\n", result, tName);
  END GenRecord;

PROCEDURE GenObject (t: Type.T; args: Expr.List; result: Temp.T) =
  VAR
    x: Type.T;
    key: String.T;
    value: Expr.T;
    field: Value.T;
    visible: Type.T;
    opaque: Type.T;
    sig: Type.T;
    default: Value.T;
    offset: INTEGER;
    defaultE: Expr.T;
    override: BOOLEAN;
    sharedM: BOOLEAN;
    tmp: Temp.T;
  BEGIN
    (* allocate the object's storage & its method list *)
    Emit.Op ("{\001\nregister char** ptr = (char**) ");
    IF Type.IsTraced (t) THEN Emit.Op ("T") ELSE Emit.Op ("U") END;
    Emit.OpI ("NEWOBJ (TC@);\n", Type.Name (t));
    (* do the user specified initialization *)
    sharedM := TRUE; (* so far, a shared method suite *)
    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;
      VAR b: BOOLEAN := ObjectType.LookUp (t, key, field, visible, opaque);
      BEGIN <* ASSERT b *> END;
      tmp := Expr.Compile (value);
      IF Method.Split (field, override, sig, default) THEN
        IF (sharedM) THEN
          Emit.OpI ("CLONE_METHOD_SUITE (ptr, TC@);\n", Type.Name (t));
          sharedM := FALSE;
        END;
        Emit.OpI ("((t@_methods*)((*ptr) + (", Type.Name (visible));
        IF (opaque # NIL) THEN
          Emit.OpI ("TC@->methodsize + ", Type.Name (opaque));
        END;
        ObjectType.EmitOffsets (visible, opaque, TRUE);
        Emit.Op  (")))");
      ELSE
        <* ASSERT Field.Split (field, offset, sig, defaultE) *>
        Emit.OpI ("((t@_fields*)((char*)ptr + (", Type.Name (visible));
        IF (opaque # NIL) THEN
          Emit.OpI ("TC@->datasize + ", Type.Name (opaque));
        END;
	ObjectType.EmitOffsets (visible, opaque, FALSE);
	Emit.Op  (")))");
      END;
      Emit.OpS ("->_@", key);
      Emit.OpT (" = @;\n", tmp);
      Temp.Free (tmp);
    END;
    (* finally, give the object to the user *)
    Emit.OpTI ("@ = (t@) ptr;\n\002};\n", result, Type.Name (t));
  END GenObject;

PROCEDURE GenOpaque (t: Type.T; args: Expr.List; result: Temp.T) =
  VAR x: Type.T; i: INTEGER;
  BEGIN
    x := t;
    WHILE (OpaqueType.Is (x)) DO x := Type.Base (OpaqueType.Super (x));  END;
    IF ObjectType.Is (x) THEN
      GenObject (t, args, result);
    ELSE
      i := Type.Name (Expr.TypeOf (args[0]));
      Emit.OpTI ("@ = (t@) ", result, i);
      IF (Type.IsTraced (t)) THEN Emit.Op ("T") ELSE Emit.Op ("U") END;
      Emit.OpI ("NEW (TC@);\n", i);
    END;
  END GenOpaque;

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

BEGIN
END New.