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

(* File: M3LinkerKRML.m3                                       *)
(* Last Modified On Wed Sep  2 10:27:40 PDT 1992 By rustan     *)

MODULE M3LinkerKRML;

IMPORT M3Linker, M3LinkMap, Wr, Fmt, Text, Thread, RTMisc;
IMPORT Target, RemoteMethods;
FROM M3Linker IMPORT LinkError;
<*FATAL Wr.Failure, Thread.Alerted*>

REVEAL
  S = BRANDED REF State;

TYPE
  State = RECORD
    refs           : M3LinkMap.T := NIL;
    objs           : M3LinkMap.T := NIL;
    opaques        : M3LinkMap.T := NIL;
    nTypes         : CARDINAL := 0;
    inapprNetTypes : InapprNetTypeNode := NIL;
    tcNull         : REF Typecell := NIL;
    tcRefany       : REF Typecell := NIL;
    tcAddress      : REF Typecell := NIL;
    tcRoot         : REF Typecell := NIL;
    tcUntracedRoot : REF Typecell := NIL
  END;

  InapprNetTypeNode = REF RECORD
    uid      : M3Linker.Name;
    unitName : TEXT;
    next     : InapprNetTypeNode
  END;

  OpaqueCell = RECORD
    lhs     : M3Linker.Name;
    lhsName : TEXT;
    rhs     : M3Linker.Name;
    rhsTC   : REF Typecell := NIL
  END;

  Typecode = CARDINAL;

  RemoteList = REF RECORD
    offset : CARDINAL;
    rm     : RemoteMethods.T;
    next   : RemoteList
  END;

  MethodPair = RECORD
    local:  TEXT := NIL;
    remote: RemoteMethods.T := NIL
  END;

  Typecell = RECORD
    uid              : M3Linker.Name;  (* the _t... name *)(* new field KRML *)
    typecode         : Typecode := LAST(Typecode);
    lastSubTypeTC    : Typecode := LAST(Typecode);
    selfID           : INTEGER;
    selfLink         : TEXT;
    class            : M3Linker.TypeClass;  (* new field KRML *)
    traced           : BOOLEAN;

    dataOffset       : INTEGER := 0;
        (* for object types, the quantity to add to the address of the object
             to get to the fields that belong to this object type;
           for refs, unused;
           for open arrays, the quantity to add to the address of the array
             to get to the elements *)
    dataSize         : INTEGER;
        (* for object types, the size of the fields that belong to this
             object type;
           for refs, the size of the referent;
           for open array types, the size of the "open overhead", including
             padding to align the elements; i.e. ADR (a[0]) - ADR (a) *)
    dataAlignment    : INTEGER;
        (* for object types, the alignment constraint for the fields that
             belong to this object type;
           for refs, the alignment of the referent;
           for open arrays, the alignment of the full array, including
             the header *)

    methodOffset     : INTEGER := 0;
    nMethods         : INTEGER;
    methodList       : M3Linker.OverrideList;
    methodSuite      : REF ARRAY OF MethodPair := NIL;
    methodExtendOnly : BOOLEAN;
    methodSuiteName  : TEXT := NIL;
    isObjectType     : BOOLEAN;
    isNetworkType    : BOOLEAN;
    newRemoteMethods : RemoteList := NIL;  (* sorted by offset *)
    nDimensions      : INTEGER; (* > 0 iff open array *)
    elementSize      : INTEGER;
    tracedOffs       : TEXT;
    initProc         : TEXT;
    brand            : TEXT;
    name             : TEXT;
    parentUid        : M3Linker.Name;
    parent           : REF Typecell := NIL;
    children         : REF Typecell := NIL;
    sibling          : REF Typecell := NIL
  END;



PROCEDURE New( nRefs, nObjects, nOpaques: CARDINAL ): S =
  VAR s := NEW( S );
  BEGIN
    s.refs := M3LinkMap.New( 3 * nRefs + 30 );
    s.objs := M3LinkMap.New( 3 * nObjects + 30 );
    s.opaques := M3LinkMap.New( 3 * nOpaques + 30 );
    RETURN s
  END New;  

PROCEDURE AddRefType( s: S; t: M3Linker.Type ) RAISES {LinkError} =
  BEGIN
    <* ASSERT t.class = M3Linker.TypeClass.Ref *>
    AddType( s.refs, t );
    INC( s.nTypes )
  END AddRefType;

PROCEDURE AddObjType( s: S; t: M3Linker.Type ) RAISES {LinkError} =
  VAR name: TEXT;
  BEGIN
    <* ASSERT t.class = M3Linker.TypeClass.Object *>
    IF t.super.text = NIL THEN
      IF t.name = NIL THEN name := "<anonymous>" ELSE name := t.name END;
      RAISE LinkError ( Fmt.F( "object type %s (%s) lacks supertype",
                               name, t.uid.text ))
    END;
    AddType( s.objs, t );
    INC( s.nTypes )
  END AddObjType;

