-- 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.