-- SourceBcdImpl.mesa
--    Last edited by Lewis on 18-May-81 19:01:52
--    Last edited by Sweet on July 17, 1980  11:18 AM
--    Last edited by Levin on July 6, 1982 4:45 pm

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],
  Error USING [Error, AmbiguousComponent, UnknownComponent],
  Inline USING [BITAND, BITXOR],
  PackagerDefs USING [packctreetype, globalData],
  PackEnviron USING [BcdHandle, SourceBcdSegmentBase],
  PackHeap USING [FreeSpace, GetSpace],
  Segments USING [
    BaseFromSegment, DeleteSegment, FHandle, HardDown, MoveSegment, NewSegment, Read,
    SegmentAddress, SHandle, SwapIn, Unlock],
  Strings USING [EqualSubStrings, String, SubString, SubStringDescriptor],
  SymTabOps USING [SubStringForHash],
  SymTabDefs USING [HTIndex, HTNull],
  SourceBcd,
  Table USING [Base];

SourceBcdImpl: PROGRAM
    IMPORTS Alloc, Error, Inline, PackagerDefs, PackHeap, Segments, Strings,
      SymTabOps
    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 = Strings.SubStringDescriptor;
  SubString: TYPE = Strings.SubString;


  table: Alloc.Handle _ NIL;
  
 -- ****************** Source BCD Loading and Unloading ****************** 

  bcdHeader: PUBLIC PackEnviron.BcdHandle _ NIL;

  bcdBases:  PUBLIC LONG POINTER TO BcdBaseRec _ NIL;
  bcdLimits: PUBLIC LONG POINTER TO BcdLimitRec _ NIL;

  moduleCount: PUBLIC CARDINAL _ 0;


  bcdSegment: Segments.SHandle _ NIL;

  Load: PUBLIC PROC =
    BEGIN
    pages: CARDINAL;
    table _ PackagerDefs.globalData.ownTable;
    bcdSegment _ Segments.NewSegment[
      file: PackagerDefs.globalData.sourceBcdFile,  
      base: 1, pages: 10, access: Segments.Read];
    Segments.SwapIn[
      seg: bcdSegment, base: PackEnviron.SourceBcdSegmentBase, 
      info: Segments.HardDown];  
    bcdHeader _ Segments.SegmentAddress[bcdSegment];
    IF bcdHeader.versionIdent # BcdDefs.VersionID OR bcdHeader.definitions THEN
      BEGIN
      Error.Error[error, "Invalid input BCD file: obsolete version or definitions BCD"L];
      GO TO bogus
      END;
    IF bcdHeader.repackaged THEN
      BEGIN
      Error.Error[error, "Already packaged BCDs cannot be repackaged"L];
      GO TO bogus
      END;
    IF (pages _ bcdHeader.nPages) > 10 THEN  -- load entire bcd
      BEGIN
      Segments.Unlock[bcdSegment];
      Segments.MoveSegment[
	seg: bcdSegment, base: Segments.BaseFromSegment[bcdSegment], pages: pages];
      Segments.SwapIn[
        seg: bcdSegment, base: PackEnviron.SourceBcdSegmentBase, 
	info: Segments.HardDown];  
      bcdHeader _ Segments.SegmentAddress[bcdSegment];
      END;
    PackagerDefs.globalData.sourceBcdVersion _ bcdHeader.version;
    bcdBases _ PackHeap.GetSpace[SIZE[BcdBaseRec]];
    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]];
    IF bcdBases.mtb[FIRST[MTIndex]].altoCode THEN
      BEGIN
      PackHeap.FreeSpace[bcdBases];  bcdBases _ NIL;
      Error.Error[error, "Packaging is not supported for Alto programs"L];
      GO TO bogus
      END;
    bcdLimits _ PackHeap.GetSpace[SIZE[BcdLimitRec]];
    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[];
    EXITS
      bogus =>
        BEGIN
        Segments.Unlock[bcdSegment];  Segments.DeleteSegment[bcdSegment];
        bcdSegment _ NIL; bcdHeader _ NIL;
        ERROR BadSourceBcd
	END;
    END;

  Unload: PUBLIC PROC =
    BEGIN
    IF bcdSegment = NIL THEN RETURN;
    Segments.Unlock[bcdSegment];  Segments.DeleteSegment[bcdSegment];
    bcdSegment _ NIL;
    PackHeap.FreeSpace[bcdBases];
    PackHeap.FreeSpace[bcdLimits];
    ReleaseMtiArray[];
    moduleCount _ 0;
    table _ NIL;
    END;

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

  EnumerateModules: PUBLIC PROC [
      userProc: PROC [MTIndex] RETURNS [stop: BOOLEAN]] =
    BEGIN
    mti: MTIndex _ FIRST[MTIndex];
    UNTIL mti = bcdLimits.mt DO
      mtRecSize: CARDINAL;
      IF userProc[mti] THEN RETURN;
      WITH mth: bcdBases.mtb[mti] SELECT FROM
        direct => mtRecSize _ SIZE[direct MTRecord] + mth.length;
	indirect => mtRecSize _ SIZE[indirect MTRecord];
	multiple => mtRecSize _ SIZE[multiple MTRecord];
	ENDCASE;
      mti _ mti + mtRecSize;
      ENDLOOP;
    END;

  IsTableCompiled: PUBLIC PROC [
      mti: BcdDefs.MTIndex] RETURNS [reply: BOOLEAN] =
    BEGIN
    RETURN[ bcdBases.mtb[mti].tableCompiled ];
    END;

  SubStringForName: PUBLIC PROC [ss: Strings.SubString, name: NameRecord] =
    BEGIN
    ss.base _ @bcdBases.ssb.string;
    ss.offset _ name;  ss.length _ bcdBases.ssb.size[name];
    END;

  EqualIdAndName: PUBLIC PROC [
      id: SymTabDefs.HTIndex, name: NameRecord] RETURNS [yes: BOOLEAN] =
    BEGIN
    idSS: SubString _ @idSSDesc;
      idSSDesc: SubStringDescriptor;
    nameSS: SubString _ @nameSSDesc;
      nameSSDesc: SubStringDescriptor;
    SymTabOps.SubStringForHash[idSS, id];
    SubStringForName[nameSS, name];
    RETURN[Strings.EqualSubStrings[idSS, nameSS]];
    END;


  CountModules: PROC =
    BEGIN

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


 -- BcdDefs.MTIndex -> ModuleNum mapping related declarations

  mtiArray: PUBLIC LONG DESCRIPTOR FOR ARRAY ModuleNum OF BcdMTIndex;

  InitializeMtiArray: PROC =
    BEGIN
    i: ModuleNum;

    EnterOneModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
      BEGIN
      mtiArray[i] _ LOOPHOLE[mti, BcdMTIndex];  i _ i+1;  
      RETURN[FALSE];
      END;
  
    mtiArray _ (IF moduleCount # 0 
      THEN DESCRIPTOR[PackHeap.GetSpace[moduleCount*SIZE[BcdMTIndex]], moduleCount]
      ELSE DESCRIPTOR[NIL, 0]);
    i _ 0;
    EnumerateModules[EnterOneModule];
    END;

  ReleaseMtiArray: PROC = {PackHeap.FreeSpace[BASE[mtiArray]]};

  ModuleNumForMti: PUBLIC PROC [
      mti: BcdDefs.MTIndex] RETURNS [mNum: ModuleNum] =
    BEGIN  -- map i-th module index to i
    orderedMti: BcdMTIndex _ LOOPHOLE[mti];
    l, m, u: ModuleNum;
    l _ 0;  u _ moduleCount;
    UNTIL l > u DO
      m _ (l+u)/2;
      SELECT 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 creation ******************** 

  configTreeRoot: PUBLIC CTreeIndex _ NullCTreeIndex;
  rootPointsToModule: BOOLEAN _ FALSE;

  BuildConfigTree: PUBLIC PROC =
    BEGIN
    table.AddNotify[UpdateConfigTreeBase];
    InitializeHashVectors[];
    configTreeRoot _ NullCTreeIndex;  rootPointsToModule _ FALSE;
    EnumerateModules[EnterOneModule];
    EnumerateConfigs[EnterOneConfig];
    END;
    
  DestroyConfigTree: PUBLIC PROC =
    BEGIN
    IF table ~= NIL THEN table.DropNotify[UpdateConfigTreeBase];
    configTreeRoot _ NullCTreeIndex;
    END;


  ctreeb: Table.Base;

  UpdateConfigTreeBase: Alloc.Notifier =
    BEGIN
    ctreeb _ base[PackagerDefs.packctreetype];
    END;


  CTreeHVSize: CARDINAL = 71;
  CTreeHash: TYPE = [0..CTreeHVSize);
  instHashVec, protoHashVec: ARRAY CTreeHash OF CTreeIndex;

  InitializeHashVectors: PROC =
    BEGIN
    i: CTreeHash;
    FOR i IN CTreeHash DO 
      instHashVec[i] _ protoHashVec[i] _ NullCTreeIndex 
      ENDLOOP;
    END;

  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: Strings.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;


  EnterOneModule: PROC [module: MTIndex] RETURNS [stop: BOOLEAN] =
    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 configTreeRoot = NullCTreeIndex THEN 
	{configTreeRoot _ 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: BOOLEAN] =
    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 configTreeRoot # NullCTreeIndex AND ~rootPointsToModule THEN
        CTreeBuildError[]
      ELSE {configTreeRoot _ 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;


  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, SIZE[prototype ConfigTreeNode]];
    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, SIZE[instance ConfigTreeNode]];
    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 _ FIRST[NTIndex], nti + SIZE[NTRecord] 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 [
      kind: ComponentKind, 
      configTreeNode: CTreeIndex, 
      userProc: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN]] =
    BEGIN
    IF kind = instance THEN 
      EnumerateModuleInstancesInConfig[configTreeNode, userProc]
    ELSE 
      EnumerateModulePrototypesInConfig[configTreeNode, userProc];
    END;

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

    OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
      BEGIN  OPEN node: ctreeb[cTreeNode];
      son: CTreeIndex;
      WITH node.index SELECT FROM
        module => IF userProc[mti] THEN SIGNAL DoneEnumerating;
        ENDCASE;
      IF node.firstSon # NullCTreeIndex THEN
        FOR son _ 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: BOOLEAN]] =
    BEGIN  -- no duplications must appear in the output

    OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
      BEGIN  OPEN node: ctreeb[cTreeNode];
      son: CTreeIndex;
      WITH node.index SELECT FROM
        module => 
	  BEGIN -- use a representative one
	  firstProto: CTreeIndex = FirstModulePrototype[cTreeNode];
	  WITH fp: ctreeb[firstProto].index SELECT FROM
	    module => ConditionallyOutputModulePrototype[fp.mti, userProc];
	    ENDCASE;
	  END;
        ENDCASE;
      IF node.firstSon # NullCTreeIndex THEN
        FOR son _ node.firstSon, ctreeb[son].brother UNTIL son = NullCTreeIndex DO
	  OutputConfigSubTree[son];
	  ENDLOOP;
      END;
    
    IF configTreeNode # NullCTreeIndex THEN
      BEGIN
      InitModuleHashVector[];
      OutputConfigSubTree[configTreeNode ! DoneEnumerating => CONTINUE];
      FreeModuleHashVector[];
      END;
    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;

  ModuleHVSize: CARDINAL = 71;
  ModuleHash: TYPE = [0..ModuleHVSize);
  
  -- reduces time needed to discover whether a prototype was previously output
  ModuleHashVec: ARRAY ModuleHash OF OutputModuleRec; 

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

  NewOutputModuleRec: PROC [
      file: FTIndex, link: ModulePtr] RETURNS [new: ModulePtr]  =
    BEGIN
    new _ PackHeap.GetSpace[SIZE[OutputModuleRec]];
    new^ _ OutputModuleRec[file: file, link: link];
    END;

  InitModuleHashVector: PROC =
    BEGIN
    FOR i: ModuleHash IN ModuleHash DO 
      ModuleHashVec[i] _ OutputModuleRec[file: FTNull, link: NIL]; 
      ENDLOOP;
    END;

  FreeModuleHashVector: PROC =
    BEGIN
    i: ModuleHash;
    p, first, next: ModulePtr;
    FOR i IN ModuleHash DO 
      first _ ModuleHashVec[i].link;
      FOR p _ first, next UNTIL p = NIL DO
        next _ p.link;  PackHeap.FreeSpace[p];
	ENDLOOP; 
      ModuleHashVec[i] _ OutputModuleRec[file: FTNull, link: NIL]; 
      ENDLOOP;
    END;

  ConditionallyOutputModulePrototype: PROC [
      mti: MTIndex, 
      userProc: PROC [mti: MTIndex] RETURNS [stop: BOOLEAN]] =
    BEGIN  -- 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
      BEGIN
      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];
      END;
    IF userProc[mti] THEN SIGNAL DoneEnumerating;
    END;


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

  FindModuleOrConfig: PUBLIC PROC [
        kind: ComponentKind, 
        ResetIdStream: PROC,
        FirstQualId, NextQualId: PROC RETURNS [id: SymTabDefs.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: SymTabDefs.HTIndex]] 
      RETURNS [component: CTreeIndex] = {
    start, t: CTreeIndex;
    mainPartOfId, nextId: SymTabDefs.HTIndex;
    componentFullyQual, fullyQual, immediateMatch: BOOLEAN;
    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 # SymTabDefs.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: SymTabDefs.HTIndex]] 
      RETURNS [component: CTreeIndex] = {
    start, t: CTreeIndex;
    mainPartOfId, nextId: SymTabDefs.HTIndex;
    componentFullyQual, fullyQual, immediateMatch: BOOLEAN;
    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 # SymTabDefs.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 [isAmbiguous: BOOLEAN] =
    BEGIN
    bcdLoc1: SourceBcd.BcdTableLoc = ctreeb[comp1].index;
    bcdLoc2: SourceBcd.BcdTableLoc = ctreeb[comp2].index;
    file1, file2: BcdDefs.FTIndex;
    WITH bcdLoc1 SELECT FROM  -- ambiguous if not same FTIndex (name-stamp pair)
      config =>
	BEGIN
	file1 _ bcdBases.ctb[cti].file;
	WITH bcdLoc2 SELECT FROM
          config => file2 _ bcdBases.ctb[cti].file;
          module => RETURN[TRUE];  -- one is module and the other a config
          ENDCASE;
	IF file1 # file2 THEN RETURN[TRUE];
	END;
      module =>
	BEGIN
	file1 _ bcdBases.mtb[mti].file;
	WITH bcdLoc2 SELECT FROM
          config => RETURN[TRUE];  -- one is module and the other a config
          module => file2 _ bcdBases.mtb[mti].file;
          ENDCASE;
	IF file1 # file2 THEN RETURN[TRUE];
	END;
      ENDCASE;
    RETURN[FALSE];
    END;


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

  IsModuleInConfig: PUBLIC PROC [
        kind: ComponentKind, 
        mti: BcdDefs.MTIndex,
        configTreeNode: CTreeIndex] 
      RETURNS [reply: BOOLEAN] =
    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: SymTabDefs.HTIndex, kind: ComponentKind]
      RETURNS [firstTreeLoc: CTreeIndex] =
    BEGIN  -- find first node with given instance or prototype id
    idSS: SubString _ @idSSDesc;
      idSSDesc: SubStringDescriptor;
    SymTabOps.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 Strings.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 Strings.EqualSubStrings[idSS, treeSS] THEN RETURN[p];
        p _ ctreeb[p].prototypeLink;
        ENDLOOP;
      END;
    RETURN[NullCTreeIndex];
    END;

  END.