PROCEDURE AddType( VAR map: M3LinkMap.T; t: M3Linker.Type )
    RAISES {LinkError} =
  VAR typename := t.uid.text;
      tc := NEW( REF Typecell );
  BEGIN
    tc.uid := t.uid;
    (* tc.typecode and tc.lastSubTypeTC both default to LAST(Typecode) *)
    tc.selfID := TypenameToID( typename );
    tc.selfLink := typename & "_TC";
    tc.class := t.class;
    tc.traced := VAL( t.isTraced, BOOLEAN );

    tc.dataSize := t.dataSize;
    tc.dataAlignment := t.dataAlignment;

    tc.nMethods := t.nMethods;
    tc.methodList := t.overrides;
    VAR
      sig := t.sigEncodings;  rl, p, back: RemoteList;  offset: CARDINAL;
    BEGIN
      WHILE sig # NIL DO
        offset := sig.offset;
        rl := NEW( RemoteList,
                   offset := offset,
                   rm := RemoteMethods.Add( sig.encoding ));

        (* add to tc.newRemoteMethods, sorted by offset *)
        p := tc.newRemoteMethods;  back := NIL;
        WHILE p # NIL AND p.offset < offset DO back := p;  p := p.next END;
        IF back = NIL THEN
          rl.next := tc.newRemoteMethods;  tc.newRemoteMethods := rl
        ELSE
          rl.next := back;  back.next := rl
        END;

        sig := sig.next
      END
    END;

    tc.nDimensions := t.nDimensions;
    tc.elementSize := t.elementSize;

    tc.tracedOffs := t.tracedOffs.text;
    tc.initProc := t.initProc.text;

    tc.brand := t.brand.text;
    tc.name := t.name;

    tc.parentUid := t.super; (* note, if t.super designates an opaque type, *)
                             (* tc.parentUid will get replaced in AddOpaques *)

    M3LinkMap.Insert( map, tc.uid, tc )
  END AddType;


PROCEDURE AddOpaqueName( s: S; t: M3Linker.Type ) =
  (* add type uid to linked list if supertype is ROOT *)
  VAR n: InapprNetTypeNode;
  BEGIN
    IF t.inapprNetType # NIL THEN
      n := NEW( InapprNetTypeNode, uid := t.uid, unitName := t.inapprNetType );
      n.next := s.inapprNetTypes;
      s.inapprNetTypes := n
    END
  END AddOpaqueName;

PROCEDURE AddOpaques( s: S; ul: M3Linker.UnitList; typeMap: M3LinkMap.T )
    RAISES {LinkError} =

  (* before this procedure is called, all ref and object types must have
     been added *)
  PROCEDURE AddOpaque( rev: M3Linker.Revelation ) RAISES {LinkError} =
    VAR oc := NEW( REF OpaqueCell, lhs := rev.lhs, rhs := rev.rhs );
        ocPrev: REF OpaqueCell;
        tLHS: M3Linker.Type;
        tcRHS: REF Typecell;
    BEGIN
      tLHS := M3LinkMap.Get( typeMap, rev.lhs );
      IF tLHS = NIL THEN
        RAISE LinkError ( "cannot find opaque type " & rev.lhs.text )
      END;
      oc.lhsName := tLHS.name;

      ocPrev := M3LinkMap.Get( s.opaques, rev.lhs );
      IF ocPrev # NIL THEN
        RAISE LinkError ( "multiple revelations for opaque type " &
                          oc.lhsName )
      END;

      tcRHS := LocateType( s, rev.rhs );
      IF tcRHS = NIL THEN
        RAISE LinkError ( "concrete type of revelation missing (REVEAL " &
                          oc.lhsName & " = " & rev.rhs.text & ")" )
      END;

      oc.rhsTC := tcRHS;
      M3LinkMap.Insert( s.opaques, oc.lhs, oc )
    END AddOpaque;

  VAR rev: M3Linker.Revelation;
      x: REF ARRAY OF M3LinkMap.Value;
      tc: REF Typecell;
      oc: REF OpaqueCell;
  BEGIN
    WHILE ul # NIL DO
      rev := ul.unit.revelations;
      WHILE rev # NIL DO
        IF rev.export AND NOT rev.partial THEN AddOpaque( rev ) END;
        rev := rev.next
      END;
      ul := ul.next
    END;
    (* for every type, replace any reference to an opaque supertype by
       a reference to the concrete supertype *)
    x := M3LinkMap.GetData( s.objs );
    FOR i := FIRST (x^) TO LAST (x^) DO
      IF x[i] # NIL THEN
        tc := x[i];
        IF tc.parentUid.text # NIL THEN
          oc := M3LinkMap.Get( s.opaques, tc.parentUid );
          IF oc # NIL THEN tc.parentUid := oc.rhsTC.uid END
        END
      END
    END
  END AddOpaques;

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

PROCEDURE FindChildren( s: S ) RAISES {LinkError} =
  VAR x: REF ARRAY OF M3LinkMap.Value;
      tc, tcRefany, tcAddress: REF Typecell := NIL;
  BEGIN
    (* Assign parents to all object types *)
    x := M3LinkMap.GetData( s.objs );
    FOR i := FIRST (x^) TO LAST (x^) DO
      IF x[i] # NIL THEN
        tc := x[i];
        <* ASSERT tc.parent = NIL *>
        <* ASSERT tc.parentUid.text # NIL *>

        tc.parent := LocateType( s, tc.parentUid );
        IF tc.parent = NIL THEN
          RAISE LinkError ( "parent type of object type " & TypeName( tc ) &
                            " missing" )
        END;
        tc.sibling := tc.parent.children;
        tc.parent.children := tc;

        IF tc.name = NIL THEN (* skip *)
        ELSIF Text.Equal( tc.name, "ROOT" ) THEN
            <* ASSERT tcRefany = NIL *>
            <* ASSERT s.tcRoot = NIL *>
            tcRefany := tc.parent;
            s.tcRoot := tc;
            <* ASSERT Text.Equal( tcRefany.name, "REFANY" ) *>
        ELSIF Text.Equal( tc.name, "_UNTRACED_ROOT_" ) THEN
            <* ASSERT tcAddress = NIL *>
            <* ASSERT s.tcUntracedRoot = NIL *>
            tcAddress := tc.parent;
            s.tcUntracedRoot := tc;
            <* ASSERT Text.Equal( tcAddress.name, "ADDRESS" ) *>
        END
      END
    END;

    IF tcRefany = NIL THEN
      RAISE LinkError ( "type ROOT missing" )
    ELSIF tcAddress = NIL THEN
      RAISE LinkError ( "type UNTRACED ROOT missing" )
    END;
    <* ASSERT s.tcRefany = NIL *>  <* ASSERT s.tcAddress = NIL *>
    s.tcRefany := tcRefany;
    s.tcAddress := tcAddress;

    (* Assign parents to the other reference types *)
    x := M3LinkMap.GetData( s.refs );
    FOR i := FIRST (x^) TO LAST (x^) DO
      IF x[i] # NIL THEN
        tc := x[i];
        <* ASSERT tc.parentUid.text = NIL *>
        <* ASSERT tc.parent = NIL *>
        IF tc # tcRefany AND tc # tcAddress THEN
          <* ASSERT tc.sibling = NIL *>
          <* ASSERT tc.children = NIL *>
          IF tc.name # NIL AND Text.Equal( tc.name, "NULL" ) THEN
            (* NULL is special cased, and is not put into the
               parent/sibling/children tree *)
            <* ASSERT s.tcNull = NIL *>
            s.tcNull := tc
          ELSE
            IF tc.traced THEN
              tc.parent := tcRefany;   tc.parentUid := tcRefany.uid
            ELSE
              tc.parent := tcAddress;  tc.parentUid := tcAddress.uid
            END;
            tc.sibling := tc.parent.children;
            tc.parent.children := tc
          END
        END
      END
    END;

    <* ASSERT s.tcNull # NIL *>
  END FindChildren;

