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

(* File: ObjectType.m3                                         *)
(* Last modified on Fri Sep  4 15:21:31 PDT 1992 by rustan     *)
(*      modified on Mon Jun  8 08:30:12 PDT 1992 by kalsow     *)
(*      modified on Thu Dec  5 17:22:00 PST 1991 by muller     *)

MODULE ObjectType;

IMPORT Type, TypeRep, Scope, Expr, String, Target, Emit, Method;
IMPORT Value, Error, RecordType, ProcType, OpaqueType, Revelation;
IMPORT Field, Reff, Addr, RefType, Word, M3, TextExpr, Frame, MBuf;
IMPORT ObjectAdr, ObjectRef, Token, Temp, Module;
IMPORT TrOffsets, Formal, ESet, ParamCode, Text;
FROM Scanner IMPORT Match, Match1, GetToken, cur;

CONST
  Unknown_offset = -1;
  Unchecked_offset = -2;

TYPE
  P = Type.T BRANDED "ObjectType.T" OBJECT
        brandE       : Expr.T;
        brand        : String.T;
        superType    : Type.T;
        fields       : Scope.T;
        fieldOffset  : INTEGER;
        fieldSize    : INTEGER;
        fieldAlign   : INTEGER;
        methods      : Scope.T;
        nNewMethods  : INTEGER;
        methodOffset : INTEGER;
        isNetworkT   : BOOLEAN;
      OVERRIDES
        check      := Check;
        base       := TypeRep.SelfBase;
        isEqual    := EqualChk;
        isSubtype  := Subtyper;
        isNetworkType := NetworkTyper;
        count      := TypeRep.NotOrdinal;
        bounds     := TypeRep.NotBounded;
        size       := Sizer;
        minSize    := Sizer;
        alignment  := Aligner;
	isEmpty    := TypeRep.IsNever;
        dependsOn  := TypeRep.DependsOnNone;
        compile    := Compiler;
        initCost   := InitCoster;
        initValue  := GenInit;
        tracedOffs := TracedOffs;
        paramEncoding := ParamEnc;
        mapper     := TypeRep.GenRefMap;
        fprint     := FPrinter;
        class      := MyClass;
      END;

