-- SourceBcdImpl.mesa
--    Last edited by Lewis on  4-Jan-82 14:16:52
--    Last edited by Satterthwaite, December 30, 1982 10:38 am

DIRECTORY
  Alloc USING [AddNotify, DropNotify, Handle, Notifier, Words],
  BcdDefs USING [
    CTIndex, CTNull, CTRecord, EXPIndex, FTIndex, FTNull, IMPIndex,
    MTIndex, MTRecord, Namee, NameRecord, NTIndex, NTRecord, SGIndex, SPIndex,
    VersionID],
  BcdOps USING [BcdBase],
  BcdUtilDefs USING [BcdBasePtr, BcdBases, BcdLimitPtr, BcdLimits],
  CIFS: TYPE USING [GetFC],
  Error USING [Error, AmbiguousComponent, UnknownComponent],
  HashOps USING [HTIndex, htNull, SubStringForHash],
  Inline USING [BITAND, BITXOR],
  PackagerDefs USING [globalData, GlobalData, packctreetype],
  Space: TYPE USING [
    Handle, nullHandle, virtualMemory, Create, Delete, LongPointer, Map],
  String USING [EqualSubStrings, SubString, SubStringDescriptor],
  SourceBcd,
  Table: TYPE USING [Base, Limit];

SourceBcdImpl: PROGRAM
    IMPORTS 
      Alloc, CIFS, Error, Inline, HashOps, PackagerDefs, Space, String
    EXPORTS SourceBcd =
  BEGIN OPEN SourceBcd, BcdDefs;

 -- Source Bcd is obsolete, already repackaged, or was compiled for Alto
  BadSourceBcd: PUBLIC ERROR = CODE;

  ConfigTreeBuildingError: ERROR = CODE;
  CTreeBuildError: PROC = {ERROR ConfigTreeBuildingError};

  SubStringDescriptor: TYPE = String.SubStringDescriptor;
  SubString: TYPE = String.SubString;


  gd: PackagerDefs.GlobalData _ NIL;  -- initialized by Load
  table: Alloc.Handle _ NIL;


 -- ****************** Source BCD Loading and Unloading ****************** 

  bcdHeader: PUBLIC BcdOps.BcdBase _ NIL;

  bcdBases:  PUBLIC BcdUtilDefs.BcdBasePtr _ NIL;
  bcdLimits: PUBLIC BcdUtilDefs.BcdLimitPtr _ NIL;

  moduleCount: PUBLIC CARDINAL _ 0;


  bcdSegment: Space.Handle _ Space.nullHandle;

  Load: PUBLIC PROC = {
    ENABLE UNWIND => Unload[];
    pages: CARDINAL;
    gd _ PackagerDefs.globalData;
    table _ gd.ownTable;
    bcdSegment _ Space.nullHandle;  bcdHeader _ NIL;
    bcdBases _ NIL;  bcdLimits _ NIL;
    bcdSegment _ Space.Create[size: 10, parent: Space.virtualMemory];
    bcdSegment.Map[window: [file: gd.sourceBcdFile.GetFC, base: 1]];
    bcdHeader _ bcdSegment.LongPointer;
    IF bcdHeader.versionIdent # BcdDefs.VersionID OR bcdHeader.definitions THEN {
      Unload[];
      Error.Error[
        error, "Invalid input BCD file: obsolete version or definitions BCD"L];
      ERROR BadSourceBcd};
    IF bcdHeader.repackaged THEN {
      Unload[];
      Error.Error[error, "Already packaged BCDs cannot be repackaged"L];
      ERROR BadSourceBcd};
    IF (pages _ bcdHeader.nPages) > 10 THEN { -- load entire bcd
      Space.Delete[bcdSegment];
      bcdSegment _ Space.Create[size: pages, parent: Space.virtualMemory];
      bcdSegment.Map[window: [file: gd.sourceBcdFile.GetFC, base: 1]];
      bcdHeader _ bcdSegment.LongPointer};
    gd.sourceBcdVersion _ bcdHeader.version;
    bcdBases _ gd.zone.NEW[BcdUtilDefs.BcdBases _ [
      ctb: LOOPHOLE[bcdHeader + bcdHeader.ctOffset],
      mtb: LOOPHOLE[bcdHeader + bcdHeader.mtOffset],
      lfb: LOOPHOLE[bcdHeader + bcdHeader.lfOffset],
      rfb: LOOPHOLE[bcdHeader + bcdHeader.rfOffset],
      tfb: LOOPHOLE[bcdHeader + bcdHeader.tfOffset],
      etb: LOOPHOLE[bcdHeader + bcdHeader.expOffset],
      itb: LOOPHOLE[bcdHeader + bcdHeader.impOffset],
      sgb: LOOPHOLE[bcdHeader + bcdHeader.sgOffset],
      ftb: LOOPHOLE[bcdHeader + bcdHeader.ftOffset],
      ssb: LOOPHOLE[bcdHeader + bcdHeader.ssOffset],
      evb: LOOPHOLE[bcdHeader + bcdHeader.evOffset],
      spb: LOOPHOLE[bcdHeader + bcdHeader.spOffset],
      ntb: LOOPHOLE[bcdHeader + bcdHeader.ntOffset],
      tyb: LOOPHOLE[bcdHeader + bcdHeader.typOffset],
      tmb: LOOPHOLE[bcdHeader + bcdHeader.tmOffset],
      fpb: LOOPHOLE[bcdHeader + bcdHeader.fpOffset] ]];
    bcdLimits _ gd.zone.NEW[BcdUtilDefs.BcdLimits _ [
      ct: bcdHeader.ctLimit,
      sg: bcdHeader.sgLimit,
      ft: bcdHeader.ftLimit,
      mt: bcdHeader.mtLimit,
      et: bcdHeader.expLimit,
      it: bcdHeader.impLimit,
      nt: bcdHeader.ntLimit,
      sp: bcdHeader.spLimit,
      tm: bcdHeader.tmLimit,
      fp: bcdHeader.fpLimit]];
    CountModules[];
    InitializeMtiArray[]};

  Unload: PUBLIC PROC = {
    IF bcdSegment # Space.nullHandle THEN {
      Space.Delete[bcdSegment];
      bcdSegment _ Space.nullHandle;  bcdHeader _ NIL};
    IF bcdBases # NIL THEN gd.zone.FREE[@bcdBases];
    IF bcdLimits # NIL THEN gd.zone.FREE[@bcdLimits];
    ReleaseMtiArray[];
    moduleCount _ 0;
    table _ NIL;  gd _ NIL};

  EnumerateConfigs: PUBLIC PROC [
      userProc: PROC [CTIndex] RETURNS [stop: BOOL]] =
    BEGIN
    cti: CTIndex _ CTIndex.FIRST;
    UNTIL cti = bcdLimits.ct DO  
      IF userProc[cti] THEN RETURN;
      cti _ cti + CTRecord.SIZE + bcdBases.ctb[cti].nControls;
      ENDLOOP;
    END;

  EnumerateModules: PUBLIC PROC [
      userProc: PROC [MTIndex] RETURNS [stop: BOOL]] = {
    FOR mti: MTIndex _ MTIndex.FIRST, mti + MTRecord.SIZE
     UNTIL mti = bcdLimits.mt DO
      IF userProc[mti] THEN RETURN;
      ENDLOOP};

  IsTableCompiled: PUBLIC PROC [mti: BcdDefs.MTIndex] RETURNS [BOOL] = {
    RETURN[bcdBases.mtb[mti].tableCompiled]};

  SubStringForName: PUBLIC PROC [ss: String.SubString, name: NameRecord] = {
    ss.base _ @bcdBases.ssb.string;
    ss.offset _ name;  ss.length _ bcdBases.ssb.size[name]};

  EqualIdAndName: PUBLIC PROC [
      id: HashOps.HTIndex, name: NameRecord] RETURNS [yes: BOOL] = {
    idSS: SubString _ @idSSDesc;
      idSSDesc: SubStringDescriptor;
    nameSS: SubString _ @nameSSDesc;
      nameSSDesc: SubStringDescriptor;
    HashOps.SubStringForHash[idSS, id];
    SubStringForName[nameSS, name];
    RETURN[String.EqualSubStrings[idSS, nameSS]]};


  CountModules: PROC = {

    CountOneModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL_FALSE] = {
      moduleCount _ moduleCount+1};
  
    moduleCount _ 0;
    EnumerateModules[CountOneModule]};


 -- BcdDefs.MTIndex -> ModuleNum mapping related declarations

  mtiArray: LONG POINTER TO ModuleMap;  -- ModuleNum -> MTIndex
  ModuleMap: TYPE = RECORD [SEQUENCE length: CARDINAL OF MTIndex];

  InitializeMtiArray: PROC = {
    i: ModuleNum _ 0;

    EnterOneModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL_FALSE] = {
      mtiArray[i] _ mti;  i _ i+1};
  
    mtiArray _ gd.zone.NEW[ModuleMap[moduleCount]];
    EnumerateModules[EnterOneModule]};

  ReleaseMtiArray: PROC = {
    IF mtiArray # NIL THEN gd.zone.FREE[@mtiArray]};

  ModuleNumForMti: PUBLIC PROC [mti: BcdDefs.MTIndex] RETURNS [ModuleNum] =
    BEGIN  -- map i-th module index to i
    Ord: PROC [mti: BcdDefs.MTIndex] RETURNS [CARDINAL] = INLINE {
      RETURN [mti-BcdDefs.MTIndex.FIRST]};
    orderedMti: CARDINAL = Ord[mti];
    l, m, u: ModuleNum;
    l _ 0;  u _ moduleCount;
    UNTIL l > u DO
      m _ (l+u)/2;
      SELECT Ord[mtiArray[m]] FROM
        < orderedMti => l _ m+1;
        > orderedMti => u _ m-1;
        ENDCASE => RETURN[m];  -- mti found at mtiArray[m]
      ENDLOOP;
    RETURN[nullModuleNum];     -- could not find mti 
    END;


 -- ***************** Configuration tree node attributes ***************** 

  ConfigTreeNode: PUBLIC TYPE = RECORD [
    father:        CTreeIndex,  -- containing config
    brother:       CTreeIndex,  -- next config/module in containing config
    firstSon:      CTreeIndex,  -- first contained config/module
    prototypeName: BcdDefs.NameRecord,
    anotherNodeWSameProtoName: BOOL,
    instanceLink, prototypeLink: CTreeIndex, -- links nodes w = hash values
    instancePrev, prototypePrev: CTreeIndex, -- links nodes w = ids
    index:         BcdTableLoc,  -- module or config table index
    body: SELECT kind: ComponentKind FROM
      instance  => [instanceName: BcdDefs.NameRecord],
      prototype => []      -- for prototypes, instanceName = prototypeName
      ENDCASE];

  CTreeIndex: TYPE = Table.Base RELATIVE POINTER[0..Table.Limit) TO ConfigTreeNode;

 -- Conceptually, all components (modules and configurations) stored in the
 -- Configuration Tree have names of the form [instanceName prototypeName].
 -- If the component is a prototype, however, only the prototype name is
 -- actually stored; its instance name is the same as the prototype name.


  ctreeb: Table.Base;

  UpdateBases: Alloc.Notifier = {ctreeb _ base[PackagerDefs.packctreetype]};


  Father: PUBLIC PROC [self: CTreeIndex] RETURNS [CTreeIndex] = {
    RETURN [ctreeb[self].father]};

  EnumerateSons: PUBLIC PROC [
      self: CTreeIndex, userProc: PROC [CTreeIndex] RETURNS [stop: BOOL]] = {
    IF self # nullCTreeIndex THEN
      FOR cti: CTreeIndex _ ctreeb[self].firstSon, ctreeb[cti].brother UNTIL cti=nullCTreeIndex DO
        IF userProc[cti] THEN EXIT;
        ENDLOOP;
    RETURN};
  
  Kind: PUBLIC PROC [self: CTreeIndex] RETURNS [ComponentKind] = {
    RETURN [ctreeb[self].kind]};

  Name: PUBLIC PROC [
      self: CTreeIndex, kind: ComponentKind] RETURNS [BcdDefs.NameRecord] = {
    RETURN [SELECT kind FROM
      $prototype => ctreeb[self].prototypeName,
      $instance => WITH s~~ctreeb[self] SELECT FROM
        instance => s.instanceName,
        ENDCASE => s.prototypeName,
      ENDCASE => ERROR]};

  SharedProtoName: PUBLIC PROC [self: CTreeIndex] RETURNS [BOOL] = {
    RETURN [ctreeb[self].anotherNodeWSameProtoName]};

  Link: PUBLIC PROC [self: CTreeIndex, kind: ComponentKind] RETURNS [CTreeIndex] = {
    RETURN [SELECT kind FROM
      $prototype => ctreeb[self].prototypeLink,
      $instance => ctreeb[self].instanceLink,
      ENDCASE => ERROR]};

  Prev: PUBLIC PROC [self: CTreeIndex, kind: ComponentKind] RETURNS [CTreeIndex] = {
    RETURN [SELECT kind FROM
      $prototype => ctreeb[self].prototypePrev,
      $instance => ctreeb[self].instancePrev,
      ENDCASE => ERROR]};
  
  Index: PUBLIC PROC [self: CTreeIndex] RETURNS [BcdTableLoc] = {
    RETURN [ctreeb[self].index]};


 -- ******************** Configuration tree creation ******************** 

  BuildConfigTree: PUBLIC PROC RETURNS [root: CTreeIndex _ nullCTreeIndex] =
    BEGIN
    rootPointsToModule: BOOL _ FALSE;

    EnterOneModule: PROC [module: MTIndex] RETURNS [stop: BOOL] =
      BEGIN  OPEN mRec: bcdBases.mtb[module];
      m, c: CTreeIndex;
      config: CTIndex = mRec.config;  -- config containing module
      m _ InsertModuleNode[module];
      IF config = CTNull THEN 
	BEGIN  -- might be processing compiler-generated Bcd: record tree root
	IF root = nullCTreeIndex THEN {root _ m; rootPointsToModule _ TRUE};
	RETURN[FALSE];
	END;    
      c _ InsertConfigNode[config];
      ctreeb[m].father _ c;
      ctreeb[m].brother _ ctreeb[c].firstSon;  ctreeb[c].firstSon _ m;
      RETURN[FALSE];
      END;

    EnterOneConfig: PROC [config: CTIndex] RETURNS [stop: BOOL] =
      BEGIN  OPEN cRec: bcdBases.ctb[config];
      c, e: CTreeIndex;
      encloser: CTIndex = cRec.config;  -- configuration enclosing config
      c _ InsertConfigNode[config];
      IF encloser = CTNull THEN  -- we have found the config tree's root
	IF root # nullCTreeIndex AND ~rootPointsToModule THEN
	  CTreeBuildError[]
	ELSE {root _ c;  rootPointsToModule _ FALSE;  RETURN[FALSE]};
      e _ InsertConfigNode[encloser];
      ctreeb[c].father _ e;
      ctreeb[c].brother _ ctreeb[e].firstSon;  ctreeb[e].firstSon _ c;
      RETURN[FALSE];
      END;

    table.AddNotify[UpdateBases];
    InitializeHashVectors[];  InitializeModuleVector[];
      BEGIN
      ENABLE UNWIND => DestroyConfigTree[root];
      EnumerateModules[EnterOneModule];
      EnumerateConfigs[EnterOneConfig];
      END;
    RETURN
    END;
    
  DestroyConfigTree: PUBLIC PROC [root: CTreeIndex] =
    BEGIN
    ReleaseHashVectors[];  ReleaseModuleVector[];
    IF table # NIL THEN table.DropNotify[UpdateBases];
    END;


  CTreeHVSize: CARDINAL = 71;
  CTreeHash: TYPE = [0..CTreeHVSize);
  
  instHashVec:  LONG POINTER TO CTreeMap _ NIL;  -- CTreeHash -> CTreeIndex
  protoHashVec: LONG POINTER TO CTreeMap _ NIL;
  CTreeMap: TYPE = ARRAY CTreeHash OF CTreeIndex;

  InitializeHashVectors: PROC = {
    instHashVec  _ gd.zone.NEW[CTreeMap _ ALL[nullCTreeIndex]];
    protoHashVec _ gd.zone.NEW[CTreeMap _ ALL[nullCTreeIndex]]};

  ReleaseHashVectors: PROC = {
    IF instHashVec # NIL THEN gd.zone.FREE[@instHashVec];
    IF protoHashVec # NIL THEN gd.zone.FREE[@protoHashVec]};

  HashForName: PROC [name: NameRecord] RETURNS [CTreeHash] =
    BEGIN
    desc: SubStringDescriptor _ [base: @bcdBases.ssb.string, 
      offset: name, length: bcdBases.ssb.size[name]];
    ss: SubString = @desc;
    RETURN[HashValue[ss]];
    END;

  HashValue: PROC [s: SubString] RETURNS [CTreeHash] =
    BEGIN  -- computes the hash index for substring s
    CharMask: PROC [CHARACTER, WORD] RETURNS [CARDINAL] =
      LOOPHOLE[Inline.BITAND];
    mask: WORD = 137B;                -- masks out ASCII case shifts
    n: CARDINAL = s.length;
    b: LONG STRING = s.base;
    v: WORD;
    v _ CharMask[b[s.offset], mask]*177B + CharMask[b[s.offset+(n-1)], mask];
    RETURN[Inline.BITXOR[v, n*17B] MOD CTreeHVSize]
    END;


  InsertModuleNode: PROC [module: MTIndex] RETURNS [newNode: CTreeIndex] =
    BEGIN
    mProtoName, mInstName: NameRecord;
    mProtoHash, mInstHash: CTreeHash;
    protoPrev, instPrev: CTreeIndex;
    mProtoName _ bcdBases.mtb[module].name;
    mProtoHash _ HashForName[mProtoName];
    IF bcdBases.mtb[module].namedInstance THEN
      BEGIN 
      mInstName _ NameFromNameTable[Namee[module[module]]];
      mInstHash _ HashForName[mInstName];
      newNode _ NewInstanceNode[
        instanceName: mInstName, prototypeName: mProtoName,
        index: BcdTableLoc[module[module]]];
      END
    ELSE
      BEGIN 
      mInstName _ mProtoName;  mInstHash _ mProtoHash;
      newNode _ NewPrototypeNode[
        prototypeName: mProtoName, index: BcdTableLoc[module[module]]];
      END;
    -- set newNode's prototypeLink (hash chain), prototypePrev (same id) links
    protoPrev _ PrevNodeSameProtoName[mProtoName, protoHashVec[mProtoHash]];
    IF protoPrev = nullCTreeIndex THEN  -- mProtoName has not been seen before
      BEGIN  -- add node to (prototype) hash chain for mProtoName
      ctreeb[newNode].prototypeLink _ protoHashVec[mProtoHash];
      protoHashVec[mProtoHash] _ newNode;
      ctreeb[newNode].prototypePrev _ nullCTreeIndex;
      END
    ELSE    -- mProtoName has been seen before; don't put in hash chain,
      BEGIN -- just add to "nodes with same prototype id" chain off protoPrev
      ctreeb[newNode].anotherNodeWSameProtoName _ TRUE;
      ctreeb[protoPrev].anotherNodeWSameProtoName _ TRUE;
      ctreeb[newNode].prototypePrev _ ctreeb[protoPrev].prototypePrev;
      ctreeb[protoPrev].prototypePrev _ newNode;
      ctreeb[newNode].prototypeLink _ nullCTreeIndex;
      END;
    -- set newNode's instanceLink and instancePrev links
    instPrev _ PrevNodeSameInstName[mInstName, instHashVec[mInstHash]];
    IF instPrev = nullCTreeIndex THEN  -- mInstName has not been seen before
      BEGIN  -- add node to (instance) hash chain for mInstName
      ctreeb[newNode].instanceLink _ instHashVec[mInstHash];
      instHashVec[mInstHash] _ newNode;
      ctreeb[newNode].instancePrev _ nullCTreeIndex;
      END
    ELSE    -- mInstName has been seen before; don't put in hash chain,
      BEGIN -- just add to "nodes with same instance id" chain off instPrev
      ctreeb[newNode].instancePrev _ ctreeb[instPrev].instancePrev;
      ctreeb[instPrev].instancePrev _ newNode;
      ctreeb[newNode].instanceLink _ nullCTreeIndex;
      END;
    RETURN[newNode];
    END;


  InsertConfigNode: PROC [config: CTIndex] RETURNS [newNode: CTreeIndex] =
    BEGIN
    kind: ComponentKind;
    cProtoName, cInstName: NameRecord;
    cProtoHash, cInstHash: CTreeHash;
    protoPrev, instPrev: CTreeIndex;
    c: CTreeIndex;
    cProtoName _ bcdBases.ctb[config].name;
    cProtoHash _ HashForName[cProtoName];
    IF bcdBases.ctb[config].namedInstance THEN
      BEGIN 
      kind _ instance; 
      cInstName _ NameFromNameTable[Namee[config[config]]];
      cInstHash _ HashForName[cInstName];
      END
    ELSE {kind _ prototype;  cInstName _ cProtoName;  cInstHash _ cProtoHash};
    c _ protoHashVec[cInstHash];  -- see if node for config already exists 
    WHILE c # nullCTreeIndex DO
      IF ctreeb[c].prototypeName = cProtoName THEN
        WITH ctreeb[c] SELECT FROM
	  instance => 
	    IF kind = instance AND instanceName = cInstName THEN RETURN[c];
	  prototype =>
	    IF kind = prototype THEN RETURN[c];
	  ENDCASE;
      c _ ctreeb[c].prototypeLink;
      ENDLOOP;
    newNode _ (IF kind = instance 
      THEN NewInstanceNode[
        instanceName: cInstName, prototypeName: cProtoName,
        index: BcdTableLoc[config[config]]]
      ELSE NewPrototypeNode[
        prototypeName: cProtoName, index: BcdTableLoc[config[config]]]);
    -- set newNode's prototypeLink (hash chain), prototypePrev (same id) links
    protoPrev _ PrevNodeSameProtoName[cProtoName, protoHashVec[cProtoHash]];
    IF protoPrev = nullCTreeIndex THEN  -- cProtoName has not been seen before
      BEGIN  -- add node to (prototype) hash chain for cProtoName
      ctreeb[newNode].prototypeLink _ protoHashVec[cProtoHash];
      protoHashVec[cProtoHash] _ newNode;
      ctreeb[newNode].prototypePrev _ nullCTreeIndex;
      END
    ELSE    -- cProtoName has been seen before; don't put in hash chain,
      BEGIN -- just add to "nodes with same prototype id" chain off protoPrev
      ctreeb[newNode].anotherNodeWSameProtoName _ TRUE;
      ctreeb[protoPrev].anotherNodeWSameProtoName _ TRUE;
      ctreeb[newNode].prototypePrev _ ctreeb[protoPrev].prototypePrev;
      ctreeb[protoPrev].prototypePrev _ newNode;
      ctreeb[newNode].prototypeLink _ nullCTreeIndex;
      END;
    -- set newNode's instanceLink and instancePrev links
    instPrev _ PrevNodeSameInstName[cInstName, instHashVec[cInstHash]];
    IF instPrev = nullCTreeIndex THEN  -- cInstName has not been seen before
      BEGIN  -- add node to (instance) hash chain for cInstName
      ctreeb[newNode].instanceLink _ instHashVec[cInstHash];
      instHashVec[cInstHash] _ newNode;
      ctreeb[newNode].instancePrev _ nullCTreeIndex;
      END
    ELSE    -- cInstName has been seen before; don't put in hash chain,
      BEGIN -- just add to "nodes with same instance id" chain off instPrev
      ctreeb[newNode].instancePrev _ ctreeb[instPrev].instancePrev;
      ctreeb[instPrev].instancePrev _ newNode;
      ctreeb[newNode].instanceLink _ nullCTreeIndex;
      END;
    RETURN[newNode];
    END;

  NewPrototypeNode: PROC [
      prototypeName: NameRecord, index: BcdTableLoc] RETURNS [newNode: CTreeIndex] =
    BEGIN
    newNode _ table.Words[
      PackagerDefs.packctreetype, ConfigTreeNode.prototype.SIZE];
    ctreeb[newNode] _ ConfigTreeNode[
      father:        nullCTreeIndex,
      brother:       nullCTreeIndex,
      firstSon:      nullCTreeIndex,
      prototypeName: prototypeName,
      anotherNodeWSameProtoName: FALSE,
      instanceLink:  nullCTreeIndex,
      prototypeLink: nullCTreeIndex,
      instancePrev:  nullCTreeIndex,
      prototypePrev: nullCTreeIndex,
      index:         index,
      body:          prototype[] ];
    END;  

  NewInstanceNode: PROC [
	instanceName, prototypeName: NameRecord, 
	index: BcdTableLoc]
      RETURNS [newNode: CTreeIndex] =
    BEGIN
    newNode _ table.Words[
      PackagerDefs.packctreetype, ConfigTreeNode.instance.SIZE];
    ctreeb[newNode] _ ConfigTreeNode[
      father:        nullCTreeIndex,
      brother:       nullCTreeIndex,
      firstSon:      nullCTreeIndex,
      prototypeName: prototypeName,
      anotherNodeWSameProtoName: FALSE,
      instanceLink:  nullCTreeIndex,
      prototypeLink: nullCTreeIndex,
      instancePrev:  nullCTreeIndex,
      prototypePrev: nullCTreeIndex,
      index:         index,
      body:          instance[instanceName: instanceName] ];
    END;  

  NameFromNameTable: PROC [namee: BcdDefs.Namee] RETURNS [name: NameRecord] =
    BEGIN
    nti: NTIndex;
    FOR nti _ NTIndex.FIRST, nti + NTRecord.SIZE UNTIL nti = bcdLimits.nt DO
      IF bcdBases.ntb[nti].item = namee THEN RETURN[bcdBases.ntb[nti].name];
      ENDLOOP;
    CTreeBuildError[];
    END;

  PrevNodeSameInstName: PROC [
      name: NameRecord, chainHead: CTreeIndex] RETURNS [CTreeIndex] =
    BEGIN  -- locate in hash chain a previous node with given instance name
    p: CTreeIndex;
    p _ chainHead;
    WHILE p # nullCTreeIndex DO
      WITH ctreeb[p] SELECT FROM
	instance => 
	  IF instanceName = name THEN RETURN[p];
	prototype =>  -- for a prototype, instance name = prototype name  
	  IF prototypeName = name THEN RETURN[p];
	ENDCASE;
      p _ ctreeb[p].instanceLink;
      ENDLOOP;
    RETURN[nullCTreeIndex];
    END;

  PrevNodeSameProtoName: PROC [
      name: NameRecord, chainHead: CTreeIndex] RETURNS [CTreeIndex] =
    BEGIN  -- locate in hash chain a previous node with given prototype name
    p: CTreeIndex;
    p _ chainHead;
    WHILE p # nullCTreeIndex DO
      IF ctreeb[p].prototypeName = name THEN RETURN[p];
      p _ ctreeb[p].prototypeLink;
      ENDLOOP;
    RETURN[nullCTreeIndex];
    END;


 -- ******* Enumerate module (instances/prototypes) in a configuration *******

  DoneEnumerating: SIGNAL = CODE;

  EnumerateModulesInConfig: PUBLIC PROC [
      configTreeNode: CTreeIndex, 
      kind: ComponentKind, 
      userProc: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL]] =
    BEGIN
    IF kind = instance THEN 
      EnumerateModuleInstancesInConfig[configTreeNode, userProc]
    ELSE 
      EnumerateModulePrototypesInConfig[configTreeNode, userProc];
    END;

  EnumerateModuleInstancesInConfig: PROC [
      configTreeNode: CTreeIndex, 
      userProc: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL]] =
    BEGIN

    OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
      BEGIN  OPEN node: ctreeb[cTreeNode];
      WITH node.index SELECT FROM
        m: BcdTableLoc.module => IF userProc[m.mti] THEN SIGNAL DoneEnumerating;
        ENDCASE;
      FOR son: CTreeIndex _ node.firstSon, ctreeb[son].brother UNTIL son = nullCTreeIndex DO
	OutputConfigSubTree[son];
	ENDLOOP;
      END;
    
    IF configTreeNode # nullCTreeIndex THEN
      OutputConfigSubTree[configTreeNode ! DoneEnumerating => CONTINUE];
    END;

  EnumerateModulePrototypesInConfig: PROC [
      configTreeNode: CTreeIndex, 
      userProc: PROC [mti: MTIndex] RETURNS [stop: BOOL]] =
    BEGIN  -- no duplications must appear in the output

    OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
      BEGIN  OPEN node: ctreeb[cTreeNode];
      IF node.index.kind = module THEN 
	BEGIN -- use a representative one
	firstProto: CTreeIndex = FirstModulePrototype[cTreeNode];
	WITH ctreeb[firstProto].index SELECT FROM
	  fp: BcdTableLoc.module => ConditionallyOutputModulePrototype[fp.mti, userProc];
	  ENDCASE;
	END;
      FOR son: CTreeIndex _ node.firstSon, ctreeb[son].brother UNTIL son = nullCTreeIndex DO
	OutputConfigSubTree[son];
	ENDLOOP;
      END;
    
    IF configTreeNode # nullCTreeIndex THEN {
      OutputConfigSubTree[configTreeNode ! DoneEnumerating => CONTINUE];
      ResetModuleVector[]};
    END;

  FirstModulePrototype: PROC [this: CTreeIndex] RETURNS [first: CTreeIndex] =
    BEGIN
    first _ this;
    DO 
      this _ ctreeb[first].prototypePrev;
      IF this = nullCTreeIndex THEN EXIT;
      IF ~AmbiguousPrototypeReference[first, this] THEN first _ this;
      ENDLOOP;
    END;

  -- reduces time needed to discover whether a prototype was previously output
  ModuleHVSize: CARDINAL = 71;
  ModuleHash: TYPE = [0..ModuleHVSize);
  
  moduleHashVec: LONG POINTER TO OutModuleMap _ NIL;  
  OutModuleMap: TYPE = ARRAY ModuleHash OF OutputModuleRec;

  OutputModuleRec: TYPE = RECORD [  -- describes modules already output
    file: FTIndex,
    link: ModulePtr];
  ModulePtr: TYPE = LONG POINTER TO OutputModuleRec;

  InitializeModuleVector: PROC = {
    moduleHashVec _ gd.zone.NEW[OutModuleMap _ ALL[[file: FTNull, link: NIL]]]};

  ResetModuleVector: PROC = {
    p, first, next: ModulePtr;
    FOR i: ModuleHash IN ModuleHash DO 
      first _ moduleHashVec[i].link;
      FOR p _ first, next UNTIL p = NIL DO
        next _ p.link;  gd.zone.FREE[@p];
	ENDLOOP; 
      moduleHashVec[i] _ OutputModuleRec[file: FTNull, link: NIL]; 
      ENDLOOP};

  ReleaseModuleVector: PROC = {
    IF moduleHashVec # NIL THEN gd.zone.FREE[@moduleHashVec]};

  NewOutputModuleRec: PROC [
      file: FTIndex, link: ModulePtr] RETURNS [new: ModulePtr] = {
    new _ gd.zone.NEW[OutputModuleRec _ [file: file, link: link]]};


  ConditionallyOutputModulePrototype: PROC [
      mti: MTIndex, 
      userProc: PROC [mti: MTIndex] RETURNS [stop: BOOL]] = {
    -- output only if no prior module with same FTIndex was output
    moduleName: NameRecord _ bcdBases.mtb[mti].name;
    moduleHash: ModuleHash _ HashForName[moduleName];
    moduleFile: FTIndex;
    p: ModulePtr;
    IF moduleHashVec[moduleHash].file = FTNull THEN
      moduleHashVec[moduleHash].file _ bcdBases.mtb[mti].file
    ELSE {  -- look for a previously output module with same FTIndex
      moduleFile _ bcdBases.mtb[mti].file;
      IF moduleHashVec[moduleHash].file = moduleFile THEN RETURN;
      FOR p _ moduleHashVec[moduleHash].link, p.link UNTIL p = NIL DO
	IF p.file = moduleFile THEN RETURN;
	ENDLOOP;
      moduleHashVec[moduleHash].link _ NewOutputModuleRec[
	moduleFile, moduleHashVec[moduleHash].link]};
    IF userProc[mti] THEN SIGNAL DoneEnumerating};


 -- ********** Locate a module or configuration instance/prototype **********

  FindModuleOrConfig: PUBLIC PROC [
        kind: ComponentKind, 
        ResetIdStream: PROC,
        FirstQualId, NextQualId: PROC RETURNS [id: HashOps.HTIndex]] 
      RETURNS [component: CTreeIndex] = {
    component _ (IF kind = instance 
      THEN FindInstance[ResetIdStream, FirstQualId, NextQualId]
      ELSE FindPrototype[ResetIdStream, FirstQualId, NextQualId]);
    RETURN[component]};
    
  FindInstance: PROC [
        ResetIdStream: PROC,
        FirstQualId, NextQualId: PROC RETURNS [id: HashOps.HTIndex]] 
      RETURNS [component: CTreeIndex] = {
    start, t: CTreeIndex;
    mainPartOfId, nextId: HashOps.HTIndex;
    componentFullyQual, fullyQual, immediateMatch: BOOL;
    component _ nullCTreeIndex;  componentFullyQual _ FALSE;
    ResetIdStream[];
    mainPartOfId _ FirstQualId[];
    start _ LookupId[mainPartOfId, instance];
    WHILE start # nullCTreeIndex DO -- attempt to match qualified id stream beginning at start
      BEGIN
      fullyQual _ TRUE;             -- assume id stream is fully qualified initially 
      t _ start;                    -- t runs from start up father links in the config tree
      nextId _ NextQualId[];
      WHILE nextId # HashOps.htNull DO -- attempt to match nextId among t's ancestor nodes
        immediateMatch _ FALSE; 
        IF (t _ ctreeb[t].father) # nullCTreeIndex THEN
	  WITH ctreeb[t] SELECT FROM  -- try to match instance name
	    instance => IF EqualIdAndName[nextId, instanceName] THEN immediateMatch _ TRUE;
	    prototype => IF EqualIdAndName[nextId, prototypeName] THEN immediateMatch _ TRUE;
	    ENDCASE;
	IF ~immediateMatch THEN {
	  fullyQual _ FALSE; 
          UNTIL t = nullCTreeIndex DO
	    WITH ctreeb[t] SELECT FROM
	      instance => IF EqualIdAndName[nextId, instanceName] THEN EXIT;
	      prototype => IF EqualIdAndName[nextId, prototypeName] THEN EXIT;
	      ENDCASE;
	    t _ ctreeb[t].father;
            REPEAT
  	      FINISHED => GOTO NoMatchFromStart;
            ENDLOOP};
        nextId _ NextQualId[];
        ENDLOOP;
      -- a match has been found beginning at start
      IF component = nullCTreeIndex THEN {component _ start;  componentFullyQual _ fullyQual}
      ELSE {  -- another match was found; keep the best one 
        IF fullyQual THEN {  
	  IF componentFullyQual THEN { 
            Error.AmbiguousComponent[error, instance, component, start];
            RETURN[nullCTreeIndex]};
	  component _ start;  componentFullyQual _ TRUE}
	ELSE  -- if old match was fully qaulified continue to use it, otherwise...
	  IF ~componentFullyQual THEN {
            Error.AmbiguousComponent[error, instance, component, start];
            RETURN[nullCTreeIndex]}}; 
      EXITS
        NoMatchFromStart => NULL;
      END;
      start _ ctreeb[start].instancePrev;  -- try an alternative starting node
      ResetIdStream[];
      ENDLOOP;
    IF component = nullCTreeIndex THEN Error.UnknownComponent[error, instance, mainPartOfId];    
    RETURN[component]};
    
  FindPrototype: PROC [
        ResetIdStream: PROC,
        FirstQualId, NextQualId: PROC RETURNS [id: HashOps.HTIndex]] 
      RETURNS [component: CTreeIndex] = {
    start, t: CTreeIndex;
    mainPartOfId, nextId: HashOps.HTIndex;
    componentFullyQual, fullyQual, immediateMatch: BOOL;
    component _ nullCTreeIndex;  componentFullyQual _ FALSE;
    ResetIdStream[];
    mainPartOfId _ FirstQualId[];
    start _ LookupId[mainPartOfId, prototype];
    WHILE start # nullCTreeIndex DO -- attempt to match qualified id stream beginning at start
      BEGIN
      fullyQual _ TRUE;             -- assume id stream is fully qualified initially 
      t _ start;                    -- t runs from start up father links in the config tree
      nextId _ NextQualId[];
      WHILE nextId # HashOps.htNull DO -- attempt to match nextId among t's ancestor nodes
        immediateMatch _ FALSE; 
        IF (t _ ctreeb[t].father) # nullCTreeIndex THEN
	  IF EqualIdAndName[nextId, ctreeb[t].prototypeName] THEN immediateMatch _ TRUE;
        IF ~immediateMatch THEN {
	  fullyQual _ FALSE;
          UNTIL t = nullCTreeIndex DO
	    IF EqualIdAndName[nextId, ctreeb[t].prototypeName] THEN EXIT;
	    t _ ctreeb[t].father;
            REPEAT
  	      FINISHED => GOTO NoMatchFromStart;
            ENDLOOP};
        nextId _ NextQualId[];
        ENDLOOP;
      -- a match has been found beginning at start
      IF component = nullCTreeIndex THEN {component _ start;  componentFullyQual _ fullyQual}
      ELSE {  -- another match was found; keep the best one
        IF fullyQual THEN {  
	  IF componentFullyQual AND AmbiguousPrototypeReference[component, start] THEN { 
            Error.AmbiguousComponent[error, prototype, component, start];
            RETURN[nullCTreeIndex]};
	  component _ start;  componentFullyQual _ TRUE}
	ELSE  -- if old match was fully qaulified continue to use it, otherwise...
	  IF ~componentFullyQual THEN {
	    IF AmbiguousPrototypeReference[component, start] THEN { 
              Error.AmbiguousComponent[error, prototype, component, start];
              RETURN[nullCTreeIndex]};
	    component _ start;  componentFullyQual _ FALSE}}; 
      EXITS
        NoMatchFromStart => NULL;
      END;
      start _ ctreeb[start].prototypePrev;  -- try an alternative starting node
      ResetIdStream[];
      ENDLOOP;
    IF component = nullCTreeIndex THEN Error.UnknownComponent[error, prototype, mainPartOfId];    
    RETURN[component]};

  AmbiguousPrototypeReference: PROC [comp1, comp2: CTreeIndex] RETURNS [BOOL] =
    BEGIN
    -- ambiguous if not same FTIndex (name-stamp pair)
    RETURN [WITH ctreeb[comp1].index SELECT FROM
      c1: BcdTableLoc.config =>
	WITH ctreeb[comp2].index SELECT FROM
          c2: BcdTableLoc.config => bcdBases.ctb[c1.cti].file # bcdBases.ctb[c2.cti].file,
          ENDCASE => TRUE,  -- one is module, the other a config
      m1: BcdTableLoc.module =>
	WITH ctreeb[comp2].index SELECT FROM
          m2: BcdTableLoc.module => bcdBases.mtb[m1.mti].file # bcdBases.mtb[m2.mti].file,
          ENDCASE => TRUE,  -- one is module and the other a config
      ENDCASE => TRUE]
    END;


 -- ******** Determine if module prototype/instance is in a config ********

  IsModuleInConfig: PUBLIC PROC [
        kind: ComponentKind, 
        mti: BcdDefs.MTIndex,
        configTreeNode: CTreeIndex] 
      RETURNS [BOOL] =
    BEGIN
    moduleName: NameRecord _ bcdBases.mtb[mti].name;
    start, t: CTreeIndex;
    start _ LookupName[moduleName, kind];
    WHILE start # nullCTreeIndex DO
      IF ctreeb[start].index.kind = module THEN
        FOR t _ ctreeb[start].father, ctreeb[t].father 
         UNTIL t = nullCTreeIndex DO
	  IF t = configTreeNode THEN RETURN[TRUE];
          ENDLOOP;
      -- any alternative starting nodes?
      IF kind = instance THEN start _ ctreeb[start].instancePrev
      ELSE start _ ctreeb[start].prototypePrev; 
      ENDLOOP;
    RETURN[FALSE];
    END;


 -- ******** Find first node with given instance or prototype id ********

  LookupId: PUBLIC PROC [
      id: HashOps.HTIndex, kind: ComponentKind] RETURNS [firstTreeLoc: CTreeIndex] =
    BEGIN  -- find first node with given instance or prototype id
    idSS: SubString _ @idSSDesc;
      idSSDesc: SubStringDescriptor;
    HashOps.SubStringForHash[idSS, id];
    RETURN[LookupSS[idSS, kind]];
    END;

  LookupName: PUBLIC PROC [
      name: NameRecord, kind: ComponentKind] RETURNS [firstTreeLoc: CTreeIndex] =
    BEGIN  -- find first node with instance/prototype name (NameRecord)
    nameSS: SubString _ @nameSSDesc;
      nameSSDesc: SubStringDescriptor;
    SubStringForName[nameSS, name];
    RETURN[LookupSS[nameSS, kind]];
    END;

  LookupSS: PUBLIC PROC [
      idSS: SubString, kind: ComponentKind] RETURNS [firstTreeLoc: CTreeIndex] =
    BEGIN  -- find first node with given instance or prototype id substring
    idHash: CTreeHash;
    treeSS: SubString _ @treeSSDesc;
      treeSSDesc: SubStringDescriptor;
    p: CTreeIndex;
    idHash _ HashValue[idSS];
    IF kind = instance THEN
      BEGIN  -- find first node with given instance id
      p _ instHashVec[idHash];
      WHILE p # nullCTreeIndex DO
        WITH ctreeb[p] SELECT FROM
	  instance => SubStringForName[treeSS, instanceName];
	  prototype => SubStringForName[treeSS, prototypeName];
	  ENDCASE;
        IF String.EqualSubStrings[idSS, treeSS] THEN RETURN[p];
	p _ ctreeb[p].instanceLink;
        ENDLOOP
      END
    ELSE
      BEGIN  -- find first node with given prototype id
      p _ protoHashVec[idHash];
      WHILE p # nullCTreeIndex DO
        SubStringForName[treeSS, ctreeb[p].prototypeName];
        IF String.EqualSubStrings[idSS, treeSS] THEN RETURN[p];
        p _ ctreeb[p].prototypeLink;
        ENDLOOP;
      END;
    RETURN[nullCTreeIndex];
    END;

  END.