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

(* File: M3LinkerPgm.m3                                        *)
(* Last Modified On Fri Jul 10 22:44:44 1992 By rustan     *)
(*      Modified On Mon Mar  2 15:22:51 PST 1992 By kalsow     *)

MODULE M3LinkerPgm EXPORTS M3Linker, M3LinkerRep;

IMPORT Text, Wr, Thread, M3LinkMap;
<*FATAL Wr.Failure, Thread.Alerted*>

CONST
  Margin = 72;

TYPE
  State = RECORD
    base       : LinkSet;
    modules    : M3LinkMap.T;
    interfaces : M3LinkMap.T;
    types      : M3LinkMap.T;
    errors     : Wr.T;
    mode       : CheckMode;
    failed     : BOOLEAN := FALSE;
    refany     : Type := NIL;
    address    : Type := NIL;
    null       : Type := NIL;
    text       : Type := NIL;
    root       : Type := NIL;
    un_root    : Type := NIL;
    revealed   : REF ARRAY OF Type;
    main       : Unit := NIL;
    builtin    : Unit := NIL;
  END;

(*------------------------------------------------------------------------*)


PROCEDURE CheckSet (base: LinkSet;  m: CheckMode;  errors : Wr.T): BOOLEAN =
  VAR s: State;
  BEGIN
    IF (base = NIL) THEN RETURN FALSE END;

    s.base       := base;
    s.errors     := errors;
    s.mode       := m;
    s.failed     := FALSE;
    s.modules    := base.modules;
    s.interfaces := base.interfaces;
    AllocateMaps (s);

    CheckUnits (s);
    IF (s.failed) THEN RETURN FALSE END;

    CheckVersionStamps (s);
    IF (s.failed) THEN RETURN FALSE END;

    BuildTypeMap (s);
    IF (s.failed) THEN RETURN FALSE END;

    CheckTypes (s);
    IF (s.failed) THEN RETURN FALSE END;

    CheckRevelations (s);
    IF (s.failed) THEN RETURN FALSE END;

    (* success! *)

    base.mode       := m;
    base.interfaces := s.interfaces;
    base.modules    := s.modules;
    base.types      := s.types;
    base.revealed   := s.revealed;
    base.refany     := s.refany;
    base.address    := s.address;
    base.null       := s.null;
    base.text       := s.text;
    base.root       := s.root;
    base.un_root    := s.un_root;
    base.main       := s.main;
    base.builtin    := s.builtin;
    RETURN TRUE;
  END CheckSet;

