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

(* File: M3LinkerWr.m3                                         *)
(* Last Modified On Wed Sep  2 10:11:34 PDT 1992 By rustan     *)
(*      Modified On Mon Mar  2 15:23:28 PST 1992 By kalsow     *)
(*      Modified On Thu Feb  6 01:20:43 PST 1992 By muller     *)


MODULE M3LinkerWr EXPORTS M3Linker, M3LinkerRep;

IMPORT Wr, Fmt, TxtIntTbl, Thread;
<*FATAL Wr.Failure, Thread.Alerted*>

TYPE
  IMap = TxtIntTbl.T;

TYPE
  State = RECORD
    output        : Wr.T;
    compressing   : BOOLEAN := FALSE;
    next_vs_id    : INTEGER := 0;
    next_type_id  : INTEGER := 0;
    next_utype_id : INTEGER := 0;
    vsMap         : IMap    := NIL;
    typeMap       : IMap    := NIL;
    utypeMap      : IMap    := NIL;
  END;


PROCEDURE WriteUnits (base: LinkSet;  magic: TEXT;  output: Wr.T) =
  VAR u: UnitList;  s: State;
  BEGIN
    IF (base = NIL) THEN RETURN END;
    IF (output = NIL) THEN RETURN END;

    s.output := output;
    s.compressing := (base.all_units # NIL) AND (base.all_units.next # NIL);
    IF (s.compressing) THEN
      s.vsMap    := TxtIntTbl.New (100);
      s.typeMap  := TxtIntTbl.New (100);
      s.utypeMap := TxtIntTbl.New (100);
    END;

    Out (s, LinkerMagic);
    IF (magic # NIL) THEN Out (s, "Z", magic) END;
    u := base.all_units;
    WHILE (u # NIL) DO
      WriteUnit (s, u.unit);
      u := u.next;
    END;
  END WriteUnits;

PROCEDURE WriteUnit (VAR s: State;  u: Unit) =
  CONST Tag = ARRAY BOOLEAN OF TEXT {"\nM", "\nI"};
  BEGIN
    Out (s, Tag[u.interface], u.name.text);
    WriteNameList       (s, u.exported_units, "A");
    WriteNameList       (s, u.imported_units, "B");
    WriteNameList       (s, u.imported_generics, "g");
    WriteVersionStamps  (s, u.imported_symbols, FALSE);
    WriteVersionStamps  (s, u.exported_symbols, TRUE);
    WriteUndefinedTypes (s, u.undefined_types);
    WriteDefinedTypes   (s, u.defined_types);
    WriteRevelations    (s, u.revelations);
  END WriteUnit;

PROCEDURE WriteNameList (VAR s: State;  n: NameList;  tag: TEXT) =
  BEGIN
    WHILE (n # NIL) DO
      Out (s, tag, n.name.text);
      n := n.next;
    END;
  END WriteNameList;

(* new KRML *)
PROCEDURE WriteOverrideList (VAR s: State;  o: OverrideList;  tag: TEXT) =
  BEGIN
    WHILE (o # NIL) DO
      OutX (s, tag, o.supertype.text, " ", Fmt.Int( o.offset ));
      Out (s, " ", o.Cname.text);
      o := o.next;
    END;
  END WriteOverrideList;

PROCEDURE WriteSigEncodings (VAR s: State;  sig: SigCodeList;  tag: TEXT) =
  BEGIN
    WHILE sig # NIL DO
      Out (s, tag, Fmt.Int( sig.offset ), " ", sig.encoding);
      sig := sig.next
    END
  END WriteSigEncodings;
(* end KRML *)

PROCEDURE WriteVersionStamps (VAR s: State; vs: VersionStamp; export: BOOLEAN)=
  CONST Tag  = ARRAY BOOLEAN OF TEXT { "i", "e" };
  CONST CTag = ARRAY BOOLEAN OF TEXT { "G", "W" };
  CONST DTag = ARRAY BOOLEAN OF TEXT { "K", "V" };
  VAR tag := Tag [export];
  VAR uid: INTEGER;
  BEGIN
    IF (s.compressing) THEN
      WHILE (vs # NIL) DO
        IF s.vsMap.in (vs.symbol.text, uid) THEN
          Out (s, CTag[export], Fmt.Int (uid));
        ELSE
          uid := s.next_vs_id;  INC (s.next_vs_id);
          EVAL s.vsMap.put (vs.symbol.text, uid);
          OutX (s, DTag[export], Fmt.Int (uid), " ", vs.symbol.text, " ");
          OutStamp (s, vs.stamp);
        END;
        vs := vs.next;
      END;
    ELSE
      WHILE (vs # NIL) DO
        OutX (s, tag, vs.symbol.text, " ");
        OutStamp (s, vs.stamp);
        vs := vs.next;
      END;
    END;
  END WriteVersionStamps;

PROCEDURE WriteRevelations (VAR s: State;  r: Revelation) =
  CONST import_tag = ARRAY BOOLEAN OF TEXT { "r", "x" };
  CONST export_tag = ARRAY BOOLEAN OF TEXT { "R", "X" };
  BEGIN
    WHILE (r # NIL) DO
      IF (r.export)
        THEN OutX (s, export_tag [r.partial]);
        ELSE OutX (s, import_tag [r.partial], r.unit.text, " ");
      END;
      Out (s, r.lhs.text, " ", r.rhs.text);
      r := r.next;
    END;
  END WriteRevelations;

PROCEDURE WriteUndefinedTypes (VAR s: State;  t: UndefinedType) =
  VAR uid: INTEGER;
  BEGIN
    IF (s.compressing) THEN
      WHILE (t # NIL) DO
        IF s.utypeMap.in (t.uid.text, uid) THEN
          Out (s, "U", Fmt.Int (uid));
        ELSE
          uid := s.next_utype_id;  INC (s.next_utype_id);
          EVAL s.utypeMap.put (t.uid.text, uid);
          Out (s, "J", Fmt.Int (uid), " ", t.uid.text, TypeClassName[t.class]);
          IF (t.name # NIL) THEN Out (s, "N", t.name) END;
        END;
        t := t.next;
      END;
    ELSE
      WHILE (t # NIL) DO
        Out (s, "\nu", t.uid.text, TypeClassName[t.class]);
        IF (t.name # NIL) THEN Out (s, "N", t.name) END;
        t := t.next;
      END;
    END;
  END WriteUndefinedTypes;

CONST TypeClassName = ARRAY TypeClass OF TEXT {
  " 0", " 1", " 2", " 3", " 4", " 5", " 6", " 7", " 8", " 9", " 10", " 11" };

PROCEDURE WriteDefinedTypes (VAR s: State;  t: Type) =
  VAR uid: INTEGER;
  BEGIN
    IF (s.compressing) THEN
      WHILE (t # NIL) DO
        IF s.typeMap.in (t.uid.text, uid) THEN
          Out (s, "Q", Fmt.Int (uid));
        ELSE
          uid := s.next_type_id;  INC (s.next_type_id);
          EVAL s.typeMap.put (t.uid.text, uid);
          Out (s, "H", Fmt.Int (uid), " ", t.uid.text, TypeClassName[t.class]);
          WriteOneType (s, t);
        END;
        t := t.next;
      END;
    ELSE
      WHILE (t # NIL) DO
        Out (s, "\nt", t.uid.text, TypeClassName[t.class]);
        WriteOneType (s, t);
        t := t.next;
      END;
    END;
  END WriteDefinedTypes;

PROCEDURE WriteOneType (VAR s: State; t: Type) =
  CONST Map = ARRAY OF TEXT { "k0 ", "k1 " };
  BEGIN
    IF (t.name # NIL) THEN Out (s, "N", t.name) END;
    WriteNameList (s, t.depends, "d");
    IF (t.super.text # NIL) THEN Out (s, "S", t.super.text) END;
    OutM (s, "D", t.preDecl);
    OutM (s, "C", t.decl);
    OutM (s, "O", t.methodDecl);
    WriteOverrideList (s, t.overrides, "o");
    WriteSigEncodings (s, t.sigEncodings, "s");
    (* new KRML *)
    IF t.isTraced # 2 THEN
      OutX (s, Map[ t.isTraced ],
            Fmt.Int( t.dataSize ), " ",
            Fmt.Int( t.dataAlignment ), " ");
      Out (s, Fmt.Int( t.nMethods ), " ",
           Fmt.Int( t.nDimensions ), " ",
           Fmt.Int( t.elementSize ))
    END;
    IF t.brand.text # NIL THEN Out (s, "l", t.brand.text) END;
    IF t.initProc.text # NIL THEN Out (s, "n", t.initProc.text) END;
    IF t.mapProc.text # NIL THEN Out (s, "m", t.mapProc.text) END;
    IF t.tracedOffs.text # NIL THEN Out (s, "b", t.tracedOffs.text) END;
    (* end KRML *)
  END WriteOneType;

PROCEDURE OutStamp (VAR s: State;  READONLY x: StampData) =
  BEGIN
    WriteStamp (s.output, x);
    Wr.PutChar (s.output, '\n');
  END OutStamp;

PROCEDURE OutM (VAR s: State;  tag, multi: TEXT) =
  BEGIN
    IF (multi = NIL) THEN RETURN END;
    Out  (s, tag);
    OutX (s, multi); (* it's already got a \n appended *)
    Out  (s, "*");
  END OutM;

PROCEDURE Out (VAR s: State;  a, b, c, d, e: TEXT := NIL) =
  BEGIN
    OutX (s, a, b, c, d, e);
    Wr.PutChar (s.output, '\n');
  END Out;

PROCEDURE OutX (VAR s: State;  a, b, c, d, e: TEXT := NIL) =
  BEGIN
    IF (a # NIL) THEN Wr.PutText (s.output, a) END;
    IF (b # NIL) THEN Wr.PutText (s.output, b) END;
    IF (c # NIL) THEN Wr.PutText (s.output, c) END;
    IF (d # NIL) THEN Wr.PutText (s.output, d) END;
    IF (e # NIL) THEN Wr.PutText (s.output, e) END;
  END OutX;

BEGIN
END M3LinkerWr.