PROCEDURE AssignTypecodes( s: S ) RAISES {LinkError} =
  VAR typecode: Typecode := 0;
  PROCEDURE Assign( tc: REF Typecell; isObjectType, isNetworkType: BOOLEAN ) =
    BEGIN
      WHILE tc # NIL DO
        <* ASSERT tc.typecode = LAST(Typecode) *>
        IF typecode = 2 THEN
          <* ASSERT tc.name # NIL AND Text.Equal( tc.name, "TEXT" ) *>
        END;
        tc.typecode := typecode;  INC( typecode );
        IF tc = s.tcRoot OR tc = s.tcUntracedRoot THEN
          <* ASSERT NOT isObjectType AND NOT isNetworkType *>
          tc.isObjectType := TRUE
        ELSE
          tc.isObjectType := isObjectType
        END;
        IF tc.name # NIL AND Text.Equal( tc.name, "NETWORK" ) THEN
          <* ASSERT isObjectType AND NOT isNetworkType *>
          tc.isNetworkType := TRUE
        ELSE
          tc.isNetworkType := isNetworkType
        END;
        Assign( tc.children, tc.isObjectType, tc.isNetworkType );
        tc.lastSubTypeTC := typecode - 1;
        tc := tc.sibling
      END
    END Assign;
  BEGIN
    (* Note about the order of the following calls to Assign:

       Since NULL is a subtype of every reference type, it is treated
       in a special way:  it is assigned typecode 0.  This typecell
       was set up in such a way that its parent/sibling/children
       pointers are all NIL.

       Moreover, since the compiler generates constant strings,
       the typecode for TEXT must be in synch with the compiler.
       Since TEXT is a subtype of REFANY, REFANY's typecode is chosen
       as 1, and TEXT's typecode as 2.  This is achieved by moving
       TEXT to be REFANY's first child, and calling Assign on tcRefany
       immediately after tcNull.
    *)
    VAR back, p: REF Typecell;
    BEGIN
      back := NIL;  p := s.tcRefany.children;
      WHILE p # NIL AND ( p.name = NIL OR NOT Text.Equal( p.name, "TEXT" )) DO
        back := p;  p := p.sibling
      END;
      <* ASSERT p # NIL AND p.name # NIL AND Text.Equal( p.name, "TEXT" ) *>
      IF back # NIL THEN  (* if back = NIL, TEXT is already in right place *)
        back.sibling := p.sibling;
        p.sibling := s.tcRefany.children;
        s.tcRefany.children := p
      END
    END;

    Assign( s.tcNull, FALSE, FALSE );  <* ASSERT typecode = 1 *>
    Assign( s.tcRefany, FALSE, FALSE );
    Assign( s.tcAddress, FALSE, FALSE );
    <* ASSERT typecode = s.nTypes *>
  END AssignTypecodes;

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

PROCEDURE CheckRevelations( s: S; ul: M3Linker.UnitList ) RAISES {LinkError} =
  VAR rev: M3Linker.Revelation;
  BEGIN
    WHILE ul # NIL DO
      rev := ul.unit.revelations;
      WHILE rev # NIL DO CheckRev( s, rev );  rev := rev.next END;
      ul := ul.next
    END;
    CheckNetworkTypes( s )
  END CheckRevelations;

PROCEDURE CheckRev( s: S; rev: M3Linker.Revelation ) RAISES {LinkError} =
  (* ensure that a partial revelations is consistent *)
  VAR oc: REF OpaqueCell;
      tc: REF Typecell;
      lhsName, rhsName: TEXT;
      error: TEXT := NIL;
  BEGIN
    IF rev.export AND NOT rev.partial THEN RETURN END;

    oc := M3LinkMap.Get( s.opaques, rev.lhs );
    IF oc = NIL THEN
      RAISE LinkError ( "opaque type not found: " & rev.lhs.text )
    END;

    tc := LocateType( s, rev.rhs, rev.partial );
    IF tc = NIL THEN
      RAISE LinkError ( "undefined type in revelation: " & rev.rhs.text )
    END;

    IF rev.partial THEN
      (* partial export OR partial import *)
      IF NOT IsSubtype( oc.rhsTC, tc ) THEN
        error := "inconsistent revelation:  %s <: %s"
      ELSIF tc = s.tcRoot AND oc.rhsTC.isNetworkType AND
            NOT ( oc.rhsTC.name # NIL AND
                  Text.Equal( oc.rhsTC.name, "NETWORK" ))
      THEN
        error :=
              "network object type revealed as general object type:  %s <: %s"
      END
    ELSE
      (* complete import *)
      IF oc.rhsTC # tc THEN
        error := "identified types not equal: %s and %s"
      END
    END;

    IF error # NIL THEN
      lhsName := rev.lhs.text;
      IF oc.lhsName # NIL THEN
        lhsName := oc.lhsName & " (" & lhsName & ")"
      END;
      rhsName := tc.uid.text;
      IF tc.name # NIL THEN
        rhsName := tc.name & " (" & rhsName & ")"
      END;

      RAISE LinkError ( Fmt.F( error, lhsName, rhsName ))
    END
  END CheckRev;

