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

(* File: Field.m3                                              *)
(* Last modified on Tue Sep  8 10:58:30 PDT 1992 by kalsow     *)
(*      modified on Fri Apr 20 06:47:07 1990 by muller         *)

MODULE Field;

IMPORT Value, ValueRep, Type, String, Expr, Error, SubrangeType;
IMPORT AssignStmt, MBuf, PackedType, Emit, ArrayType, EnumType;

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

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

PROCEDURE New (name: String.T;  offset: INTEGER;
                 type: Type.T;  dfault: Expr.T): Value.T =
  VAR t: T;
  BEGIN
    t := Create (name);
    t.offset  := offset;
    t.tipe    := type;
    t.dfault  := dfault;
    RETURN t;
  END New;

PROCEDURE Split (field: Value.T;  VAR offset: INTEGER;
                                                  VAR type: Type.T): BOOLEAN =
  BEGIN
    TYPECASE field OF
    | NULL =>  RETURN FALSE;

    | T(t) =>  offset  := t.offset;
               type    := t.tipe;
               RETURN TRUE;

    ELSE RETURN FALSE;
    END;
  END Split;

PROCEDURE SplitX (field: Value.T;  VAR offset: INTEGER;  VAR type: Type.T) =
  VAR t: T := field;
  BEGIN
    offset  := t.offset;
    type    := t.tipe;
  END SplitX;

PROCEDURE GetDefault (field: Value.T): Expr.T =
  BEGIN
    TYPECASE field OF
    | NULL =>  RETURN NIL;
    | T(t) =>  RETURN t.dfault;
    ELSE       RETURN NIL;
    END;
  END GetDefault;

PROCEDURE SetOffset (field: Value.T;  newOffset: INTEGER) =
  BEGIN
    NARROW (field, T).offset := newOffset;
  END SetOffset;

PROCEDURE NeedsSignExtension (field: Value.T): BOOLEAN =
  VAR t: T := field;  bits, min, max: INTEGER;  type: Type.T;
  BEGIN
    IF NOT PackedType.Split (t.tipe, bits, type) THEN
      RETURN FALSE;
    ELSIF EnumType.Is (type) THEN
      RETURN TRUE;
    ELSIF SubrangeType.Split (type, min, max) THEN
      RETURN (min >= 0) AND (max >= 0)
    ELSE (* non-ordinal *)
      RETURN FALSE;
    END;
  END NeedsSignExtension;

PROCEDURE EmitDeclaration (field: Value.T) =
  VAR t: T := field;  bits, min, max: INTEGER;  type: Type.T;
  BEGIN
    Type.Compile (t.tipe);
    IF NOT PackedType.Split (t.tipe, bits, type) THEN
      Emit.OpF ("@ ", t.tipe);
      Emit.OpS ("@;\n", t.name);
    ELSIF EnumType.Is (type) THEN
      IF (Type.MinSize (type) < bits)
        THEN Emit.Op ("signed_");
        ELSE Emit.Op ("unsigned ");
      END;
      Emit.OpSI ("int @ : @;\n", t.name, bits);
    ELSIF SubrangeType.Split (type, min, max) THEN
      IF (min < 0) OR (max < 0) OR (Type.MinSize (type) < bits)
        THEN Emit.Op ("signed_");
        ELSE Emit.Op ("unsigned ");
      END;
      Emit.OpSI ("int @ : @;\n", t.name, bits);
    ELSE (* non-ordinal *)
      <* ASSERT bits = Type.Size (type) *>
      Emit.OpF ("@ ", type);
      Emit.OpS ("@;\n", t.name);
    END;
  END EmitDeclaration;

PROCEDURE IsEqual (va, vb: Value.T;  x: Type.Assumption): BOOLEAN =
  VAR a: T := va;  b: T := vb;
  BEGIN
    RETURN (a # NIL) AND (b # NIL)
       AND (a.name = b.name)
       AND (a.offset = b.offset)
       AND Type.IsEqual (a.tipe, b.tipe, x)
       AND Expr.IsEqual (Expr.ConstValue (a.dfault),
                         Expr.ConstValue (b.dfault));
  END IsEqual;

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 TypeCheck (t: T;  VAR cs: Value.CheckState) =
  VAR index, elt: Type.T;
  BEGIN
    Type.Check (TypeOf (t));
    IF Type.IsEmpty (t.tipe) THEN
      Error.Str (t.name, "empty field type");
    END;
    IF ArrayType.Split (t.tipe, index, elt) AND (index = NIL) THEN
      Error.Str (t.name, "fields may not be open arrays");
    END;
    t.checked := TRUE;

    IF (t.dfault # NIL) THEN
      (* check for assignability!! *)
      t.dfault := AssignStmt.CheckRHS (t.tipe, t.dfault, cs);
      Expr.TypeCheck (t.dfault, cs);
      IF (Expr.ConstValue (t.dfault) = NIL) THEN
        Error.Str (t.name, "default is not a constant");
      END;
      (* NOTE: we don't save the constant-folded version of the default,
         otherwise we'd loose references to large named constants. *)
    END;
  END TypeCheck;

PROCEDURE Compile (t: T) =
  BEGIN
    Type.Compile (t.tipe);
  END Compile;

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

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

PROCEDURE FPrinter (t: T;  map: Type.FPMap;  wr: MBuf.T) =
  BEGIN
    MBuf.PutText (wr, "FIELD ");
    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 Field.