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