PROCEDURE Parse (sup: Type.T;  traced: BOOLEAN;  brand: Expr.T;
                                            READONLY fail: Token.Set): Type.T =
  TYPE TK = Token.T;
  VAR p: P;  fail2: Token.Set;
  BEGIN
    fail2 := fail + Token.Set {TK.tMETHODS, TK.tOVERRIDES, TK.tEND};
    LOOP
      p := New (sup, traced, brand, NIL, NIL);
      Match (TK.tOBJECT, fail2, fail2);

      p.fields := Scope.PushNew (FALSE, NIL);
      RecordType.ParseFieldList (fail2);
      Scope.PopNew ();

      p.methods := Scope.PushNew (FALSE, NIL);
      IF (cur.token = TK.tMETHODS) THEN
        GetToken (); (* METHODS *)
        ParseMethodList (p, fail2, overrides := FALSE);
      END;
      IF (cur.token = TK.tOVERRIDES) THEN
        GetToken (); (* OVERRIDES *)
        ParseMethodList (p, fail2, overrides := TRUE);
      END;
      Scope.PopNew ();

      Match1 (TK.tEND, fail);
      brand := RefType.ParseBrand (fail + Token.Set {TK.tOBJECT, TK.tMETHODS});
      IF (cur.token # TK.tOBJECT) THEN
        IF (brand # NIL) THEN Error.Msg ("dangling brand") END;
        EXIT;
      END;
      sup := p;
      traced := FALSE;
    END;
    RETURN p;
  END Parse;

PROCEDURE ParseMethodList (p: P;  READONLY fail: Token.Set; 
                           overrides := FALSE) =
  TYPE TK = Token.T;
  VAR id: String.T;  sig: Type.T;  proc: Expr.T;  offset: INTEGER := 0;
  BEGIN
    WHILE (cur.token = TK.tIDENT) DO
      id := cur.string;
      GetToken (); (* ID *)

      sig := NIL;
      IF (cur.token = TK.tLPAREN) THEN
        sig := ProcType.ParseSignature (fail + Token.ExprStart
                                           + Token.Set {TK.tASSIGN, TK.tSEMI},
                                        NIL);
      END;

      proc := NIL;
      IF (cur.token = TK.tEQUAL) THEN
        Error.Msg ("default value must begin with ':='");
        cur.token := TK.tASSIGN;
      END;
      IF cur.token = TK.tASSIGN THEN
        GetToken (); (* := *)
        proc := Expr.Parse (fail + Token.Set {TK.tSEMI});
      END;

      IF overrides THEN
        IF sig # NIL THEN
          Error.Str (id, "overrides cannot have a signature");
        ELSIF proc = NIL THEN
          Error.Str (id, "missing default value in method override");
        END;
      ELSE 
        IF sig = NIL THEN
          Error.Str (id, "missing method signature (old override?)");
        END;
      END;
      
      EVAL Method.New (id, offset, p, sig, proc);
      INC (offset);

      IF (cur.token # TK.tSEMI) THEN EXIT END;
      GetToken (); (* ; *)
    END;
  END ParseMethodList;

PROCEDURE New (super: Type.T;  traced: BOOLEAN;  brand: Expr.T;
                                            fields, methods: Scope.T): Type.T =
  VAR p: P;
  BEGIN
    IF (super = NIL) THEN
      IF (traced)
        THEN super := ObjectRef.T;
	ELSE super := ObjectAdr.T;
      END;
    END;
    p := NEW (P);
    TypeRep.Init (p);
    p.isTraced     := traced;
    p.hasUntraced  := NOT traced;
    p.brandE       := brand;
    p.brand        := NIL;
    p.superType    := super;
    p.fields       := fields;
    p.fieldOffset  := Unchecked_offset;
    p.fieldSize    := -1;
    p.fieldAlign   := -1;
    p.methods      := methods;
    p.nNewMethods  := 0;
    p.methodOffset := Unchecked_offset;
    RETURN p;
  END New;

PROCEDURE Is (t: Type.T): BOOLEAN =
  VAR l, m: Revelation.TypeList; u:  Type.T;
  BEGIN
    IF (t = NIL) THEN RETURN FALSE END;
    t := Type.Strip (t);

    (* try for TYPE t = OBJECT ... END *)
    IF (TYPECODE (t) = TYPECODE (P)) THEN RETURN TRUE END;

    IF NOT OpaqueType.Is (t) THEN RETURN FALSE END;

    (* try for TYPE t <: ObjectType *)
    u := OpaqueType.Super (t);
    IF Is (u) THEN RETURN TRUE END;

    (***************    
    (* try for REVEAL t = OBJECT ... END *)
    u := Type.Strip (Revelation.LookUp (t));
    IF (TYPECODE (u) = TYPECODE (P)) THEN RETURN TRUE END;
    ********************)

    l := Revelation.LookUpAll (t);

    (* try for REVEAL t <: OBJECT ... END *)
    m := l;
    WHILE (m # NIL) DO
      IF (TYPECODE (Type.Strip (m.type)) = TYPECODE (P)) THEN RETURN TRUE END;
      m := m.next;
    END;

    (* try for REVEAL t <: U where U is an object type *)
    m := l;
    WHILE (m # NIL) DO
      IF Is (m.type) THEN RETURN TRUE END;
      m := m.next;
    END;

    RETURN FALSE;
  END Is;

PROCEDURE IsBranded (t: Type.T): BOOLEAN =
  VAR u: Type.T;
  BEGIN
    IF (t = NIL) THEN RETURN FALSE END;
    t := Type.Strip (t);

    (* try for TYPE t = BRANDED OBJECT ... END *)
    IF (TYPECODE (t) = TYPECODE (P)) THEN
      RETURN (NARROW (t, P).brand # NIL);
    END;

    IF NOT OpaqueType.Is (t) THEN RETURN FALSE END;

    (* try for REVEAL t = BRANDED OBJECT ... END *)
    u := Revelation.LookUp (t);
    IF (u = NIL) THEN RETURN FALSE END;
    u := Type.Strip (u);
    IF (TYPECODE (u) = TYPECODE (P)) THEN
      RETURN (NARROW (u, P).brand # NIL);
    END;

    RETURN FALSE;
  END IsBranded;

PROCEDURE Super (t: Type.T): Type.T =
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN NIL;
    | P(p) => RETURN p.superType;
    ELSE      RETURN NIL;
    END;
  END Super;

PROCEDURE LookUp (t: Type.T; id: String.T;
                           VAR value: Value.T;  VAR visible: Type.T): BOOLEAN =
  VAR p: P;  v: Value.T;  l: Revelation.TypeList;  z: Type.T;
  BEGIN
    LOOP
      t := Type.Strip (t);

      IF (t = NIL) THEN
        RETURN FALSE;

      ELSIF (TYPECODE (t) = TYPECODE (P)) THEN
        (* found an object type => try it! *)
        p := t;
        v := Scope.LookUp (p.methods, id, TRUE);
        IF (v # NIL) THEN
          (* find the first non-override declaration for this method *)
          p := PrimaryMethodDeclaration (p, v, id);
          IF (p = NIL) THEN RETURN FALSE END;
        ELSE
          (* try for a field *)
          v := Scope.LookUp (p.fields, id, TRUE);
        END;
        IF (v # NIL) THEN
          value   := v;
          visible := p;
          RETURN TRUE;
        END;
        t := p.superType;

      ELSIF OpaqueType.Is (t) THEN
        (* try any revelations that are visible *)
	z := Revelation.LookUp (t);
	IF (z # NIL) THEN
	  (* use the concrete type *)
	  t := z;
	ELSE
          (* try any subtype revelations that are visible *)
          l := Revelation.LookUpAll (t);
          WHILE (l # NIL) DO
            IF LookUp(l.type, id, value, visible) THEN RETURN TRUE END;
            l := l.next;
          END;
          t := OpaqueType.Super (t);
	END;

      ELSE (* ??? *)
        RETURN FALSE;
      END;

    END; (* LOOP *)
  END LookUp;

PROCEDURE PrimaryMethodDeclaration (p: P;  v: Value.T;  name: String.T): P =
  VAR offset: INTEGER;  override: BOOLEAN;  t, visible: Type.T;  obj: Value.T;
  BEGIN
    Method.SplitX (v, offset, override, t);
    IF NOT override THEN RETURN p END;
    IF LookUp (p.superType, name, obj, visible) THEN RETURN visible END;
    RETURN NIL;
  END PrimaryMethodDeclaration;

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

PROCEDURE Check (p: P) =
  VAR
    super    : Type.T;
    x        : Expr.T;
    objs     : Scope.ValueList;
    names    : Scope.NameList;
    name     : String.T;
    n        : INTEGER;
    o, v     : Value.T;
    sig      : Type.T;
    override : BOOLEAN;
    t1       : Type.T;
    hash     : INTEGER;
    offset   : INTEGER;
    cs := M3.OuterCheckState;
  BEGIN
    hash := 0;

    (* check out my super type *)
    Type.Check (p.superType);
    super := Type.Strip (p.superType);
    IF (super = NIL) THEN
      (* no super type specified *)
    ELSIF Is (super) THEN
      (* super type is an object type *)
      p.isTraced := super.isTraced;
      hash := Word.Times (super.hash, 37);
    ELSE
      (* super type isn't an object! *)
      Error.Msg ("super type must be an object type");
      p.superType := NIL;
      p.isTraced  := super.isTraced;
    END;

    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));
        RefType.NoteBrand (p, p.brand);
      ELSE
        Error.Msg ("brand is not a TEXT constant");
      END;
    END;

    p.isNetworkT := Type.IsNetworkType( super );
    p.isLocalOnly := NOT p.isNetworkT;

    (* include the fields my hash value *)
    Scope.ToListWithAliases (p.fields, objs, n, names);
    FOR i := 0 TO n - 1 DO
      o := objs[i];
      IF (names = NIL)
        THEN name := Value.CName (o);
        ELSE name := names[i];
      END;
      hash := Word.Plus (Word.Times (hash, 23), String.Hash (name));
      Field.SetOffset (o, i);
      hash := Word.Plus (Word.Times (hash, 23), i);
      IF (Scope.LookUp (p.methods, name, TRUE) # NIL) THEN
        Error.Str (name, "field and method with the same name");
      END;
    END;

    (* include the methods in my hash value *)
    Scope.ToListWithAliases (p.methods, objs, n, names);
    FOR i := 0 TO n - 1 DO
      IF (names = NIL)
        THEN name := Value.CName (objs[i]);
        ELSE name := names[i];
      END;
      hash := Word.Plus (Word.Times (hash, 23), String.Hash (name));
      hash := Word.Plus (Word.Times (hash, 23), 617);
    END;
    p.hash := hash;

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

      (* bind method overrides to their original declarations *)
      Scope.ToListWithAliases (p.methods, objs, n, names);
      p.nNewMethods := n;
      FOR i := 0 TO n - 1 DO
        o := objs[i];
        IF (names = NIL)
          THEN name := Value.CName (o);
          ELSE name := names[i];
        END;
        Method.SplitX (o, offset, override, sig);
        IF (override) THEN
          IF LookUp (super, name, v, t1)
            AND Method.Split (v, offset, override, sig) THEN
            DEC (p.nNewMethods);
            Method.NoteOverride (o, v);
          ELSE
            Error.Str (name, "no method to override in supertype");
          END;
        END;
      END;

      (* checkout my fields & methods *)
      Scope.TypeCheck (p.fields, cs);
      Scope.TypeCheck (p.methods, cs);

    DEC (Type.recursionDepth); (*------------------------------------*)

    IF (NOT p.isTraced) AND Module.IsSafe() THEN CheckTracedFields (p) END;
  END Check;

PROCEDURE CheckTracedFields (p: P) =
  VAR fields: Scope.ValueList;  nFields: INTEGER;
  BEGIN
    Scope.ToList (p.fields, fields, nFields);
    FOR i := 0 TO nFields-1 DO
      IF Type.IsTraced (Value.TypeOf (fields[i])) THEN
        Error.Str (Value.CName (fields[i]),
                   "unsafe: untraced object contains a traced field");
      END;
    END;
  END CheckTracedFields;

PROCEDURE CheckNetworkMethods (p: P): BOOLEAN =
  PROCEDURE Err( s: String.T; t: TEXT ) =
    BEGIN
      Error.Str( s, t );  good := FALSE
    END Err;
  VAR
    objs     : Scope.ValueList;
    names    : Scope.NameList;
    name     : String.T;
    n        : INTEGER;
    o        : Value.T;
    sig      : Type.T;
    override : BOOLEAN;
    offset   : INTEGER;
    formals  : Scope.ValueList;
    fCnt     : INTEGER;
    info     : Formal.Info;
    good     : BOOLEAN := TRUE;
  BEGIN
    Scope.ToListWithAliases (p.methods, objs, n, names);
    FOR i := 0 TO n - 1 DO
      o := objs[i];
      IF (names = NIL)
        THEN name := Value.CName (o);
        ELSE name := names[i]
      END;
      Method.SplitX (o, offset, override, sig);
      IF NOT override THEN
        Scope.ToList( ProcType.Formals( sig ), formals, fCnt );
        FOR i := 0 TO fCnt - 1 DO
          Formal.Split( formals[i], info );
          IF Type.IsLocalOnly( info.type ) THEN
            Err( info.name, "parameter is local-only" )
          END;
          IF info.mode # Formal.Mode.mVALUE THEN
            Err( info.name, "parameter mode is not VALUE" )
          END
        END;

        WITH retType = ProcType.Result( sig ) DO
          IF Type.IsLocalOnly( retType ) THEN
            Err( name, "result type is local-only" )
          ELSIF Type.Size( retType ) > Target.INTSIZE OR
                ProcType.LargeResult( retType )
          THEN
            Err( name, "Mosaic Modula-3D restriction: " &
                       "this return type disallowed" )
          END
        END;

        ESet.CheckLocalOnly( ProcType.Raises( sig ), name )
      END
    END;
    RETURN good
  END CheckNetworkMethods;

PROCEDURE Compiler (p: P) =
  VAR
    nFields, nMethods, nNewMethods: INTEGER;
    fields, methods: Scope.ValueList;
    mNames: Scope.NameList;
    (* new KRML *)
    saveXfile: Emit.Stream;
    hasInitProc: BOOLEAN;  
    (* end KRML *)
  BEGIN
    IF p.isNetworkT AND NOT CheckNetworkMethods( p ) THEN RETURN END;

    (* compute the size & alignment requirements *)
    GetOffsets (p);

    Emit.OpF ("typedef _ADDRESS @;\n", p);
    TypeRep.MarkCompiled (p);

    Type.Compile (p.superType);
    Scope.InitValues (p.fields);
    Scope.InitValues (p.methods);

    Scope.ToList (p.fields, fields, nFields);
    Scope.ToListWithAliases (p.methods, methods, nMethods, mNames);

    (* generate my method record *)
    nNewMethods := GenMethods (p, methods, nMethods);
    <* ASSERT nNewMethods = p.nNewMethods *>

    (* generate my fields *)
    GenFields (p, fields, nFields);

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

    IF TypeRep.StartLinkInfo (p) THEN RETURN END;

    IF (p.superType # NIL) THEN Emit.OpF ("S@\n", p.superType) END;

    (* generate my dependencies *)
    FOR i := 0 TO nFields-1 DO
      Emit.OpF ("d@\n", Value.TypeOf (fields[i]));
    END;
    FOR i := 0 TO nMethods-1 DO
      Emit.OpF ("d@\n", ProcType.CResult (Value.TypeOf (methods[i])));
    END;

    (* generate my "pre-declaration" *)
    Emit.Op   ("D\n");
    Emit.OpFF ("typedef struct @_FIELDS* @;\n", p, p);
    Emit.Op   ("*\n");

    (* generate my method record *)
    Emit.Op   ("O\n");
    nNewMethods := GenMethods (p, methods, nMethods);
    Emit.Op   ("*\n");

    (* new KRML *)
    (* generate a list of the methods which differ from the supertype's *)
    GenOverrides (p, methods, nMethods, mNames);

    (* generate signature encodings for new methods of network object types *)
    IF p.isNetworkT THEN GenSigEncodings( methods, nMethods ) END;
    (* end KRML *)

    (* generate my fields *)
    Emit.Op   ("C\n");
    GenFields (p, fields, nFields);
    Emit.Op   ("*\n");

    (* new KRML *)
    Emit.OpIII ("k@ @ @ ",  (* traced, dataSize, dataAlignment *)
                ORD (p.isTraced),
                p.fieldSize DIV Target.CHARSIZE,
                p.fieldAlign DIV Target.CHARSIZE );
    Emit.OpI ("@ 0 0\n", nNewMethods); (* nMethods, nDimensions, elementSize *)
    IF (p.brand # NIL) THEN
      Emit.OpS ("l@\n", p.brand)
    END;
    (* end KRML *)

    (* new KRML *)
    IF p.isTraced THEN
      TrOffsets.Emit( RecordType.TracedOffsets( fields, nFields ), TRUE)
    END;
    (* end KRML *)

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

    (**************************** KRML
    (* generate my "setup" procedure (called during final link phase) *)
    GenSetupProc (p, methods, nMethods, mNames);
    ************************** KRML *)

    (* generate my "init" procedure (called by NEW) *)
    hasInitProc := (* new KRML *)
    GenNewProc (p, fields, nFields);

    (*** KRML GenMapProc (p, fields, nFields); ***)

    (* new KRML *)
    WITH save = Emit.Switch (saveXfile), cn = Module.CurrentName() DO
      IF hasInitProc THEN
        Emit.OpF ("n@_init", p);
        IF cn # NIL THEN Emit.OpS ("_@\n", cn) END
      END;
      Emit.OpF ("m@_map", p);
      IF cn # NIL THEN Emit.OpS ("_@\n", cn) END;
      EVAL Emit.Switch (save)
    END;
    (* end KRML *)

    (* generate my Type cell info *)
    Emit.OpF  ("_IMPORT _TYPE @_tc;", p);  (* new KRML *)
(**************************** KRML
    Emit.OpF  ("_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 *)
                       p.fieldSize DIV Target.CHARSIZE,
                       p.fieldAlign DIV Target.CHARSIZE);
    Emit.OpI  ("  0, @,\n",       (* methodOffset, methodSize *)
                       (nNewMethods * Target.ADDRSIZE) DIV Target.CHARSIZE);
    Emit.Op   ("  0, 0,\n");      (* nDimensions, elementSize *)
    Emit.Op   ("  0,\n");         (* defaultMethods *)
    Emit.OpF  ("  @_setup,\n", p);(* setupProc *)
    Emit.OpF  ("  @_map,\n", p);  (* mapProc *)
    Emit.OpF  ("  @_init,\n", p); (* initProc *)
    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.OpF  ("  &@_TC,\n",      (* parentLink *)
                        p.superType);
    Emit.Op   ("  0, 0, 0\n");    (* parent, children, sibling *)
    Emit.Op   ("};\n");
************************** KRML *)

  END Compiler;

PROCEDURE GenFields (p: P;  fields: Scope.ValueList;  nFields: INTEGER) =
  BEGIN
    IF (nFields > 0) THEN
      Emit.Op ("typedef struct {\n\001");
      FOR i := 0 TO nFields - 1 DO  Field.EmitDeclaration (fields[i])  END;
      Emit.OpF  ("\002} @_fields;\n", p);
    END;
  END GenFields;

PROCEDURE GenMethods (p: P;  methods: Scope.ValueList;  n: INTEGER): INTEGER =
  VAR
    val      : Value.T;
    type     : Type.T;
    override : BOOLEAN;
    offset   : INTEGER;
    nMethods : INTEGER := 0;
  BEGIN
    FOR i := 0 TO n - 1 DO
      val := methods[i];
      Method.SplitX (val, offset, override, type);
      IF (NOT override) THEN
        IF (nMethods = 0) THEN Emit.Op ("typedef struct {\001\n") END;
        Emit.OpF ("@ ", ProcType.CResult (type));
        Emit.OpS ("(*@)();\n", Value.CName (val));
        (***************************
        Emit.OpF ("@ ", type);
        Emit.OpS ("@;\n", Value.CName (val));
        ****************************)
        INC (nMethods);
      END;
    END;
    IF (nMethods > 0) THEN Emit.OpF  ("\002} @_methods;\n", p) END;
    RETURN nMethods;
  END GenMethods;

(* new KRML *)
PROCEDURE GenSigEncodings (methods: Scope.ValueList;  n: INTEGER) =
  VAR
    val      : Value.T;
    sig      : Type.T;
    override : BOOLEAN;
    offset   : INTEGER;
  BEGIN
    FOR i := 0 TO n - 1 DO
      val := methods[i];
      Method.SplitX (val, offset, override, sig);
      IF NOT override THEN
        Emit.OpI( "s@ ", offset );
        Emit.OpX( "@\n", SigEncoding( sig ))
      END
    END
  END GenSigEncodings;

PROCEDURE SigEncoding( sig: Type.T ): TEXT =
  VAR
    enc, e  : TEXT;
    formals : Scope.ValueList;
    n       : INTEGER;
    info    : Formal.Info;
  BEGIN
    Scope.ToList( ProcType.Formals( sig ), formals, n );

    (* the sig encoding starts with the encoding of the result, and of
       the first parameter, which is a network type *)
    enc := Type.ParamEncoding( ProcType.Result( sig )) & ParamCode.Network;

    FOR i := 0 TO n - 1 DO
      Formal.Split( formals[i], info );
      e := Type.ParamEncoding( info.type );

      <* ASSERT e # NIL *>
      FOR j := 0 TO Text.Length( e ) - 1 DO
        WITH ch = Text.GetChar( e, j ) DO
          <* ASSERT ch = ParamCode.WordCh OR ch = ParamCode.NetworkCh *>
        END
      END;

      enc := enc & e
    END;

    RETURN enc
  END SigEncoding;

PROCEDURE GenOverrides (p: P;  methods: Scope.ValueList;
                        nMethods: INTEGER;  mNames: Scope.NameList) =
  VAR
    offset: INTEGER;
    override: BOOLEAN;
    val, top, dfault: Value.T;
    sig, tVisible: Type.T;
    name: String.T;
  BEGIN
    FOR i := 0 TO nMethods - 1 DO
      val := methods[i];
      dfault := Method.GetDefault (val);
      IF (dfault # NIL) THEN
        Method.SplitX (val, offset, override, sig);
        IF (mNames = NIL)
          THEN name := Value.CName (val);
          ELSE name := mNames[i];
        END;
        VAR b: BOOLEAN := LookUp (p, name, top, tVisible);
        BEGIN <* ASSERT b *> END;
        Emit.OpF ("o@ ", tVisible);
        Emit.OpI ("@ ", offset );
        Emit.OpN ("@\n", dfault)
      END
    END
  END GenOverrides;
(* end KRML *)

PROCEDURE GenNewProc (p: P;  fields: Scope.ValueList;  nFields: INTEGER)
    : BOOLEAN =
  (* returns TRUE exactly when an init proc was generated *)
  VAR
    val     : Value.T;
    offset  : INTEGER;
    type    : Type.T;
    dfault  : Expr.T;
    name    : String.T;
    x       : Temp.T;
    stack   : String.Stack;
    needed  := FALSE;
    frame   : Frame.T;
  BEGIN
    FOR i := 0 TO nFields - 1 DO
      val := fields[i];
      dfault := Field.GetDefault (val);
      IF (dfault = NIL) THEN
        Field.SplitX (val, offset, type);
        IF Type.InitCost (type, TRUE) # 0 THEN
          needed := TRUE;
          EXIT;
        END;
      ELSIF NOT Expr.IsZeroes (dfault) THEN
        needed := TRUE;
        EXIT;
      END;
    END;
    IF NOT needed THEN
      Emit.OpF ("\003#define @_init 0\n", p);
      RETURN FALSE;
    END;

    Frame.Push (frame, 2);
    (*** KRML  Emit.OpF ("\n_LOCAL_PROC _VOID @_init (_obj)\n", p);  *)
    (* end KRML *)
    Emit.OpF ("\n_EXPORT _VOID @_init_", p );
    WITH cn = Module.CurrentName() DO
      <* ASSERT cn # NIL *>
      Emit.OpS ("@ (_obj)\n", cn)
    END;
    (* new KRML *)
    Emit.Op  ("_ADDRESS _obj;\n{\001\n");
    Emit.OpF ("@_fields* _p;\n", p);
    EVAL Emit.SwitchToBody (); Emit.Op  ("\001");
    Emit.OpF ("_p = (@_fields*) ", p);
    IF (p.superType = NIL)
      THEN Emit.Op  ("_obj;\n");
      ELSE Emit.OpF ("(_obj + @_TC->dataOffset);\n", p);
    END;
    name := String.Add ("_p->");
    FOR i := 0 TO nFields - 1 DO
      val := fields[i];
      dfault := Field.GetDefault (val);
      IF (dfault = NIL) THEN
        Field.SplitX (val, offset, type);
        stack.top := 2; 
        stack.stk [0] := name;
        stack.stk [1] := Value.CName (val);
        Type.InitVariable (type, TRUE, stack);
      ELSIF NOT Expr.IsZeroes (dfault) THEN
        (* BUG: should do a full assignment! *)
        x := Expr.Compile (dfault);
        Emit.OpS ("_p->@ = ", Value.CName (val));
        Emit.OpT ("@;\n", x);
        Temp.Free (x);
      END;
    END;
    Frame.Pop (frame);
    RETURN TRUE;
  END GenNewProc;

(*************************************************************** KRML
PROCEDURE GenSetupProc (p: P;  methods: Scope.ValueList;
                             nMethods: INTEGER;  mNames: Scope.NameList) =
  VAR
    offset: INTEGER;
    override: BOOLEAN;
    val, top, dfault: Value.T;
    sig, tVisible: Type.T;
    name: String.T;
    frame: Frame.T;
  BEGIN
    Frame.Push (frame, 1);
    Emit.OpF ("\n_LOCAL_PROC _VOID @_setup ()\n", p);
    Emit.Op  ("{\001\n");
    Emit.Op  ("_ADDRESS _defaults;\n");
    EVAL Emit.SwitchToBody (); Emit.Op  ("\001");
    Emit.OpF ("_defaults = (_ADDRESS) @_TC->defaultMethods;\n", p);
    FOR i := 0 TO nMethods - 1 DO
      val := methods[i];
      dfault := Method.GetDefault (val);
      IF (dfault # NIL) THEN
        Method.SplitX (val, offset, override, sig);
        IF (mNames = NIL)
          THEN name := Value.CName (val);
          ELSE name := mNames[i];
        END;
        VAR b: BOOLEAN := LookUp (p, name, top, tVisible);
        BEGIN <* ASSERT b *> END;
        Emit.OpF ("*((_PROC* ) (_defaults + @_TC->methodOffset", tVisible);
        Emit.OpI (" + @)) = ", (offset * Target.ADDRSIZE) DIV Target.CHARSIZE);
        Emit.OpN ("(_PROC) @;\n", dfault);
      END;
    END;
    Frame.Pop (frame);
  END GenSetupProc;


PROCEDURE GenMapProc (p: P;  fields: Scope.ValueList;  nFields: INTEGER) =
  VAR
    field   : Value.T;
    offset  : INTEGER;
    type    : Type.T;
    prefix  : String.Stack;
    frame   : Frame.T;
  BEGIN
    (* generate my "MapProc" (called by the garbage collector) *)
    Frame.Push (frame, 5);
    (****** 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.Op  ("_ADDRESS _r;\n");
    Emit.Op  ("_MAPPROC_MASK _mask;\n{\001\n");
    IF (nFields > 0) THEN Emit.OpF ("@_fields* _o;\n", p) END;
    EVAL Emit.SwitchToBody (); Emit.Op  ("\001");
    IF (p.superType # NIL) THEN
      Emit.OpF ("@_TC->mapProc (_p, _arg, _r, _mask);\n", p.superType);
    END;
    IF (nFields > 0) THEN
      Emit.OpF ("_o = (@_fields*) ", p);
      IF (p.superType = NIL)
        THEN Emit.Op  ("_r;\n");
        ELSE Emit.OpF ("(_r + @_TC->dataOffset);\n", p);
      END;
      prefix.top := 2;
      prefix.stk [0] := String.Add ("_o->");
      FOR i := 0 TO nFields - 1 DO
        field := fields[i];
        Field.SplitX (field, offset, type);
        prefix.stk [1] := Value.CName (field);
        Type.GenMap (type, prefix);
      END;
    END;
    Frame.Pop (frame);
  END GenMapProc;
************************************************************ KRML *)

PROCEDURE EqualChk (a: P;  t: Type.T;  x: Type.Assumption): BOOLEAN =
  VAR b: P;  na, nb: INTEGER;  xa, xb: Scope.ValueList;
  BEGIN
    TYPECASE Type.Strip (t) OF
    | NULL => RETURN FALSE;
    | P(p) => b := p;
    ELSE      RETURN FALSE;
    END;

    IF (a = NIL)
      OR (a.isTraced # b.isTraced)
      OR (a.brand # b.brand)
      OR (NOT Type.IsEqual (a.superType, b.superType, x)) THEN
      RETURN FALSE;
    END;

    (* check the fields *)
    Scope.ToList (a.fields, xa, na);
    Scope.ToList (b.fields, xb, nb);
    IF (na # nb) THEN RETURN FALSE END;
    FOR i := 0 TO na - 1 DO
      IF NOT Field.IsEqual (xa[i], xb[i], x) THEN RETURN FALSE END;
    END;

    (* check the methods *)
    Scope.ToList (a.methods, xa, na);
    Scope.ToList (b.methods, xb, nb);
    IF (na # nb) THEN RETURN FALSE END;
    FOR i := 0 TO na - 1 DO
      IF NOT Method.IsEqual (xa[i], xb[i], x) THEN RETURN FALSE END;
    END;

    RETURN TRUE;
  END EqualChk;

PROCEDURE Subtyper (a: P;  t: Type.T): BOOLEAN =
  BEGIN
    IF (t = NIL) THEN RETURN FALSE END;
    IF (a.isTraced)
      THEN IF Type.IsEqual (t, Reff.T, NIL) THEN RETURN TRUE END;
      ELSE IF Type.IsEqual (t, Addr.T, NIL) THEN RETURN TRUE END;
    END;
    RETURN Type.IsEqual (a, t, NIL)
        OR ((a.superType # NIL) AND Type.IsSubtype (a.superType, t));
  END Subtyper;

PROCEDURE NetworkTyper (p: P): BOOLEAN =
  BEGIN
    IF NOT p.inCheck THEN Type.Check( p ) END;
    RETURN p.isNetworkT
  END NetworkTyper;

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 InitCoster (<*UNUSED*> p: P;  zeroed: BOOLEAN): INTEGER =
  BEGIN
    IF (zeroed) THEN RETURN 0 ELSE RETURN 1 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 ParamEnc (p: P): TEXT =
  BEGIN
    <* ASSERT p.isNetworkT *>
    RETURN ParamCode.Network
  END ParamEnc;

PROCEDURE FPrinter (p: P;  map: Type.FPMap;  wr: MBuf.T) =
  VAR n: INTEGER;  elts: Scope.ValueList;
  BEGIN
    IF Type.IsEqual (p, ObjectRef.T, NIL) THEN
      MBuf.PutText (wr, "$objectref");
    ELSIF Type.IsEqual (p, ObjectAdr.T, NIL) THEN
      MBuf.PutText (wr, "$objectadr");
    ELSE
      MBuf.PutText (wr, "OBJECT ");
      IF (NOT p.isTraced) THEN MBuf.PutText (wr, "UNTRACED ") END;
      Type.Fingerprint (p.superType, map, wr);
      MBuf.PutText (wr, " ");
      IF (p.brand # NIL) THEN
        MBuf.PutText (wr, "BRAND(");
        String.Put (wr, p.brand);
        MBuf.PutText (wr, ") ");
      END;
      Scope.ToList (p.fields, elts, n);
      FOR i := 0 TO n - 1 DO Value.Fingerprint (elts[i], map, wr) END;
      Scope.ToList (p.methods, elts, n);
      FOR i := 0 TO n - 1 DO Value.Fingerprint (elts[i], map, wr) END;
    END;
  END FPrinter;

PROCEDURE MethodOffset (t: Type.T): INTEGER =
  VAR p := Confirm (t);
  BEGIN
    IF (p = NIL) THEN RETURN Unknown_offset END;
    GetOffsets (p);
    RETURN p.methodOffset;
  END MethodOffset;

PROCEDURE FieldOffset (t: Type.T): INTEGER =
  VAR p := Confirm (t);
  BEGIN
    IF (p = NIL) THEN RETURN Unknown_offset END;
    GetOffsets (p);
    RETURN p.fieldOffset;
  END FieldOffset;

PROCEDURE FieldSize (t: Type.T): INTEGER =
  VAR p := Confirm (t);
  BEGIN
    IF (p = NIL) THEN RETURN Unknown_offset END;
    GetOffsets (p);
    IF (p.fieldOffset < 0) THEN RETURN Unknown_offset END;
    RETURN RecordType.RoundUp (p.fieldOffset + p.fieldSize, p.fieldAlign);
  END FieldSize;

PROCEDURE GetOffsets (p: P) =
  VAR super: P;
  BEGIN
    IF (p.fieldOffset # Unchecked_offset) THEN (* already done *) RETURN END;

    IF (p.superType = NIL) THEN  (* p is ROOT or UNTRACED ROOT *)
      p.fieldOffset  := Target.ADDRSIZE;
      p.methodOffset := 0;  (* KRML  Target.INTSIZE; *)
      p.fieldSize    := 0;
      p.fieldAlign   := 0;
    ELSE
      p.fieldOffset  := Unknown_offset;
      p.methodOffset := Unknown_offset;

      (* compute the field sizes and alignments *)
      RecordType.SizeAndAlignment (p.fields, p.fieldSize, p.fieldAlign);

      (* round the object's size up to at least the size of a heap header *)
      p.fieldSize := RecordType.RoundUp (p.fieldSize, Target.ADDRSIZE);

      (* try to get my supertype's offset *)
      super := Confirm (p.superType);
      IF (super # NIL) THEN (* supertype is visible *)
        GetOffsets (super);
        IF (super.fieldOffset >= 0) THEN
          p.fieldOffset  := super.fieldOffset + super.fieldSize;
          p.fieldOffset  := RecordType.RoundUp (p.fieldOffset, p.fieldAlign);
          p.methodOffset := super.methodOffset
                            + super.nNewMethods * Target.ADDRSIZE;
        END;
      END;
    END;
  END GetOffsets;

PROCEDURE Confirm (t: Type.T): P =
  BEGIN
    LOOP
      TYPECASE Type.Strip (t) OF
      | NULL => RETURN NIL;
      | P(p) => RETURN p;
      ELSE t := Revelation.LookUp (t);
      END;
    END;
  END Confirm;

BEGIN
END ObjectType.