-- SourceBcdImpl.mesa
-- Last edited by Lewis on 4-Jan-82 14:16:52
-- Last edited by Satterthwaite, December 30, 1982 10:38 am
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],
BcdOps USING [BcdBase],
BcdUtilDefs USING [BcdBasePtr, BcdBases, BcdLimitPtr, BcdLimits],
CIFS: TYPE USING [GetFC],
Error USING [Error, AmbiguousComponent, UnknownComponent],
HashOps USING [HTIndex, htNull, SubStringForHash],
Inline USING [BITAND, BITXOR],
PackagerDefs USING [globalData, GlobalData, packctreetype],
Space: TYPE USING [
Handle, nullHandle, virtualMemory, Create, Delete, LongPointer, Map],
String USING [EqualSubStrings, SubString, SubStringDescriptor],
SourceBcd,
Table: TYPE USING [Base, Limit];
SourceBcdImpl: PROGRAM
IMPORTS
Alloc, CIFS, Error, Inline, HashOps, PackagerDefs, Space, String
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 = String.SubStringDescriptor;
SubString: TYPE = String.SubString;
gd: PackagerDefs.GlobalData ← NIL; -- initialized by Load
table: Alloc.Handle ← NIL;
-- ****************** Source BCD Loading and Unloading ******************
bcdHeader: PUBLIC BcdOps.BcdBase ← NIL;
bcdBases: PUBLIC BcdUtilDefs.BcdBasePtr ← NIL;
bcdLimits: PUBLIC BcdUtilDefs.BcdLimitPtr ← NIL;
moduleCount: PUBLIC CARDINAL ← 0;
bcdSegment: Space.Handle ← Space.nullHandle;
Load: PUBLIC PROC = {
ENABLE UNWIND => Unload[];
pages: CARDINAL;
gd ← PackagerDefs.globalData;
table ← gd.ownTable;
bcdSegment ← Space.nullHandle; bcdHeader ← NIL;
bcdBases ← NIL; bcdLimits ← NIL;
bcdSegment ← Space.Create[size: 10, parent: Space.virtualMemory];
bcdSegment.Map[window: [file: gd.sourceBcdFile.GetFC, base: 1]];
bcdHeader ← bcdSegment.LongPointer;
IF bcdHeader.versionIdent # BcdDefs.VersionID OR bcdHeader.definitions THEN {
Unload[];
Error.Error[
error, "Invalid input BCD file: obsolete version or definitions BCD"L];
ERROR BadSourceBcd};
IF bcdHeader.repackaged THEN {
Unload[];
Error.Error[error, "Already packaged BCDs cannot be repackaged"L];
ERROR BadSourceBcd};
IF (pages ← bcdHeader.nPages) > 10 THEN { -- load entire bcd
Space.Delete[bcdSegment];
bcdSegment ← Space.Create[size: pages, parent: Space.virtualMemory];
bcdSegment.Map[window: [file: gd.sourceBcdFile.GetFC, base: 1]];
bcdHeader ← bcdSegment.LongPointer};
gd.sourceBcdVersion ← bcdHeader.version;
bcdBases ← gd.zone.NEW[BcdUtilDefs.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] ]];
bcdLimits ← gd.zone.NEW[BcdUtilDefs.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[]};
Unload: PUBLIC PROC = {
IF bcdSegment # Space.nullHandle THEN {
Space.Delete[bcdSegment];
bcdSegment ← Space.nullHandle; bcdHeader ← NIL};
IF bcdBases # NIL THEN gd.zone.FREE[@bcdBases];
IF bcdLimits # NIL THEN gd.zone.FREE[@bcdLimits];
ReleaseMtiArray[];
moduleCount ← 0;
table ← NIL; gd ← NIL};
EnumerateConfigs: PUBLIC PROC [
userProc: PROC [CTIndex] RETURNS [stop: BOOL]] =
BEGIN
cti: CTIndex ← CTIndex.FIRST;
UNTIL cti = bcdLimits.ct DO
IF userProc[cti] THEN RETURN;
cti ← cti + CTRecord.SIZE + bcdBases.ctb[cti].nControls;
ENDLOOP;
END;
EnumerateModules: PUBLIC PROC [
userProc: PROC [MTIndex] RETURNS [stop: BOOL]] = {
FOR mti: MTIndex ← MTIndex.FIRST, mti + MTRecord.SIZE
UNTIL mti = bcdLimits.mt DO
IF userProc[mti] THEN RETURN;
ENDLOOP};
IsTableCompiled: PUBLIC PROC [mti: BcdDefs.MTIndex] RETURNS [BOOL] = {
RETURN[bcdBases.mtb[mti].tableCompiled]};
SubStringForName: PUBLIC PROC [ss: String.SubString, name: NameRecord] = {
ss.base ← @bcdBases.ssb.string;
ss.offset ← name; ss.length ← bcdBases.ssb.size[name]};
EqualIdAndName: PUBLIC PROC [
id: HashOps.HTIndex, name: NameRecord] RETURNS [yes: BOOL] = {
idSS: SubString ← @idSSDesc;
idSSDesc: SubStringDescriptor;
nameSS: SubString ← @nameSSDesc;
nameSSDesc: SubStringDescriptor;
HashOps.SubStringForHash[idSS, id];
SubStringForName[nameSS, name];
RETURN[String.EqualSubStrings[idSS, nameSS]]};
CountModules: PROC = {
CountOneModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL←FALSE] = {
moduleCount ← moduleCount+1};
moduleCount ← 0;
EnumerateModules[CountOneModule]};
-- BcdDefs.MTIndex -> ModuleNum mapping related declarations
mtiArray: LONG POINTER TO ModuleMap; -- ModuleNum -> MTIndex
ModuleMap: TYPE = RECORD [SEQUENCE length: CARDINAL OF MTIndex];
InitializeMtiArray: PROC = {
i: ModuleNum ← 0;
EnterOneModule: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL←FALSE] = {
mtiArray[i] ← mti; i ← i+1};
mtiArray ← gd.zone.NEW[ModuleMap[moduleCount]];
EnumerateModules[EnterOneModule]};
ReleaseMtiArray: PROC = {
IF mtiArray # NIL THEN gd.zone.FREE[@mtiArray]};
ModuleNumForMti: PUBLIC PROC [mti: BcdDefs.MTIndex] RETURNS [ModuleNum] =
BEGIN -- map i-th module index to i
Ord: PROC [mti: BcdDefs.MTIndex] RETURNS [CARDINAL] = INLINE {
RETURN [mti-BcdDefs.MTIndex.FIRST]};
orderedMti: CARDINAL = Ord[mti];
l, m, u: ModuleNum;
l ← 0; u ← moduleCount;
UNTIL l > u DO
m ← (l+u)/2;
SELECT Ord[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 node attributes *****************
ConfigTreeNode: PUBLIC TYPE = RECORD [
father: CTreeIndex, -- containing config
brother: CTreeIndex, -- next config/module in containing config
firstSon: CTreeIndex, -- first contained config/module
prototypeName: BcdDefs.NameRecord,
anotherNodeWSameProtoName: BOOL,
instanceLink, prototypeLink: CTreeIndex, -- links nodes w = hash values
instancePrev, prototypePrev: CTreeIndex, -- links nodes w = ids
index: BcdTableLoc, -- module or config table index
body: SELECT kind: ComponentKind FROM
instance => [instanceName: BcdDefs.NameRecord],
prototype => [] -- for prototypes, instanceName = prototypeName
ENDCASE];
CTreeIndex: TYPE = Table.Base RELATIVE POINTER[0..Table.Limit) TO ConfigTreeNode;
-- Conceptually, all components (modules and configurations) stored in the
-- Configuration Tree have names of the form [instanceName prototypeName].
-- If the component is a prototype, however, only the prototype name is
-- actually stored; its instance name is the same as the prototype name.
ctreeb: Table.Base;
UpdateBases: Alloc.Notifier = {ctreeb ← base[PackagerDefs.packctreetype]};
Father: PUBLIC PROC [self: CTreeIndex] RETURNS [CTreeIndex] = {
RETURN [ctreeb[self].father]};
EnumerateSons: PUBLIC PROC [
self: CTreeIndex, userProc: PROC [CTreeIndex] RETURNS [stop: BOOL]] = {
IF self # nullCTreeIndex THEN
FOR cti: CTreeIndex ← ctreeb[self].firstSon, ctreeb[cti].brother UNTIL cti=nullCTreeIndex DO
IF userProc[cti] THEN EXIT;
ENDLOOP;
RETURN};
Kind: PUBLIC PROC [self: CTreeIndex] RETURNS [ComponentKind] = {
RETURN [ctreeb[self].kind]};
Name: PUBLIC PROC [
self: CTreeIndex, kind: ComponentKind] RETURNS [BcdDefs.NameRecord] = {
RETURN [SELECT kind FROM
$prototype => ctreeb[self].prototypeName,
$instance => WITH s~~ctreeb[self] SELECT FROM
instance => s.instanceName,
ENDCASE => s.prototypeName,
ENDCASE => ERROR]};
SharedProtoName: PUBLIC PROC [self: CTreeIndex] RETURNS [BOOL] = {
RETURN [ctreeb[self].anotherNodeWSameProtoName]};
Link: PUBLIC PROC [self: CTreeIndex, kind: ComponentKind] RETURNS [CTreeIndex] = {
RETURN [SELECT kind FROM
$prototype => ctreeb[self].prototypeLink,
$instance => ctreeb[self].instanceLink,
ENDCASE => ERROR]};
Prev: PUBLIC PROC [self: CTreeIndex, kind: ComponentKind] RETURNS [CTreeIndex] = {
RETURN [SELECT kind FROM
$prototype => ctreeb[self].prototypePrev,
$instance => ctreeb[self].instancePrev,
ENDCASE => ERROR]};
Index: PUBLIC PROC [self: CTreeIndex] RETURNS [BcdTableLoc] = {
RETURN [ctreeb[self].index]};
-- ******************** Configuration tree creation ********************
BuildConfigTree: PUBLIC PROC RETURNS [root: CTreeIndex ← nullCTreeIndex] =
BEGIN
rootPointsToModule: BOOL ← FALSE;
EnterOneModule: PROC [module: MTIndex] RETURNS [stop: BOOL] =
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 root = nullCTreeIndex THEN {root ← 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: BOOL] =
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 root # nullCTreeIndex AND ~rootPointsToModule THEN
CTreeBuildError[]
ELSE {root ← 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;
table.AddNotify[UpdateBases];
InitializeHashVectors[]; InitializeModuleVector[];
BEGIN
ENABLE UNWIND => DestroyConfigTree[root];
EnumerateModules[EnterOneModule];
EnumerateConfigs[EnterOneConfig];
END;
RETURN
END;
DestroyConfigTree: PUBLIC PROC [root: CTreeIndex] =
BEGIN
ReleaseHashVectors[]; ReleaseModuleVector[];
IF table # NIL THEN table.DropNotify[UpdateBases];
END;
CTreeHVSize: CARDINAL = 71;
CTreeHash: TYPE = [0..CTreeHVSize);
instHashVec: LONG POINTER TO CTreeMap ← NIL; -- CTreeHash -> CTreeIndex
protoHashVec: LONG POINTER TO CTreeMap ← NIL;
CTreeMap: TYPE = ARRAY CTreeHash OF CTreeIndex;
InitializeHashVectors: PROC = {
instHashVec ← gd.zone.NEW[CTreeMap ← ALL[nullCTreeIndex]];
protoHashVec ← gd.zone.NEW[CTreeMap ← ALL[nullCTreeIndex]]};
ReleaseHashVectors: PROC = {
IF instHashVec # NIL THEN gd.zone.FREE[@instHashVec];
IF protoHashVec # NIL THEN gd.zone.FREE[@protoHashVec]};
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: LONG 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;
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, ConfigTreeNode.prototype.SIZE];
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, ConfigTreeNode.instance.SIZE];
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 ← NTIndex.FIRST, nti + NTRecord.SIZE 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 [
configTreeNode: CTreeIndex,
kind: ComponentKind,
userProc: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL]] =
BEGIN
IF kind = instance THEN
EnumerateModuleInstancesInConfig[configTreeNode, userProc]
ELSE
EnumerateModulePrototypesInConfig[configTreeNode, userProc];
END;
EnumerateModuleInstancesInConfig: PROC [
configTreeNode: CTreeIndex,
userProc: PROC [mti: BcdDefs.MTIndex] RETURNS [stop: BOOL]] =
BEGIN
OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
BEGIN OPEN node: ctreeb[cTreeNode];
WITH node.index SELECT FROM
m: BcdTableLoc.module => IF userProc[m.mti] THEN SIGNAL DoneEnumerating;
ENDCASE;
FOR son: CTreeIndex ← 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: BOOL]] =
BEGIN -- no duplications must appear in the output
OutputConfigSubTree: PROC [cTreeNode: CTreeIndex] =
BEGIN OPEN node: ctreeb[cTreeNode];
IF node.index.kind = module THEN
BEGIN -- use a representative one
firstProto: CTreeIndex = FirstModulePrototype[cTreeNode];
WITH ctreeb[firstProto].index SELECT FROM
fp: BcdTableLoc.module => ConditionallyOutputModulePrototype[fp.mti, userProc];
ENDCASE;
END;
FOR son: CTreeIndex ← node.firstSon, ctreeb[son].brother UNTIL son = nullCTreeIndex DO
OutputConfigSubTree[son];
ENDLOOP;
END;
IF configTreeNode # nullCTreeIndex THEN {
OutputConfigSubTree[configTreeNode ! DoneEnumerating => CONTINUE];
ResetModuleVector[]};
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;
-- reduces time needed to discover whether a prototype was previously output
ModuleHVSize: CARDINAL = 71;
ModuleHash: TYPE = [0..ModuleHVSize);
moduleHashVec: LONG POINTER TO OutModuleMap ← NIL;
OutModuleMap: TYPE = ARRAY ModuleHash OF OutputModuleRec;
OutputModuleRec: TYPE = RECORD [ -- describes modules already output
file: FTIndex,
link: ModulePtr];
ModulePtr: TYPE = LONG POINTER TO OutputModuleRec;
InitializeModuleVector: PROC = {
moduleHashVec ← gd.zone.NEW[OutModuleMap ← ALL[[file: FTNull, link: NIL]]]};
ResetModuleVector: PROC = {
p, first, next: ModulePtr;
FOR i: ModuleHash IN ModuleHash DO
first ← moduleHashVec[i].link;
FOR p ← first, next UNTIL p = NIL DO
next ← p.link; gd.zone.FREE[@p];
ENDLOOP;
moduleHashVec[i] ← OutputModuleRec[file: FTNull, link: NIL];
ENDLOOP};
ReleaseModuleVector: PROC = {
IF moduleHashVec # NIL THEN gd.zone.FREE[@moduleHashVec]};
NewOutputModuleRec: PROC [
file: FTIndex, link: ModulePtr] RETURNS [new: ModulePtr] = {
new ← gd.zone.NEW[OutputModuleRec ← [file: file, link: link]]};
ConditionallyOutputModulePrototype: PROC [
mti: MTIndex,
userProc: PROC [mti: MTIndex] RETURNS [stop: BOOL]] = {
-- 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
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]};
IF userProc[mti] THEN SIGNAL DoneEnumerating};
-- ********** Locate a module or configuration instance/prototype **********
FindModuleOrConfig: PUBLIC PROC [
kind: ComponentKind,
ResetIdStream: PROC,
FirstQualId, NextQualId: PROC RETURNS [id: HashOps.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: HashOps.HTIndex]]
RETURNS [component: CTreeIndex] = {
start, t: CTreeIndex;
mainPartOfId, nextId: HashOps.HTIndex;
componentFullyQual, fullyQual, immediateMatch: BOOL;
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 # HashOps.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: HashOps.HTIndex]]
RETURNS [component: CTreeIndex] = {
start, t: CTreeIndex;
mainPartOfId, nextId: HashOps.HTIndex;
componentFullyQual, fullyQual, immediateMatch: BOOL;
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 # HashOps.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 [BOOL] =
BEGIN
-- ambiguous if not same FTIndex (name-stamp pair)
RETURN [WITH ctreeb[comp1].index SELECT FROM
c1: BcdTableLoc.config =>
WITH ctreeb[comp2].index SELECT FROM
c2: BcdTableLoc.config => bcdBases.ctb[c1.cti].file # bcdBases.ctb[c2.cti].file,
ENDCASE => TRUE, -- one is module, the other a config
m1: BcdTableLoc.module =>
WITH ctreeb[comp2].index SELECT FROM
m2: BcdTableLoc.module => bcdBases.mtb[m1.mti].file # bcdBases.mtb[m2.mti].file,
ENDCASE => TRUE, -- one is module and the other a config
ENDCASE => TRUE]
END;
-- ******** Determine if module prototype/instance is in a config ********
IsModuleInConfig: PUBLIC PROC [
kind: ComponentKind,
mti: BcdDefs.MTIndex,
configTreeNode: CTreeIndex]
RETURNS [BOOL] =
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: HashOps.HTIndex, kind: ComponentKind] RETURNS [firstTreeLoc: CTreeIndex] =
BEGIN -- find first node with given instance or prototype id
idSS: SubString ← @idSSDesc;
idSSDesc: SubStringDescriptor;
HashOps.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 String.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 String.EqualSubStrings[idSS, treeSS] THEN RETURN[p];
p ← ctreeb[p].prototypeLink;
ENDLOOP;
END;
RETURN[nullCTreeIndex];
END;
END.