-- SemanticEntryImpl.mesa  
-- Last edited by Lewis on  2-Apr-81 10:19:18
-- Last edited by Sweet on September 16, 1980  12:50 PM
-- last edited by Levin on July 6, 1982 4:40 pm

DIRECTORY
  Alloc USING [AddNotify, DropNotify, Handle, Notifier, Words],
  BcdDefs USING [MTIndex, MTNull],
  Error USING [
    Error, ErrorHti, FrameInTwoFramePacks, FrameNotPlaced,
    TableCompModuleNotIncAsUnit],
  PackagerDefs USING [
    globalData, packctreetype, packtreetype, packsttype],
  PackHeap USING [GetSpace, FreeSpace],
  SemanticEntry USING [STIndex, STRecord],
  SourceBcd USING [
    ComponentKind, CTreeIndex, EnumerateModules, EnumerateModulesInConfig,
    FindModuleOrConfig, IsTableCompiled, LookupId, ModuleNum, moduleCount,
    ModuleNumForMti, NullCTreeIndex],
  SymTabDefs USING [HTIndex, HTNull],
  Table USING [Base],
  Tree: FROM "PackTree" USING [
    Index, Link, Map, Null, NullIndex, root, Scan, Test],
  TreeOps: FROM "PackTreeOps" USING [
    ListLength, ListHead, ListTail, ScanList, SearchList, UpdateList];

