-- SourceBcdImpl.mesa
-- Last edited by Lewis on 18-May-81 19:01:52
-- Last edited by Sweet on July 17, 1980 11:18 AM
-- Last edited by Levin on July 6, 1982 4:45 pm
DIRECTORY
Alloc USING [AddNotify, DropNotify, Handle, Notifier, Words],
BcdDefs USING [
CTIndex, CTNull, CTRecord, EXPIndex, FTIndex, FTNull, IMPIndex,
MTIndex, MTRecord, Namee, NameRecord, NTIndex, NTRecord, SGIndex, SPIndex,
VersionID],
Error USING [Error, AmbiguousComponent, UnknownComponent],
Inline USING [BITAND, BITXOR],
PackagerDefs USING [packctreetype, globalData],
PackEnviron USING [BcdHandle, SourceBcdSegmentBase],
PackHeap USING [FreeSpace, GetSpace],
Segments USING [
BaseFromSegment, DeleteSegment, FHandle, HardDown, MoveSegment, NewSegment, Read,
SegmentAddress, SHandle, SwapIn, Unlock],
Strings USING [EqualSubStrings, String, SubString, SubStringDescriptor],
SymTabOps USING [SubStringForHash],
SymTabDefs USING [HTIndex, HTNull],
SourceBcd,
Table USING [Base];
SourceBcdImpl: PROGRAM
IMPORTS Alloc, Error, Inline, PackagerDefs, PackHeap, Segments, Strings,
SymTabOps
EXPORTS SourceBcd =
BEGIN OPEN SourceBcd, BcdDefs;
-- Source Bcd is obsolete, already repackaged, or was compiled for Alto
BadSourceBcd: PUBLIC ERROR = CODE;
ConfigTreeBuildingError: ERROR = CODE;
CTreeBuildError: PROC = {ERROR ConfigTreeBuildingError};
SubStringDescriptor: TYPE = Strings.SubStringDescriptor;
SubString: TYPE = Strings.SubString;
table: Alloc.Handle ← NIL;
-- ****************** Source BCD Loading and Unloading ******************
bcdHeader: PUBLIC PackEnviron.BcdHandle ← NIL;
bcdBases: PUBLIC LONG POINTER TO BcdBaseRec ← NIL;
bcdLimits: PUBLIC LONG POINTER TO BcdLimitRec ← NIL;
moduleCount: PUBLIC CARDINAL ← 0;
bcdSegment: Segments.SHandle ← NIL;
Load: PUBLIC PROC =
BEGIN
pages: CARDINAL;
table ← PackagerDefs.globalData.ownTable;
bcdSegment ← Segments.NewSegment[
file: PackagerDefs.globalData.sourceBcdFile,
base: 1, pages: 10, access: Segments.Read];
Segments.SwapIn[
seg: bcdSegment, base: PackEnviron.SourceBcdSegmentBase,
info: Segments.HardDown];
bcdHeader ← Segments.SegmentAddress[bcdSegment];
IF bcdHeader.versionIdent # BcdDefs.VersionID OR bcdHeader.definitions THEN
BEGIN
Error.Error[error, "Invalid input BCD file: obsolete version or definitions BCD"L];
GO TO bogus
END;
IF bcdHeader.repackaged THEN
BEGIN
Error.Error[error, "Already packaged BCDs cannot be repackaged"L];
GO TO bogus
END;
IF (pages ← bcdHeader.nPages) > 10 THEN -- load entire bcd
BEGIN
Segments.Unlock[bcdSegment];
Segments.MoveSegment[
seg: bcdSegment, base: Segments.BaseFromSegment[bcdSegment], pages: pages];
Segments.SwapIn[
seg: bcdSegment, base: PackEnviron.SourceBcdSegmentBase,
info: Segments.HardDown];
bcdHeader ← Segments.SegmentAddress[bcdSegment];
END;
PackagerDefs.globalData.sourceBcdVersion ← bcdHeader.version;
bcdBases ← PackHeap.GetSpace[SIZE[BcdBaseRec]];
bcdBases↑ ← [
ctb: LOOPHOLE[bcdHeader + bcdHeader.ctOffset],
mtb: LOOPHOLE[bcdHeader + bcdHeader.mtOffset],
lfb: LOOPHOLE[bcdHeader + bcdHeader.lfOffset],
rfb: LOOPHOLE[bcdHeader + bcdHeader.rfOffset],
tfb: LOOPHOLE[bcdHeader + bcdHeader.tfOffset],
etb: LOOPHOLE[bcdHeader + bcdHeader.expOffset],
itb: LOOPHOLE[bcdHeader + bcdHeader.impOffset],
sgb: LOOPHOLE[bcdHeader + bcdHeader.sgOffset],
ftb: LOOPHOLE[bcdHeader + bcdHeader.ftOffset],
ssb: LOOPHOLE[bcdHeader + bcdHeader.ssOffset],
evb: LOOPHOLE[bcdHeader + bcdHeader.evOffset],
spb: LOOPHOLE[bcdHeader + bcdHeader.spOffset],
ntb: LOOPHOLE[bcdHeader + bcdHeader.ntOffset],
tyb: LOOPHOLE[bcdHeader + bcdHeader.typOffset],
tmb: LOOPHOLE[bcdHeader + bcdHeader.tmOffset],
fpb: LOOPHOLE[bcdHeader + bcdHeader.fpOffset]];
IF bcdBases.mtb[FIRST[MTIndex]].altoCode THEN
BEGIN
PackHeap.FreeSpace[bcdBases]; bcdBases ← NIL;
Error.Error[error, "Packaging is not supported for Alto programs"L];
GO TO bogus
END;
bcdLimits ← PackHeap.GetSpace[SIZE[BcdLimitRec]];
bcdLimits↑ ← [
ct: bcdHeader.ctLimit,
sg: bcdHeader.sgLimit,
ft: bcdHeader.ftLimit,
mt: bcdHeader.mtLimit,
et: bcdHeader.expLimit,
it: bcdHeader.impLimit,
nt: bcdHeader.ntLimit,
sp: bcdHeader.spLimit,
tm: bcdHeader.tmLimit,
fp: bcdHeader.fpLimit];
CountModules[];
InitializeMtiArray[];
EXITS
bogus =>
BEGIN
Segments.Unlock[bcdSegment]; Segments.DeleteSegment[bcdSegment];
bcdSegment ← NIL; bcdHeader ← NIL;
ERROR BadSourceBcd
END;
END;
Unload: PUBLIC PROC =
BEGIN
IF bcdSegment = NIL THEN RETURN;
Segments.Unlock[bcdSegment]; Segments.DeleteSegment[bcdSegment];
bcdSegment ← NIL;
PackHeap.FreeSpace[bcdBases];
PackHeap.FreeSpace[bcdLimits];
ReleaseMtiArray[];
moduleCount ← 0;
table ← NIL;
END;
EnumerateConfigs: PUBLIC PROC [
userProc: PROC [CTIndex] RETURNS [stop: BOOLEAN]] =
BEGIN
cti: CTIndex ← FIRST[CTIndex];
UNTIL cti = bcdLimits.ct DO
IF userProc[cti] THEN RETURN;
cti ← cti + SIZE[CTRecord] + bcdBases.ctb[cti].nControls;
ENDLOOP;
END;
EnumerateModules: PUBLIC PROC [
userProc: PROC [MTIndex] RETURNS [stop: BOOLEAN]] =
BEGIN
mti: MTIndex ← FIRST[MTIndex];
UNTIL mti = bcdLimits.mt DO
mtRecSize: CARDINAL;
IF userProc[mti] THEN RETURN;
WITH mth: bcdBases.mtb[mti] SELECT FROM
direct => mtRecSize ← SIZE[direct MTRecord] + mth.length;
indirect => mtRecSize ← SIZE[indirect MTRecord];
multiple => mtRecSize ← SIZE[multiple MTRecord];
ENDCASE;
mti ← mti + mtRecSize;
ENDLOOP;
END;
IsTableCompiled: PUBLIC PROC [
mti: BcdDefs.MTIndex] RETURNS [reply: BOOLEAN] =
BEGIN
RETURN[ bcdBases.mtb[mti].tableCompiled ];
END;
SubStringForName: PUBLIC PROC [ss: Strings.SubString, name: NameRecord] =
BEGIN
ss.base ← @bcdBases.ssb.string;
ss.offset ← name; ss.length ← bcdBases.ssb.size[name];
END;
EqualIdAndName: PUBLIC PROC [
id: SymTabDefs.HTIndex, name: NameRecord] RETURNS [yes: BOOLEAN] =
BEGIN
idSS: SubString ← @idSSDesc;
idSSDesc: SubStringDescriptor;
nameSS: SubString ← @nameSSDesc;
nameSSDesc: SubStringDescriptor;
SymTabOps.SubStringForHash[idSS, id];
SubStringForName[nameSS, name];
RETURN[Strings.EqualSubStrings[idSS, nameSS]];
END;
CountModules: PROC =
BEGIN
CountOneModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
{moduleCount ← moduleCount+1; RETURN[FALSE]};
moduleCount ← 0;
EnumerateModules[CountOneModule];
END;
-- BcdDefs.MTIndex -> ModuleNum mapping related declarations
mtiArray: PUBLIC LONG DESCRIPTOR FOR ARRAY ModuleNum OF BcdMTIndex;
InitializeMtiArray: PROC =
BEGIN
i: ModuleNum;
EnterOneModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN] =
BEGIN
mtiArray[i] ← LOOPHOLE[mti, BcdMTIndex]; i ← i+1;
RETURN[FALSE];
END;
mtiArray ← (IF moduleCount # 0
THEN DESCRIPTOR[PackHeap.GetSpace[moduleCount*SIZE[BcdMTIndex]], moduleCount]
ELSE DESCRIPTOR[NIL, 0]);
i ← 0;
EnumerateModules[EnterOneModule];
END;
ReleaseMtiArray: PROC = {PackHeap.FreeSpace[BASE[mtiArray]]};
ModuleNumForMti: PUBLIC PROC [
mti: BcdDefs.MTIndex] RETURNS [mNum: ModuleNum] =
BEGIN -- map i-th module index to i
orderedMti: BcdMTIndex ← LOOPHOLE[mti];
l, m, u: ModuleNum;
l ← 0; u ← moduleCount;
UNTIL l > u DO
m ← (l+u)/2;
SELECT mtiArray[m] FROM
< orderedMti => l ← m+1;
> orderedMti => u ← m-1;
ENDCASE => RETURN[m]; -- mti found at mtiArray[m]
ENDLOOP;
RETURN[NullModuleNum]; -- could not find mti
END;
-- ******************** Configuration tree creation ********************
configTreeRoot: PUBLIC CTreeIndex ← NullCTreeIndex;
rootPointsToModule: BOOLEAN ← FALSE;
BuildConfigTree: PUBLIC PROC =
BEGIN
table.AddNotify[UpdateConfigTreeBase];
InitializeHashVectors[];
configTreeRoot ← NullCTreeIndex; rootPointsToModule ← FALSE;
EnumerateModules[EnterOneModule];
EnumerateConfigs[EnterOneConfig];
END;
DestroyConfigTree: PUBLIC PROC =
BEGIN
IF table ~= NIL THEN table.DropNotify[UpdateConfigTreeBase];
configTreeRoot ← NullCTreeIndex;
END;
ctreeb: Table.Base;
UpdateConfigTreeBase: Alloc.Notifier =
BEGIN
ctreeb ← base[PackagerDefs.packctreetype];
END;
CTreeHVSize: CARDINAL = 71;
CTreeHash: TYPE = [0..CTreeHVSize);
instHashVec, protoHashVec: ARRAY CTreeHash OF CTreeIndex;
InitializeHashVectors: PROC =
BEGIN
i: CTreeHash;
FOR i IN CTreeHash DO
instHashVec[i] ← protoHashVec[i] ← NullCTreeIndex
ENDLOOP;
END;
HashForName: PROC [name: NameRecord] RETURNS [CTreeHash] =
BEGIN
desc: SubStringDescriptor ← [base: @bcdBases.ssb.string,
offset: name, length: bcdBases.ssb.size[name]];
ss: SubString = @desc;
RETURN[HashValue[ss]];
END;
HashValue: PROC [s: SubString] RETURNS [CTreeHash] =
BEGIN -- computes the hash index for substring s
CharMask: PROC [CHARACTER, WORD] RETURNS [CARDINAL] =
LOOPHOLE[Inline.BITAND];
mask: WORD = 137B; -- masks out ASCII case shifts
n: CARDINAL = s.length;
b: Strings.String = s.base;
v: WORD;
v ← CharMask[b[s.offset], mask]*177B + CharMask[b[s.offset+(n-1)], mask];
RETURN[Inline.BITXOR[v, n*17B] MOD CTreeHVSize]
END;
EnterOneModule: PROC [module: MTIndex] RETURNS [stop: BOOLEAN] =
BEGIN OPEN mRec: bcdBases.mtb[module];
m, c: CTreeIndex;
config: CTIndex = mRec.config; -- config containing module
m ← InsertModuleNode[module];
IF config = CTNull THEN
BEGIN -- might be processing compiler-generated Bcd: record tree root
IF configTreeRoot = NullCTreeIndex THEN
{configTreeRoot ← m; rootPointsToModule ← TRUE};
RETURN[FALSE];
END;
c ← InsertConfigNode[config];
ctreeb[m].father ← c;
ctreeb[m].brother ← ctreeb[c].firstSon; ctreeb[c].firstSon ← m;
RETURN[FALSE];
END;
EnterOneConfig: PROC [config: CTIndex] RETURNS [stop: BOOLEAN] =
BEGIN OPEN cRec: bcdBases.ctb[config];
c, e: CTreeIndex;
encloser: CTIndex = cRec.config; -- configuration enclosing config
c ← InsertConfigNode[config];
IF encloser = CTNull THEN -- we have found the config tree's root
IF configTreeRoot # NullCTreeIndex AND ~rootPointsToModule THEN
CTreeBuildError[]
ELSE {configTreeRoot ← c; rootPointsToModule ← FALSE; RETURN[FALSE]};
e ← InsertConfigNode[encloser];
ctreeb[c].father ← e;
ctreeb[c].brother ← ctreeb[e].firstSon; ctreeb[e].firstSon ← c;
RETURN[FALSE];
END;
InsertModuleNode: PROC [module: MTIndex] RETURNS [newNode: CTreeIndex] =
BEGIN
mProtoName, mInstName: NameRecord;
mProtoHash, mInstHash: CTreeHash;
protoPrev, instPrev: CTreeIndex;
mProtoName ← bcdBases.mtb[module].name;
mProtoHash ← HashForName[mProtoName];
IF bcdBases.mtb[module].namedInstance THEN
BEGIN
mInstName ← NameFromNameTable[Namee[module[module]]];
mInstHash ← HashForName[mInstName];
newNode ← NewInstanceNode[
instanceName: mInstName, prototypeName: mProtoName,
index: BcdTableLoc[module[module]]];
END
ELSE
BEGIN
mInstName ← mProtoName; mInstHash ← mProtoHash;
newNode ← NewPrototypeNode[
prototypeName: mProtoName, index: BcdTableLoc[module[module]]];
END;
-- set newNode's prototypeLink (hash chain), prototypePrev (same id) links
protoPrev ← PrevNodeSameProtoName[mProtoName, protoHashVec[mProtoHash]];
IF protoPrev = NullCTreeIndex THEN -- mProtoName has not been seen before
BEGIN -- add node to (prototype) hash chain for mProtoName
ctreeb[newNode].prototypeLink ← protoHashVec[mProtoHash];
protoHashVec[mProtoHash] ← newNode;
ctreeb[newNode].prototypePrev ← NullCTreeIndex;
END
ELSE -- mProtoName has been seen before; don't put in hash chain,
BEGIN -- just add to "nodes with same prototype id" chain off protoPrev
ctreeb[newNode].anotherNodeWSameProtoName ← TRUE;
ctreeb[protoPrev].anotherNodeWSameProtoName ← TRUE;
ctreeb[newNode].prototypePrev ← ctreeb[protoPrev].prototypePrev;
ctreeb[protoPrev].prototypePrev ← newNode;
ctreeb[newNode].prototypeLink ← NullCTreeIndex;
END;
-- set newNode's instanceLink and instancePrev links
instPrev ← PrevNodeSameInstName[mInstName, instHashVec[mInstHash]];
IF instPrev = NullCTreeIndex THEN -- mInstName has not been seen before
BEGIN -- add node to (instance) hash chain for mInstName
ctreeb[newNode].instanceLink ← instHashVec[mInstHash];
instHashVec[mInstHash] ← newNode;
ctreeb[newNode].instancePrev ← NullCTreeIndex;
END
ELSE -- mInstName has been seen before; don't put in hash chain,
BEGIN -- just add to "nodes with same instance id" chain off instPrev
ctreeb[newNode].instancePrev ← ctreeb[instPrev].instancePrev;
ctreeb[instPrev].instancePrev ← newNode;
ctreeb[newNode].instanceLink ← NullCTreeIndex;
END;
RETURN[newNode];
END;
InsertConfigNode: PROC [config: CTIndex] RETURNS [newNode: CTreeIndex] =
BEGIN
kind: ComponentKind;
cProtoName, cInstName: NameRecord;
cProtoHash, cInstHash: CTreeHash;
protoPrev, instPrev: CTreeIndex;
c: CTreeIndex;
cProtoName ← bcdBases.ctb[config].name;
cProtoHash ← HashForName[cProtoName];
IF bcdBases.ctb[config].namedInstance THEN
BEGIN
kind ← instance;
cInstName ← NameFromNameTable[Namee[config[config]]];
cInstHash ← HashForName[cInstName];
END
ELSE {kind ← prototype; cInstName ← cProtoName; cInstHash ← cProtoHash};
c ← protoHashVec[cInstHash]; -- see if node for config already exists
WHILE c # NullCTreeIndex DO
IF ctreeb[c].prototypeName = cProtoName THEN
WITH ctreeb[c] SELECT FROM
instance =>
IF kind = instance AND instanceName = cInstName THEN RETURN[c];
prototype =>
IF kind = prototype THEN RETURN[c];
ENDCASE;
c ← ctreeb[c].prototypeLink;
ENDLOOP;
newNode ← (IF kind = instance
THEN NewInstanceNode[
instanceName: cInstName, prototypeName: cProtoName,
index: BcdTableLoc[config[config]]]
ELSE NewPrototypeNode[
prototypeName: cProtoName, index: BcdTableLoc[config[config]]]);
-- set newNode's prototypeLink (hash chain), prototypePrev (same id) links
protoPrev ← PrevNodeSameProtoName[cProtoName, protoHashVec[cProtoHash]];
IF protoPrev = NullCTreeIndex THEN -- cProtoName has not been seen before
BEGIN -- add node to (prototype) hash chain for cProtoName
ctreeb[newNode].prototypeLink ← protoHashVec[cProtoHash];
protoHashVec[cProtoHash] ← newNode;
ctreeb[newNode].prototypePrev ← NullCTreeIndex;
END
ELSE -- cProtoName has been seen before; don't put in hash chain,
BEGIN -- just add to "nodes with same prototype id" chain off protoPrev
ctreeb[newNode].anotherNodeWSameProtoName ← TRUE;
ctreeb[protoPrev].anotherNodeWSameProtoName ← TRUE;
ctreeb[newNode].prototypePrev ← ctreeb[protoPrev].prototypePrev;
ctreeb[protoPrev].prototypePrev ← newNode;
ctreeb[newNode].prototypeLink ← NullCTreeIndex;
END;
-- set newNode's instanceLink and instancePrev links
instPrev ← PrevNodeSameInstName[cInstName, instHashVec[cInstHash]];
IF instPrev = NullCTreeIndex THEN -- cInstName has not been seen before
BEGIN -- add node to (instance) hash chain for cInstName
ctreeb[newNode].instanceLink ← instHashVec[cInstHash];
instHashVec[cInstHash] ← newNode;
ctreeb[newNode].instancePrev ← NullCTreeIndex;
END
ELSE -- cInstName has been seen before; don't put in hash chain,
BEGIN -- just add to "nodes with same instance id" chain off instPrev
ctreeb[newNode].instancePrev ← ctreeb[instPrev].instancePrev;
ctreeb[instPrev].instancePrev ← newNode;
ctreeb[newNode].instanceLink ← NullCTreeIndex;
END;
RETURN[newNode];
END;
NewPrototypeNode: PROC [
prototypeName: NameRecord, index: BcdTableLoc]
RETURNS [newNode: CTreeIndex] =
BEGIN
newNode ← table.Words[
PackagerDefs.packctreetype, SIZE[prototype ConfigTreeNode]];
ctreeb[newNode] ← ConfigTreeNode[
father: NullCTreeIndex,
brother: NullCTreeIndex,
firstSon: NullCTreeIndex,
prototypeName: prototypeName,
anotherNodeWSameProtoName: FALSE,
instanceLink: NullCTreeIndex,
prototypeLink: NullCTreeIndex,
instancePrev: NullCTreeIndex,
prototypePrev: NullCTreeIndex,
index: index,
body: prototype[] ];
END;
NewInstanceNode: PROC [
instanceName, prototypeName: NameRecord,
index: BcdTableLoc]
RETURNS [newNode: CTreeIndex] =
BEGIN
newNode ← table.Words[
PackagerDefs.packctreetype, SIZE[instance ConfigTreeNode]];
ctreeb[newNode] ← ConfigTreeNode[
father: NullCTreeIndex,
brother: NullCTreeIndex,
firstSon: NullCTreeIndex,
prototypeName: prototypeName,
anotherNodeWSameProtoName: FALSE,
instanceLink: NullCTreeIndex,
prototypeLink: NullCTreeIndex,
instancePrev: NullCTreeIndex,
prototypePrev: NullCTreeIndex,
index: index,
body: instance[instanceName: instanceName] ];
END;
NameFromNameTable: PROC [namee: BcdDefs.Namee] RETURNS [name: NameRecord] =
BEGIN
nti: NTIndex;
FOR nti ← FIRST[NTIndex], nti + SIZE[NTRecord] UNTIL nti = bcdLimits.nt DO
IF bcdBases.ntb[nti].item = namee THEN RETURN[bcdBases.ntb[nti].name];
ENDLOOP;
CTreeBuildError[];
END;
PrevNodeSameInstName: PROC [
name: NameRecord, chainHead: CTreeIndex] RETURNS [CTreeIndex] =
BEGIN -- locate in hash chain a previous node with given instance name
p: CTreeIndex;
p ← chainHead;
WHILE p # NullCTreeIndex DO
WITH ctreeb[p] SELECT FROM
instance =>
IF instanceName = name THEN RETURN[p];
prototype => -- for a prototype, instance name = prototype name
IF prototypeName = name THEN RETURN[p];
ENDCASE;
p ← ctreeb[p].instanceLink;
ENDLOOP;
RETURN[NullCTreeIndex];
END;
PrevNodeSameProtoName: PROC [
name: NameRecord, chainHead: CTreeIndex] RETURNS [CTreeIndex] =
BEGIN -- locate in hash chain a previous node with given prototype name
p: CTreeIndex;
p ← chainHead;
WHILE p # NullCTreeIndex DO
IF ctreeb[p].prototypeName = name THEN RETURN[p];
p ← ctreeb[p].prototypeLink;
ENDLOOP;
RETURN[NullCTreeIndex];
END;
-- ******* Enumerate module (instances/prototypes) in a configuration *******
DoneEnumerating: SIGNAL = CODE;
EnumerateModulesInConfig: PUBLIC PROC [
kind: ComponentKind,
configTreeNode: CTreeIndex,
userProc: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN]] =
BEGIN
IF kind = instance THEN
EnumerateModuleInstancesInConfig[configTreeNode, userProc]
ELSE
EnumerateModulePrototypesInConfig[configTreeNode, userProc];
END;
EnumerateModuleInstancesInConfig: PROC [
configTreeNode: CTreeIndex,
userProc: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOLEAN]] =
BEGIN
OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
BEGIN OPEN node: ctreeb[cTreeNode];
son: CTreeIndex;
WITH node.index SELECT FROM
module => IF userProc[mti] THEN SIGNAL DoneEnumerating;
ENDCASE;
IF node.firstSon # NullCTreeIndex THEN
FOR son ← node.firstSon, ctreeb[son].brother UNTIL son = NullCTreeIndex DO
OutputConfigSubTree[son];
ENDLOOP;
END;
IF configTreeNode # NullCTreeIndex THEN
OutputConfigSubTree[configTreeNode ! DoneEnumerating => CONTINUE];
END;
EnumerateModulePrototypesInConfig: PROC [
configTreeNode: CTreeIndex,
userProc: PROC [mti: MTIndex] RETURNS [stop: BOOLEAN]] =
BEGIN -- no duplications must appear in the output
OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
BEGIN OPEN node: ctreeb[cTreeNode];
son: CTreeIndex;
WITH node.index SELECT FROM
module =>
BEGIN -- use a representative one
firstProto: CTreeIndex = FirstModulePrototype[cTreeNode];
WITH fp: ctreeb[firstProto].index SELECT FROM
module => ConditionallyOutputModulePrototype[fp.mti, userProc];
ENDCASE;
END;
ENDCASE;
IF node.firstSon # NullCTreeIndex THEN
FOR son ← node.firstSon, ctreeb[son].brother UNTIL son = NullCTreeIndex DO
OutputConfigSubTree[son];
ENDLOOP;
END;
IF configTreeNode # NullCTreeIndex THEN
BEGIN
InitModuleHashVector[];
OutputConfigSubTree[configTreeNode ! DoneEnumerating => CONTINUE];
FreeModuleHashVector[];
END;
END;
FirstModulePrototype: PROC [this: CTreeIndex] RETURNS [first: CTreeIndex] =
BEGIN
first ← this;
DO
this ← ctreeb[first].prototypePrev;
IF this = NullCTreeIndex THEN EXIT;
IF ~AmbiguousPrototypeReference[first, this] THEN first ← this;
ENDLOOP;
END;
ModuleHVSize: CARDINAL = 71;
ModuleHash: TYPE = [0..ModuleHVSize);
-- reduces time needed to discover whether a prototype was previously output
ModuleHashVec: ARRAY ModuleHash OF OutputModuleRec;
OutputModuleRec: TYPE = RECORD [ -- describes modules already output
file: FTIndex,
link: ModulePtr];
ModulePtr: TYPE = LONG POINTER TO OutputModuleRec;
NewOutputModuleRec: PROC [
file: FTIndex, link: ModulePtr] RETURNS [new: ModulePtr] =
BEGIN
new ← PackHeap.GetSpace[SIZE[OutputModuleRec]];
new↑ ← OutputModuleRec[file: file, link: link];
END;
InitModuleHashVector: PROC =
BEGIN
FOR i: ModuleHash IN ModuleHash DO
ModuleHashVec[i] ← OutputModuleRec[file: FTNull, link: NIL];
ENDLOOP;
END;
FreeModuleHashVector: PROC =
BEGIN
i: ModuleHash;
p, first, next: ModulePtr;
FOR i IN ModuleHash DO
first ← ModuleHashVec[i].link;
FOR p ← first, next UNTIL p = NIL DO
next ← p.link; PackHeap.FreeSpace[p];
ENDLOOP;
ModuleHashVec[i] ← OutputModuleRec[file: FTNull, link: NIL];
ENDLOOP;
END;
ConditionallyOutputModulePrototype: PROC [
mti: MTIndex,
userProc: PROC [mti: MTIndex] RETURNS [stop: BOOLEAN]] =
BEGIN -- output only if no prior module with same FTIndex was output
moduleName: NameRecord ← bcdBases.mtb[mti].name;
moduleHash: ModuleHash ← HashForName[moduleName];
moduleFile: FTIndex;
p: ModulePtr;
IF ModuleHashVec[moduleHash].file = FTNull THEN
ModuleHashVec[moduleHash].file ← bcdBases.mtb[mti].file
ELSE -- look for a previously output module with same FTIndex
BEGIN
moduleFile ← bcdBases.mtb[mti].file;
IF ModuleHashVec[moduleHash].file = moduleFile THEN RETURN;
FOR p ← ModuleHashVec[moduleHash].link, p.link UNTIL p = NIL DO
IF p.file = moduleFile THEN RETURN;
ENDLOOP;
ModuleHashVec[moduleHash].link ← NewOutputModuleRec[
moduleFile, ModuleHashVec[moduleHash].link];
END;
IF userProc[mti] THEN SIGNAL DoneEnumerating;
END;
-- ********** Locate a module or configuration instance/prototype **********
FindModuleOrConfig: PUBLIC PROC [
kind: ComponentKind,
ResetIdStream: PROC,
FirstQualId, NextQualId: PROC RETURNS [id: SymTabDefs.HTIndex]]
RETURNS [component: CTreeIndex] = {
component ← (IF kind = instance
THEN FindInstance[ResetIdStream, FirstQualId, NextQualId]
ELSE FindPrototype[ResetIdStream, FirstQualId, NextQualId]);
RETURN[component]};
FindInstance: PROC [
ResetIdStream: PROC,
FirstQualId, NextQualId: PROC RETURNS [id: SymTabDefs.HTIndex]]
RETURNS [component: CTreeIndex] = {
start, t: CTreeIndex;
mainPartOfId, nextId: SymTabDefs.HTIndex;
componentFullyQual, fullyQual, immediateMatch: BOOLEAN;
component ← NullCTreeIndex; componentFullyQual ← FALSE;
ResetIdStream[];
mainPartOfId ← FirstQualId[];
start ← LookupId[mainPartOfId, instance];
WHILE start # NullCTreeIndex DO -- attempt to match qualified id stream beginning at start
BEGIN
fullyQual ← TRUE; -- assume id stream is fully qualified initially
t ← start; -- t runs from start up father links in the config tree
nextId ← NextQualId[];
WHILE nextId # SymTabDefs.HTNull DO -- attempt to match nextId among t's ancestor nodes
immediateMatch ← FALSE;
IF (t ← ctreeb[t].father) # NullCTreeIndex THEN
WITH ctreeb[t] SELECT FROM -- try to match instance name
instance => IF EqualIdAndName[nextId, instanceName] THEN immediateMatch ← TRUE;
prototype => IF EqualIdAndName[nextId, prototypeName] THEN immediateMatch ← TRUE;
ENDCASE;
IF ~immediateMatch THEN {
fullyQual ← FALSE;
UNTIL t = NullCTreeIndex DO
WITH ctreeb[t] SELECT FROM
instance => IF EqualIdAndName[nextId, instanceName] THEN EXIT;
prototype => IF EqualIdAndName[nextId, prototypeName] THEN EXIT;
ENDCASE;
t ← ctreeb[t].father;
REPEAT
FINISHED => GOTO NoMatchFromStart;
ENDLOOP};
nextId ← NextQualId[];
ENDLOOP;
-- a match has been found beginning at start
IF component = NullCTreeIndex THEN {component ← start; componentFullyQual ← fullyQual}
ELSE { -- another match was found; keep the best one
IF fullyQual THEN {
IF componentFullyQual THEN {
Error.AmbiguousComponent[error, instance, component, start];
RETURN[NullCTreeIndex]};
component ← start; componentFullyQual ← TRUE}
ELSE -- if old match was fully qaulified continue to use it, otherwise...
IF ~componentFullyQual THEN {
Error.AmbiguousComponent[error, instance, component, start];
RETURN[NullCTreeIndex]}};
EXITS
NoMatchFromStart => NULL;
END;
start ← ctreeb[start].instancePrev; -- try an alternative starting node
ResetIdStream[];
ENDLOOP;
IF component = NullCTreeIndex THEN Error.UnknownComponent[error, instance, mainPartOfId];
RETURN[component]};
FindPrototype: PROC [
ResetIdStream: PROC,
FirstQualId, NextQualId: PROC RETURNS [id: SymTabDefs.HTIndex]]
RETURNS [component: CTreeIndex] = {
start, t: CTreeIndex;
mainPartOfId, nextId: SymTabDefs.HTIndex;
componentFullyQual, fullyQual, immediateMatch: BOOLEAN;
component ← NullCTreeIndex; componentFullyQual ← FALSE;
ResetIdStream[];
mainPartOfId ← FirstQualId[];
start ← LookupId[mainPartOfId, prototype];
WHILE start # NullCTreeIndex DO -- attempt to match qualified id stream beginning at start
BEGIN
fullyQual ← TRUE; -- assume id stream is fully qualified initially
t ← start; -- t runs from start up father links in the config tree
nextId ← NextQualId[];
WHILE nextId # SymTabDefs.HTNull DO -- attempt to match nextId among t's ancestor nodes
immediateMatch ← FALSE;
IF (t ← ctreeb[t].father) # NullCTreeIndex THEN
IF EqualIdAndName[nextId, ctreeb[t].prototypeName] THEN immediateMatch ← TRUE;
IF ~immediateMatch THEN {
fullyQual ← FALSE;
UNTIL t = NullCTreeIndex DO
IF EqualIdAndName[nextId, ctreeb[t].prototypeName] THEN EXIT;
t ← ctreeb[t].father;
REPEAT
FINISHED => GOTO NoMatchFromStart;
ENDLOOP};
nextId ← NextQualId[];
ENDLOOP;
-- a match has been found beginning at start
IF component = NullCTreeIndex THEN {component ← start; componentFullyQual ← fullyQual}
ELSE { -- another match was found; keep the best one
IF fullyQual THEN {
IF componentFullyQual AND AmbiguousPrototypeReference[component, start] THEN {
Error.AmbiguousComponent[error, prototype, component, start];
RETURN[NullCTreeIndex]};
component ← start; componentFullyQual ← TRUE}
ELSE -- if old match was fully qaulified continue to use it, otherwise...
IF ~componentFullyQual THEN {
IF AmbiguousPrototypeReference[component, start] THEN {
Error.AmbiguousComponent[error, prototype, component, start];
RETURN[NullCTreeIndex]};
component ← start; componentFullyQual ← FALSE}};
EXITS
NoMatchFromStart => NULL;
END;
start ← ctreeb[start].prototypePrev; -- try an alternative starting node
ResetIdStream[];
ENDLOOP;
IF component = NullCTreeIndex THEN Error.UnknownComponent[error, prototype, mainPartOfId];
RETURN[component]};
AmbiguousPrototypeReference: PROC [
comp1, comp2: CTreeIndex] RETURNS [isAmbiguous: BOOLEAN] =
BEGIN
bcdLoc1: SourceBcd.BcdTableLoc = ctreeb[comp1].index;
bcdLoc2: SourceBcd.BcdTableLoc = ctreeb[comp2].index;
file1, file2: BcdDefs.FTIndex;
WITH bcdLoc1 SELECT FROM -- ambiguous if not same FTIndex (name-stamp pair)
config =>
BEGIN
file1 ← bcdBases.ctb[cti].file;
WITH bcdLoc2 SELECT FROM
config => file2 ← bcdBases.ctb[cti].file;
module => RETURN[TRUE]; -- one is module and the other a config
ENDCASE;
IF file1 # file2 THEN RETURN[TRUE];
END;
module =>
BEGIN
file1 ← bcdBases.mtb[mti].file;
WITH bcdLoc2 SELECT FROM
config => RETURN[TRUE]; -- one is module and the other a config
module => file2 ← bcdBases.mtb[mti].file;
ENDCASE;
IF file1 # file2 THEN RETURN[TRUE];
END;
ENDCASE;
RETURN[FALSE];
END;
-- ******** Determine if module prototype/instance is in a config ********
IsModuleInConfig: PUBLIC PROC [
kind: ComponentKind,
mti: BcdDefs.MTIndex,
configTreeNode: CTreeIndex]
RETURNS [reply: BOOLEAN] =
BEGIN
moduleName: NameRecord ← bcdBases.mtb[mti].name;
start, t: CTreeIndex;
start ← LookupName[moduleName, kind];
WHILE start # NullCTreeIndex DO
IF ctreeb[start].index.kind = module THEN
FOR t ← ctreeb[start].father, ctreeb[t].father
UNTIL t = NullCTreeIndex DO
IF t = configTreeNode THEN RETURN[TRUE];
ENDLOOP;
-- any alternative starting nodes?
IF kind = instance THEN start ← ctreeb[start].instancePrev
ELSE start ← ctreeb[start].prototypePrev;
ENDLOOP;
RETURN[FALSE];
END;
-- ******** Find first node with given instance or prototype id ********
LookupId: PUBLIC PROC [
id: SymTabDefs.HTIndex, kind: ComponentKind]
RETURNS [firstTreeLoc: CTreeIndex] =
BEGIN -- find first node with given instance or prototype id
idSS: SubString ← @idSSDesc;
idSSDesc: SubStringDescriptor;
SymTabOps.SubStringForHash[idSS, id];
RETURN[LookupSS[idSS, kind]];
END;
LookupName: PUBLIC PROC [
name: NameRecord, kind: ComponentKind]
RETURNS [firstTreeLoc: CTreeIndex] =
BEGIN -- find first node with instance/prototype name (NameRecord)
nameSS: SubString ← @nameSSDesc;
nameSSDesc: SubStringDescriptor;
SubStringForName[nameSS, name];
RETURN[LookupSS[nameSS, kind]];
END;
LookupSS: PUBLIC PROC [
idSS: SubString, kind: ComponentKind]
RETURNS [firstTreeLoc: CTreeIndex] =
BEGIN -- find first node with given instance or prototype id substring
idHash: CTreeHash;
treeSS: SubString ← @treeSSDesc;
treeSSDesc: SubStringDescriptor;
p: CTreeIndex;
idHash ← HashValue[idSS];
IF kind = instance THEN
BEGIN -- find first node with given instance id
p ← instHashVec[idHash];
WHILE p # NullCTreeIndex DO
WITH ctreeb[p] SELECT FROM
instance => SubStringForName[treeSS, instanceName];
prototype => SubStringForName[treeSS, prototypeName];
ENDCASE;
IF Strings.EqualSubStrings[idSS, treeSS] THEN RETURN[p];
p ← ctreeb[p].instanceLink;
ENDLOOP
END
ELSE
BEGIN -- find first node with given prototype id
p ← protoHashVec[idHash];
WHILE p # NullCTreeIndex DO
SubStringForName[treeSS, ctreeb[p].prototypeName];
IF Strings.EqualSubStrings[idSS, treeSS] THEN RETURN[p];
p ← ctreeb[p].prototypeLink;
ENDLOOP;
END;
RETURN[NullCTreeIndex];
END;
END.