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

(* File: M3LinkerC.m3                                          *)
(* Last Modified On Thu Sep  3 14:12:41 PDT 1992 By rustan     *)
(*      Modified On Wed Jun 10 14:34:34 PDT 1992 By kalsow     *)

MODULE M3LinkerC EXPORTS M3Linker, M3LinkerRep;

IMPORT Text, Wr, TextSet, Fmt, Thread, M3LinkMap;
(* new KRML *)
IMPORT M3LinkerKRML;
(* end KRML *)
<*FATAL Wr.Failure, Thread.Alerted*>

TYPE
  State = RECORD
    base          : LinkSet    := NIL;
    magic         : TEXT       := NIL;
    verbose       : BOOLEAN    := FALSE;
    output        : Wr.T       := NIL;
    typeNames     : TextSet.T  := NIL; (* user type name *)
    magicImports  : TextSet.T  := NIL;
    n_typecells   : INTEGER    := 0;
    n_modules     : INTEGER    := 0;
    n_base_mods   : INTEGER    := 0;
    mode          : CheckMode;
    has_main      : BOOLEAN;
    type_needed   : BoolMap;
    emitted_raw   : BoolMap;
    emitted_pre   : BoolMap;
    emitted_flat  : BoolMap;
    emitted_proc  : BoolMap;
    emitted_tc    : BoolMap;
    dfs_count     : INTEGER;
    init_stack    : UnitInfo;
    ss            : M3LinkerKRML.S := NIL;  (* new KRML *)
  END;

TYPE
  BoolMap = REF ARRAY OF BOOLEAN;

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

PROCEDURE GenerateMain (base: LinkSet;  magic: TEXT;
                          output: Wr.T;  verbose: BOOLEAN) RAISES {LinkError} =
  VAR s: State;  n: INTEGER;
  BEGIN
    s.mode         := base.mode;
    s.base         := base;
    s.magic        := magic;
    s.output       := output;
    s.verbose      := verbose;
    s.typeNames    := TextSet.New ();
    s.magicImports := TextSet.New ();
    s.has_main     := (s.mode = Mode.Program) OR (s.mode = Mode.Overlay);

    n := NUMBER (s.base.revealed^);
    s.type_needed  := NEW (BoolMap, n);
    s.emitted_raw  := NEW (BoolMap, n);
    s.emitted_pre  := NEW (BoolMap, n);
    s.emitted_flat := NEW (BoolMap, n);
    s.emitted_proc := NEW (BoolMap, n);
    s.emitted_tc   := NEW (BoolMap, n);

    (* new KRML *)
    InitTypecells( s );
    (* end KRML *)

    Out (s, "#include \"M3Runtime.h\"\n");
    GenerateTypeDecls (s);
    GenerateMainProc (s);
    M3LinkerKRML.PrintTypeSummary( s.ss, s.output );  (* new KRML *)
  END GenerateMain;

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

PROCEDURE GenerateTypeDecls (VAR s: State) =
  BEGIN
    ResetTypes (s);
    ForEachType (s, FindNeeded);
    Out (s, "\n/*-----------------------------------------*/\n");
    ForEachType (s, GenTypePreDecl);
    Out (s, "\n/*-----------------------------------------*/\n");
    ForEachType (s, FilterRawTypeDecl);
    Out (s, "\n/*-----------------------------------------*/\n");
    ForEachType (s, GenTypeDecl);
    Out (s, "\n/*-----------------------------------------*/\n");
    ForEachType (s, GenTypeNames);
    Out (s, "\n/*-----------------------------------------*/\n");
    ForEachType (s, GenTypeCells);

  END GenerateTypeDecls;

PROCEDURE ResetTypes (VAR s: State) =
  BEGIN
    FOR i := 0 TO LAST (s.emitted_raw^) DO
      s.type_needed[i]  := FALSE;
      s.emitted_raw[i]  := FALSE;
      s.emitted_pre[i]  := FALSE;
      s.emitted_flat[i] := FALSE;
      s.emitted_proc[i] := FALSE;
      s.emitted_tc[i]   := FALSE;
    END;
  END ResetTypes;

TYPE TypeVisitor = PROCEDURE (VAR s: State;  t: Type;  tx: INTEGER);