SemanticEntryImpl: PROGRAM
    IMPORTS Alloc, Error, PackagerDefs, PackHeap, SourceBcd, Tree, TreeOps
    EXPORTS SemanticEntry =
  BEGIN OPEN PackagerDefs, SemanticEntry;

  SEerror: PROC = {ERROR BuildSEerror};
  BuildSEerror: PUBLIC ERROR = CODE;


 -- Parse tree, semantic table, and source bcd configuration tree bases
  table: Alloc.Handle _ NIL;
  tb, stb, ctreeb: Table.Base;

  Notifier: Alloc.Notifier =
    BEGIN
    tb     _ base[PackagerDefs.packtreetype];  
    stb    _ base[PackagerDefs.packsttype];
    ctreeb _ base[PackagerDefs.packctreetype];
    END;


  NewSemanticEntry: PROC RETURNS [newSE: STIndex] =
    BEGIN
    newSE _ table.Words[PackagerDefs.packsttype, SIZE[STRecord]];
    stb[newSE] _ [
      hti: SymTabDefs.HTNull, 
      treeNode: Tree.NullIndex, 
      kind: unknown[]];
    END;


 -- *********************** Build semantic entries ************************

  anyMergeSegments, anyMergeFramePacks: BOOLEAN;

  BuildSemanticEntries: PUBLIC PROC =
    BEGIN
    table _ PackagerDefs.globalData.ownTable;
    table.AddNotify[Notifier];
    WITH Tree.root SELECT FROM
      subtree => 
        BEGIN
        anyMergeSegments _ anyMergeFramePacks _ FALSE;
        InitializeFrameArray[];
        RecordSegAndFramePackIds[];  -- and set anyMergeSegments, anyMergeFramePacks
        ProcessSegAndFramePacks[];
	IF anyMergeSegments THEN ProcessMergeSegments[];
	IF anyMergeFramePacks THEN ProcessMergeFramePacks[];
        VerifyAllFramesPlaced[];
        DestroyFrameArray[];
        ReleaseSegAndFramePackIds[];
        END;
      ENDCASE => SEerror[];
    table.DropNotify[Notifier];
    table _ NIL;
    END;


 -- ************* Verify correct placement of global frames *************

  -- parse tree nodes of frame packs containing each global frame
  frameArray: LONG DESCRIPTOR FOR ARRAY SourceBcd.ModuleNum OF Tree.Index;

  InitializeFrameArray: PROC =
    BEGIN
    i: SourceBcd.ModuleNum;
    IF SourceBcd.moduleCount # 0 THEN 
      BEGIN
      frameArray _ DESCRIPTOR[
        PackHeap.GetSpace[SourceBcd.moduleCount*SIZE[Tree.Index]],
        SourceBcd.moduleCount];
      FOR i IN [0..SourceBcd.moduleCount) DO
        frameArray[i] _ Tree.NullIndex;
        ENDLOOP;
      END
    ELSE frameArray _ DESCRIPTOR[NIL, 0];
    END;

  DestroyFrameArray: PROC =
    {IF BASE[frameArray] # NIL THEN PackHeap.FreeSpace[BASE[frameArray]]};

  MarkFramePlaced: PROC [mti: BcdDefs.MTIndex, fpNode: Tree.Index] =
    BEGIN
    mNum: SourceBcd.ModuleNum _ SourceBcd.ModuleNumForMti[mti];
    IF frameArray[mNum] # Tree.NullIndex THEN
      BEGIN
      fpId1, fpId2: SymTabDefs.HTIndex;
      WITH tb[frameArray[mNum]].son[1] SELECT FROM
	hash => fpId1 _ index;
	ENDCASE => SEerror[];
      WITH tb[fpNode].son[1] SELECT FROM
	hash => fpId2 _ index;
	ENDCASE => SEerror[];
      Error.FrameInTwoFramePacks[error, mti, fpId1, fpId2];
      END
    ELSE frameArray[mNum] _ fpNode;
    END;

  VerifyAllFramesPlaced: PROC =
    BEGIN
    
    VerifyOneFramePlaced: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
      BEGIN
      mNum: SourceBcd.ModuleNum _ SourceBcd.ModuleNumForMti[mti];
      IF frameArray[mNum] = Tree.NullIndex THEN
	Error.FrameNotPlaced[warning, mti];
      RETURN[FALSE];
      END;

    SourceBcd.EnumerateModules[VerifyOneFramePlaced];
    END;


 -- ****** Management of segment and frame pack tree node arrays ******

  segArray, fpArray: TreeNodeArray;
  TreeNodeArray: TYPE = LONG DESCRIPTOR FOR ARRAY OF Tree.Index;

  segCount, fpCount: CARDINAL;
  currentSeg, currentFP: CARDINAL;

  RecordSegAndFramePackIds: PROC =
    BEGIN
    segCount _ fpCount _ 0;
    TreeOps.ScanList[Tree.root, CountSegOrFPId];
    IF segCount # 0 THEN segArray _ DESCRIPTOR[
      PackHeap.GetSpace[segCount*SIZE[Tree.Index]], segCount]
    ELSE segArray _ DESCRIPTOR[NIL, 0];
    IF fpCount # 0 THEN fpArray _ DESCRIPTOR[
      PackHeap.GetSpace[fpCount*SIZE[Tree.Index]], fpCount]
    ELSE fpArray _ DESCRIPTOR[NIL, 0];
    currentSeg _ currentFP _ 0;
    TreeOps.ScanList[Tree.root, NoteSegOrFPId];
    END;

  ReleaseSegAndFramePackIds: PROC = 
    BEGIN
    IF BASE[segArray] # NIL THEN PackHeap.FreeSpace[BASE[segArray]];  
    IF BASE[fpArray] # NIL THEN PackHeap.FreeSpace[BASE[fpArray]];
    segCount _ fpCount _ 0;
    END;

  CountSegOrFPId: Tree.Scan =
    BEGIN
    WITH t SELECT FROM
      subtree =>
        BEGIN node: Tree.Index = index;
        SELECT tb[node].name FROM
          codeSeg   => segCount _ segCount+1;
          framePack => fpCount _ fpCount+1;
          merge     => {segCount _ segCount+1;  anyMergeSegments _ TRUE};
          mergeFP   => {fpCount _ fpCount+1;  anyMergeFramePacks _ TRUE};
          ENDCASE;
        END;
      ENDCASE => SEerror[];
    END;

  NoteSegOrFPId: Tree.Scan =
    BEGIN
    nodeName: SymTabDefs.HTIndex;
    i: CARDINAL;
    saveIndex: CARDINAL = globalData.textIndex;
    WITH t SELECT FROM
      subtree =>
        BEGIN node: Tree.Index = index;
        globalData.textIndex _ tb[node].info;
        WITH tb[node].son[1] SELECT FROM
          hash => nodeName _ index;
          ENDCASE => SEerror[];
        SELECT tb[node].name FROM
          codeSeg, merge => 
	    BEGIN
            FOR i IN [0..currentSeg) DO
              WITH tb[segArray[i]].son[1] SELECT FROM
                hash => 
        	  IF nodeName = index THEN  
        	    BEGIN
        	    Error.ErrorHti[error, "appears twice as a code segment name"L, nodeName];
                    EXIT;
        	    END;
                ENDCASE => SEerror[];
              ENDLOOP;
            segArray[currentSeg] _ node;  currentSeg _ currentSeg+1;
	    END;
          framePack, mergeFP => 
	    BEGIN
            FOR i IN [0..currentFP) DO
              WITH tb[fpArray[i]].son[1] SELECT FROM
                hash => 
        	  IF nodeName = index THEN   
        	    BEGIN
        	    Error.ErrorHti[error, "appears twice as a frame pack name"L, nodeName];
                    EXIT;
        	    END;
                ENDCASE => SEerror[];
              ENDLOOP;
	    fpArray[currentFP] _ node;  currentFP _ currentFP+1;
	    END;
          ENDCASE; 
        END;
      ENDCASE => SEerror[];
    globalData.textIndex _ saveIndex;
    END;

  FindSeg: PROC [
      id: SymTabDefs.HTIndex] RETURNS [found: BOOLEAN, segNode: Tree.Index] =
    BEGIN
    i: CARDINAL;
    FOR i IN [0..segCount) DO
      segNode _ segArray[i];
      WITH tb[segNode].son[1] SELECT FROM
        hash => IF id = index THEN RETURN[TRUE, segNode];
        ENDCASE => SEerror[];
      ENDLOOP;
    RETURN[FALSE, Tree.NullIndex];
    END;

  FindFramePack: PROC [
      id: SymTabDefs.HTIndex] RETURNS [found: BOOLEAN, fpNode: Tree.Index] =
    BEGIN
    i: CARDINAL;
    FOR i IN [0..fpCount) DO
      fpNode _ fpArray[i];
      WITH tb[fpNode].son[1] SELECT FROM
        hash => IF id = index THEN RETURN[TRUE, fpNode];
        ENDCASE => SEerror[];
      ENDLOOP;
    RETURN[FALSE, Tree.NullIndex];
    END;


 -- ****** Process the identifiers in code segments and frame packs ******

  ProcessSegAndFramePacks: PROC =
    BEGIN

    ProcessSegOrFP: Tree.Scan =
      BEGIN
      WITH t SELECT FROM
        subtree =>
          BEGIN node: Tree.Index = index;
          SELECT tb[node].name FROM
            codeSeg   => ProcessOneCodeSeg[node];
            framePack => ProcessOneFramePack[node];
            ENDCASE;
          END;
        ENDCASE => SEerror[];
      END;

    TreeOps.ScanList[Tree.root, ProcessSegOrFP];
    END;


 -- ********************** Process a code segment **********************

  currentSegId: SymTabDefs.HTIndex;  
  currentSegNode: Tree.Index;   

  cpArray: TreeNodeArray;  -- Segment's code pack tree node array
  cpCount, currentCP: CARDINAL;

  ProcessOneCodeSeg: PROC [segNode: Tree.Index] =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    globalData.textIndex _ tb[segNode].info;
    currentSegNode _ segNode;
    WITH tb[segNode].son[1] SELECT FROM
      hash => currentSegId _ index;
      ENDCASE => SEerror[];
    RecordCodePackIds[segNode];
    ProcessCodePacks[segNode];
    ReleaseCodePackIds[];
    globalData.textIndex _ saveIndex;
    END;

  RecordCodePackIds: PROC [segNode: Tree.Index] =
    BEGIN
    cpCount _ TreeOps.ListLength[tb[segNode].son[2]];
    IF cpCount # 0 THEN cpArray _ DESCRIPTOR[
      PackHeap.GetSpace[cpCount*SIZE[Tree.Index]], cpCount]
    ELSE cpArray _ DESCRIPTOR[NIL, 0];
    currentCP _ 0;
    TreeOps.ScanList[tb[segNode].son[2], NoteCPId];
    END;

  ReleaseCodePackIds: PROC = 
    BEGIN
    IF BASE[cpArray] # NIL THEN PackHeap.FreeSpace[BASE[cpArray]];
    cpCount _ 0;
    END;

  NoteCPId: Tree.Scan =
    BEGIN
    cpId: SymTabDefs.HTIndex;
    i: CARDINAL;
    WITH t SELECT FROM
      subtree =>
        BEGIN cpNode: Tree.Index = index;
        SELECT tb[cpNode].name FROM 
          codePack, unnamedCodePack, discardCodePack =>
	    BEGIN
            WITH tb[cpNode].son[1] SELECT FROM
              hash => cpId _ index;
              ENDCASE => SEerror[];
            FOR i IN [0..currentCP) DO
              WITH tb[cpArray[i]].son[1] SELECT FROM
                hash => 
        	  IF cpId = index THEN 
        	    BEGIN
        	    Error.ErrorHti[error, "appears twice as a code pack name"L, cpId];
                    EXIT;
        	    END;
                ENDCASE => SEerror[];
              ENDLOOP;
            cpArray[currentCP] _ cpNode;  currentCP _ currentCP+1;
    	    END;
          ENDCASE => SEerror[];
        END;
      ENDCASE => SEerror[];
    END;

  FindCodePack: PROC [
      id: SymTabDefs.HTIndex] RETURNS [found: BOOLEAN, cpNode: Tree.Index] =
    BEGIN
    i: CARDINAL;
    FOR i IN [0..cpCount) DO
      cpNode _ cpArray[i];
      WITH tb[cpNode].son[1] SELECT FROM
        hash => IF id = index THEN RETURN[TRUE, cpNode];
        ENDCASE => SEerror[];
      ENDLOOP;
    RETURN[FALSE, Tree.NullIndex];
    END;


  ProcessCodePacks: PROC [segNode: Tree.Index] =
    {TreeOps.ScanList[tb[segNode].son[2], ProcessOneCodePack]};

  currentCpNode: Tree.Index;

  ProcessOneCodePack: Tree.Scan =
    BEGIN
    WITH t SELECT FROM
      subtree =>
        BEGIN
        currentCpNode _ index;
        TreeOps.ScanList[tb[currentCpNode].son[2], ProcessOneComponentDesc];
        END;
      ENDCASE => SEerror[];
    END;

  ProcessOneComponentDesc: Tree.Scan =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    WITH t SELECT FROM
      subtree =>
        BEGIN cdNode: Tree.Index = index;
        globalData.textIndex _ tb[cdNode].info;
	SELECT tb[cdNode].name FROM
          allComp          => ProcessAllComp[cdNode];
          compItems        => ProcessCompItems[cdNode];
          exceptItems      => ProcessExceptItems[cdNode];
          exceptPacks      => ProcessExceptPacks[cdNode];
          itemsExceptPacks => ProcessItemsExceptPacks[cdNode];
          exceptPacksItems => ProcessExceptPacksItems[cdNode];
          mainProcs        => ProcessMainProcs[cdNode];
          ENDCASE => SEerror[]; 
        tb[cdNode].cp  _ currentCpNode;
        tb[cdNode].seg _ currentSegNode;
        END;
      ENDCASE => SEerror[];
    globalData.textIndex _ saveIndex;
    END;

  ProcessAllComp: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
    END;

  ProcessCompItems: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component [ItemList]
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
    WITH tb[cdNode].son[1] SELECT FROM
      symbol => 
        BEGIN componentSE: STIndex = index;
	WITH stb[componentSE] SELECT FROM
          config => 
            IF cNode # SourceBcd.NullCTreeIndex THEN
              tb[cdNode].son[2] _ LookupComponentItems[cNode, tb[cdNode].son[2]];
          module => 
            IF mNode # SourceBcd.NullCTreeIndex AND mti # BcdDefs.MTNull THEN
              IF SourceBcd.IsTableCompiled[mti] THEN 
		Error.TableCompModuleNotIncAsUnit[error, mti];
          ENDCASE;
        END;
      ENDCASE => SEerror[];
    END;

  ProcessExceptItems: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component EXCEPT [ItemList]
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
    WITH tb[cdNode].son[1] SELECT FROM
      symbol => 
        BEGIN componentSE: STIndex = index;
	WITH stb[componentSE] SELECT FROM
          config => 
            IF cNode # SourceBcd.NullCTreeIndex THEN
              tb[cdNode].son[2] _ LookupComponentItems[cNode, tb[cdNode].son[2]];
          module => 
            IF mNode # SourceBcd.NullCTreeIndex AND mti # BcdDefs.MTNull THEN
              IF SourceBcd.IsTableCompiled[mti] THEN 
		Error.TableCompModuleNotIncAsUnit[error, mti];
          ENDCASE;
        END;
      ENDCASE => SEerror[];
    END;

  ProcessExceptPacks: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component EXCEPT PackList
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
    WITH tb[cdNode].son[1] SELECT FROM
      symbol => 
        BEGIN componentSE: STIndex = index;
	WITH stb[componentSE] SELECT FROM
          module => 
            IF mNode # SourceBcd.NullCTreeIndex AND mti # BcdDefs.MTNull THEN
              IF SourceBcd.IsTableCompiled[mti] THEN 
		Error.TableCompModuleNotIncAsUnit[error, mti];
          ENDCASE;
        END;
      ENDCASE => SEerror[];
    tb[cdNode].son[2] _ LookupCodePacks[tb[cdNode].son[2]];
    END;

  ProcessItemsExceptPacks: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component [ItemList] EXCEPT PackList
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
    WITH tb[cdNode].son[1] SELECT FROM
      symbol => 
        BEGIN componentSE: STIndex = index;
	WITH stb[componentSE] SELECT FROM
          module =>
            Error.Error[
	      error, "The component in this kind of component description must not be a module"L]; 
          config =>  -- process ItemList 
            IF cNode # SourceBcd.NullCTreeIndex THEN
              tb[cdNode].son[2] _ LookupComponentItems[cNode, tb[cdNode].son[2]];
          ENDCASE;
        END;
      ENDCASE => SEerror[];
    tb[cdNode].son[3] _ LookupCodePacks[tb[cdNode].son[3]];
    END;

  ProcessExceptPacksItems: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component EXCEPT PackList, [ItemList]
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
    tb[cdNode].son[2] _ LookupCodePacks[tb[cdNode].son[2]];
    WITH tb[cdNode].son[1] SELECT FROM
      symbol => 
        BEGIN componentSE: STIndex = index;
	WITH stb[componentSE] SELECT FROM
          config => 
            IF cNode # SourceBcd.NullCTreeIndex THEN
              tb[cdNode].son[3] _ LookupComponentItems[cNode, tb[cdNode].son[3]];
          module => 
            IF mNode # SourceBcd.NullCTreeIndex AND mti # BcdDefs.MTNull THEN
              IF SourceBcd.IsTableCompiled[mti] THEN 
		Error.TableCompModuleNotIncAsUnit[error, mti];
          ENDCASE;
        END;
      ENDCASE => SEerror[];
    END;

  ProcessMainProcs: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= MAIN OF PackList
    packList: Tree.Link = tb[cdNode].son[1];
    IF tb[currentCpNode].name = unnamedCodePack THEN Error.Error[
      error, "A MAIN OF component description can not be used to specify an unnamed code pack"L];    
    IF TreeOps.ListLength[packList] = 1 THEN
      BEGIN  -- might be name of current code segment
      idLink: Tree.Link _ TreeOps.ListHead[packList];
      WITH idLink SELECT FROM
        hash => 
          BEGIN id: SymTabDefs.HTIndex = index;
          IF id = currentSegId THEN
            BEGIN
	    segIdSE: STIndex _ NewSemanticEntry[];
            stb[segIdSE] _ [
	      hti: currentSegId, treeNode: currentSegNode, kind: segment[]];
            tb[cdNode].son[1] _ Tree.Link[symbol[index: segIdSE]];
            RETURN;
            END;
          END;
        ENDCASE => SEerror[]; 
      END;
    tb[cdNode].son[1] _ LookupCodePacks[packList];
    END;


  LookupComponent: PROC [compList: Tree.Link] RETURNS [seLink: Tree.Link] =
    BEGIN
    componentSE: STIndex;
    WITH compList SELECT FROM 
      subtree =>
        BEGIN node: Tree.Index = index; 
        saveIndex: CARDINAL = globalData.textIndex;
        globalData.textIndex _ tb[node].info;
	IF tb[node].name # component THEN SEerror[];
        componentSE _ FindComponent[prototype, node];
        globalData.textIndex _ saveIndex;
        END;
      ENDCASE => SEerror[];
    RETURN[Tree.Link[symbol[componentSE]]];
    END;

  LookupComponentItems: PROC [
      configNode: SourceBcd.CTreeIndex, itemList: Tree.Link] 
      RETURNS [itemSElist: Tree.Link] =
    BEGIN

    LookupOneComponentItem: Tree.Map =
      BEGIN
      itemSE: STIndex;
      WITH t SELECT FROM
        hash =>
          BEGIN id: SymTabDefs.HTIndex = index;
	  itemSE _ FindConfigItem[prototype, id, configNode];
          END; 
        subtree =>
          BEGIN node: Tree.Index = index;
  	  IF tb[node].name = main THEN
            BEGIN
            Error.Error[error, "MAIN is not directly contained in a configuration"L];    
            itemSE _ NewSemanticEntry[];
            stb[itemSE] _ [hti: SymTabDefs.HTNull, treeNode: Tree.NullIndex, kind: unknown[]];
            END
          ELSE SEerror[];
          END;
        ENDCASE => SEerror[];
      RETURN[Tree.Link[symbol[itemSE]]];
      END;
  
    RETURN[TreeOps.UpdateList[itemList, LookupOneComponentItem]];
    END;

  LookupCodePacks: PROC [idList: Tree.Link] RETURNS [packList: Tree.Link] =
    {RETURN[TreeOps.UpdateList[idList, LookupOneCodePack]]};

  LookupOneCodePack: Tree.Map =
    BEGIN
    newSE: STIndex _ NewSemanticEntry[];
    cpNode: Tree.Index;
    found: BOOLEAN;
    WITH t SELECT FROM
      hash =>
        BEGIN cpId: SymTabDefs.HTIndex = index;
        [found, cpNode] _ FindCodePack[cpId];
        IF found THEN stb[newSE] _ [hti: cpId, treeNode: cpNode, kind: codePack[]]
        ELSE
          BEGIN
          Error.ErrorHti[error, "is not a code pack in the current segment"L, cpId];
          stb[newSE] _ [hti: cpId, treeNode: Tree.NullIndex, kind: unknown[]];
          END;
        RETURN[Tree.Link[symbol[newSE]]];
        END; 
      ENDCASE => SEerror[];
    END;


  FindComponent: PROC [
      kind: SourceBcd.ComponentKind, compNode: Tree.Index] 
      RETURNS [compSE: STIndex] =
    BEGIN  -- pass id stream (most qualified id first) to FindModuleOrConfig
    component: SourceBcd.CTreeIndex;
    idList: Tree.Link = tb[compNode].son[1];
    idListLen: CARDINAL = TreeOps.ListLength[idList];
    idListTail: Tree.Link = TreeOps.ListTail[idList];
    currentIdNo: CARDINAL;

    ResetIdStream: PROC = {currentIdNo _ idListLen};

    FirstQualId: PROC RETURNS [id: SymTabDefs.HTIndex] =
      BEGIN  -- returns the first (i.e. rightmost or most qualified) id
      WITH idListTail SELECT FROM
        hash => id _ index;
        ENDCASE => SEerror[];
      END;

    NextQualId: PROC RETURNS [id: SymTabDefs.HTIndex] =
      BEGIN  -- returns next qualifying configuration id
      IF (currentIdNo _ currentIdNo-1) < 1 THEN RETURN [SymTabDefs.HTNull];
      WITH idList SELECT FROM
        subtree =>
          BEGIN node: Tree.Index = index;
          IF tb[node].name = list THEN 
            WITH tb[node].son[currentIdNo] SELECT FROM
              hash => id _ index;
              ENDCASE => SEerror[]
          ELSE SEerror[];
          END;
        ENDCASE => SEerror[];
      END;

    IF idList = Tree.Null THEN SEerror[];
    component _ SourceBcd.FindModuleOrConfig[
      kind, ResetIdStream, FirstQualId, NextQualId];
    compSE _ NewSemanticEntry[];
    IF component = SourceBcd.NullCTreeIndex THEN 
      stb[compSE] _ [hti: FirstQualId[], treeNode: compNode, kind: unknown[]]
    ELSE 
      WITH ctreeb[component].index SELECT FROM
        config => stb[compSE] _ [
          hti: FirstQualId[], treeNode: compNode, 
          kind: config[cti: cti, cNode: component]];
        module => stb[compSE] _ [
          hti: FirstQualId[], treeNode: compNode, 
          kind: module[mti: mti, mNode: component]];
      ENDCASE;
    RETURN[compSE];
    END;

  FindConfigItem: PROC [
        kind: SourceBcd.ComponentKind, 
        id: SymTabDefs.HTIndex, configNode: SourceBcd.CTreeIndex] 
      RETURNS [itemSE: STIndex] =
    BEGIN  -- find the directly contained module or config "id" in configNode
    item: SourceBcd.CTreeIndex;
    itemSE _ NewSemanticEntry[];
    item _ SourceBcd.LookupId[id, kind];
    WHILE item # SourceBcd.NullCTreeIndex DO
      IF ctreeb[item].father = configNode THEN EXIT;
      IF kind = instance THEN  -- are there any alternatives? 
	item _ ctreeb[item].instancePrev
      ELSE 
        item _ ctreeb[item].prototypePrev;
      ENDLOOP;
    IF item = SourceBcd.NullCTreeIndex THEN 
      BEGIN
      Error.ErrorHti[error, "is not a directly contained item"L, id];
      stb[itemSE] _ [hti: id, treeNode: Tree.NullIndex, kind: unknown[]]
      END
    ELSE 
      WITH ctreeb[item].index SELECT FROM
        config => stb[itemSE] _ [
          hti: id, treeNode: Tree.NullIndex, kind: config[cti: cti, cNode: item]];
        module => stb[itemSE] _ [
          hti: id, treeNode: Tree.NullIndex, kind: module[mti: mti, mNode: item]];
      ENDCASE;
    RETURN[itemSE];
    END;


 -- ********************** Process a frame pack **********************

  currentFpNode: Tree.Index;

  ProcessOneFramePack: PROC [fpNode: Tree.Index] =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    globalData.textIndex _ tb[fpNode].info;
    currentFpNode _ fpNode;
    TreeOps.ScanList[tb[fpNode].son[2], ProcessOneFpCompDesc];
    globalData.textIndex _ saveIndex;
    END;

  ProcessOneFpCompDesc: Tree.Scan =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    WITH t SELECT FROM
      subtree =>
        BEGIN cdNode: Tree.Index = index;
        globalData.textIndex _ tb[cdNode].info;
	SELECT tb[cdNode].name FROM
          allComp   => AllFramesOfOneComponent[cdNode];
          compItems => FramesOfComponentItems[cdNode];
          ENDCASE => Error.Error[
            error, "Invalid component description for a frame pack"L]; 
        END;
      ENDCASE => SEerror[];
    globalData.textIndex _ saveIndex;
    END;

  AllFramesOfOneComponent: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component  (all global frames of component)
    tb[cdNode].son[1] _ LookupFpComponent[tb[cdNode].son[1]];
    END;

  FramesOfComponentItems: PROC [cdNode: Tree.Index] =
    BEGIN  -- ComponentDesc ::= Component [ItemList]  (frames of component's items)
    componentSE: STIndex;
    WITH tb[cdNode].son[1] SELECT FROM    -- process frame pack component
      subtree =>
        BEGIN node: Tree.Index = index; 
        saveIndex: CARDINAL = globalData.textIndex;
        globalData.textIndex _ tb[node].info;
	IF tb[node].name # component THEN SEerror[];
        componentSE _ FindComponent[instance, node];
        tb[cdNode].son[1] _ Tree.Link[symbol[componentSE]];
        WITH stb[componentSE] SELECT FROM
          config => 
            IF cNode # SourceBcd.NullCTreeIndex THEN
              tb[cdNode].son[2] _ LookupFpComponentItems[
	          cNode, tb[cdNode].son[2]];
          module => Error.Error[
	      error, "A component description with an itemlist in a frame pack must name a configuration"L];  
          ENDCASE;
        globalData.textIndex _ saveIndex;
        END;
      ENDCASE => SEerror[];
    END;

  LookupFpComponent: PROC [compList: Tree.Link] RETURNS [seLink: Tree.Link] =
    BEGIN
    componentSE: STIndex;

    MarkOneFramePlaced: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
      {MarkFramePlaced[mti, currentFpNode];  RETURN[FALSE]};

    WITH compList SELECT FROM       -- process frame pack component
      subtree =>
        BEGIN node: Tree.Index = index; 
        saveIndex: CARDINAL = globalData.textIndex;
        globalData.textIndex _ tb[node].info;
	IF tb[node].name # component THEN SEerror[];
        componentSE _ FindComponent[instance, node];
        WITH stb[componentSE] SELECT FROM
          module =>
            MarkFramePlaced[mti, currentFpNode]; 
          config =>
	    SourceBcd.EnumerateModulesInConfig[
	      instance, cNode, MarkOneFramePlaced];
          ENDCASE;
        globalData.textIndex _ saveIndex;
        END;
      ENDCASE => SEerror[];
    RETURN[Tree.Link[symbol[componentSE]]];
    END;

  LookupFpComponentItems: PROC [
      compNode: SourceBcd.CTreeIndex, itemList: Tree.Link] 
      RETURNS [itemSElist: Tree.Link] =
    BEGIN

    LookupOneFpComponentItem: Tree.Map =
      BEGIN
      itemSE: STIndex _ NewSemanticEntry[];

      MarkOneFramePlaced: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
        {MarkFramePlaced[mti, currentFpNode];  RETURN[FALSE]};

      WITH t SELECT FROM
        hash =>
          BEGIN id: SymTabDefs.HTIndex = index;
	  itemSE _ FindConfigItem[instance, id, compNode];
          WITH stb[itemSE] SELECT FROM
            module =>
              MarkFramePlaced[mti, currentFpNode]; 
            config =>
  	      SourceBcd.EnumerateModulesInConfig[
  	        instance, cNode, MarkOneFramePlaced];
            ENDCASE;
          END; 
        subtree =>
          BEGIN node: Tree.Index = index;
  	  IF tb[node].name = main THEN
            BEGIN
            Error.Error[error, "MAIN procedures do not have global frames"L];    
            stb[itemSE] _ [hti: SymTabDefs.HTNull, treeNode: Tree.NullIndex, kind: unknown[]];
            END
          ELSE SEerror[];
          END;
        ENDCASE => SEerror[];
        RETURN[Tree.Link[symbol[itemSE]]];
      END;
  
    RETURN[TreeOps.UpdateList[itemList, LookupOneFpComponentItem]];
    END;


 -- ********************** Process merged code segments **********************

  ProcessMergeSegments: PROC =
    BEGIN

    LookForMergeSeg: Tree.Scan =
      BEGIN
      WITH t SELECT FROM
        subtree =>
          BEGIN node: Tree.Index = index;
          SELECT tb[node].name FROM
            merge => ProcessOneMergeSeg[node];
            ENDCASE;
          END;
        ENDCASE => SEerror[];
      END;

    TreeOps.ScanList[Tree.root, LookForMergeSeg];
    END;

  ProcessOneMergeSeg: PROC [mergeNode: Tree.Index] =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    globalData.textIndex _ tb[mergeNode].info;
    ProcessIdsOfMergedOldSegs[mergeNode];
    RecordCodePackIds[mergeNode];
    ProcessMergeCodePacks[mergeNode];
    VerifyAllOldCodePacksPlaced[mergeNode];
    ReleaseCodePackIds[];
    globalData.textIndex _ saveIndex;
    END;

  mergedOldSegIdList: Tree.Link;

  ProcessIdsOfMergedOldSegs: PROC [mergeNode: Tree.Index] =
    BEGIN
    mergedOldSegIdList _ tb[mergeNode].son[3] _ TreeOps.UpdateList[
      tb[mergeNode].son[3], ProcessIdOfOneOldMergedSeg];
    END;

  ProcessIdOfOneOldMergedSeg: Tree.Map =
    BEGIN
    oldSegSE: STIndex _ NewSemanticEntry[];
    found: BOOLEAN;
    oldSegNode: Tree.Index;
    WITH t SELECT FROM
      hash =>
        BEGIN oldSegId: SymTabDefs.HTIndex = index;
	[found, oldSegNode] _ FindSeg[oldSegId];
	IF found THEN  
	  BEGIN
	  stb[oldSegSE] _ [
	    hti: oldSegId, treeNode: oldSegNode, kind: segment[]];
	  tb[oldSegNode].attr2 _ TRUE;  -- mark old segment superceded
	  TreeOps.ScanList[tb[oldSegNode].son[2], MarkOldCodePackSuperceded];
	  END
	ELSE 
	  BEGIN
	  Error.ErrorHti[error, "is not a known segment"L, oldSegId];
	  stb[oldSegSE] _ [
	    hti: oldSegId, treeNode: Tree.NullIndex, kind: unknown[]];
	  END;
	RETURN[Tree.Link[symbol[oldSegSE]]];
        END;
      ENDCASE => SEerror[];
    END;

  MarkOldCodePackSuperceded: Tree.Scan =
    BEGIN
    WITH t SELECT FROM
      subtree =>
        BEGIN cpNode: Tree.Index = index;
	SELECT tb[cpNode].name FROM
	  codePack, unnamedCodePack, discardCodePack =>
	    BEGIN
	    tb[cpNode].attr2 _ TRUE;   -- mark old code pack superceded and
	    tb[cpNode].attr3 _ FALSE;  -- not yet placed in new merge segment
            END;
          ENDCASE => SEerror[];
        END;
      ENDCASE => SEerror[];
    END;


  ProcessMergeCodePacks: PROC [mergeNode: Tree.Index] =
    {TreeOps.ScanList[tb[mergeNode].son[2], ProcessOneMergeCodePack]};

  ProcessOneMergeCodePack: Tree.Scan =
    BEGIN
    WITH t SELECT FROM
      subtree =>
        BEGIN cpNode: Tree.Index = index;
        IF tb[cpNode].attr1 THEN
	  BEGIN
	  Error.Error[
	    error, "A code pack in a merged segment can not contain an EXCEPT [MAIN] clause"L];
	  END;
        tb[cpNode].son[2] _ TreeOps.UpdateList[
	  tb[cpNode].son[2], ProcessOneMergeCompDesc];
        END;
      ENDCASE => SEerror[];
    END;

  ProcessOneMergeCompDesc: Tree.Map =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    oldCpId: SymTabDefs.HTIndex;
    oldCpNode: Tree.Index;
    oldCpSE: STIndex _ NewSemanticEntry[];
    WITH t SELECT FROM
      subtree =>
        BEGIN cdNode: Tree.Index = index;
        globalData.textIndex _ tb[cdNode].info;
	SELECT tb[cdNode].name FROM  
	  allComp =>
	    BEGIN
            [oldCpId, oldCpNode] _ ProcessMergeComponent[tb[cdNode].son[1]];
            stb[oldCpSE] _ [
              hti: oldCpId, treeNode: oldCpNode, kind: codePack[]];
	    END;
          ENDCASE => 
	    BEGIN
	    Error.Error[error, "A component description in a merged code segment may only be a reference to an old code pack"L];
	    stb[oldCpSE] _ [
	      hti: SymTabDefs.HTNull, treeNode: Tree.NullIndex, kind: unknown[]];
	    END; 
        END;
      ENDCASE => SEerror[];
    globalData.textIndex _ saveIndex;
    RETURN[Tree.Link[symbol[oldCpSE]]];
    END;

  ProcessMergeComponent: PROC [
      mergeCompLink: Tree.Link] 
      RETURNS [oldCpId: SymTabDefs.HTIndex, oldCpNode: Tree.Index] =
    BEGIN
    oldCpIdLink: Tree.Link;
    WITH mergeCompLink SELECT FROM
      subtree =>
	BEGIN compNode: Tree.Index = index;
	saveIndex: CARDINAL = globalData.textIndex;
	globalData.textIndex _ tb[compNode].info;
	IF tb[compNode].name # component THEN SEerror[];
        oldCpIdLink _ TreeOps.ListTail[tb[compNode].son[1]];
        WITH oldCpIdLink SELECT FROM
          hash => oldCpId _ index;
          ENDCASE => SEerror[];
        oldCpNode _ FindOldCodePackNode[tb[compNode].son[1]];
        IF oldCpNode # Tree.NullIndex THEN
          IF tb[oldCpNode].attr3 THEN
	    Error.ErrorHti[
	      error, "was already placed in a merged segment"L, oldCpId]
          ELSE tb[oldCpNode].attr3 _ TRUE;  -- mark placed in merged segment
        globalData.textIndex _ saveIndex;
        END;
      ENDCASE => SEerror[];
    END;

  FindOldCodePackNode: PROC [oldCpIdList: Tree.Link] RETURNS [oldCpNode: Tree.Index] =
    BEGIN
    SELECT TreeOps.ListLength[oldCpIdList] FROM
      = 1 =>  -- oldCodePackId
	RETURN[FindUnQualOldCodePackNode[oldCpIdList]];
      = 2 =>  -- oldSegmentId.oldCodePackId
	RETURN[FindQualOldCodePackNode[oldCpIdList]];
      ENDCASE =>
	BEGIN
        Error.Error[
	  error, "A component description for a merged code segment must be an optionally qualified old code pack name"L];
        RETURN[Tree.NullIndex];
        END;
    END;

  FindUnQualOldCodePackNode: PROC [oldCpIdList: Tree.Link] RETURNS [oldCpNode: Tree.Index] =
    BEGIN
    oldCpIdLink: Tree.Link;
    oldCpId: SymTabDefs.HTIndex;
    oldCpFound: BOOLEAN;

    LookForOldCpIdInOldSeg: Tree.Test =
      BEGIN
      oldSegNode: Tree.Index;
      WITH t SELECT FROM
        symbol =>
          BEGIN oldSegSE: STIndex = index;
	  WITH stb[oldSegSE] SELECT FROM
	    segment =>
	      BEGIN oldSegNode _ treeNode;
	      [oldCpFound, oldCpNode] _ LookupCpInOldSeg[oldCpId, oldSegNode];
	      END;
	    ENDCASE => SEerror[];
          END;
        ENDCASE => SEerror[];
      RETURN[oldCpFound];  -- continue search until found
      END;

    oldCpIdLink _ TreeOps.ListTail[oldCpIdList];
    WITH oldCpIdLink SELECT FROM
      hash => oldCpId _ index;
      ENDCASE => SEerror[];
    oldCpFound _ FALSE;  oldCpNode _ Tree.NullIndex;
    TreeOps.SearchList[mergedOldSegIdList, LookForOldCpIdInOldSeg];
    IF ~oldCpFound THEN
      BEGIN
      Error.ErrorHti[error, "is not a known code pack"L, oldCpId];
      RETURN[Tree.NullIndex];
      END;
    END;

  FindQualOldCodePackNode: PROC [oldCpIdList: Tree.Link] RETURNS [oldCpNode: Tree.Index] =
    BEGIN
    oldSegIdLink, oldCpIdLink: Tree.Link;
    oldSegId, oldCpId: SymTabDefs.HTIndex;
    oldSegNode: Tree.Index;
    found: BOOLEAN;
    oldSegIdLink _ TreeOps.ListHead[oldCpIdList];
    WITH oldSegIdLink SELECT FROM
      hash => oldSegId _ index;
      ENDCASE => SEerror[];
    oldCpIdLink _ TreeOps.ListTail[oldCpIdList];
    WITH oldCpIdLink SELECT FROM
      hash => oldCpId _ index;
      ENDCASE => SEerror[];
    [found, oldSegNode] _ FindSeg[oldSegId];
    IF ~found THEN
      BEGIN
      Error.ErrorHti[error, "is not a known segment"L, oldSegId];
      RETURN[Tree.NullIndex];
      END;
    VerifyInMergedSegIdList[oldSegId];
    [found, oldCpNode] _ LookupCpInOldSeg[oldCpId, oldSegNode];
    IF ~found THEN
      BEGIN
      Error.ErrorHti[error, "is not a known code pack"L, oldCpId];
      RETURN[Tree.NullIndex];
      END;
    END;

  VerifyInMergedSegIdList: PROC [oldSegId: SymTabDefs.HTIndex] =
    BEGIN
    inMergedSegIdList: BOOLEAN;

    LookForOldSegId: Tree.Test =
      BEGIN
      WITH t SELECT FROM
        symbol =>
          BEGIN oldSegSE: STIndex = index;
	  WITH stb[oldSegSE] SELECT FROM
	    segment => IF hti = oldSegId THEN inMergedSegIdList _ TRUE;
	    ENDCASE;
          END;
        ENDCASE => SEerror[];
      RETURN[inMergedSegIdList];  -- continue search until found
      END;

    inMergedSegIdList _ FALSE;
    TreeOps.SearchList[mergedOldSegIdList, LookForOldSegId];
    IF ~inMergedSegIdList THEN
      Error.ErrorHti[error, "is not a segment being merged"L, oldSegId];
    END;

  LookupCpInOldSeg: PROC [
      oldCpId: SymTabDefs.HTIndex, oldSegNode: Tree.Index] 
      RETURNS [found: BOOLEAN, oldCpNode: Tree.Index] =
    BEGIN

    LookForOldCpId: Tree.Test =
      BEGIN
      WITH t SELECT FROM
        subtree =>
          BEGIN cpNode: Tree.Index = index;
	  WITH tb[cpNode].son[1] SELECT FROM
	    hash =>
	      IF index = oldCpId THEN {found _ TRUE;  oldCpNode _ cpNode};
	    ENDCASE => SEerror[];
          END;
        ENDCASE => SEerror[];
      RETURN[found];  -- continue search until found
      END;

    found _ FALSE;  oldCpNode _ Tree.NullIndex;
    TreeOps.SearchList[tb[oldSegNode].son[2], LookForOldCpId];
    END;


  VerifyAllOldCodePacksPlaced: PROC [mergeNode: Tree.Index] =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    globalData.textIndex _ tb[mergeNode].info;
    TreeOps.ScanList[mergedOldSegIdList, VerifyOneOldSegsCodePacksPlaced];
    globalData.textIndex _ saveIndex;
    END;

  VerifyOneOldSegsCodePacksPlaced: Tree.Scan =
    BEGIN
    oldSegNode: Tree.Index;
    WITH t SELECT FROM
      symbol =>
        BEGIN oldSegSE: STIndex = index;
	WITH stb[oldSegSE] SELECT FROM
	  segment =>
	    BEGIN oldSegNode _ treeNode;
	    TreeOps.ScanList[tb[oldSegNode].son[2], VerifyOneOldCodePackPlaced];
	    END;
          ENDCASE;
        END;
      ENDCASE => SEerror[];
    END;

  VerifyOneOldCodePackPlaced: Tree.Scan =
    BEGIN
    WITH t SELECT FROM
      subtree =>
        BEGIN oldCpNode: Tree.Index = index;
	SELECT tb[oldCpNode].name FROM
	  codePack, unnamedCodePack, discardCodePack =>
	    IF ~tb[oldCpNode].attr3 THEN -- wasn't placed in new merge segment
	      BEGIN
	      WITH tb[oldCpNode].son[1] SELECT FROM
		hash => 
		  BEGIN oldCpId: SymTabDefs.HTIndex _ index; 
		  Error.ErrorHti[
		    error, "was not placed in the merged segment"L, oldCpId];
		  END;
		ENDCASE => SEerror[];
	      END;
          ENDCASE => SEerror[];
        END;
      ENDCASE => SEerror[];
    END;


 -- ********************** Process merged frame packs **********************

  ProcessMergeFramePacks: PROC =
    BEGIN

    LookForMergeFP: Tree.Scan =
      BEGIN
      WITH t SELECT FROM
        subtree =>
          BEGIN node: Tree.Index = index;
          SELECT tb[node].name FROM
            mergeFP => ProcessOneMergeFP[node];
            ENDCASE;
          END;
        ENDCASE => SEerror[];
      END;

    TreeOps.ScanList[Tree.root, LookForMergeFP];
    END;

  ProcessOneMergeFP: PROC [mergeFPNode: Tree.Index] =
    BEGIN
    saveIndex: CARDINAL = globalData.textIndex;
    globalData.textIndex _ tb[mergeFPNode].info;
    ProcessIdsOfMergedOldFPs[mergeFPNode];
    globalData.textIndex _ saveIndex;
    END;

  mergedOldFPIdList: Tree.Link;

  ProcessIdsOfMergedOldFPs: PROC [mergeFPNode: Tree.Index] =
    BEGIN
    mergedOldFPIdList _ tb[mergeFPNode].son[2] _ TreeOps.UpdateList[
      tb[mergeFPNode].son[2], ProcessIdOfOneOldMergedFP];
    END;

  ProcessIdOfOneOldMergedFP: Tree.Map =
    BEGIN
    oldFPSE: STIndex _ NewSemanticEntry[];
    found: BOOLEAN;
    oldFPNode: Tree.Index;
    WITH t SELECT FROM
      hash =>
        BEGIN oldFPId: SymTabDefs.HTIndex = index;
	[found, oldFPNode] _ FindFramePack[oldFPId];
	IF found THEN  
	  BEGIN
	  stb[oldFPSE] _ [
	    hti: oldFPId, treeNode: oldFPNode, kind: framePack[]];
	  tb[oldFPNode].attr2 _ TRUE;  -- mark old frame pack superceded
	  END
	ELSE 
	  BEGIN
	  Error.ErrorHti[error, "is not a known frame pack"L, oldFPId];
	  stb[oldFPSE] _ [
	    hti: oldFPId, treeNode: Tree.NullIndex, kind: unknown[]];
	  END;
	RETURN[Tree.Link[symbol[oldFPSE]]];
        END;
      ENDCASE => SEerror[];
    END;

  END.