PROCEDURE AllocateMaps (VAR s: State) =
  VAR
    nUnits := 0;
    nIntfs := 0;
    nTypes := 0;
    x := s.base.all_units;
    u: Unit;
    t: Type;
  BEGIN
    WHILE (x # NIL) DO
      u := x.unit;
      INC (nUnits);
      IF (u.interface) THEN INC (nIntfs) END;
      t := u.defined_types;
      WHILE (t # NIL) DO  INC (nTypes);  t := t.next  END;
      x := x.next;
    END;
    s.types      := M3LinkMap.New (3 * nTypes + 30);
    s.revealed   := NIL;
  END AllocateMaps;

(*------------------------------------------------------------------------*)

TYPE
  ImportError = REF RECORD
    name : TEXT;
    unit : Unit;
    next : ImportError;
  END;

PROCEDURE CheckUnits (VAR s: State) =
  VAR
    x := s.base.all_units;
    u: Unit;
    main: Name;
    errors: ImportError := NIL;
  BEGIN
    IF (s.mode = Mode.Program) OR (s.mode = Mode.Overlay) THEN
      (* check to make sure that "Main" is exported *)
      main.text := "Main";
      main.hash := TextHash (main.text);
      s.main := M3LinkMap.Get (s.interfaces, main);
      IF s.main = NIL THEN
        s.failed := TRUE;
        Out (s, "missing \"Main\" module\n");
        RETURN;
      END;
    END;

    (* check to make sure that all imports are satisfied *)
    WHILE (x # NIL) DO
      u := x.unit;
      CheckUnitList (s, u, u.imported_units, errors);
      CheckUnitList (s, u, u.exported_units, errors);
      x := x.next;
    END;

    IF (errors # NIL) THEN DumpImportErrors (s, errors) END;
  END CheckUnits;

PROCEDURE CheckUnitList (VAR s: State;  u: Unit;  n: NameList;
                            VAR err: ImportError) =
  BEGIN
    WHILE (n # NIL) DO
      IF M3LinkMap.Get (s.interfaces, n.name) = NIL THEN
(*********
Out (s, "*** MISSING IMPORT *** ", n.name.text);
Out (s, " in ", UnitName (u), "\n");
Out (s, "  hash = ", Fmt.Int (n.name.hash), "\n");
DumpIntfs (s);
*********)
        err := NEW (ImportError, next := err, unit := u, name := n.name.text);
      END;
      n := n.next;
    END;
  END CheckUnitList;

(****
PROCEDURE DumpIntfs (VAR s: State) =
  VAR x := M3LinkMap.GetData (s.interfaces);  u: Unit;
  BEGIN
    Out (s, "  table size = ", Fmt.Int (NUMBER (x^)), "\n");
    FOR i := 0 TO LAST (x^) DO
      u := x[i];
      IF (u # NIL) THEN
        Out (s, Fmt.Int (i), ": ", u.name.text, "  ");
        Out (s, Fmt.Int (u.name.hash), "\n");
      END;
    END;
  END DumpIntfs;
****)

PROCEDURE DumpImportErrors (VAR s: State;  err: ImportError) =
  VAR new, match, tmp: ImportError;
  BEGIN
    WHILE (err # NIL) DO
      new := NIL;
      match := err;
      err := err.next;
      match.next := NIL;
      WHILE (err # NIL) DO
        tmp := err.next;
        IF Text.Equal (err.name, match.name)
          THEN err.next := match;  match := err;
          ELSE err.next := new;    new := err;
        END;
        err := tmp;
      END;
      DumpImportErrorList (s, match);
      err := new;
    END;
  END DumpImportErrors;

PROCEDURE DumpImportErrorList (VAR s: State;  err: ImportError) =
  VAR width := 99999;  name: TEXT;  len: INTEGER;
  BEGIN
    s.failed := TRUE;
    Out (s, "missing interface \"", err.name, "\" imported by:");
    WHILE (err # NIL) DO
      name := UnitName (err.unit);
      len := Text.Length (name);
      IF (len + width > Margin) THEN  Out (s, "\n   "); width := 3  END;
      Out (s, name, "  ");  INC (width, len+2);
      err := err.next;
    END;
    Out (s, "\n");
  END DumpImportErrorList;

(*------------------------------------------------------------------------*)

PROCEDURE CheckVersionStamps (VAR s: State) =
  VAR vs: VersionStamp;  stamps := M3LinkMap.GetData (s.base.stamps);
  BEGIN
    (* scan the stamp table for any undefined stamps *)
    FOR i := 0 TO LAST (stamps^) DO
      vs := stamps[i];
      IF (vs # NIL) AND (NOT vs.export) THEN Undefined (s, vs) END;
    END;
  END CheckVersionStamps;

PROCEDURE Undefined (VAR s: State;  vs: VersionStamp) =
  VAR
    width := 999999;
    name: TEXT;
    len: INTEGER;
    u: Unit;
    z: VersionStamp;
    x := s.base.all_units;
  BEGIN
    s.failed := TRUE;
    IF (s.errors = NIL) THEN RETURN END;
    Out (s, "undefined version stamp: ", vs.symbol.text, "  <");
    WriteStamp (s.errors, vs.stamp);
    Out (s, ">");
    WHILE (x # NIL) DO
      u := x.unit;
      z := u.imported_symbols;
      WHILE (z # NIL) DO
        IF Text.Equal (z.symbol.text, vs.symbol.text) THEN
          name := UnitName (u);
          len  := Text.Length (name);
          IF (width + len > Margin) THEN Out (s, "\n     ");  width := 5 END;
          Out (s, name, "  "); INC (width, len + 2);
          EXIT;
        END;
        z := z.next;
      END;
      x := x.next;
    END;
    Out (s, "\n");
  END Undefined;

(*------------------------------------------------------------------------*)

PROCEDURE BuildTypeMap (VAR s: State) =
  VAR x := s.base.all_units;  u: Unit;  t: Type;
      (* new KRML *)
      brandMap := M3LinkMap.New ( 191 );
      bvCurr, bvPrev: BrandValue;
  TYPE BrandValue = REF RECORD brand: Name; t: Type END;
      (* end KRML *)
  BEGIN
    WHILE (x # NIL) DO
      u := x.unit;
      t := u.defined_types;
      WHILE (t # NIL) DO

        (* new KRML *)
        (* Check for duplicated brand names *)
        IF t.brand.text # NIL THEN
          bvCurr := NEW (BrandValue, brand := t.brand, t := t);
          bvPrev := M3LinkMap.Get (brandMap, t.brand);
          IF bvPrev = NIL THEN
            M3LinkMap.Insert (brandMap, t.brand, bvCurr );
          ELSE
            s.failed := TRUE;
            Out (s, TypeName (bvPrev.t), " and ", TypeName (t));
            Out (s, " share brand name ", t.brand.text, "\n" )
          END
        END;
        (* end KRML *)

        M3LinkMap.Insert (s.types, t.uid, t);
        t := t.next;
      END;
      x := x.next;
    END;
  END BuildTypeMap;

(*------------------------------------------------------------------------*)

PROCEDURE CheckTypes (VAR s: State) =
  VAR x: UnitList;
  BEGIN
    (* make sure the super types are defined *)
    x := s.base.all_units;
    WHILE (x # NIL) DO
      CheckSuperTypes (s, x.unit.defined_types);
      x := x.next;
    END;

    FindBuiltinTypes (s);

    (* make sure that all 'undefined' types are defined *)
    x := s.base.all_units;
    WHILE (x # NIL) DO
      CheckUndefinedTypes (s, x.unit);
      x := x.next;
    END;

    (* make sure that all the types named in revelations are defined *)
    x := s.base.all_units;
    WHILE (x # NIL) DO
      CheckRevelationTypes (s, x.unit, x.unit.revelations);
      x := x.next;
    END;

    (* make sure each unit recognized all network types *)
    x := s.base.all_units;
    WHILE x # NIL DO
      NoteInapprNetworkTypes (s, x.unit.name.text, x.unit.defined_types);
      x := x.next
    END
  END CheckTypes;

PROCEDURE CheckSuperTypes (VAR s: State;  t: Type) =
  VAR super: Type;
  BEGIN
    WHILE (t # NIL) DO
      IF (t.super.text # NIL) THEN
        super := M3LinkMap.Get (s.types, t.super);
        IF (super = NIL) THEN
          s.failed := TRUE;
          Out (s, "undefined super type (", t.super.text, ") for ");
          Out (s, TypeName (t), "\n");
        END;
      END;
      t := t.next;
    END;
  END CheckSuperTypes;

PROCEDURE FindBuiltinTypes (VAR s: State) =
  VAR n: Name;
  BEGIN
    n.text := BuiltinUnitName;
    n.hash := TextHash (n.text);
    s.builtin := M3LinkMap.Get (s.interfaces, n);
    IF (s.builtin = NIL) THEN
      s.failed := TRUE;
      Out (s, "no ", BuiltinUnitName, " interface?\n");
      RETURN;
    END;
    ScanForBuiltinTypes (s, s.builtin);
    <* ASSERT s.refany # NIL *>
    <* ASSERT s.address # NIL *>
    <* ASSERT s.null # NIL *>
    <* ASSERT s.text # NIL *>
    <* ASSERT s.root # NIL *>
    <* ASSERT s.un_root # NIL *>
  END FindBuiltinTypes;

PROCEDURE ScanForBuiltinTypes (VAR s: State;  u: Unit) =
  VAR t := u.defined_types;
  BEGIN
    WHILE (t # NIL) DO
      TryBuiltin (s, t, s.refany,  "REFANY");
      TryBuiltin (s, t, s.address, "ADDRESS");
      TryBuiltin (s, t, s.null,    "NULL");
      TryBuiltin (s, t, s.text,    "TEXT");
      TryBuiltin (s, t, s.root,    "ROOT");
      TryBuiltin (s, t, s.un_root, "_UNTRACED_ROOT_");
      t := t.next;
    END;
  END ScanForBuiltinTypes;

PROCEDURE TryBuiltin (VAR s: State;  t: Type;  VAR x: Type;  name: TEXT) =
  BEGIN
    IF (t.name # NIL) AND Text.Equal (t.name, name) THEN
      x := M3LinkMap.Get (s.types, t.uid);
      IF (x = NIL) THEN
        s.failed := TRUE;
        Out (s, "missing builtin type: ", name);
        Out (s, " (", t.uid.text, ")\n");
      END;
    END;
  END TryBuiltin;

PROCEDURE CheckUndefinedTypes (VAR s: State;  u: Unit) =
  VAR t := u.undefined_types;
  BEGIN
    WHILE (t # NIL) DO
      CheckType (s, u, t.uid, t.name);
      t := t.next;
    END;
  END CheckUndefinedTypes;

PROCEDURE CheckRevelationTypes (VAR s: State;  u: Unit;  r: Revelation) =
  BEGIN
    WHILE (r # NIL) DO
      CheckType (s, u, r.lhs, NIL);
      CheckType (s, u, r.rhs, NIL);
      r := r.next;
    END;
  END CheckRevelationTypes;

PROCEDURE CheckType (VAR s: State;  u: Unit;  READONLY uid: Name;  name: TEXT)=
  VAR t: Type;
  BEGIN
    t := M3LinkMap.Get (s.types, uid);
    IF (t = NIL) THEN
      s.failed := TRUE;
      Out (s, "undefined type ", name, " (", uid.text);
      Out (s, ") in ", UnitName (u), "\n");
    END;
  END CheckType;

PROCEDURE NoteInapprNetworkTypes (VAR s: State;  unitName: TEXT;  t: Type) =
  VAR super: Type;
      ty: Type;
  BEGIN
    <* ASSERT s.root # NIL *>
    <* ASSERT unitName # NIL *>
    WHILE t # NIL DO
      IF t.class = TypeClass.Opaque AND t.super.text # NIL THEN
        super := M3LinkMap.Get (s.types, t.super);
        IF super = s.root THEN
          ty := M3LinkMap.Get (s.types, t.uid);
          <* ASSERT ty # NIL *>
          ty.inapprNetType := unitName
        END
      END;
      t := t.next
    END
  END NoteInapprNetworkTypes;

(*------------------------------------------------------------------------*)

PROCEDURE CheckRevelations (VAR s: State) =
  VAR x: UnitList;  u: Unit;  nTypes: INTEGER;
  BEGIN
    (* build a table to record the full revelations *)
    nTypes := NUMBER (M3LinkMap.GetData (s.types)^);
    s.revealed := NEW (REF ARRAY OF Type, nTypes);

    (* capture the exported, full revelations *)
    x := s.base.all_units;
    WHILE (x # NIL) DO
      u := x.unit;
      NoteFullRevelation (s, u.revelations);
      x := x.next;
    END;

    (* make sure that all opaque types have a full revelation *)
    x := s.base.all_units;
    WHILE (x # NIL) DO
      u := x.unit;
      CheckOpaques (s, u.defined_types);
      x := x.next;
    END;

    (* make sure the full revelations are all consistent *)
    x := s.base.all_units;
    WHILE (x # NIL) DO
      u := x.unit;
      CheckFullRevelation (s, u, u.revelations);
      x := x.next;
    END;
  END CheckRevelations;

PROCEDURE NoteFullRevelation (VAR s: State;  r: Revelation) =
  VAR t: Type;  tx: INTEGER;
  BEGIN
    WHILE (r # NIL) DO
      IF (r.export) AND (NOT r.partial) THEN
        tx := M3LinkMap.GetIndex (s.types, r.lhs);
        t  := M3LinkMap.GetDirect (s.types, tx);
        IF (t # NIL) THEN
          IF (t.class # TypeClass.Opaque) THEN
            s.failed := TRUE;
            Out (s, "full revelation for non-opaque ", TypeName (t),"\n");
          ELSIF (s.revealed[tx] = NIL) THEN
            (* record the revelation *)
            s.revealed[tx] := M3LinkMap.Get (s.types, r.rhs);
          ELSE
            s.failed := TRUE;
            Out (s, "multiple full revelations for ", TypeName (t), "\n");
          END;
        END;
      END;
      r := r.next;
    END;
  END NoteFullRevelation;

PROCEDURE CheckOpaques (VAR s: State;  t: Type) =
  VAR tx: INTEGER;
  BEGIN
    WHILE (t # NIL) DO
      IF (t.class = TypeClass.Opaque) THEN
        tx := M3LinkMap.GetIndex (s.types, t.uid);
        IF (s.revealed[tx] = NIL) THEN
          s.failed := TRUE;
          Out (s, "no full revelation given for ", TypeName (t), "\n");
          s.revealed[tx] := M3LinkMap.Get (s.types, t.super);
            (* avoid more errors *)
        END;
      END;
      t := t.next;
    END;
  END CheckOpaques;

PROCEDURE CheckFullRevelation (VAR s: State;  u: Unit;  r: Revelation) =
  VAR lhs, rhs, super: Type;
  BEGIN
    WHILE (r # NIL) DO
      IF (r.export) AND (NOT r.partial) THEN
        lhs := M3LinkMap.Get (s.types, r.lhs);
        rhs := M3LinkMap.Get (s.types, r.rhs);
        super := M3LinkMap.Get (s.types, lhs.super);
        IF NOT CheckSubtype (s, rhs, super) THEN
          s.failed := TRUE;
          Out (s,
            "revealed type is not a subtype of the declared super type: ",
            UnitName (u), "\n");
          SubtypeErr (s, rhs, super);
        END;
      END;
      r := r.next;
    END;
  END CheckFullRevelation;

PROCEDURE CheckSubtype (VAR s: State;  a, b: Type): BOOLEAN =
  VAR ax: INTEGER;
  BEGIN
    IF (a = NIL) OR (b = NIL) THEN RETURN FALSE END;

    (***************
    IF (a.traced)
      THEN IF (b = s.refany) THEN RETURN TRUE END;
           (* ASSERT NOT Text.Equal (b.uid.text, s.refany.uid.text) *)
      ELSE IF (b = s.address) THEN RETURN TRUE END;
           (* ASSERT NOT Text.Equal (b.uid.text, s.address.uid.text) *)
    END;
    ***************)
    IF (b = s.refany) OR (b = s.address) THEN RETURN TRUE END;

    WHILE (a # NIL) DO
      IF (a = b) THEN RETURN TRUE END;
      (* ASSERT NOT Text.Equal (a.uid.text, b.uid.text) *)
      IF (a.class = TypeClass.Opaque) THEN
        ax := M3LinkMap.GetIndex (s.types, a.uid);
        a  := s.revealed[ax];
      ELSE
        a := M3LinkMap.Get (s.types, a.super);
      END;
    END;
    RETURN FALSE;
  END CheckSubtype;

PROCEDURE SubtypeErr (VAR s: State;  a, b: Type) =
  CONST DEBUG = TRUE;
  VAR ax: INTEGER;
  BEGIN
    Out (s, "   ", TypeName (a), "\n");
    Out (s, "      is not a subtype of ", TypeName (b), "\n");
    IF DEBUG THEN
      Out (s, "   [ ");
      WHILE (a # NIL) DO
        Out (s, a.uid.text);
        IF (a.class = TypeClass.Opaque) THEN
          Out (s, " == ");
          ax := M3LinkMap.GetIndex (s.types, a.uid);
          a  := s.revealed[ax];
        ELSIF (a.super.text # NIL) THEN
          Out (s, " <: ");  a := M3LinkMap.Get (s.types, a.super);
        ELSE
          EXIT;
        END;
      END;
      Out (s, " ]\n");
    END;
  END SubtypeErr;

(*------------------------------------------------------------------------*)

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

BEGIN
END M3LinkerPgm.