PROCEDURE ForEachType (VAR s: State;  visit: TypeVisitor) =
  VAR x: REF ARRAY OF M3LinkMap.Value;  t: Type;
  BEGIN
    x := M3LinkMap.GetData (s.base.types);
    FOR i := FIRST (x^) TO LAST (x^) DO
      t := x[i];
      IF (t # NIL) THEN  visit (s, t, i)  END;
    END;
  END ForEachType;

PROCEDURE TypeIsLocal (t: Type): BOOLEAN =
  BEGIN
    IF (t = NIL) THEN RETURN FALSE END;
    RETURN (t.unit = NIL)
        OR (t.unit.file = NIL)
        OR (NOT t.unit.file.imported)
        OR (t.unit.file.magic = NIL);
  END TypeIsLocal;

PROCEDURE TypeHasTypecell (t: Type): BOOLEAN =
  TYPE TC = TypeClass;  
  VAR tc: TC;
  BEGIN
    IF (t = NIL) THEN RETURN FALSE END;
    tc := t.class;
    RETURN (tc = TC.Opaque) OR (tc = TC.Ref) OR (tc = TC.Object);
  END TypeHasTypecell;

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

PROCEDURE FindNeeded (VAR s: State;  t: Type;  tx: INTEGER) =
  BEGIN
    IF TypeIsLocal (t) THEN
      IF (t.name # NIL) OR TypeHasTypecell (t) THEN
        MarkNeeded (s, t, tx);
      END;
    END;
  END FindNeeded;

PROCEDURE MarkNeeded (VAR s: State;  t: Type;  tx: INTEGER) =
  VAR x: Type;  xx: INTEGER;  n: NameList;
  BEGIN
    IF (t = NIL) OR (s.type_needed [tx]) THEN RETURN END;
    s.type_needed [tx] := TRUE;

    (* mark my concrete revelation *)
    IF (t.class = TypeClass.Opaque) THEN
      x := s.base.revealed [tx];
      IF (x # NIL) THEN
        xx := M3LinkMap.GetIndex (s.base.types, x.uid);
        MarkNeeded (s, x, xx);
      END;
    END;

    (* mark the types that I depend on *)
    n := t.depends;
    WHILE (n # NIL) DO
      xx := M3LinkMap.GetIndex (s.base.types, n.name);
      x  := M3LinkMap.GetDirect (s.base.types, xx); 
      MarkNeeded (s, x, xx);
      n := n.next;
    END;

    (* mark my super type *)
    IF (t.super.text # NIL) THEN
      xx := M3LinkMap.GetIndex (s.base.types, t.super);
      x  := M3LinkMap.GetDirect (s.base.types, xx);
      MarkNeeded (s, x, xx);
    END;
  END MarkNeeded;

PROCEDURE GenTypePreDecl (VAR s: State;  t: Type;  tx: INTEGER) =
  BEGIN
    (* emit my "pre-declaration" *)
    IF (t.preDecl # NIL) AND (s.type_needed[tx]) THEN
      StartType (s, t);
      Out (s, t.preDecl);
    END;
  END GenTypePreDecl;

PROCEDURE FilterRawTypeDecl (VAR s: State;  t: Type;  tx: INTEGER) =
  BEGIN
    IF (s.type_needed [tx]) THEN
      GenRawTypeDecl (s, t, tx);
    END;
  END FilterRawTypeDecl;

PROCEDURE GenRawTypeDecl (VAR s: State;  t: Type;  tx: INTEGER) =
  VAR n: NameList;  must_emit_decl := FALSE;  x: Type;  xx: INTEGER;
  BEGIN
    IF (s.emitted_raw[tx]) THEN RETURN END;

    (* make sure that the concrete type exists *)
    IF (t.class = TypeClass.Opaque) THEN
      <* ASSERT t.decl = NIL *>

      (* make sure that my revealed type is declared (or pre-declared) *)
      x := s.base.revealed[tx];
      IF (x.preDecl = NIL) THEN
        (* no pre declaration => no recursion is possible *)
        GenRawTypeDecl (s, x, M3LinkMap.GetIndex (s.base.types, x.uid));
      END;

      StartType (s, t);
      (*******
      Out (s, "typedef ", x.uid.text);
      Out (s, " ", t.uid.text, ";\n");
      ********)
      Out (s, "#define ", t.uid.text, " ");
      Out (s, x.uid.text, "\n");
      s.emitted_raw[tx] := TRUE; (* prevent infinite recursions *)
    END;

    IF (NOT s.emitted_pre[tx]) AND (t.preDecl # NIL) THEN
      (* this is the first time we encountered this type & it has a preDecl *)
      must_emit_decl := TRUE;
      s.emitted_raw[tx] := TRUE; (* prevent infinite recursions *)
    END;
    s.emitted_pre[tx] := TRUE;

    (* emit the types that I depend on *)
    n := t.depends;
    WHILE (n # NIL) DO
      xx := M3LinkMap.GetIndex (s.base.types, n.name);
      x  := M3LinkMap.GetDirect (s.base.types, xx); 
      GenRawTypeDecl (s, x, xx);
      n := n.next;
    END;

    (* finally, emit me *)
    IF (NOT s.emitted_raw[tx]) OR (must_emit_decl) THEN
      StartType (s, t);
      Out (s, t.decl);
      IF (t.methodDecl # NIL) THEN Out (s, t.methodDecl) END;
      s.emitted_raw[tx] := TRUE; (* prevent infinite recursions *)
    END;
  END GenRawTypeDecl;

PROCEDURE GenTypeDecl (VAR s: State;  t: Type;  tx: INTEGER) =
  VAR x: Type;  xx: INTEGER;
  BEGIN
    IF (t = NIL) THEN RETURN END;

    IF (NOT s.type_needed[tx]) THEN
      (* this is an unneeded, imported type *)
    ELSIF (s.emitted_flat[tx]) THEN
      (* already done *)
    ELSIF (t.class = TypeClass.Object) THEN
      (* emit the flat declarations *)
      xx := M3LinkMap.GetIndex (s.base.types, t.super);
      x  := M3LinkMap.GetDirect (s.base.types, xx); 
      GenTypeDecl (s, x, xx);

      StartType (s, t);

      Out (s, "typedef struct {\n");
      (*** KRML   Out (s, "  int _typecode;\n");  ***)
      IF NOT EmitObjectMethods (s, t, tx) THEN
        Out (s, "  int _pleaseCcompiler;\n")  (* KRML new *)
      END;
      Out (s, "} ", t.uid.text, "_METHODS ;\n");

      Out (s, "typedef struct ", t.uid.text, "_FIELDS {\n");
      Out (s, "  ", t.uid.text, "_METHODS*  _methods;\n");
      EmitObjectFields (s, t, tx);
      Out (s, "} ", t.uid.text, "_FIELDS;\n");
    END;

    s.emitted_flat[tx] := TRUE;
  END GenTypeDecl;

PROCEDURE GenTypeCells (VAR s: State;  t: Type;  <*UNUSED*> tx: INTEGER) =
  BEGIN
    IF TypeHasTypecell (t) THEN
      IF TypeIsLocal (t) THEN
        Out (s, "_EXPORT _TYPE* ", t.uid.text, "_TC;\n");
      END;
      INC (s.n_typecells);
    END;
  END GenTypeCells;

PROCEDURE GenTypeNames (VAR s: State;  t: Type;  tx: INTEGER) =
  VAR name := t.name;  x: Type;
  BEGIN
    IF (name # NIL) AND (s.type_needed[tx]) THEN
      x := t;
      IF (t.class = TypeClass.Opaque) THEN  x := s.base.revealed[tx]  END;
      IF NOT s.typeNames.put (name) THEN
        Out (s, "typedef ", x.uid.text, " ");
        PutCName (s, t);
        Out (s, ";\n");
      END;
    END;
  END GenTypeNames;

PROCEDURE StartType (VAR s: State;  t: Type) =
  BEGIN
    IF (s.verbose) THEN Out (s, "\n/* ", TypeName (t), " */\n")  END;
  END StartType;

PROCEDURE EmitObjectMethods (VAR s: State;  t: Type;  tx: INTEGER): BOOLEAN =
  VAR x: Type;  xx: INTEGER;
  BEGIN
    IF (t = NIL) OR (t = s.base.root) OR (t = s.base.un_root) THEN
      (* done *)
      RETURN FALSE
    ELSIF (t.class = TypeClass.Opaque) THEN
      x  := s.base.revealed[tx];
      xx := M3LinkMap.GetIndex (s.base.types, x.uid);
      RETURN EmitObjectMethods (s, x, xx)
    ELSE
      xx := M3LinkMap.GetIndex (s.base.types, t.super);
      x  := M3LinkMap.GetDirect (s.base.types, xx);
      EVAL EmitObjectMethods (s, x, xx);
      IF (t.methodDecl # NIL) AND (Text.Length (t.methodDecl) > 0) THEN
        Out (s, "  ", t.uid.text, "_methods ");
        PutCName   (s, t);
        Out (s, ";\n");
      END;
      RETURN TRUE
    END;
  END EmitObjectMethods;

PROCEDURE EmitObjectFields (VAR s: State;  t: Type;  tx: INTEGER) =
  VAR x: Type;  xx: INTEGER;
  BEGIN
    IF (t = NIL) OR (t = s.base.root) OR (t = s.base.un_root) THEN
      (* done *)
    ELSIF (t.class = TypeClass.Opaque) THEN
      x  := s.base.revealed[tx];
      xx := M3LinkMap.GetIndex (s.base.types, x.uid);
      EmitObjectFields (s, x, xx);
    ELSE
      xx := M3LinkMap.GetIndex (s.base.types, t.super);
      x  := M3LinkMap.GetDirect (s.base.types, xx);
      EmitObjectFields (s, x, xx);
      IF (t.decl # NIL) AND (Text.Length (t.decl) > 0) THEN
        Out (s, "  ", t.uid.text, "_fields ");
        PutCName   (s, t);
        Out (s, ";\n");
      END;
    END;
  END EmitObjectFields;

PROCEDURE PutCName (VAR s: State;  t: Type) =
  VAR ch: CHAR;  x := t.name;
  BEGIN
    IF (x # NIL) THEN
      FOR i := 0 TO Text.Length (x)-1 DO
        ch := Text.GetChar (x, i);
        IF (ch = '.')
          THEN Wr.PutText (s.output, "__");
          ELSE Wr.PutChar (s.output, ch);
        END;
      END;
    ELSE
      Out (s, t.uid.text);
    END;
  END PutCName;

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

TYPE
  UnitInfo = REF RECORD
    unit         : Unit;
    next         : UnitInfo;
    imports      : UnitInfoList := NIL;
    exporters    : UnitInfoList := NIL;
    dfs_id       : INTEGER  := 0;
    low_link     : INTEGER  := 0;
    prev_stack   : UnitInfo := NIL;
    init_started : BOOLEAN  := FALSE;
    stacked      : BOOLEAN  := FALSE;
  END;

TYPE
  UnitInfoList = REF RECORD
    ui   : UnitInfo;
    next : UnitInfoList;
  END;

PROCEDURE GenerateMainProc (VAR s: State) =
  VAR
    u       : Unit;
    main    : UnitInfo;
    builtin : UnitInfo;
    n       : NameList;
    ui, vi  : UnitInfo;
    all_ui  : UnitInfo := NIL;
    intfs   : REF ARRAY OF UnitInfo;
    units   : REF ARRAY OF M3LinkMap.Value;
  BEGIN
    (* allocate the UnitInfo nodes for the interfaces *)
    units := M3LinkMap.GetData (s.base.interfaces);
    intfs := NEW (REF ARRAY OF UnitInfo, NUMBER (units^));
    FOR i := 0 TO LAST (units^) DO
      u := units[i];
      ui := NIL;
      IF (u # NIL) THEN
        ui := NEW (UnitInfo, unit := u, next := all_ui);
        all_ui := ui;
      END;
      intfs [i] := ui;
    END;

    (* allocate the UnitInfo nodes for the modules *)
    units := M3LinkMap.GetData (s.base.modules);
    FOR i := 0 TO LAST (units^) DO
      u := units[i];
      IF (u # NIL) THEN
        all_ui := NEW (UnitInfo, unit := u, next := all_ui);
      END;
    END;

    (* connect the UnitInfo graph *)
    ui := all_ui;
    WHILE (ui # NIL) DO
      u  := ui.unit;

      n := u.imported_units;
      WHILE (n # NIL) DO
        vi := FindUnit (s, intfs, n.name);
        IF (ui # vi) THEN
          ui.imports := NEW (UnitInfoList, next := ui.imports, ui := vi);
        END;
        n := n.next;
      END;

      n := u.exported_units;
      WHILE (n # NIL) DO
        vi := FindUnit (s, intfs, n.name);
        IF (ui # vi) THEN
          ui.imports := NEW (UnitInfoList, next := ui.imports, ui := vi);
          vi.exporters := NEW (UnitInfoList, next := vi.exporters, ui := ui);
        END;
        n := n.next;
      END;

      ui := ui.next;
    END;

    (* locate "Main" *)
    IF (s.has_main)
      THEN main := FindUnit (s, intfs, s.base.main.name);
      ELSE main := NIL;
    END;
    IF (s.base.builtin # NIL)
      THEN builtin := FindUnit (s, intfs, s.base.builtin.name);
      ELSE builtin := NIL;
    END;

    Out (s, "\n/*-----------------------------------------*/\n");

    ui := all_ui;
    WHILE (ui # NIL) DO
      ImportUnit (s, ui);
      ui := ui.next;
    END;

    IF (s.mode # Mode.Library) THEN
      Out (s, "\n/*-----------------------------------------*/\n");
      Out (s, "_PRIVATE _LINK_INFO* _modules [] = { 0,\n");

      s.dfs_count := 1;
      s.init_stack := NIL;
      IF (builtin # NIL) THEN InitUnit (s, builtin, NIL) END;
      InitUnit (s, main, all_ui);

      Out (s, "  0,\n};\n");
    END;

    Out (s, "\n/*-----------------------------------------*/\n");

    IF (s.magic # NIL) THEN
      Out (s, "_EXPORT char ", s.magic, " = 1;\n\n");
    END;

    IF (s.has_main) THEN
      Out (s, "\n/*-----------------------------------------*/\n");
      (********************* KRML
      Out (s, "_PRIVATE _TYPE* _types[", Fmt.Int (s.n_typecells+10), "];\n\n");
      ******************* KRML *)
      (* new KRML *)
      M3LinkerKRML.GeneratePredecls( s.ss, s.output );
      M3LinkerKRML.GenerateTypecells( s.ss, s.output );
      M3LinkerKRML.GenerateTypecellList( s.ss, s.output );
      M3LinkerKRML.GenerateTCs( s.ss, s.output );
      Out (s, "\n/*-----------------------------------------*/\n");
      (* end KRML *)
    END;

    IF (s.mode # Mode.Library) THEN
      Out (s, "_IMPORT int          RT0u__tcAddress;\n");  (* new KRML *)
      (************** KRML
      Out (s, "_IMPORT _ADDRESS     _M3__bottom_of_stack;\n");
      Out (s, "_IMPORT int          RTArgs__argc;\n");
      Out (s, "_IMPORT char**       RTArgs__argv;\n");
      Out (s, "_IMPORT char**       RTArgs__envp;\n");
      ************ KRML *)
      Out (s, "_IMPORT int          RT0u__nModules;\n");
      Out (s, "_IMPORT _LINK_INFO** RT0u__modules;\n");
      (************** KRML
      Out (s, "_IMPORT int          RT0u__nTypes;\n");
      ************ KRML *)
      Out (s, "_IMPORT _TYPE**      RT0u__types;\n");
      Out (s, "\n");
    END;

    CASE (s.mode) OF
    | Mode.Program =>
        Out (s, "main (argc, argv, envp)\n");
        Out (s, "int argc;  char** argv;  char** envp;\n");
        Out (s, "{\n" );  (* new KRML *)
        (************** KRML
        Out (s, "{ int _root;\n");
        Out (s, "  _M3__bottom_of_stack = (_ADDRESS) &_root;\n");
        Out (s, "  RTArgs__argc = argc;\n");
        Out (s, "  RTArgs__argv = argv;\n");
        Out (s, "  RTArgs__envp = envp;\n");
        ************ KRML *)
        Out (s, "  RT0u__tcAddress = ",
             Fmt.Int (M3LinkerKRML.GetTcAddress (s.ss)), ";\n"); (* new KRML *)
        Out (s, "  RT0u__nModules = ", Fmt.Int (s.n_modules), ";\n");
        Out (s, "  RT0u__modules = _modules + 1;\n");
        (************** KRML
        Out (s, "  RT0u__nTypes = ", Fmt.Int (s.n_typecells), ";\n");
        ************ KRML *)
        Out (s, "  RT0u__types = _types;\n");
        Out (s, "  RTMain__Run ();\n");
        Out (s, "  return 0;\n");  (* new KRML *)
        Out (s, "}\n");
    | Mode.BaseProgram =>
        Out (s, "main (argc, argv, envp)\n");
        Out (s, "int argc;  char** argv;  char** envp;\n");
        Out (s, "{\n" );  (* new KRML *)
        (************** KRML
        Out (s, "{ int _root;\n");
        Out (s, "  _M3__bottom_of_stack = (_ADDRESS) &_root;\n");
        Out (s, "  RTArgs__argc = argc;\n");
        Out (s, "  RTArgs__argv = argv;\n");
        Out (s, "  RTArgs__envp = envp;\n");
        ************ KRML *)
        Out (s, "  RT0u__tcAddress = ",
             Fmt.Int (M3LinkerKRML.GetTcAddress (s.ss)), ";\n"); (* new KRML *)
        Out (s, "  RT0u__nModules = ", Fmt.Int (s.n_modules), ";\n");
        Out (s, "  RT0u__modules = _modules + 1;\n");
        Out (s, "  RTMain__Run ();\n");
        Out (s, "  return 0;\n");  (* new KRML *)
        Out (s, "}\n");
    | Mode.Overlay =>
        Out (s, "_PRIVATE _LINK_INFO* _all_modules [",
                  Fmt.Int (s.n_modules + s.n_base_mods), "];\n\n");
        Out (s, "_init_overlay ()\n");
        Out (s, "{\n");
        Out (s, "  register int i, j;\n");
        Out (s, "  RT0u__types = _types;\n");
        (************** KRML
        Out (s, "  RT0u__nTypes = ", Fmt.Int (s.n_typecells), ";\n");
        ************ KRML *)
        Out (s, "  for (i = 0; i < RT0u__nModules; i++)");
        Out (s, "    _all_modules[i] = RT0u__modules[i];\n");
        Out (s, "  RT0u__nModules += ", Fmt.Int (s.n_modules), ";\n");
        Out (s, "  for (j = 1; i < RT0u__nModules; i++, j++)");
        Out (s, "    _all_modules[i] = _modules[j];\n");
        Out (s, "  RT0u__modules = _all_modules;\n");
        Out (s, "}\n");
    | Mode.Library =>
        (* no code to generate *)
    END;
  END GenerateMainProc;

PROCEDURE FindUnit (VAR s: State;  intfs: REF ARRAY OF UnitInfo;
                     READONLY name: Name): UnitInfo =
  VAR x: INTEGER;
  BEGIN
    x := M3LinkMap.GetIndex (s.base.interfaces, name);
    IF (0 <= x) AND (x <= LAST (intfs^))
      THEN RETURN intfs[x];
      ELSE RETURN NIL;
    END;
  END FindUnit;

PROCEDURE KeepUnit (VAR s: State;  u: Unit): BOOLEAN =
  BEGIN
    RETURN (s.mode = Mode.Program)
        OR (s.mode = Mode.BaseProgram)
        OR ((s.mode = Mode.Overlay) AND (NOT u.file.imported));
  END KeepUnit;

PROCEDURE ImportUnit (VAR s: State;  ui: UnitInfo) =
  CONST Prefix = ARRAY BOOLEAN OF TEXT { "_IMPORT _LINK_INFO _M_",
                                         "_IMPORT _LINK_INFO _I_" };
  VAR u := ui.unit;  f := u.file;
  BEGIN
    IF KeepUnit (s, u) THEN
      Out (s, Prefix [u.interface], u.name.text, ";\n");
    END;

    IF (f.imported) AND (f.magic # NIL)
      AND (NOT s.magicImports.put (f.magic)) THEN
      Out (s, "_IMPORT char ", f.magic, ";\n");
      Out (s, "_PRIVATE char* __", f.magic, " = &");
      Out (s, f.magic, ";\n");
    END;
  END ImportUnit;

PROCEDURE InitUnit (VAR s: State;  ui: UnitInfo;  others: UnitInfo) =
  (* This procedure is adapted from the algorithm, SEARHC, given in
     "The Design and Analysis of Computer Algorithms" by Aho, Hopcroft,
     and Ullman for finding strongly connected components. *)
  VAR x: UnitInfoList;  z, next_z: UnitInfo;  n_mods: INTEGER;
  BEGIN
    IF (ui # NIL) THEN
      ui.init_started := TRUE;
      ui.dfs_id := s.dfs_count;  INC (s.dfs_count);
      ui.low_link := ui.dfs_id;

      <*ASSERT NOT ui.stacked *>
      ui.stacked := TRUE;
      ui.prev_stack := s.init_stack;
      s.init_stack := ui;

      (* visit my imports *)
      x := ui.imports;
      WHILE (x # NIL) DO  InitProbe (s, ui, x.ui); x := x.next;  END;
      (* visit my exporters *)
      x := ui.exporters;
      WHILE (x # NIL) DO  InitProbe (s, ui, x.ui); x := x.next;  END;
    END;

    (* visit everbody else *)
    z := others;
    WHILE (z # NIL) DO  InitProbe (s, ui, z); z := z.next;  END;

    IF (ui # NIL) AND (ui.low_link = ui.dfs_id) THEN
      (* ui is the root of a strongly connected component *)
      (* => "pop" the component off the stack *)
      n_mods := s.n_modules;

      (* first, init the interfaces in the component *)
      z := s.init_stack;
      LOOP
        IF (z.unit.interface) THEN EmitInit (s, z.unit) END;
        IF (z = ui) THEN EXIT END;
        z := z.prev_stack;
      END;

      (* then, init the modules in the component *)
      z := s.init_stack;
      LOOP
        IF (NOT z.unit.interface) THEN EmitInit (s, z.unit) END;
        IF (z = ui) THEN EXIT END;
        z := z.prev_stack;
      END;

      IF (n_mods # s.n_modules) THEN Out (s, "\n") END; (* break the list *)

      (* finally, pop the stack *)
      z := s.init_stack;
      LOOP
        next_z := z.prev_stack;
        z.stacked := FALSE;
        z.prev_stack := NIL;
        IF (z = ui) THEN EXIT END;
        z := next_z;
      END;
      s.init_stack := next_z;
    END;
  END InitUnit;

PROCEDURE InitProbe (VAR s: State;  v, w: UnitInfo) =
  BEGIN
    IF (NOT w.init_started) THEN
      InitUnit (s, w, NIL);
      IF (v # NIL) THEN v.low_link := MIN (w.low_link, v.low_link) END;
    ELSIF (v # NIL) AND (w.dfs_id < v.dfs_id) AND (w.stacked) THEN
      v.low_link := MIN (w.dfs_id, v.low_link);
    END;
  END InitProbe;

PROCEDURE EmitInit (VAR s: State;  u: Unit) =
  CONST Prefix = ARRAY BOOLEAN OF TEXT { "  &_M_", "  &_I_" };
  BEGIN
    IF KeepUnit (s, u) THEN
      Out (s, Prefix [u.interface], u.name.text, ",\n");
      INC (s.n_modules);
    ELSE
      INC (s.n_base_mods);
    END;
  END EmitInit;

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

PROCEDURE Out (VAR s: State;  a, b, c, d: 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;
  END Out;


(* new KRML --------------------------------------------------------------*)

PROCEDURE InitTypecells( VAR s: State ) RAISES {LinkError} =
  VAR x: REF ARRAY OF M3LinkMap.Value;
      c := ARRAY TypeClass OF CARDINAL { 0, .. };
      t: Type;
  BEGIN
    <* ASSERT s.ss = NIL *>

    x := M3LinkMap.GetData (s.base.types);
    FOR i := FIRST (x^) TO LAST (x^) DO
      IF x[i] # NIL THEN t := x[i]; INC( c[ t.class ] ) END
    END;
    s.ss := M3LinkerKRML.New( c[ TypeClass.Ref ],
                              c[ TypeClass.Object ],
                              c[ TypeClass.Opaque ] );
    FOR i := FIRST (x^) TO LAST (x^) DO
      IF x[i] # NIL THEN
        t := x[i];
        CASE t.class OF
          TypeClass.Ref    => M3LinkerKRML.AddRefType( s.ss, t )
        | TypeClass.Object => M3LinkerKRML.AddObjType( s.ss, t )
        | TypeClass.Opaque => M3LinkerKRML.AddOpaqueName( s.ss, t )
        ELSE (* skip *)
        END 
      END
    END;

    M3LinkerKRML.AddOpaques( s.ss, s.base.all_units, s.base.types );

    (* Note, duplicate brand names was already checked for in
       M3LinkerPgm.BuildTypeMap *)

    M3LinkerKRML.FindChildren( s.ss );
    M3LinkerKRML.AssignTypecodes( s.ss );
    M3LinkerKRML.CheckRevelations( s.ss, s.base.all_units );
    M3LinkerKRML.FixSizes( s.ss );

    M3LinkerKRML.CheckTypes( s.ss )
  END InitTypecells;

(* end KRML *)

BEGIN
END M3LinkerC.