-- SemanticEntryImpl.mesa  
-- Last edited by JGS   on 17-Sep-82 14:23:16
-- Last edited by Satterthwaite, December 29, 1982 4:19 pm

DIRECTORY
  Alloc USING [AddNotify, DropNotify, Handle, Notifier, Words],
  BcdDefs USING [MTIndex, MTNull],
  Error USING [
    Error, ErrorHti, FrameInTwoFramePacks, FrameNotPlaced,
    TableCompModuleNotIncAsUnit],
  PackagerDefs USING [globalData, GlobalData, packtreetype, packsttype],
  SemanticEntry USING [HTIndex, htNull, STIndex, STRecord],
  SourceBcd USING [
    BcdTableLoc, ComponentKind, CTreeIndex, EnumerateModules, EnumerateModulesInConfig,
    Father, FindModuleOrConfig, Index, IsTableCompiled, LookupId, ModuleNum, moduleCount,
    ModuleNumForMti, nullCTreeIndex, Prev],
  Table USING [Base],
  Tree: FROM "PackTree" USING [Index, Link, Map, Scan, Test, null, nullIndex],
  TreeOps: FROM "PackTreeOps" USING [
    GetHash, GetNode, GetSe, ListLength, ListHead, ListTail, ScanList, SearchList, UpdateList];

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

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


  gd: PackagerDefs.GlobalData _ NIL;
  table: Alloc.Handle _ NIL;
  tb, stb: Table.Base;

  Notifier: Alloc.Notifier = {
    tb     _ base[PackagerDefs.packtreetype];  
    stb    _ base[PackagerDefs.packsttype]};


  NewSemanticEntry: PROC RETURNS [newSE: STIndex] = {
    newSE _ table.Words[PackagerDefs.packsttype, STRecord.SIZE];
    stb[newSE] _ [
      hti: htNull, 
      treeNode: Tree.nullIndex, 
      kind: unknown[]]};


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

  anyMergeSegments, anyMergeFramePacks: BOOL;

  BuildSemanticEntries: PUBLIC PROC [--root: Tree.Link--] = {
    gd _ PackagerDefs.globalData;
    table _ gd.ownTable;
    table.AddNotify[Notifier];
    anyMergeSegments _ anyMergeFramePacks _ FALSE;
    InitializeFrameArray[];
    RecordSegAndFramePackIds[gd.root];  -- and set anyMergeSegments, anyMergeFramePacks
    ProcessSegAndFramePacks[gd.root];
    IF anyMergeSegments THEN ProcessMergeSegments[gd.root];
    IF anyMergeFramePacks THEN ProcessMergeFramePacks[gd.root];
    VerifyAllFramesPlaced[];
    DestroyFrameArray[];
    ReleaseSegAndFramePackIds[];
    table.DropNotify[Notifier];
    table _ NIL;  gd _ NIL};


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

  -- parse tree nodes of frame packs containing each global frame
  frameArray: LONG POINTER TO FrameMap _ NIL;  -- SourceBcd.ModuleNum -> Tree.Index
  FrameMap: TYPE = RECORD [SEQUENCE length: CARDINAL OF Tree.Index];

  InitializeFrameArray: PROC = {
    frameArray _ gd.zone.NEW[FrameMap[SourceBcd.moduleCount]];
    FOR i: SourceBcd.ModuleNum IN [0..SourceBcd.moduleCount) DO
      frameArray[i] _ Tree.nullIndex;
      ENDLOOP};

  DestroyFrameArray: PROC = {gd.zone.FREE[@frameArray]};

  MarkFramePlaced: PROC [mti: BcdDefs.MTIndex, fpNode: Tree.Index] = {
    mNum: SourceBcd.ModuleNum _ SourceBcd.ModuleNumForMti[mti];
    IF frameArray[mNum] # Tree.nullIndex THEN
      BEGIN
      fpId1: HTIndex = TreeOps.GetHash[tb[frameArray[mNum]].son[1]];
      fpId2: HTIndex = TreeOps.GetHash[tb[fpNode].son[1]];
      Error.FrameInTwoFramePacks[error, mti, fpId1, fpId2];
      END
    ELSE frameArray[mNum] _ fpNode};

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

    SourceBcd.EnumerateModules[VerifyOneFramePlaced]};


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

  segArray, fpArray: TreeNodeArray _ NIL;
  TreeNodeArray: TYPE = LONG POINTER TO TreeNodeMap;  -- # -> Tree.Index
  TreeNodeMap: TYPE = RECORD [SEQUENCE length: CARDINAL OF Tree.Index];

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

  RecordSegAndFramePackIds: PROC [root: Tree.Link] = {
    segCount _ fpCount _ 0;
    TreeOps.ScanList[root, CountSegOrFPId];
    segArray _ gd.zone.NEW[TreeNodeMap[segCount]];
    fpArray _ gd.zone.NEW[TreeNodeMap[fpCount]];
    currentSeg _ currentFP _ 0;
    TreeOps.ScanList[root, NoteSegOrFPId]};

  ReleaseSegAndFramePackIds: PROC = {
    gd.zone.FREE[@segArray];  
    gd.zone.FREE[@fpArray];
    segCount _ fpCount _ 0};

  CountSegOrFPId: Tree.Scan = {
    node: Tree.Index = TreeOps.GetNode[t];
    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};

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

  FindSeg: PROC [
      id: HTIndex] RETURNS [found: BOOL, segNode: Tree.Index] = {
    FOR i: CARDINAL IN [0..segCount) DO
      segNode _ segArray[i];
      IF id = TreeOps.GetHash[tb[segNode].son[1]] THEN RETURN[TRUE, segNode];
      ENDLOOP;
    RETURN[FALSE, Tree.nullIndex]};

  FindFramePack: PROC [id: HTIndex] RETURNS [found: BOOL, fpNode: Tree.Index] = {
    FOR i: CARDINAL IN [0..fpCount) DO
      fpNode _ fpArray[i];
      IF id = TreeOps.GetHash[tb[fpNode].son[1]] THEN RETURN[TRUE, fpNode];
      ENDLOOP;
    RETURN[FALSE, Tree.nullIndex]};


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

  ProcessSegAndFramePacks: PROC [root: Tree.Link] = {

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

    TreeOps.ScanList[root, ProcessSegOrFP]};


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

  currentSegId: HTIndex;  
  currentSegNode: Tree.Index;   

  cpArray: TreeNodeArray _ NIL;  -- code pack # -> tree node map
  cpCount, currentCP: CARDINAL;

  ProcessOneCodeSeg: PROC [segNode: Tree.Index] = {
    saveIndex: CARDINAL = gd.textIndex;
    gd.textIndex _ tb[segNode].info;
    currentSegNode _ segNode;
    currentSegId _ TreeOps.GetHash[tb[segNode].son[1]];
    RecordCodePackIds[segNode];
    ProcessCodePacks[segNode];
    ReleaseCodePackIds[];
    gd.textIndex _ saveIndex};

  RecordCodePackIds: PROC [segNode: Tree.Index] = {
    cpCount _ TreeOps.ListLength[tb[segNode].son[2]];
    cpArray _ gd.zone.NEW[TreeNodeMap[cpCount]];
    currentCP _ 0;
    TreeOps.ScanList[tb[segNode].son[2], NoteCPId]};

  ReleaseCodePackIds: PROC =  {
    gd.zone.FREE[@cpArray];
    cpCount _ 0};

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

  FindCodePack: PROC [
      id: HTIndex] RETURNS [found: BOOL, cpNode: Tree.Index] = {
    FOR i: CARDINAL IN [0..cpCount) DO
      cpNode _ cpArray[i];
      IF id = TreeOps.GetHash[tb[cpNode].son[1]] THEN RETURN[TRUE, cpNode];
      ENDLOOP;
    RETURN[FALSE, Tree.nullIndex]};


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

  currentCpNode: Tree.Index;

  ProcessOneCodePack: Tree.Scan = {
    currentCpNode _ TreeOps.GetNode[t];
    TreeOps.ScanList[tb[currentCpNode].son[2], ProcessOneComponentDesc]};

  ProcessOneComponentDesc: Tree.Scan = {
    saveIndex: CARDINAL = gd.textIndex;
    cdNode: Tree.Index = TreeOps.GetNode[t];
    gd.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];
      mainOfPL         => ProcessMainOfPL[cdNode];
      evOfPL           => ProcessEvOfPL[cdNode];
      catchOfPL        => ProcessCatchOfPL[cdNode];
      ENDCASE => SEerror[]; 
    tb[cdNode].cp  _ currentCpNode;
    tb[cdNode].seg _ currentSegNode;
    gd.textIndex _ saveIndex};

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

  ProcessCompItems: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= Component [ItemList]
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
      BEGIN componentSE: STIndex = TreeOps.GetSe[tb[cdNode].son[1]];
      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};

  ProcessExceptItems: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= Component EXCEPT [ItemList]
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
      BEGIN componentSE: STIndex = TreeOps.GetSe[tb[cdNode].son[1]];
      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};

  ProcessExceptPacks: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= Component EXCEPT PackList
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
      BEGIN componentSE: STIndex = TreeOps.GetSe[tb[cdNode].son[1]];
      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;
    tb[cdNode].son[2] _ LookupCodePacks[tb[cdNode].son[2]]};

  ProcessItemsExceptPacks: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= Component [ItemList] EXCEPT PackList
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
      BEGIN componentSE: STIndex = TreeOps.GetSe[tb[cdNode].son[1]];
      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;
    tb[cdNode].son[3] _ LookupCodePacks[tb[cdNode].son[3]]};

  ProcessExceptPacksItems: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= Component EXCEPT PackList, [ItemList]
    tb[cdNode].son[1] _ LookupComponent[tb[cdNode].son[1]];
    tb[cdNode].son[2] _ LookupCodePacks[tb[cdNode].son[2]];
      BEGIN componentSE: STIndex = TreeOps.GetSe[tb[cdNode].son[1]];
      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};

  ProcessMainOfPL: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= MAIN OF PackList
    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];    
    DoMiscCodeCompDesc[cdNode]};

  ProcessEvOfPL: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= ENTRY VECTOR OF PackList
    IF tb[currentCpNode].name = unnamedCodePack THEN Error.Error[
      error, "An ENTRY VECTOR OF component description can not be used to specify an unnamed code pack"L];    
    DoMiscCodeCompDesc[cdNode]};

  ProcessCatchOfPL: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= CATCH CODE OF PackList
    IF tb[currentCpNode].name = unnamedCodePack THEN Error.Error[
      error, "A CATCH CODE OF component description can not be used to specify an unnamed code pack"L];    
    DoMiscCodeCompDesc[cdNode]};

  DoMiscCodeCompDesc: PROC [cdNode: Tree.Index] = {
    -- process MAIN/ENTRY VECTOR/CATCH CODE OF PackList
    packList: Tree.Link = tb[cdNode].son[1];
    IF TreeOps.ListLength[packList] = 1 THEN { -- name of current code seg?
      idLink: Tree.Link _ TreeOps.ListHead[packList];
      id: HTIndex = TreeOps.GetHash[idLink];
      IF id = currentSegId THEN {
	segIdSE: STIndex _ NewSemanticEntry[];
	stb[segIdSE] _ [
	  hti: currentSegId, treeNode: currentSegNode, kind: segment[]];
	tb[cdNode].son[1] _ Tree.Link[symbol[index: segIdSE]];
	RETURN}};
    tb[cdNode].son[1] _ LookupCodePacks[packList]};


  LookupComponent: PROC [compList: Tree.Link] RETURNS [seLink: Tree.Link] = {
    componentSE: STIndex;
    node: Tree.Index = TreeOps.GetNode[compList]; 
    saveIndex: CARDINAL = gd.textIndex;
    gd.textIndex _ tb[node].info;
    IF tb[node].name # component THEN SEerror[];
    componentSE _ FindComponent[prototype, node];
    gd.textIndex _ saveIndex;
    RETURN[Tree.Link[symbol[componentSE]]]};

  LookupComponentItems: PROC [  -- in a configuration
      configNode: SourceBcd.CTreeIndex, itemList: Tree.Link] 
    RETURNS [itemSElist: Tree.Link] = {

    LookupOneComponentItem: Tree.Map = {
      itemSE: STIndex;
      WITH t SELECT FROM
        hash =>
	  itemSE _ FindConfigItem[prototype, index, configNode];
        subtree => {
          node: Tree.Index = index;
  	  SELECT tb[node].name FROM
	    main => 
              Error.Error[error, "MAIN is not directly contained in a configuration"L];    
	    ev => 
              Error.Error[error, "ENTRY VECTOR is not directly contained in a configuration"L];    
	    catch => 
              Error.Error[error, "CATCH CODE is not directly contained in a configuration"L];    
	    ENDCASE => SEerror[];
	  itemSE _ NewSemanticEntry[];
	  stb[itemSE] _ [
	    hti: htNull, treeNode: Tree.nullIndex, kind: unknown[]]};
        ENDCASE => SEerror[];
      RETURN[Tree.Link[symbol[itemSE]]]};
  
    RETURN[TreeOps.UpdateList[itemList, LookupOneComponentItem]]};

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

  LookupOneCodePack: Tree.Map = {
    newSE: STIndex _ NewSemanticEntry[];
    cpNode: Tree.Index;
    found: BOOL;
    cpId: HTIndex = TreeOps.GetHash[t];
    [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]]]};


  FindComponent: PROC [
      kind: SourceBcd.ComponentKind, compNode: Tree.Index] 
      RETURNS [compSE: STIndex] = {
    -- 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: HTIndex] =
      BEGIN  -- returns the first (i.e. rightmost or most qualified) id
      id _ TreeOps.GetHash[idListTail];
      END;

    NextQualId: PROC RETURNS [id: HTIndex] =
      BEGIN  -- returns next qualifying configuration id
      IF (currentIdNo _ currentIdNo-1) < 1 THEN RETURN [htNull];
        BEGIN node: Tree.Index = TreeOps.GetNode[idList];
        IF tb[node].name = list THEN 
          id _ TreeOps.GetHash[tb[node].son[currentIdNo]]
        ELSE SEerror[];
        END;
      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 {
      index: SourceBcd.BcdTableLoc = component.Index;
      WITH 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]};

  FindConfigItem: PROC [
        kind: SourceBcd.ComponentKind, 
        id: HTIndex, configNode: SourceBcd.CTreeIndex] 
      RETURNS [itemSE: STIndex] = {
    -- 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 item.Father = configNode THEN EXIT;
      item _ item.Prev[kind];  -- are there any alternatives?
      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  {
      index: SourceBcd.BcdTableLoc = item.Index;
      WITH 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]};


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

  currentFpNode: Tree.Index;

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

  ProcessOneFpCompDesc: Tree.Scan = {
    saveIndex: CARDINAL = gd.textIndex;
    cdNode: Tree.Index = TreeOps.GetNode[t];
    gd.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];
    gd.textIndex _ saveIndex};

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

  FramesOfComponentItems: PROC [cdNode: Tree.Index] = {
    -- ComponentDesc ::= Component [ItemList]  (frames of component's items)
    componentSE: STIndex;
    -- process frame pack component
    node: Tree.Index = TreeOps.GetNode[tb[cdNode].son[1]]; 
    saveIndex: CARDINAL = gd.textIndex;
    gd.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;
    gd.textIndex _ saveIndex};

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

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

    node: Tree.Index = TreeOps.GetNode[compList]; 
    saveIndex: CARDINAL = gd.textIndex;
    gd.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[cNode, $instance, MarkOneFramePlaced];
	ENDCASE;
    gd.textIndex _ saveIndex;
    RETURN[Tree.Link[symbol[componentSE]]]};

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

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

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

      WITH t SELECT FROM
        hash =>
	  BEGIN
	  itemSE _ FindConfigItem[instance, index, compNode];
          WITH stb[itemSE] SELECT FROM
            module =>
              MarkFramePlaced[mti, currentFpNode]; 
            config =>
  	      SourceBcd.EnumerateModulesInConfig[cNode, $instance, MarkOneFramePlaced];
            ENDCASE;
          END;
        subtree =>
          BEGIN node: Tree.Index = index;
  	  SELECT tb[node].name FROM
	    main => 
              Error.Error[error, "MAIN procedures do not have global frames"L];    
	    ev => 
              Error.Error[error, "Entry vectors do not have global frames"L];    
	    catch => 
              Error.Error[error, "Catch code does not have a global frame"L];    
            ENDCASE => SEerror[];
	  stb[itemSE] _ [hti: htNull, treeNode: Tree.nullIndex, kind: unknown[]];
          END;
        ENDCASE => SEerror[];
        RETURN[Tree.Link[symbol[itemSE]]];
      END;
  
    RETURN[TreeOps.UpdateList[itemList, LookupOneFpComponentItem]]};


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

  ProcessMergeSegments: PROC [root: Tree.Link] = {

    LookForMergeSeg: Tree.Scan =
      BEGIN
      node: Tree.Index = TreeOps.GetNode[t];
      SELECT tb[node].name FROM
	merge => ProcessOneMergeSeg[node];
	ENDCASE;
       END;

    TreeOps.ScanList[root, LookForMergeSeg]};

  ProcessOneMergeSeg: PROC [mergeNode: Tree.Index] = {
    saveIndex: CARDINAL = gd.textIndex;
    gd.textIndex _ tb[mergeNode].info;
    ProcessIdsOfMergedOldSegs[mergeNode];
    RecordCodePackIds[mergeNode];
    ProcessMergeCodePacks[mergeNode];
    VerifyAllOldCodePacksPlaced[mergeNode];
    ReleaseCodePackIds[];
    gd.textIndex _ saveIndex};

  mergedOldSegIdList: Tree.Link;

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

  ProcessIdOfOneOldMergedSeg: Tree.Map = {
    oldSegSE: STIndex _ NewSemanticEntry[];
    found: BOOL;
    oldSegNode: Tree.Index;
    oldSegId: HTIndex = TreeOps.GetHash[t];
    [found, oldSegNode] _ FindSeg[oldSegId];
    IF found THEN  
      BEGIN
      stb[oldSegSE] _ [
	hti: oldSegId, treeNode: oldSegNode, kind: segment[]];
      tb[oldSegNode].attrs[$superceded] _ 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]]]};

  MarkOldCodePackSuperceded: Tree.Scan = {
    cpNode: Tree.Index = TreeOps.GetNode[t];
    SELECT tb[cpNode].name FROM
      codePack, unnamedCodePack, discardCodePack =>
	BEGIN
	tb[cpNode].attrs[$superceded] _ TRUE;   -- mark old code pack superceded and
	tb[cpNode].attrs[$placed] _ FALSE;  -- not yet placed in new merge segment
	END;
      ENDCASE => SEerror[]};


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

  ProcessOneMergeCodePack: Tree.Scan = {
    cpNode: Tree.Index = TreeOps.GetNode[t];
    IF tb[cpNode].attrs[$exceptMAIN] THEN 
      Error.Error[
	error, "A code pack in a merged segment can not contain an EXCEPT [MAIN] clause"L];
    IF tb[cpNode].attrs[$exceptEV] THEN 
      Error.Error[
	error, "A code pack in a merged segment can not contain an EXCEPT [ENTRY VECTOR] clause"L];
    IF tb[cpNode].attrs[$exceptCatch] THEN
      Error.Error[
	error, "A code pack in a merged segment can not contain an EXCEPT [CATCH CODE] clause"L];
    oldDiscardCodePackFound _ FALSE;
    tb[cpNode].son[2] _ TreeOps.UpdateList[
      tb[cpNode].son[2], ProcessOneMergeCompDesc];
    IF oldDiscardCodePackFound
	AND tb[cpNode].name = unnamedCodePack
	AND (TreeOps.ListLength[tb[cpNode].son[2]] = 1) THEN  
      tb[cpNode].name _ discardCodePack};  -- propogate DISCARD attribute

  ProcessOneMergeCompDesc: Tree.Map = {
    saveIndex: CARDINAL = gd.textIndex;
    oldCpId: HTIndex;
    oldCpNode: Tree.Index;
    oldCpSE: STIndex _ NewSemanticEntry[];
    cdNode: Tree.Index = TreeOps.GetNode[t];
    gd.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[]];
	IF tb[oldCpNode].name = discardCodePack THEN
	  oldDiscardCodePackFound _ TRUE;
	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: htNull, treeNode: Tree.nullIndex, kind: unknown[]];
	END;
    gd.textIndex _ saveIndex;
    RETURN[Tree.Link[symbol[oldCpSE]]]};

  ProcessMergeComponent: PROC [
      mergeCompLink: Tree.Link] 
      RETURNS [oldCpId: HTIndex, oldCpNode: Tree.Index] = {
    oldCpIdLink: Tree.Link;
    compNode: Tree.Index = TreeOps.GetNode[mergeCompLink];
    saveIndex: CARDINAL = gd.textIndex;
    gd.textIndex _ tb[compNode].info;
    IF tb[compNode].name # component THEN SEerror[];
    oldCpIdLink _ TreeOps.ListTail[tb[compNode].son[1]];
    oldCpId _ TreeOps.GetHash[oldCpIdLink];
    oldCpNode _ FindOldCodePackNode[tb[compNode].son[1]];
    IF oldCpNode # Tree.nullIndex THEN
      IF tb[oldCpNode].attrs[$placed] THEN
	Error.ErrorHti[
	  error, "was already placed in a merged segment"L, oldCpId]
      ELSE tb[oldCpNode].attrs[$placed] _ TRUE;  -- mark placed in merged segment
    gd.textIndex _ saveIndex};

  FindOldCodePackNode: PROC [
      oldCpIdList: Tree.Link] RETURNS [oldCpNode: Tree.Index] = {
    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};

  FindUnQualOldCodePackNode: PROC [
      oldCpIdList: Tree.Link] RETURNS [oldCpNode: Tree.Index] = {
    oldCpIdLink: Tree.Link;
    oldCpId: HTIndex;
    oldCpFound: BOOL;

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

    oldCpIdLink _ TreeOps.ListTail[oldCpIdList];
    oldCpId _ TreeOps.GetHash[oldCpIdLink];
    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};

  FindQualOldCodePackNode: PROC [
      oldCpIdList: Tree.Link] RETURNS [oldCpNode: Tree.Index] = {
    oldSegIdLink, oldCpIdLink: Tree.Link;
    oldSegId, oldCpId: HTIndex;
    oldSegNode: Tree.Index;
    found: BOOL;
    oldSegIdLink _ TreeOps.ListHead[oldCpIdList];
    oldSegId _ TreeOps.GetHash[oldSegIdLink];
    oldCpIdLink _ TreeOps.ListTail[oldCpIdList];
    oldCpId _ TreeOps.GetHash[oldCpIdLink];
    [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};

  VerifyInMergedSegIdList: PROC [oldSegId: HTIndex] = {
    inMergedSegIdList: BOOL;

    LookForOldSegId: Tree.Test =
      BEGIN
      oldSegSE: STIndex = TreeOps.GetSe[t];
	  WITH stb[oldSegSE] SELECT FROM
	    segment => IF hti = oldSegId THEN inMergedSegIdList _ TRUE;
	    ENDCASE;
      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]};

  LookupCpInOldSeg: PROC [
      oldCpId: HTIndex, oldSegNode: Tree.Index] 
      RETURNS [found: BOOL, oldCpNode: Tree.Index] = {

    LookForOldCpId: Tree.Test =
      BEGIN
      cpNode: Tree.Index = TreeOps.GetNode[t];
      IF TreeOps.GetHash[tb[cpNode].son[1]] = oldCpId THEN {
        found _ TRUE;  oldCpNode _ cpNode};
      RETURN[found];  -- continue search until found
      END;

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


  VerifyAllOldCodePacksPlaced: PROC [mergeNode: Tree.Index] = {
    saveIndex: CARDINAL = gd.textIndex;
    gd.textIndex _ tb[mergeNode].info;
    TreeOps.ScanList[mergedOldSegIdList, VerifyOneOldSegsCodePacksPlaced];
    gd.textIndex _ saveIndex};

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

  VerifyOneOldCodePackPlaced: Tree.Scan = {
    oldCpNode: Tree.Index = TreeOps.GetNode[t];
    SELECT tb[oldCpNode].name FROM
      codePack, unnamedCodePack, discardCodePack =>
	IF ~tb[oldCpNode].attrs[$placed] THEN -- wasn't placed in new merge segment
	  BEGIN
	  oldCpId: HTIndex _ TreeOps.GetHash[tb[oldCpNode].son[1]]; 
	  Error.ErrorHti[
	    error, "was not placed in the merged segment"L, oldCpId];
	  END;
      ENDCASE => SEerror[]};


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

  ProcessMergeFramePacks: PROC [root: Tree.Link] = {

    LookForMergeFP: Tree.Scan =
      BEGIN
      node: Tree.Index = TreeOps.GetNode[t];
      SELECT tb[node].name FROM
	mergeFP => ProcessOneMergeFP[node];
	ENDCASE;
      END;

    TreeOps.ScanList[root, LookForMergeFP]};

  ProcessOneMergeFP: PROC [mergeFPNode: Tree.Index] = {
    saveIndex: CARDINAL = gd.textIndex;
    gd.textIndex _ tb[mergeFPNode].info;
    ProcessIdsOfMergedOldFPs[mergeFPNode];
    gd.textIndex _ saveIndex};

  mergedOldFPIdList: Tree.Link;

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

  ProcessIdOfOneOldMergedFP: Tree.Map = {
    oldFPSE: STIndex _ NewSemanticEntry[];
    found: BOOL;
    oldFPNode: Tree.Index;
    oldFPId: HTIndex = TreeOps.GetHash[t];
    [found, oldFPNode] _ FindFramePack[oldFPId];
    IF found THEN  
      BEGIN
      stb[oldFPSE] _ [
	hti: oldFPId, treeNode: oldFPNode, kind: framePack[]];
      tb[oldFPNode].attrs[$superceded] _ 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.