PROCEDURE CheckNetworkTypes( s: S ) RAISES {LinkError} =
  VAR tc: REF Typecell := s.tcRoot.children;
      oc: REF OpaqueCell;
      n := s.inapprNetTypes;
  BEGIN
    WHILE tc # NIL DO
      IF tc.name # NIL AND Text.Equal( tc.name, "NETWORK" ) THEN EXIT END;
      tc := tc.sibling
    END;
    <* ASSERT tc # NIL *>
    (* tc is now typecell for NETWORK *)
    WHILE n # NIL DO
      oc := M3LinkMap.Get( s.opaques, n.uid );
      IF oc.rhsTC # tc AND IsSubtype( oc.rhsTC, tc ) THEN
        RAISE LinkError ( Fmt.F(
             "network object type visible only as general object type in " &
             "%s:  %s",
             n.unitName, TypeName( oc.rhsTC )))
      END;
      n := n.next
    END
  END CheckNetworkTypes;

PROCEDURE IsSubtype( tcSub, tcSuper: REF Typecell ): BOOLEAN =
  BEGIN
    <* ASSERT tcSub.typecode # LAST(Typecode) *>
    <* ASSERT tcSuper.typecode # LAST(Typecode) *>
    WITH typecode = tcSub.typecode DO
      IF typecode = 0 THEN RETURN TRUE END; (* <A t :: NULL <: t> *)
      RETURN tcSuper.typecode <= typecode AND typecode <= tcSuper.lastSubTypeTC
    END
  END IsSubtype;

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

PROCEDURE FixSizes( s: S ) RAISES {LinkError} =
  (* fix the data and method sizes and offsets *)
  BEGIN
    FixObjectSizes( s, s.tcRoot, NIL );
    FixObjectSizes( s, s.tcUntracedRoot, NIL );
    OptimizeMethodSuites( s.tcRoot );
    OptimizeMethodSuites( s.tcUntracedRoot )
  END FixSizes;

PROCEDURE FixObjectSizes( s: S; tc, tcParent: REF Typecell )
    RAISES {LinkError} =
  (* for ROOT and UNTRACED ROOT, tcParent should be passed in as NIL *)
  BEGIN
    (* fix sizes of this type *)
    <* ASSERT tc.methodSuite = NIL *>
    IF tcParent = NIL THEN
      <* ASSERT tc = s.tcRoot OR tc = s.tcUntracedRoot *>
      <* ASSERT tc.dataOffset = 0 *>
      <* ASSERT tc.methodOffset = 0 *>
      <* ASSERT tc.tracedOffs = NIL *>
    ELSE
      tc.dataOffset := RTMisc.Upper( tcParent.dataSize, tc.dataAlignment );
      INC( tc.dataSize, tc.dataOffset );
      tc.dataAlignment := MAX( tc.dataAlignment, tcParent.dataAlignment );
      tc.methodOffset := tcParent.nMethods;
      INC( tc.nMethods, tc.methodOffset )
    END;

    (* construct the method suite from the method list *)
    IF tc.nMethods > 0 THEN
      ConstructMethodSuite( s, tc, tcParent )
    END;

    IF tc.tracedOffs # NIL THEN
      tc.tracedOffs := UpdateTracedOffsets( tc.tracedOffs, tc.dataOffset, tc )
    END;

    (* fix sizes of subtypes *)
    VAR ch := tc.children; BEGIN
      WHILE ch # NIL DO
        FixObjectSizes( s, ch, tc );
        ch := ch.sibling
      END
    END
  END FixObjectSizes;

