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

(* File: RefType.m3                                            *)
(* Last modified on Fri Sep  4 15:21:59 PDT 1992 by rustan     *)
(*      modified on Mon Mar  2 11:20:14 PST 1992 by kalsow     *)
(*      modified on Thu Dec  5 17:20:18 PST 1991 by muller     *)

MODULE RefType;

IMPORT Token, Type, TypeRep, Scanner, ObjectType, Target, Emit;
IMPORT Null, Reff, Addr, Error, Expr, Module, MBuf, TextExpr;
IMPORT String, OpaqueType, Revelation, Int, OpenArrayType, Frame;
IMPORT ProcType, ArrayType, ObjectAdr, RecordType, Scope, Word, M3;
IMPORT TrOffsets;

TYPE
  P = Type.T BRANDED "RefType.T"OBJECT
	brandE     : Expr.T;
	brand      : String.T;
	target     : Type.T;
      OVERRIDES
        check      := Check;
        base       := TypeRep.SelfBase;
        isEqual    := EqualChk;
        isSubtype  := Subtyper;
        count      := TypeRep.NotOrdinal;
        bounds     := TypeRep.NotBounded;
        size       := Sizer;
        minSize    := Sizer;
        alignment  := Aligner;
	isEmpty    := TypeRep.IsNever;
        dependsOn  := DependsOn;
        compile    := Compiler;
        initCost   := InitCoster;
        initValue  := GenInit;
        tracedOffs := TracedOffs;
        paramEncoding := TypeRep.ParamEncUndefined;
        mapper     := TypeRep.GenRefMap;
        fprint     := FPrinter;
        class      := MyClass;
      END;

TYPE
  BrandNode = BRANDED "RefType.BrandNode" REF RECORD
    next  : BrandNode;
    brand : String.T;
    type  : Type.T;
    error : BOOLEAN;
  END;

VAR root, WeirdPart : String.T;
VAR all_brands: ARRAY [0..97] OF BrandNode;