PROCEDURE ConstructMethodSuite( s: S; tc, tcParent: REF Typecell )
    RAISES {LinkError} =
  VAR nMethodsParent: CARDINAL;
      tcSuper: REF Typecell;
      o: M3Linker.OverrideList;
  BEGIN
    (* create the method suite and fill in inherited method information *)
    tc.methodSuite := NEW( REF ARRAY OF MethodPair, tc.nMethods );
    IF tcParent = NIL THEN
      nMethodsParent := 0
    ELSE
      nMethodsParent := tcParent.nMethods;
      FOR i := FIRST(tc.methodSuite^) TO LAST(tc.methodSuite^) DO
        IF i = nMethodsParent THEN EXIT END;
        (* copy parent's method i *)
        tc.methodSuite[i] := tcParent.methodSuite[i]
      END
    END;

    (* fill in the new local method information *)
    tc.methodExtendOnly := TRUE;
    o := tc.methodList;
    WHILE o # NIL DO
      tcSuper := LocateType( s, o.supertype, TRUE );
      IF tcSuper = NIL OR
         tcSuper.typecode = LAST(Typecode) OR (* check if init'd *)
         NOT IsSubtype( tc, tcSuper ) OR      (* so this test can be done *)
         tcSuper.nMethods - tcSuper.methodOffset <= o.offset
      THEN
        (* none of these conditions should ever occur, unless
           the user has mucked with a .[im]x file himself, modules
           have been compiled with different versions of the
           compiler, or a programmer error (on the part of the
           compiler/linker writer) has been committed *)
        RAISE LinkError (
              "corrupt method link information for type " & TypeName( tc ))
      END;
      IF tcSuper # tc THEN tc.methodExtendOnly := FALSE END;
      tc.methodSuite[ tcSuper.methodOffset + o.offset ].local := o.Cname.text;
      o := o.next
    END;

    (* fill in the new remote method information *)
    IF NOT tc.isNetworkType THEN RETURN END;
    VAR rl: RemoteList := tc.newRemoteMethods;
        firstMethod := tcParent.nMethods;
        nNewMethods := tc.nMethods - firstMethod;
        n: CARDINAL := 0;
    BEGIN
      WHILE rl # NIL DO
        IF nNewMethods <= rl.offset OR rl.offset # n THEN
          RAISE LinkError (
                "corrupt remote method link information for type " &
                TypeName( tc ))
        END;
        WITH nn = n + tc.methodOffset DO
          <* ASSERT rl.rm # NIL AND tc.methodSuite[nn].remote = NIL *>
          tc.methodSuite[nn].remote := rl.rm
        END;
        rl := rl.next;  INC( n )
      END;
      IF n # nNewMethods THEN
        RAISE LinkError (
              "corrupt remote method link information for type " &
              TypeName( tc ))
      END
    END
  END ConstructMethodSuite;

PROCEDURE UpdateTracedOffsets( offsets: TEXT; base: CARDINAL;
                               tc: REF Typecell): TEXT RAISES {LinkError} =
  (* 'offsets' is a string of numbers, delimited with spaces and commas *)
  (* output the string 'offsets' with each natural replaced by 'base'
     plus the number *)
  PROCEDURE Error() RAISES {LinkError} =
    BEGIN
      RAISE LinkError ( "corrupt traced offset sequence, type " &
            TypeName( tc ))
    END Error;
  PROCEDURE AppendNum() =
    BEGIN
      <* ASSERT c < NUMBER(nums^) *>
      IF neg
        THEN nums[c] := -num
        ELSE nums[c] := num
      END;
      INC( c )
    END AppendNum;
  PROCEDURE ConstructNewOffsets(): TEXT RAISES {LinkError} =
    (*  Note.  The following two constants must be in synch with those
        defined in the run-time (module RTHeapKRML) and those defined
        in the linker (module M3LinkerKRML). *)
    CONST MapEnd = -1;
          MapArray = -2;
    VAR result: TEXT := "";
        i: CARDINAL := 0;
        balance: CARDINAL := 1;
            (* remainder of string should contain 'balance' more MapEnd's
               than MapArray's;  'balance' may never reach 0 before the
               end of the string *)
        bb: CARDINAL;
    BEGIN
      IF c = 0 THEN RETURN result END;
      WHILE i < c-1 DO
        IF nums[i] >= 0 THEN
          IF balance > 1 THEN bb := 0 ELSE bb := base END;
          result := result & Fmt.Int( nums[i]+bb ) & ","
        ELSIF nums[i] = MapEnd THEN
          DEC( balance );  IF balance = 0 THEN Error() END;
          result := result & Fmt.Int( nums[i] ) & ", "
        ELSIF nums[i] = MapArray THEN
          IF c-1 <= i+3 OR nums[i+1] < 0 OR nums[i+2] < 0 OR nums[i+3] < 0 THEN
            Error()
          END;
          IF balance > 1 THEN bb := 0 ELSE bb := base END;
          result := result &
                        Fmt.F( " %s,%s,%s,%s,",
                               Fmt.Int( nums[i] ),
                               Fmt.Int( nums[i+1]+bb ), (* array offset *)
                               Fmt.Int( nums[i+2] ),    (* num of elem *)
                               Fmt.Int( nums[i+3] ));   (* elem size *)
          INC( i, 3 );  INC( balance )
        ELSE
          Error()
        END;
        INC( i )
      END;
      IF balance # 1 OR nums[c-1] # MapEnd THEN Error() END;
      RETURN result & Fmt.Int( MapEnd )
    END ConstructNewOffsets;
  VAR i: CARDINAL := 0;
      n := Text.Length(offsets);
      state: [0..2] := 0;
      neg: BOOLEAN;
      num: CARDINAL;  (* magnitude of number *)
      ch: CHAR;
      nums: REF ARRAY OF INTEGER := NEW( REF ARRAY OF INTEGER, n );
      c: CARDINAL := 0;  (* number of used array slots in 'nums' *)
  BEGIN
    WHILE i < n DO
      ch := Text.GetChar( offsets, i );  INC( i );
      CASE state OF
        0 =>  CASE ch OF
                ' ', ',' =>  (* skip *)
              | '0'..'9' =>  neg := FALSE;  num := ORD(ch) - ORD('0');
                             state := 2
              | '-'      =>  state := 1
              ELSE Error()
              END
      | 1 =>  CASE ch OF
                '0'..'9' =>  neg := TRUE;  num := ORD(ch) - ORD('0');
                             state := 2
              ELSE Error()
              END
      | 2 =>  CASE ch OF
                '0'..'9' =>  num := num * 10 + ORD(ch) - ORD('0')
              | ' ', ',' =>  AppendNum(); state := 0
              ELSE Error()
              END
      END
    END;
    CASE state OF
      0 =>  (* skip *)
    | 1 =>  Error()
    | 2 =>  AppendNum()
    END;
    RETURN ConstructNewOffsets()
  END UpdateTracedOffsets;

PROCEDURE OptimizeMethodSuites( tc: REF Typecell ) =
  VAR ch: REF Typecell := tc.children;
  BEGIN
    <* ASSERT tc.methodSuiteName = NIL *>
    WHILE ch # NIL DO
      OptimizeMethodSuites( ch );
      IF ch.methodExtendOnly THEN tc.methodSuiteName := ch.methodSuiteName END;
      ch := ch.sibling
    END;
    IF tc.methodSuiteName = NIL THEN
      tc.methodSuiteName := tc.uid.text
    END
  END OptimizeMethodSuites;

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

PROCEDURE CheckTypes( s: S ) RAISES {LinkError} =
  (* This procedure used to be called at run-time after all the types
     have been set up.  Although the conditions checked for herein
     may seem irrelevant, due to the code above, they are done nevertheless
     as sanity checks.  *)

  PROCEDURE Power2Check( tc: REF Typecell ) RAISES {LinkError} =
    BEGIN
      IF tc.traced THEN
        WITH align = tc.dataAlignment DO
          IF align < FIRST(is_power) OR LAST(is_power) < align OR
             NOT is_power[align]
          THEN
            RAISE LinkError( "type " & TypeName( tc ) &
                             " has a non-power-of-2 data alignment" )
          END
        END
      END
    END Power2Check;

  PROCEDURE ForEachType( tc: REF Typecell;
                         p: PROCEDURE ( tc: REF Typecell ) RAISES {LinkError} )
      RAISES {LinkError} =
    BEGIN
      WHILE tc # NIL DO
        p( tc );
        ForEachType( tc.children, p );
        tc := tc.sibling
      END
    END ForEachType;

  VAR is_power: ARRAY [0..8] OF BOOLEAN;
  BEGIN
    TRY
      (* compute the small powers of 2 *)
      FOR i := FIRST(is_power) TO LAST(is_power) DO is_power[i] := FALSE END;
      is_power[ 1 ] := TRUE;
      is_power[ 2 ] := TRUE;
      is_power[ 4 ] := TRUE;
      is_power[ 8 ] := TRUE;

      (* Check that all data alignments are small powers of 2 (see
         RTHeap.CheckTypes) *)
      ForEachType( s.tcNull, Power2Check );
      ForEachType( s.tcRefany, Power2Check );
      ForEachType( s.tcAddress, Power2Check )

    EXCEPT
      LinkError ( t ) => RAISE LinkError ( "internal error: " & t )
    END
    (* NOTE, the 'align' array must still be around at run-time (and must
       thus first be initalized at some point, too *)
  END CheckTypes;

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

PROCEDURE GenForEachType( s: S; p: PROCEDURE( tc: REF Typecell )) =
  PROCEDURE Gen( tc: REF Typecell ) =
    BEGIN
      WHILE tc # NIL DO
        p( tc );
        Gen( tc.children );
        tc := tc.sibling
      END
    END Gen;
  BEGIN
    (* See note in procedure AssignTypecodes about the order of
       the following calls to Gen.  *)
    Gen( s.tcNull );
    Gen( s.tcRefany );
    Gen( s.tcAddress )
  END GenForEachType;

PROCEDURE GenForEachOpaque( s: S; p: PROCEDURE( oc: REF OpaqueCell )) =
  VAR x: REF ARRAY OF M3LinkMap.Value;
      oc: REF OpaqueCell;
  BEGIN
    x := M3LinkMap.GetData( s.opaques );
    FOR i := FIRST (x^) TO LAST (x^) DO
      IF x[i] # NIL THEN oc := x[i]; p( oc ) END
    END
  END GenForEachOpaque;

PROCEDURE GeneratePredecls( s: S; wr: Wr.T ) =
  PROCEDURE GenT( tc: REF Typecell ) =
    BEGIN
      Out( wr, Fmt.F( "_EXPORT _TYPE* %s_TC;\n", tc.uid.text ));
      IF tc.methodSuite # NIL AND
         Text.Equal( tc.uid.text, tc.methodSuiteName )
      THEN
        WITH ms = tc.methodSuite DO
          FOR i := FIRST(ms^) TO LAST(ms^) DO
            IF ms[i].local # NIL THEN
              OutF( wr, "_IMPORT _VOID %s();\n", ms[i].local )
            END
          END
        END
      END;
      IF tc.initProc # NIL THEN
        OutF( wr, "_IMPORT _VOID %s();\n", tc.initProc )
      END
    END GenT;
  PROCEDURE GenR( tc: REF Typecell ) =
    BEGIN
      IF tc.isNetworkType AND tc.methodSuite # NIL AND
         Text.Equal( tc.uid.text, tc.methodSuiteName )
      THEN
        WITH ms = tc.methodSuite DO
          FOR i := FIRST(ms^) TO LAST(ms^) DO
            IF ms[i].local # NIL THEN
              <* ASSERT ms[i].remote # NIL *>
              OutF( wr, "REMOTE_METHOD( %s_remote_%s, _%s_remote_%s,\n",
                    tc.methodSuiteName, Fmt.Int( i ),
                    tc.methodSuiteName, Fmt.Int( i ));
              OutF( wr, "               _%s, _%s )\n",
                    ms[i].local,
                    RemoteMethods.CName( ms[i].remote ))
            END
          END
        END
      END
    END GenR;
  PROCEDURE GenO( oc: REF OpaqueCell ) =
    BEGIN
      Out( wr, Fmt.F( "_EXPORT _TYPE* %s_TC;\n", oc.lhs.text ))
    END GenO;
  BEGIN
    (* pre-declarations are needed for all _tc's and _TC's *)
    Out( wr, "/* pre-decls */\n" );
    GenForEachType( s, GenT );
    GenForEachOpaque( s, GenO );
    Out( wr, "\n/* remote methods */\n" );
    RemoteMethods.GenPreDecls( wr );
    Out( wr, "_IMPORT _VOID _call_rpc_client();\n" );
    Out( wr, "#define REMOTE_METHOD( method_name, mn, proc, pt ) \\\n" );
    Out( wr, "_PRIVATE _VOID method_name(); \\\n" &
             "  asm(\"mn:\"); \\\n" &
             "  asm(\"mov # proc, @--sp\"); \\\n" &
             "  asm(\"mov # pt, @--sp\"); \\\n" &
             "  asm(\"jmp _call_rpc_client\");\n" );
    GenForEachType( s, GenR );
    Out( wr, "\n" )
  END GeneratePredecls;

PROCEDURE GenerateMethodSuites( wr: Wr.T; tc: REF Typecell ) =
  VAR ms := tc.methodSuite;
      first := FIRST( ms^ );  last := LAST( ms^ );
  BEGIN
    OutF( wr, "_PRIVATE _PROC %s_methodSuite[] = {\n", tc.methodSuiteName );
    FOR i := first TO last DO
      IF i # first THEN Out( wr, ",\n" ) END;
      IF ms[i].local = NIL THEN
        Out( wr, "  0" )
      ELSE
        OutF( wr, "  %s", ms[i].local )
      END
    END;
    Out( wr, "\n};\n" );

    IF NOT tc.isNetworkType THEN RETURN END;

    OutF( wr, "_PRIVATE _PROC %s_remoteMethods[] = {\n", tc.methodSuiteName );
    FOR i := first TO last DO
      IF i # first THEN Out( wr, ",\n" ) END;
      IF ms[i].local = NIL THEN
        Out( wr, "  0" )
      ELSE
        OutF( wr, "  %s_remote_%s", tc.methodSuiteName, Fmt.Int( i ))
      END
    END;
    Out( wr, "\n};\n" )
  END GenerateMethodSuites;

PROCEDURE GenerateTypecells( s: S; wr: Wr.T ) =
  PROCEDURE GenM( tc: REF Typecell ) =
    BEGIN
      IF tc.methodSuite # NIL AND
         Text.Equal( tc.uid.text, tc.methodSuiteName )
      THEN
        GenerateMethodSuites( wr, tc )
      END
    END GenM;
  PROCEDURE Gen( tc: REF Typecell ) =
    VAR uid := tc.uid.text;
        name: TEXT;
    BEGIN
      (* First generate the method suite and traced offsets (if any);
         then generate the typecell itself *)
      IF tc.name = NIL THEN name := "<anonymous>" ELSE name := tc.name END;

      IF tc.tracedOffs # NIL THEN
        OutF( wr, "_PRIVATE int %s_tracedOffsets[] =\n", uid );
        Out( wr, "  { ", tc.tracedOffs, " };\n" )
      END;

      OutF( wr, "_EXPORT _TYPE %s_tc = {  /* %s */\n", uid, name );
      OutF( wr, "  %s, %s,\n",
            Fmt.Int( tc.typecode ),
            Fmt.Int( tc.lastSubTypeTC ));

      OutF( wr, "  %s, %s,\n", 
            Fmt.Int( tc.dataOffset ),
            Fmt.Int( tc.dataSize ));
      OutF( wr, "  %s,\n",
            Fmt.Int( tc.methodOffset * Target.ADDRSIZE DIV Target.CHARSIZE ));
      OutF( wr, "  %s, %s,\n",
            Fmt.Int( tc.nDimensions ),
            Fmt.Int( tc.elementSize ));

      IF NOT tc.isObjectType THEN
        <* ASSERT NOT tc.isNetworkType AND
                  tc.methodSuite = NIL AND tc.newRemoteMethods = NIL *>
        Out( wr, "  0, 0,\n" )             (* defaultMethods, remoteMethods *)
      ELSE
        IF tc.methodSuite = NIL THEN
          Out( wr, "  EMPTY_METHOD_SUITE, " )
        ELSE
          OutF( wr, "  (_ADDRESS)%s_methodSuite, ", tc.methodSuiteName )
        END;
        IF NOT tc.isNetworkType THEN
          <* ASSERT tc.newRemoteMethods = NIL *>
          Out( wr, "0,\n" )
        ELSIF tc.methodSuite # NIL THEN
          OutF( wr, "(_ADDRESS)%s_remoteMethods,\n", tc.methodSuiteName )
        ELSE
          <* ASSERT tc.newRemoteMethods = NIL *>
          Out( wr, "EMPTY_METHOD_SUITE,\n" )
        END
      END;

      IF tc.tracedOffs = NIL THEN                   (* tracedOffsets *)
        Out( wr, "  0,\n" )
      ELSE
        OutF( wr, "  %s_tracedOffsets,\n", uid )
      END;

      IF tc.initProc = NIL THEN                     (* initProc *)
        Out( wr, "  0,\n" )
      ELSE
        OutF( wr, "  %s,\n", tc.initProc )
      END;

      IF tc.parentUid.text = NIL THEN               (* parent *)
        OutF( wr, "  0, " )
      ELSE
        OutF( wr, "  &%s_tc, ", tc.parentUid.text )
      END;

      Out( wr, "\n};\n\n" );
    END Gen;
  BEGIN
    Out( wr, "/* method suites */\n" );
    Out( wr, "#define EMPTY_METHOD_SUITE (_ADDRESS)0x1234  " &
              "/* any non-0 value would do */\n" );
    GenForEachType( s, GenM );
    Out( wr, "\n/* typecells */\n" );
    GenForEachType( s, Gen );
    Out( wr, "\n" )
  END GenerateTypecells;

PROCEDURE GenerateTypecellList( s: S; wr: Wr.T ) =
  PROCEDURE Gen( tc: REF Typecell ) =
    BEGIN
      IF tc.typecode > 0 THEN Out( wr, ",\n" ) END;
      Out( wr, "  &", tc.uid.text, "_tc" )
    END Gen;
  BEGIN
    Out( wr, "/* table to map from typecodes to typecells */\n" );
    Out( wr, "_PRIVATE _TYPE* _types[] = {\n" );
    GenForEachType( s, Gen );
    Out( wr, "\n};\n\n" )
  END GenerateTypecellList;

PROCEDURE GenerateTCs( s: S; wr: Wr.T ) =
  PROCEDURE GenT( tc: REF Typecell ) =
    BEGIN
      WITH uid = tc.uid.text DO
        Out( wr, Fmt.F( "_EXPORT _TYPE* %s_TC = &%s_tc;\n", uid, uid ))
      END
    END GenT;
  PROCEDURE GenO( oc: REF OpaqueCell ) =
    BEGIN
      Out( wr, Fmt.F( "_EXPORT _TYPE* %s_TC = &%s_tc;\n",
                      oc.lhs.text, oc.rhs.text ))
    END GenO;
  BEGIN
    Out( wr, "/* _TC definitions for types */\n" );
    GenForEachType( s, GenT );
    Out( wr, "/* _TC definitions for opaques */\n" );
    GenForEachOpaque( s, GenO );
    Out( wr, "\n" )
  END GenerateTCs;

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

PROCEDURE GetTcAddress( s: S ): CARDINAL =
  BEGIN
    (* FindChildren and AssignTypecodes must have been called first *)
    <* ASSERT s.tcAddress # NIL *>
    <* ASSERT s.tcAddress.typecode # LAST(Typecode) *>
    RETURN s.tcAddress.typecode
  END GetTcAddress;

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

PROCEDURE PrintTypeSummary( s: S; wr: Wr.T ) =
  CONST spaces: TEXT = "                                        ";
  PROCEDURE PrintTree( tc: REF Typecell; level: CARDINAL ) =
    VAR name: TEXT;
    BEGIN
      WHILE tc # NIL DO
        IF tc.name = NIL THEN name := "<anonymous>" ELSE name := tc.name END;
        OutF( wr, "  %s  %3s  %s%s\n",
                  tc.uid.text,
                  Fmt.Int( tc.typecode ),
                  Text.Sub( spaces, 0, level * 2 ), name );
        PrintTree( tc.children, level+1 );
        tc := tc.sibling
      END
    END PrintTree;
  PROCEDURE PrintOpaques() =
    VAR x: REF ARRAY OF M3LinkMap.Value;
        oc: REF OpaqueCell;
    BEGIN
      x := M3LinkMap.GetData( s.opaques );
      FOR i := FIRST (x^) TO LAST (x^) DO
        IF x[i] # NIL THEN
          oc := x[i];
          OutF( wr, "  %s = %s   %s\n",
                oc.lhs.text, oc.rhs.text, oc.lhsName )
        END
      END
    END PrintOpaques;
  BEGIN
    Out( wr, "\n/* -----  Type summary:\n" );
    PrintTree( s.tcNull, 0 );
    PrintTree( s.tcRefany, 0 );
    PrintTree( s.tcAddress, 0 );
    Out( wr, "\n" );
    PrintOpaques();
    Out( wr, "\n----- end of Type summary */\n\n" )
  END PrintTypeSummary;

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

PROCEDURE LocateType( s: S; uid: M3Linker.Name;
                      considerOpaques: BOOLEAN := FALSE ): REF Typecell =
  VAR tc: REF Typecell;
      oc: REF OpaqueCell;
  BEGIN
    tc := M3LinkMap.Get( s.refs, uid );
    IF tc = NIL THEN tc := M3LinkMap.Get( s.objs, uid ) END;
    IF tc = NIL AND considerOpaques THEN
      oc := M3LinkMap.Get( s.opaques, uid );
      IF oc # NIL THEN <* ASSERT oc.rhsTC # NIL *> tc := oc.rhsTC END
    END;
    RETURN tc
  END LocateType;

PROCEDURE TypenameToID ( typename: TEXT ): INTEGER =
  VAR id := TextToHex( Text.Sub( typename, 2, Text.Length(typename)));
  BEGIN
    <* ASSERT id # 0 *>
    RETURN id
  END TypenameToID;

PROCEDURE TextToHex ( t: TEXT ): INTEGER =
  VAR i: INTEGER := 0;
      ch: CHAR;
      d: INTEGER;
  BEGIN
    IF t # NIL THEN
      FOR j := 0 TO Text.Length(t)-1 DO
        ch := Text.GetChar( t, j );

        CASE ch OF
          '0'..'9' =>  d := ORD( ch ) - ORD('0') + 0
        | 'a'..'f' =>  d := ORD( ch ) - ORD('a') + 10
        | 'A'..'F' =>  d := ORD( ch ) - ORD('A') + 10
        ELSE <* ASSERT FALSE *>
        END;

        i := i * 16 + d
      END
    END;
    RETURN i
  END TextToHex;

PROCEDURE TypeName( tc: REF Typecell ): TEXT =
  VAR name: TEXT := tc.uid.text;
  BEGIN
    IF tc.name # NIL THEN name := tc.name & " (" & name & ")" END;
    RETURN name
  END TypeName;

PROCEDURE OutF( wr: Wr.T;  f: TEXT; a, b, c, d: TEXT := NIL ) =
  BEGIN
    Out( wr, Fmt.F( f, a, b, c, d ))
  END OutF;

PROCEDURE Out( wr: Wr.T;  a, b, c, d: TEXT := NIL ) =
  BEGIN
    IF (a # NIL) THEN Wr.PutText (wr, a) END;
    IF (b # NIL) THEN Wr.PutText (wr, b) END;
    IF (c # NIL) THEN Wr.PutText (wr, c) END;
    IF (d # NIL) THEN Wr.PutText (wr, d) END;
  END Out;


BEGIN
END M3LinkerKRML.