PROCEDURE Parse (READONLY fail: Token.Set): Type.T =
  VAR brand: Expr.T;  traced: BOOLEAN;  super: Type.T;
  BEGIN
    traced := TRUE;
    brand := NIL;
    super := NIL;
    IF (Scanner.cur.token = Token.T.tUNTRACED) THEN
      Scanner.GetToken (); (* UNTRACED *)
      IF (Scanner.cur.token = Token.T.tIDENT) THEN
        IF root = NIL THEN root := String.Add ("ROOT"); END;
	IF (Scanner.cur.string # root) THEN
	  Error.Str (Scanner.cur.string, "expected UNTRACED ROOT");
	END;
	Scanner.GetToken (); (* IDENT *)
	super := ObjectAdr.T;
	IF (Scanner.cur.token # Token.T.tOBJECT) THEN RETURN super END;
      END;
      traced := FALSE;
    END;
    brand := ParseBrand (fail + Token.Set {Token.T.tREF, Token.T.tOBJECT});
    IF (Scanner.cur.token = Token.T.tREF) THEN
      IF (super # NIL) THEN Error.Msg ("expected OBJECT declaration") END;
      Scanner.GetToken (); (* REF *)
      RETURN New (Type.Parse (fail), traced, brand);
    ELSE (* must be an object type *)
      RETURN ObjectType.Parse (super, traced, brand, fail);
    END;
  END Parse;

PROCEDURE New (target: Type.T;  traced: BOOLEAN;  brand: Expr.T): Type.T =
  VAR p: P;
  BEGIN
    p := NEW (P);
    TypeRep.Init (p);
    p.isTraced := traced;
    p.isLocalOnly := TRUE;
    p.hasUntraced := NOT traced;
    p.brandE   := brand;
    p.brand    := NIL;
    p.target   := target;
    RETURN p;
  END New;

PROCEDURE ParseBrand (READONLY fail: Token.Set): Expr.T =
  VAR brand: Expr.T;
  BEGIN
    brand := NIL;
    IF (Scanner.cur.token = Token.T.tBRANDED) THEN
      Scanner.GetToken (); (* BRANDED *)
      IF (Scanner.cur.token IN Token.ExprStart)
        THEN brand := Expr.Parse (fail);
        ELSE brand := GenerateBrand ();
      END;
    END;
    RETURN brand;
  END ParseBrand;

PROCEDURE GenerateBrand (): Expr.T =
  VAR brand: String.T;
  BEGIN
    IF WeirdPart = NIL THEN WeirdPart := String.Add ("_#$%^_"); END;
    brand := String.Concat (Module.CurrentName (), WeirdPart);
    RETURN TextExpr.New (String.Unique (brand));
  END GenerateBrand;

PROCEDURE Is (t: Type.T): BOOLEAN =
  BEGIN
    WHILE (t # NIL) DO
      t := Type.Strip (t);
      IF (TYPECODE (t) = TYPECODE (P)) THEN RETURN TRUE END;
      IF NOT OpaqueType.Is (t) THEN RETURN FALSE END;
      t := Revelation.LookUp (t);
    END;
    RETURN FALSE;
  END Is;

PROCEDURE IsBranded (t: Type.T): BOOLEAN =
  BEGIN
    WHILE (t # NIL) DO
      t := Type.Strip (t);
      IF (TYPECODE (t) = TYPECODE (P)) THEN
        RETURN (NARROW (t, P).brand # NIL);
      END;
      IF  NOT OpaqueType.Is (t) THEN RETURN FALSE END;
      t := Revelation.LookUp (t);
    END;
    RETURN FALSE;
  END IsBranded;

PROCEDURE Split (t: Type.T;  VAR target: Type.T): BOOLEAN =
  BEGIN
    WHILE (t # NIL) DO
      t := Type.Strip (t);
      TYPECASE t OF
      | NULL => RETURN FALSE;
      | P(p) => target := p.target; RETURN TRUE;
      ELSE
        IF  NOT OpaqueType.Is (t) THEN RETURN FALSE END;
        t := Revelation.LookUp (t);
      END;
    END;
    RETURN FALSE;
  END Split;

PROCEDURE NoteBrand (t: Type.T;  b: String.T) =
  VAR cell : INTEGER   := String.Hash (b) MOD NUMBER (all_brands);
  VAR node : BrandNode := all_brands[cell];
  BEGIN
    IF (b = NIL) OR (t = NIL) THEN RETURN END;
    LOOP
      IF (node = NIL) THEN
        (* add an entry to the table *)
        node := NEW (BrandNode, type := t, brand := b, error := FALSE);
        node.next := all_brands[cell];
        all_brands[cell] := node;
        RETURN;
      END;
      IF (node.brand = b) AND (node.type # t) THEN
        IF (t.origin # node.type.origin) THEN
          (* error, duplicate brand *)
          BrandError (t, b);
          IF NOT node.error THEN BrandError (node.type, b) END;
          node.error := TRUE;
        END;
        RETURN;
      END;
      node := node.next;
    END;
  END NoteBrand;

PROCEDURE BrandError (t: Type.T;  b: String.T) =
  VAR save := Scanner.offset;
  BEGIN
    Scanner.offset := t.origin;
    Error.Str (b, "duplicate brand");
    Scanner.offset := save;
  END BrandError;

PROCEDURE MyClass (<*UNUSED*> p: P): TypeRep.Class =
  BEGIN
    RETURN TypeRep.Class.Ref;
  END MyClass;

PROCEDURE Check (p: P) =
  VAR x: Expr.T;  hash: INTEGER;  cs := M3.OuterCheckState;
  BEGIN
    hash := 839;
    IF (p.brandE # NIL) THEN
      Expr.TypeCheck (p.brandE, cs);
      x := Expr.ConstValue (p.brandE);
      IF (x = NIL) THEN
        Error.Msg ("brand is not a constant");
      ELSIF TextExpr.Split (x, p.brand) THEN
        hash := Word.Plus (Word.Times (hash, 37), String.Hash (p.brand));
        NoteBrand (p, p.brand);
      ELSE
        Error.Msg ("brand is not a TEXT constant");
      END;
    END;
    p.hash := hash;

    p.checked := TRUE;
    INC (Type.recursionDepth); (*------------------------------------*)
      Type.Check (p.target);
    DEC (Type.recursionDepth); (*------------------------------------*)

    IF (NOT p.isTraced) AND (Type.IsTraced (p.target)) AND Module.IsSafe() THEN
      Error.Msg ("unsafe: untraced ref type to a traced type");
    END;
  END Check;

PROCEDURE Compiler (p: P) =
  VAR
    dims : INTEGER;
    size : INTEGER;
    alignment: INTEGER;
    elemSize: INTEGER;
    ta, tb: Type.T;
    prefix: String.Stack;
    depends: BOOLEAN;
    hasMapProc := FALSE;
    hasInitProc := FALSE;
    frame: Frame.T;
    prevEmitStream: Emit.Stream;  (* new KRML *)
  BEGIN
    depends := GenDecl (p);
    TypeRep.MarkCompiled (p);
    Type.Compile (p.target);

    (* import my type cell *)
    Emit.OpF ("_IMPORT _TYPE* @_TC;\n", p);

    IF TypeRep.StartLinkInfo (p) THEN RETURN END;
    Emit.OpF ("d@\n", p.target);

    (* C declaration *)
    IF (depends) THEN Emit.Op ("C\n") ELSE Emit.Op ("D\n") END;
    EVAL GenDecl (p);
    Emit.Op ("*\n");

    (* new KRML *)
    (** generate tracedOffsets **)
    IF p.isTraced THEN
      TrOffsets.Emit( Type.TracedOffsets( p.target ), TRUE)
    END;
    (* end KRML *)

    (*** KRML EVAL ***) prevEmitStream := (* new KRML *)
    Emit.Switch (Emit.Stream.TypeCells);

    (******************************************** KRML
    (** "map" procedure **)
    IF (p.isTraced) AND
       (Type.IsTraced (p.target) OR Type.HasUntraced (p.target)) THEN
      hasMapProc := TRUE;
      Frame.Push (frame, 4);
      (********* KRML
      Emit.OpF ("\n_LOCAL_PROC _VOID @_map (_p, _arg, _r, _mask)\n", p);
      ******* KRML *)
      (* new KRML *)
      Emit.OpF ("\n_EXPORT _VOID @_map_", p);
      WITH cn = Module.CurrentName() DO
        <* ASSERT cn # NIL *>
        Emit.OpS ("@ (_p, _arg, _r, _mask)\n", cn)
      END;
      (* end KRML *)
      Emit.Op  ("_VOID ( *_p) ();\n");
      Emit.Op  ("_ADDRESS _arg;\n");
      Emit.OpF ("@* _r;\n", p.target);
      Emit.Op  ("_MAPPROC_MASK _mask;\n{\001\n");
      EVAL Emit.SwitchToBody (); Emit.Op  ("\001");
      prefix.top := 1; prefix.stk [0] := String.Add ("( *_r)");
      Type.GenMap (p.target, prefix);
      Frame.Pop (frame);
    END;
    ****************************************** KRML *)

    (** "init" procedure **)
    IF (Type.InitCost (p.target, TRUE) # 0) THEN
      hasInitProc := TRUE;
      Frame.Push (frame, 1);
      (*** KRML Emit.OpF ("\n_LOCAL_PROC _VOID @_init (_ref)\n", p); *)
      (* new KRML *)
      Emit.OpF ("\n_EXPORT _VOID @_init_", p);
      WITH cn = Module.CurrentName() DO
        <* ASSERT cn # NIL *>
        Emit.OpS ("@ (_ref)\n", cn)
      END;
      (* end KRML *)
      Emit.OpF ("register @* _ref;\n{\001\n", p.target);
      EVAL Emit.SwitchToBody (); Emit.Op ("\001");
      prefix.top := 1; prefix.stk [0] := String.Add ("(*_ref)");
      Type.InitVariable (p.target, TRUE, prefix);
      Frame.Pop (frame);
    END;

    ta := Type.Base (p.target);
    dims := OpenArrayType.OpenDepth (ta);
    alignment := Type.Alignment (p.target);
    IF (dims = 0) THEN
      (* not an open array *)
      size := Type.Size (p.target);
      elemSize := 0;
    ELSE (* target is an open array *)
      WITH ai = Type.Alignment (Int.T), ae = Type.Alignment (p.target) DO
        size := Type.Size (Addr.T);         (* address of the elements *)
        size := ((size + ai - 1) DIV ai) * ai; (* align. for the sizes *)
        INC (size, Type.Size (Int.T) * dims);  (* the sizes *)
        size := ((size + ae - 1) DIV ae) * ae; (* align. for the elements *)
      END;
      tb := OpenArrayType.OpenType (ta);
      elemSize := Type.Size (tb);
    END;

    (* new KRML *)
    prevEmitStream := Emit.Switch( prevEmitStream );
    Emit.OpIII ("k@ @ @ ",  (* traced, dataSize, dataAlignment *)
                ORD (p.isTraced),
                MAX (size DIV Target.CHARSIZE, 1),
                MAX (alignment DIV Target.CHARSIZE, 1) );
    Emit.OpII ("0 @ @\n",   (* nMethods, nDimensions, elementSize *)
               dims, elemSize DIV Target.CHARSIZE);
    IF (p.brand # NIL) THEN
      Emit.OpS ("l@\n", p.brand)
    END;
    WITH cn = Module.CurrentName() DO
      IF hasInitProc THEN
        Emit.OpF ("n@_init", p);
        IF cn # NIL THEN Emit.OpS ("_@\n", cn) END
      END;
      IF hasMapProc THEN
        Emit.OpF ("n@_map", p);
        IF cn # NIL THEN Emit.OpS ("_@\n", cn) END
      END
    END;
    EVAL Emit.Switch( prevEmitStream );
    (* end KRML *)

    (* generate my Type cell info *)
    Emit.OpF  ("\n_IMPORT _TYPE @_tc;\n", p);  (* new KRML *)
(**************************** KRML
    Emit.OpF  ("\n_PRIVATE _TYPE @_tc = {\n", p);
    Emit.Op   ("  0, 0,\n");      (* typecode, lastSubTypeTC *)
    Emit.OpH  ("  0x@,\n",        (* selfID *)
                       Type.Name (p));
    Emit.OpF  ("  &@_TC,\n", p);  (* selfLink *)
    Emit.OpI  ("  0, @,\n",       (* fpInfo, traced *)
                       ORD (p.isTraced));
    Emit.OpII ("  0, @, @,\n",    (* dataOffset, dataSize, dataAlignment *)
                       MAX (size DIV Target.CHARSIZE, 1),
                       MAX (alignment DIV Target.CHARSIZE, 1));
    Emit.Op   ("  0, 0,\n");      (* methodOffset, methodSize *)
    Emit.OpII ("  @, @,\n",       (* nDimensions, elementSize *)
                       dims, elemSize DIV Target.CHARSIZE);
    Emit.Op   ("  0,\n");         (* defaultMethods *)
    Emit.Op   ("  0,\n");         (* setupProc *)
    IF (hasMapProc)               (* mapProc *)
      THEN Emit.OpF ("  @_map,\n", p);
      ELSE Emit.Op  ("  0,\n");
    END;
    IF (hasInitProc)              (* initProc *)
      THEN Emit.OpF ("  @_init,\n", p);
      ELSE Emit.Op  ("  0,\n");
    END;
    IF (p.brand # NIL)            (* brand *)
      THEN Emit.OpS ("  \"@\",\n", p.brand);
      ELSE Emit.Op  ("  0,\n");
    END;
    IF (p.declared # NIL) THEN    (* name *)
      Emit.Op  ("  \""); 
      Scope.GenName (p.declared, dots := TRUE);
      Emit.Op  ("\",\n");
    ELSE
      Emit.Op   ("  0,\n");
    END;
    Emit.Op   ("  0,\n");         (* parentLink *)
    Emit.Op   ("  0, 0, 0\n");    (* parent, children, sibling *)
    Emit.Op   ("};\n");
************************** KRML *)

  END Compiler;

PROCEDURE GenDecl (p: P): BOOLEAN =
  VAR ta, tb: Type.T;  fields: Scope.T;
  BEGIN
    IF RecordType.Split (p.target, fields) THEN
      Emit.OpFF ("typedef struct _rec@ *@;\n", p.target, p);
      RETURN FALSE;
    ELSIF ArrayType.Split (p.target, ta, tb) THEN
      Emit.OpFF ("typedef struct _array@ *@;\n", p.target, p);
      RETURN FALSE;
    ELSIF (p.target = NIL) THEN
      (* an open reference type: REFANY, ADDRESS, NULL, ... *)
      Emit.OpF ("typedef _ADDRESS @;\n", p);
      RETURN FALSE;
    ELSIF NOT Type.DependsOn (p.target, p) THEN
      Type.Compile (p.target);
      Emit.OpFF ("typedef @* @;\n", p.target, p);
      RETURN TRUE;
    ELSE (* T = REF T ? *)
      Emit.OpF ("typedef _ADDRESS @;\n", p);
      RETURN FALSE;
    END;
  END GenDecl;

PROCEDURE EqualChk (a: P;  t: Type.T;  x: Type.Assumption): BOOLEAN =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(b) => RETURN (a.isTraced = b.isTraced)
                 AND (a.brand = b.brand)
		 AND Type.IsEqual (a.target, b.target, x);
    ELSE      RETURN FALSE;
    END;
  END EqualChk;

PROCEDURE Subtyper (a, b: Type.T): BOOLEAN =
  BEGIN
    IF Type.IsEqual (a, b, NIL) THEN RETURN TRUE END;

    IF Type.IsEqual (a, Null.T, NIL) THEN
      RETURN Type.IsSubtype (b, Reff.T)
          OR Type.IsSubtype (b, Addr.T)
          OR ProcType.Is (b);
    END;

    RETURN ((a.isTraced) AND Type.IsEqual (b, Reff.T, NIL))
        OR ((NOT a.isTraced) AND Type.IsEqual (b, Addr.T, NIL));
  END Subtyper;

PROCEDURE Sizer (<*UNUSED*> t: Type.T): INTEGER =
  BEGIN
    RETURN Target.ADDRSIZE;
  END Sizer;

PROCEDURE Aligner (<*UNUSED*> t: Type.T): INTEGER =
  BEGIN
    RETURN Target.ADDRALIGN;
  END Aligner;

PROCEDURE DependsOn (p: P;  t: Type.T): BOOLEAN =
  BEGIN
    RETURN Type.DependsOn (p.target, t);
  END DependsOn;

PROCEDURE InitCoster (<*UNUSED*>p: P;  zeroed: BOOLEAN): INTEGER =
  BEGIN
    IF NOT zeroed THEN RETURN 1 ELSE RETURN 0 END;
  END InitCoster;

PROCEDURE GenInit (p: P) =
  BEGIN
    Emit.OpF ("(@)_NIL", p);
  END GenInit;

PROCEDURE TracedOffs (p: P;  offset: CARDINAL): TrOffsets.T =
  BEGIN
    IF p.isTraced THEN
      RETURN TrOffsets.New( offset )
    ELSE
      RETURN NIL
    END
  END TracedOffs;

PROCEDURE FPrinter (p: P;  map: Type.FPMap;  wr: MBuf.T) =
  BEGIN
    IF Type.IsEqual (p, Reff.T, NIL) THEN
      MBuf.PutText (wr, "$refany");
    ELSIF Type.IsEqual (p, Addr.T, NIL) THEN
      MBuf.PutText (wr, "$address");
    ELSIF Type.IsEqual (p, Null.T, NIL) THEN
      MBuf.PutText (wr, "$null");
    ELSE
      MBuf.PutText (wr, "REF ");
      IF (NOT p.isTraced) THEN MBuf.PutText (wr, "UNTRACED ") END;
      IF (p.brand # NIL) THEN
        MBuf.PutText (wr, "BRAND(");
        String.Put (wr, p.brand);
        MBuf.PutText (wr, ") ");
      END;
      Type.Fingerprint (p.target, map, wr);
    END;
  END FPrinter;

BEGIN
END RefType.