DIRECTORY
Alloc: TYPE USING [AddNotify, Bounds, DropNotify, Handle, Notifier, Top, Words],
BcdBindDefs: TYPE USING [Relocations, RelocHandle, RelocType],
BcdComData:
TYPE
USING [
currentName, objectStamp, op, outputFti, table, textIndex, typeExported],
BcdControlDefs: TYPE USING [],
BcdDefs:
TYPE
USING [
rftype, BCD, BcdBase, ControlItem, CTIndex, CTNull, CTRecord, cttype, cxtype,
evtype, EXPIndex, EXPNull, EXPRecord, exptype, FPIndex, FPNull, FPRecord, fptype,
FTIndex, FTNull, FTRecord, FTSelf, fttype,
IMPIndex, IMPNull, IMPRecord, imptype, lftype, Link, LinkLocation,
MTIndex, MTNull, MTRecord, mttype, NameRecord, nttype, NullLink,
NullName, SGIndex, SGRecord, sgtype, SpaceID, SPIndex, SPNull, SPRecord,
sptype, sstype, sttype, tftype, treetype, TMIndex, TMRecord, tmtype, TYPIndex,
TYPNull, typtype, VersionID],
BcdErrorDefs:
TYPE
USING [
Error, ErrorFile, ErrorHti, ErrorItem, ErrorModule, ErrorName, ErrorSti,
Error2Files, GetSti],
BcdFileDefs: TYPE USING [CapabilityForFile, UnknownFile],
BcdLiterals: TYPE USING [LoadLiterals, MapLitLinks, MapTypeLinks, UnloadLiterals],
BcdUtilDefs:
TYPE
USING [
BcdBasePtr, BcdBases, BcdLimits, ContextForTree,
CreateInstanceName, EnterConfig, EnterExport, EnterFramePack,
EnterImport, EnterModule, EnterSegment, EnterSpace, EnterType,
EnterTypeMap, FileForVersion, EqVersions, GetDummyGfi, GetGfi,
HtiForName, MergeFile, NameForSti, NewSemanticEntry,
SetFileVersion],
FS: TYPE USING [OpenFile, Error, Read],
OSMiscOps: TYPE USING [MergeStamps, TimeToStamp],
PrincOps: TYPE USING [EPRange, GFTIndex],
PrincOpsUtils: TYPE USING [LongCOPY],
Symbols:
TYPE
USING [
CXIndex, cxNull, HTIndex, htNull, STIndex, STMap, stNull],
Table: TYPE USING [Base, Index],
Tree: TYPE USING [Index, Link, NodeName, Scan, null, nullIndex],
TreeOps: TYPE USING [GetNode, ListLength, ScanList, UpdateList],
VM: TYPE USING [AddressForPageNumber, Allocate, Free, Interval, nullInterval];
BcdLoad:
PROGRAM
IMPORTS
Alloc, BcdErrorDefs, BcdFileDefs, BcdUtilDefs, BcdLiterals,
FS, OSMiscOps, PrincOpsUtils, TreeOps, VM,
data: BcdComData
EXPORTS BcdControlDefs = {
OPEN BcdDefs, Symbols;
Zero:
PROC [p:
LONG
POINTER, l:
CARDINAL] ~
INLINE {
IF l # 0 THEN {p^ ← 0; PrincOpsUtils.LongCOPY[from~p, to~(p+1), nwords~(l-1)]}};
FileMapItem: TYPE ~ RECORD [old, new: FTIndex];
InterfaceOp: TYPE ~ Tree.NodeName [$plus..$then];
ExportAssigner: TYPE ~ PROC;
LoadError: PUBLIC ERROR ~ CODE;
currentCx, loadCx: CXIndex;
loadTree: Tree.Index;
loadExpi: EXPIndex;
packSti: STIndex;
currentOp: InterfaceOp;
table: Alloc.Handle;
tb, stb, cxb: Table.Base;
exportsALL: BOOL;
localBases: BcdUtilDefs.BcdBasePtr ← NEW[BcdUtilDefs.BcdBases];
limits: BcdUtilDefs.BcdLimits;
bcd: BcdUtilDefs.BcdBasePtr;
Notifier: Alloc.Notifier ~ {
tb ← base[treetype]; stb ← base[sttype]; cxb ← base[cxtype];
localBases^ ← [
ssb: LOOPHOLE[base[sstype]],
ctb: base[cttype], mtb: base[mttype],
lfb: base[lftype], rfb: base[rftype], tfb: base[tftype],
etb: base[exptype], evb: base[evtype],
itb: base[imptype],
sgb: base[sgtype], ftb: base[fttype],
tyb: base[typtype], tmb: base[tmtype],
ntb: base[nttype],
spb: base[sptype], fpb: base[fptype]]};
Error: PROC ~ {ERROR LoadError};
LoadRoot:
PUBLIC
PROC [root: Tree.Link]
RETURNS [BcdBindDefs.RelocHandle] ~ {
node: Tree.Index;
table ← data.table; table.AddNotify[Notifier];
bcd ← localBases;
currentOp ← $plus; currentParms ← Tree.null;
processExports ← VerifyExports;
relocationHead ← NIL;
loadExpi ← EXPNull; loadTree ← Tree.nullIndex; loadCx ← cxNull;
exportsALL ← FALSE;
data.typeExported ← FALSE;
node ← TreeOps.GetNode[root];
SELECT tb[node].name
FROM
$source => {
packSti ← FindSti[tb[node].son[2]];
[] ← LoadLocalConfig[TreeOps.GetNode[tb[node].son[3]], $outer, htNull]};
ENDCASE => Error[];
table.DropNotify[Notifier]; table ← NIL;
RETURN [relocationHead]};
FindSti:
PROC [t: Tree.Link]
RETURNS [STIndex] ~ {
RETURN [
IF t = Tree.null
THEN stNull
ELSE
WITH t
SELECT
FROM
symbol => index,
subtree => FindSti[tb[index].son[1]],
ENDCASE => ERROR LoadError]};
currentParms: Tree.Link;
BodyWalk: Tree.Scan ~ {
WITH t
SELECT
FROM
symbol => LoadSti[index, htNull];
subtree => {
node: Tree.Index ~ index;
saveIndex: CARDINAL ~ data.textIndex;
data.textIndex ← tb[node].info;
SELECT tb[node].name
FROM
$list => TreeOps.ScanList[t, BodyWalk];
$item => LoadItem[t];
$config => NULL;
$assign => LoadAssign[t];
$module => {
currentParms ← tb[node].son[2]; LoadItem[tb[node].son[1]]};
ENDCASE => Error[];
data.textIndex ← saveIndex};
ENDCASE => Error[]};
LoadLocalConfig:
PROC [
node: Tree.Index, level: BcdBindDefs.RelocType, name: HTIndex]
RETURNS [Symbols.STMap] ~ {
saveCx: CXIndex ~ currentCx;
saveLhs: Tree.Link ~ lhs;
saveAssigner: ExportAssigner ~ processExports;
saveName: NameRecord ~ data.currentName;
saveIndex: CARDINAL ~ data.textIndex;
currentCti: CTIndex;
firstConfig: CTIndex ~ table.Top[cttype];
firstModule: MTIndex ~ table.Top[mttype];
localRel: BcdBindDefs.RelocHandle;
firstImport: IMPIndex ~ table.Top[imptype];
data.textIndex ← tb[node].info;
lhs ← Tree.null; processExports ← NormalExports;
currentCx ← BcdUtilDefs.ContextForTree[tb[node].son[4]];
AllocateRelocations[level];
localRel ← rel; localRel.parentcx ← saveCx;
BodyWalk[tb[node].son[5]]; -- process body of config
IF data.op = $bind
THEN {
nControls: CARDINAL ← 0;
CountControl:
PROC [item: ControlItem, sti: STIndex] ~ {
nControls ← nControls + 1;
IF item = [module[MTNull]]
AND sti # stNull
THEN
BcdErrorDefs.ErrorHti[$error,
"is not valid as a CONTROL module"L, stb[sti].hti]};
EnumerateControls[tb[node].son[3], CountControl];
currentCti ← table.Words[cttype, CTRecord.
SIZE + nControls*ControlItem.
SIZE];
BEGIN OPEN newConfig: localBases.ctb[currentCti];
i: CARDINAL ← 0;
AssignControl:
PROC [item: ControlItem, sti: STIndex] ~ {
newConfig.controls[i] ← item; i ← i+1};
data.currentName ← newConfig.name ← NameForLink[tb[node].son[4]];
IF name = htNull THEN newConfig.namedInstance ← FALSE
ELSE {
newConfig.namedInstance ← TRUE;
BcdUtilDefs.CreateInstanceName[name, [config[currentCti]]]};
newConfig.file ← FTSelf; newConfig.config ← CTNull;
UpdateConfigParent[currentCti, firstConfig, currentCti];
UpdateModuleParent[currentCti, firstModule, table.Top[mttype]];
newConfig.nControls ← nControls;
EnumerateControls[tb[node].son[3], AssignControl];
END};
lhs ← saveLhs; processExports ← saveAssigner;
loadTree ← node; loadCx ← currentCx; currentCx ← saveCx;
exportsALL ← tb[node].attrs[$exportsALL];
processExports[];
currentCx ← loadCx;
localRel.import ← table.Bounds[imptype].size;
localRel.dummygfi ← BcdUtilDefs.GetDummyGfi[0];
ProcessLocalImports[firstImport];
localRel.importLimit ← table.Top[imptype];
loadTree ← Tree.nullIndex; loadCx ← cxNull;
currentCx ← saveCx;
data.currentName ← saveName;
data.textIndex ← saveIndex;
RETURN [[config[currentCti]]]};
EnumerateControls: PROC [t: Tree.Link, proc: PROC [ControlItem, STIndex]] ~ {
Item: Tree.Scan ~ {
WITH t
SELECT
FROM
symbol => {
sti: STIndex ~ index;
BEGIN
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH m~~s.map
SELECT
FROM
module => proc[[module[m.mti]], sti];
interface =>
IF localBases.etb[m.expi].port = $module
THEN {
gfi: PrincOps.GFTIndex ~ localBases.etb[m.expi].links[0].gfi;
FindModule:
PROC [mti: MTIndex]
RETURNS [stop:
BOOL] ~ {
RETURN [localBases.mtb[mti].gfi = gfi]};
limits.mt ← table.Top[mttype];
proc[[module[EnumerateModules[FindModule]]], sti]}
ELSE GOTO notvalid;
config =>
-- proc[[config[m.cti]], sti];
FOR i:
CARDINAL
IN [0 .. localBases.ctb[m.cti].nControls)
DO
proc[localBases.ctb[m.cti].controls[i], stNull];
ENDLOOP;
ENDCASE => GOTO notvalid;
local =>
WITH m~~s.map
SELECT
FROM
config =>
-- proc[[config[m.cti]], sti];
FOR i:
CARDINAL
IN [0 .. localBases.ctb[m.cti].nControls)
DO
proc[localBases.ctb[m.cti].controls[i], stNull];
ENDLOOP;
ENDCASE => GOTO notvalid;
ENDCASE => GOTO notvalid;
EXITS
notvalid => proc[[module[MTNull]], sti];
END};
ENDCASE => Error[]};
TreeOps.ScanList[t, Item]};
NameForLink:
PROC [t: Tree.Link]
RETURNS [NameRecord] ~ {
RETURN [
WITH t
SELECT
FROM
symbol => BcdUtilDefs.NameForSti[index],
ENDCASE => NullName]};
LoadSti:
PROC [sti: STIndex, name: HTIndex] ~ {
ENABLE BcdErrorDefs.GetSti => {RESUME [sti]};
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH p~~s
SELECT
FROM
file => s.map ← Load[sti, name];
instance => s.map ← Load[p.sti, name];
ENDCASE => Error[];
local => s.map ← LoadLocalConfig[s.info, $inner, name];
ENDCASE => NotLoadable[sti]};
NotLoadable:
PROC [sti: STIndex] ~ {
BcdErrorDefs.ErrorSti[$error, "is not loadable (probably needs ""[]"")"L, sti]};
FileForSti:
PROC [sti: STIndex]
RETURNS [FTIndex] ~ {
RETURN [
IF sti = stNull THEN FTNull
ELSE
WITH s~~stb[sti]
SELECT
FROM
unknown => FTNull,
external =>
WITH p~~s
SELECT
FROM
file => p.fti,
instance => FileForSti[p.sti],
ENDCASE => ERROR LoadError,
ENDCASE => ERROR LoadError]};
FileForPortableItem:
PROC [p: PortableItem]
RETURNS [FTIndex] ~ {
RETURN [
WITH p
SELECT
FROM
interface => MapFile[bcd.etb[expi].file],
module => MapFile[bcd.mtb[mti].file],
ENDCASE => ERROR LoadError]};
DeclarePortableItem:
PROC [sti: STIndex, p: PortableItem] ~ {
WITH p
SELECT
FROM
interface => DeclareInterface[sti, expi, TRUE];
module => DeclareModule[sti, mti, TRUE];
ENDCASE => Error[]};
DeclareInterface:
PROC [sti: STIndex, eti: EXPIndex, setMap:
BOOL] ~ {
fti: FTIndex ~ MapFile[bcd.etb[eti].file];
WITH s~~stb[sti]
SELECT
FROM
external => {
IF setMap THEN s.map ← [interface[EXPNull]];
WITH p~~s
SELECT
FROM
instance =>
IF p.sti = stNull THEN s.pointer ← file[fti]
ELSE DeclareInterface[p.sti, eti, FALSE];
file => p.fti ← fti;
ENDCASE => Error[]};
unknown =>
stb[sti].body ← external[
pointer~file[fti],
map~(IF setMap THEN [interface[EXPNull]] ELSE [unknown[]])];
ENDCASE => Error[]};
DeclareModule:
PROC [sti: STIndex, mti: MTIndex, setMap:
BOOL] ~ {
WITH s~~stb[sti]
SELECT
FROM
external => {
IF setMap THEN s.map ← [module[MTNull]];
WITH p~~s
SELECT
FROM
instance => DeclareModule[p.sti, mti, FALSE];
file => p.fti ← MapFile[bcd.mtb[mti].file];
ENDCASE => Error[]};
unknown => {
fti: FTIndex ~ MapFile[bcd.mtb[mti].file];
stb[sti].body ← external[
pointer~file[fti],
map~(IF setMap THEN [module[MTNull]] ELSE [unknown[]])]};
ENDCASE => Error[]};
currentLinkLoc: LinkLocation ← $frame;
explicitLinkLoc: BOOL ← FALSE;
LoadItem:
PROC [t: Tree.Link] ~ {
node: Tree.Index ~ TreeOps.GetNode[t];
IF tb[node].name # $item THEN Error[];
WITH s1~~tb[node].son[1]
SELECT
FROM
symbol => {
sti: STIndex ~ s1.index;
currentLinkLoc ← IF tb[node].attrs[$codeLinks] THEN $code ELSE $frame;
explicitLinkLoc ← tb[node].attrs[$explicitLinkLoc];
LoadSti[
sti,
(IF tb[node].son[2] = Tree.null THEN htNull ELSE stb[sti].hti)] };
ENDCASE => Error[]};
BcdRelocations: TYPE ~ BcdBindDefs.Relocations;
relocationHead: BcdBindDefs.RelocHandle;
rel: BcdBindDefs.RelocHandle;
FileMap: TYPE ~ RECORD [SEQUENCE length: CARDINAL OF FTIndex];
fileMap: REF FileMap ← NIL;
MapFile:
PROC [fti: FTIndex]
RETURNS [FTIndex] ~ {
SELECT
TRUE
FROM
(bcd = localBases) => RETURN [fti];
(fti = FTSelf) => RETURN [bcdFti];
(fti = FTNull) => RETURN [FTNull];
ENDCASE => {
fileIndex: CARDINAL ~ LOOPHOLE[fti, CARDINAL]/FTRecord.SIZE;
IF fileMap[fileIndex] = FTNull THEN fileMap[fileIndex] ← bcd.MergeFile[fti];
RETURN [fileMap[fileIndex]]}};
AllocateRelocations:
PROC [type: BcdBindDefs.RelocType] ~ {
p: BcdBindDefs.RelocHandle ~ NEW[BcdRelocations];
IF relocationHead = NIL THEN relocationHead ← rel ← p
ELSE {rel.link ← p; rel ← p};
IF (rel.type ← type) = $file
THEN {
rel.firstgfi ← rel.lastgfi ← BcdUtilDefs.GetGfi[0];
rel.dummygfi ← BcdUtilDefs.GetDummyGfi[0];
rel.import ← table.Bounds[imptype].size;
rel.importLimit ← LOOPHOLE[rel.import];
rel.module ← table.Bounds[mttype].size;
rel.config ← table.Bounds[cttype].size;
rel.parentcx ← cxNull}
ELSE rel.originalfirstdummy ← 1;
rel.textIndex ← data.textIndex;
rel.context ← currentCx;
rel.parameters ← currentParms; currentParms ← Tree.null};
processExports: ExportAssigner;
Load:
PROC [sti: STIndex, name: HTIndex]
RETURNS [map: Symbols.STMap] ~ {
fti: FTIndex ~ FileForSti[sti];
nFiles:
CARDINAL;
BEGIN
IF fti = FTNull
THEN {
NotLoadable[SIGNAL BcdErrorDefs.GetSti]; GOTO fail};
IF fti = data.outputFti
THEN
BcdErrorDefs.Error[$error, "Output file referenced as input"L];
LoadBcd[fti
! BcdFileDefs.UnknownFile => {
BcdErrorDefs.ErrorFile[$error, "cannot be opened"L, fti]; GOTO fail};
EmptyBcdFile => {
BcdErrorDefs.ErrorFile[$error, "is empty"L, fti]; GOTO fail};
DefsFile => {
BcdErrorDefs.ErrorFile[$error, "is a definitions file"L, fti]; GOTO fail};
NonDefsFile => {
BcdErrorDefs.ErrorFile[$error, "is not a definitions file"L, fti]; GOTO fail};
IncompatibleVersion => {
BcdErrorDefs.ErrorFile[$error, "has an incompatible version"L, fti]; GOTO fail}];
EXITS fail => RETURN [[unknown[]]];
END;
nFiles ← LOOPHOLE[limits.ft, CARDINAL]/FTRecord.SIZE;
fileMap ← NEW[FileMap[nFiles]];
FOR i: CARDINAL IN [0..fileMap.length) DO fileMap[i] ← FTNull ENDLOOP;
IF bHeader.extended
THEN
BcdLiterals.LoadLiterals[fti, bHeader, MapFile, MapSegment];
IF limits.ct # CTIndex.
FIRST
THEN {
-- configuration
map ← LoadConfigs[name, sti]; [] ← LoadModules[htNull, sti]}
ELSE map ← LoadModules[name, sti];
ProcessTypeMap[];
processExports[];
ProcessImports[];
LoadSpaces[];
LoadFramePacks[];
rel.lastgfi ← BcdUtilDefs.GetGfi[0]-1;
rel.importLimit ← LOOPHOLE[table.Bounds[imptype].size];
IF bHeader.typeExported THEN data.typeExported ← TRUE;
IF bHeader.extended THEN BcdLiterals.UnloadLiterals[];
UnloadBcd[];
fileMap ← NIL};
CheckInternalName:
PROC [name: NameRecord, sti: STIndex] ~ {
IF name # BcdUtilDefs.NameForSti[sti]
THEN
BcdErrorDefs.ErrorSti[$error,
"does not match the module or configuration name in the Bcd"L, sti]};
bcdFile: FS.OpenFile;
bcdInterval: VM.Interval ← VM.nullInterval;
bcdFti: FTIndex;
bHeader: BcdDefs.BcdBase;
EmptyBcdFile: ERROR ~ CODE;
DefsFile: ERROR ~ CODE;
NonDefsFile: ERROR ~ CODE;
IncompatibleVersion: ERROR ~ CODE;
LoadBcd:
PROC [fti: FTIndex] ~ {
bcdPages: CARDINAL ← 1;
DeleteHeader:
PROC ~ {
IF bcdInterval #
VM.nullInterval
THEN {
VM.Free[bcdInterval]; bcdInterval ← VM.nullInterval}};
bcdInterval ← VM.nullInterval;
bcdFile ← BcdFileDefs.CapabilityForFile[fti];
DO
bcdInterval ← VM.Allocate[bcdPages];
bHeader ← VM.AddressForPageNumber[bcdInterval.page];
FS.Read[file~bcdFile, from~0, nPages~bcdPages, to~bHeader
! FS.Error => {GO TO fail}];
IF bHeader.versionIdent # BcdDefs.VersionID
THEN {
DeleteHeader[]; ERROR IncompatibleVersion};
SELECT data.op
FROM
$bind => IF bHeader.definitions THEN {DeleteHeader[]; ERROR DefsFile};
$conc => IF ~bHeader.definitions THEN {DeleteHeader[]; ERROR NonDefsFile};
ENDCASE;
IF bcdPages >= bHeader.nPages THEN EXIT;
bcdPages ← bHeader.nPages;
VM.Free[bcdInterval]; bcdInterval ← VM.nullInterval;
REPEAT
fail => {DeleteHeader[]; ERROR BcdFileDefs.UnknownFile[fti]};
ENDLOOP;
bcdFti ← fti;
BcdUtilDefs.SetFileVersion[fti, bHeader.version];
data.objectStamp ← OSMiscOps.MergeStamps[
data.objectStamp, OSMiscOps.TimeToStamp[bHeader.version]];
bcd ←
NEW[BcdUtilDefs.BcdBases ← [
ctb~LOOPHOLE[bHeader + bHeader.ctOffset],
mtb~LOOPHOLE[bHeader + bHeader.mtOffset],
lfb~LOOPHOLE[bHeader + bHeader.lfOffset],
rfb~LOOPHOLE[bHeader + bHeader.rfOffset],
tfb~LOOPHOLE[bHeader + bHeader.tfOffset],
etb~LOOPHOLE[bHeader + bHeader.expOffset],
itb~LOOPHOLE[bHeader + bHeader.impOffset],
sgb~LOOPHOLE[bHeader + bHeader.sgOffset],
ftb~LOOPHOLE[bHeader + bHeader.ftOffset],
ssb~LOOPHOLE[bHeader + bHeader.ssOffset],
evb~LOOPHOLE[bHeader + bHeader.evOffset],
tyb~LOOPHOLE[bHeader + bHeader.typOffset],
tmb~LOOPHOLE[bHeader + bHeader.tmOffset],
ntb~LOOPHOLE[bHeader + bHeader.ntOffset],
spb~LOOPHOLE[bHeader + bHeader.spOffset],
fpb~LOOPHOLE[bHeader + bHeader.fpOffset] ]];
limits ← [
ct~bHeader.ctLimit, mt~bHeader.mtLimit,
et~bHeader.expLimit,
it~bHeader.impLimit,
sg~bHeader.sgLimit, ft~bHeader.ftLimit,
tm~bHeader.tmLimit,
nt~bHeader.ntLimit,
sp~bHeader.spLimit, fp~bHeader.fpLimit];
AllocateRelocations[$file];
rel.originalfirstdummy ← bHeader.firstdummy};
UnloadBcd:
PROC ~ {
VM.Free[bcdInterval]; bcdInterval ← VM.nullInterval;
bcd ← localBases};
CTRecordSize:
PROC [bcd: BcdUtilDefs.BcdBasePtr, cti: CTIndex]
RETURNS [
NAT] ~
INLINE {
RETURN [CTRecord.SIZE + bcd.ctb[cti].nControls*ControlItem.SIZE]};
EnumerateConfigurations:
PROC [proc:
PROC [CTIndex]] ~ {
cti: CTIndex ← CTIndex.FIRST;
UNTIL cti = limits.ct
DO
proc[cti];
cti ← cti + CTRecordSize[bcd, cti];
ENDLOOP};
LoadConfigs:
PROC [name: HTIndex, sti: STIndex]
RETURNS [Symbols.STMap] ~ {
rootCti: CTIndex ← CTNull;
LoadConfig:
PROC [cti: CTIndex] ~ {
root: BOOL ~ bcd.ctb[cti].config = CTNull;
newCti: CTIndex ~ bcd.EnterConfig[cti,
IF root
THEN name
ELSE htNull];
BEGIN OPEN new~~localBases.ctb[newCti];
IF ~root THEN new.config ← new.config + rel.config
ELSE {
CheckInternalName[new.name, sti];
IF rootCti # CTNull
THEN
BcdErrorDefs.ErrorSti[$warning, "contains multiple root configs"L, sti];
rootCti ← newCti; new.config ← CTNull};
new.file ← MapFile[new.file];
FOR i:
CARDINAL
IN [0 .. new.nControls)
DO
WITH c~~new.controls[i]
SELECT
FROM
module => c.mti ← c.mti + rel.module;
config => c.cti ← c.cti + rel.config;
ENDCASE => ERROR;
ENDLOOP;
END};
EnumerateConfigurations[LoadConfig];
RETURN [[config[rootCti]]]};
UpdateConfigParent:
PROC [parent: CTIndex, first, limit: CTIndex] ~ {
FOR cti: CTIndex ← first, cti + CTRecordSize[localBases, cti]
UNTIL cti = limit
DO
OPEN new~~localBases.ctb[cti];
IF new.config = CTNull THEN new.config ← parent;
ENDLOOP};
MTRecordSize:
PROC [bcd: BcdUtilDefs.BcdBasePtr, mti: MTIndex]
RETURNS [
NAT] ~
INLINE {
RETURN [
WITH m~~bcd.mtb[mti]
SELECT
FROM
direct => MTRecord.direct.SIZE + m.length*Link.SIZE,
indirect => MTRecord.indirect.SIZE,
multiple => MTRecord.multiple.SIZE,
ENDCASE => ERROR]};
EnumerateModules:
PROC [
proc: PROC [MTIndex] RETURNS [BOOL]] RETURNS [mti: MTIndex] ~ {
mti ← MTIndex.FIRST;
UNTIL mti = limits.mt
DO
IF proc[mti] THEN RETURN;
mti ← mti + MTRecordSize[bcd, mti];
ENDLOOP;
RETURN [MTNull]};
CheckPacking:
PROC [mti: MTIndex] ~ {
name: NameRecord ~ localBases.mtb[mti].name;
FOR sti: STIndex ← packSti, stb[sti].link
UNTIL sti = stNull
DO
IF BcdUtilDefs.NameForSti[sti] = name
THEN {
stb[sti].body ← external[
map~[module[mti]], pointer~file[localBases.mtb[mti].file]];
EXIT};
ENDLOOP};
MapSegment:
PROC [oldSgi: SGIndex]
RETURNS [SGIndex] ~ {
seg: SGRecord ← bcd.sgb[oldSgi];
seg.file ← MapFile[seg.file];
RETURN [BcdUtilDefs.EnterSegment[seg]]};
LoadModules:
PROC [name: HTIndex, sti: STIndex]
RETURNS [Symbols.STMap] ~ {
rootMti: MTIndex ← MTNull;
LoadModule:
PROC [mti: MTIndex]
RETURNS [
BOOL ←
FALSE] ~ {
root: BOOL ~ bcd.mtb[mti].config = CTNull;
newMti: MTIndex = bcd.EnterModule[mti,
IF root
THEN name
ELSE htNull];
BEGIN OPEN new~~localBases.mtb[newMti];
name ← htNull;
IF ~root THEN new.config ← new.config + rel.config
ELSE {
CheckInternalName[new.name, sti];
IF rootMti # MTNull
THEN
BcdErrorDefs.ErrorSti[$warning, "contains multiple modules"L, sti];
rootMti ← newMti; new.config ← CTNull};
new.gfi ← BcdUtilDefs.GetGfi[new.ngfi];
new.file ← MapFile[new.file];
new.code.sgi ← MapSegment[new.code.sgi];
new.sseg ← MapSegment[new.sseg];
CheckPacking[newMti];
IF root THEN new.linkLoc ← currentLinkLoc
ELSE
IF explicitLinkLoc
AND currentLinkLoc # new.linkLoc
THEN
NULL;
newMti];
SELECT
TRUE
FROM
new.altoCode => BcdErrorDefs.ErrorModule[$error, "was compiled for Alto"L, mti];
new.tableCompiled => NULL;
(~bHeader.spare1) => BcdErrorDefs.ErrorModule[$error, " has obsolete format"L, mti];
ENDCASE;
WITH m~~new
SELECT
FROM
multiple => {
BcdLiterals.MapTypeLinks[m.types];
BcdLiterals.MapLitLinks[m.refLiterals]};
ENDCASE;
END;
RETURN};
[] ← EnumerateModules[LoadModule];
RETURN [[module[rootMti]]]};
UpdateModuleParent:
PROC [parent: CTIndex, first, limit: MTIndex] ~ {
FOR mti: MTIndex ← first, mti + MTRecordSize[localBases, mti]
UNTIL mti = limit
DO
OPEN new~~localBases.mtb[mti];
IF new.config = CTNull THEN new.config ← parent;
ENDLOOP};
ProcessTypeMap:
PROC ~ {
FOR tmi: TMIndex ← TMIndex.
FIRST, tmi + TMRecord.
SIZE
UNTIL tmi = limits.tm
DO
newTypi: TYPIndex ~ bcd.EnterType[bcd.tmb[tmi].map];
newTmi: TMIndex ~ bcd.EnterTypeMap[tmi];
BEGIN OPEN new~~localBases.tmb[newTmi];
SELECT new.map
FROM
TYPNull => new.map ← newTypi;
newTypi => NULL;
ENDCASE => {
fti: FTIndex ~ BcdUtilDefs.FileForVersion[new.version];
BcdErrorDefs.ErrorItem[$error,
"is an exported type with clashing definitions"L, [NullName, fti], new.offset]};
END;
ENDLOOP};
EnumerateSpaces:
PROC [proc:
PROC [SPIndex]
RETURNS [
BOOL]]
RETURNS [spi: SPIndex] ~ {
spi ← SPIndex.FIRST;
UNTIL spi = limits.sp
DO
IF proc[spi] THEN RETURN;
spi ← spi + SPRecord.SIZE + bcd.spb[spi].length*SpaceID.SIZE;
ENDLOOP;
RETURN [SPNull]};
LoadSpaces: PROC ~ {
LoadSpace:
PROC [spi: SPIndex]
RETURNS [
BOOL ←
FALSE] ~ {
newSpi: SPIndex ~ bcd.EnterSpace[spi];
localBases.spb[newSpi].seg ← MapSegment[bcd.spb[spi].seg];
RETURN};
[] ← EnumerateSpaces[LoadSpace]};
EnumerateFramePacks:
PROC [proc:
PROC [FPIndex]
RETURNS [
BOOL]]
RETURNS [fpi: FPIndex] ~ {
fpi ← FPIndex.FIRST;
UNTIL fpi = limits.fp
DO
IF proc[fpi] THEN RETURN;
fpi ← fpi + FPRecord.SIZE + bcd.fpb[fpi].length*MTIndex.SIZE;
ENDLOOP;
RETURN [FPNull]};
LoadFramePacks: PROC ~ {
LoadFramePack:
PROC [fpi: FPIndex]
RETURNS [
BOOL ←
FALSE] ~ {
newFpi: FPIndex ~ bcd.EnterFramePack[fpi];
FOR i:
CARDINAL
IN [0 .. localBases.fpb[newFpi].length)
DO
localBases.fpb[newFpi].modules[i] ← localBases.fpb[newFpi].modules[i] + rel.module;
ENDLOOP;
RETURN};
[] ← EnumerateFramePacks[LoadFramePack]};
ProcessImports:
PROC ~ {
FOR impi: IMPIndex ← FirstImport[], NextImport[impi]
UNTIL impi = IMPNull
DO
newImpi: IMPIndex ~ bcd.EnterImport[impi, TRUE];
localBases.itb[newImpi].file ← MapFile[localBases.itb[newImpi].file];
[] ← BcdUtilDefs.GetDummyGfi[localBases.itb[newImpi].ngfi];
ENDLOOP};
FirstImport:
PROC
RETURNS [IMPIndex] ~
INLINE {
OPEN localBases;
RETURN [IF limits.it = IMPIndex.FIRST THEN IMPNull ELSE IMPIndex.FIRST]};
NextImport:
PROC [impi: IMPIndex]
RETURNS [IMPIndex] ~
INLINE {
OPEN localBases;
IF impi = IMPNull THEN RETURN [IMPNull];
impi ← impi + IMPRecord.SIZE;
RETURN [IF impi = limits.it THEN IMPNull ELSE impi]};
nextLocalGfi: CARDINAL;
GetLocalGfi:
PROC [n:
CARDINAL]
RETURNS [gfi: PrincOps.GFTIndex] ~ {
gfi ← nextLocalGfi;
nextLocalGfi ← nextLocalGfi + n; [] ← BcdUtilDefs.GetDummyGfi[n]};
ProcessLocalImports:
PROC [start: IMPIndex] ~ {
nextLocalGfi ← 1;
FOR sti: STIndex ← FirstLocalImport[], NextLocalImport[sti]
UNTIL sti = stNull
DO
WITH s~~stb[sti]
SELECT
FROM
unknown => DeclareImportByName[sti, start];
external =>
WITH m~~s.map
SELECT
FROM
interface => DeclareImport[sti, m.expi];
unknown => DeclareImportByName[sti, start];
config, module => BcdErrorDefs.ErrorSti[$error,
"is both a component and an import of the config"L, sti];
ENDCASE => Error[];
ENDCASE => Error[];
ENDLOOP};
FirstLocalImport:
PROC
RETURNS [STIndex] ~ {
OPEN localBases;
FOR sti: STIndex ← cxb[loadCx].link, stb[sti].link
UNTIL sti = stNull
DO
IF stb[sti].imported THEN RETURN [sti] ENDLOOP;
RETURN [stNull]};
NextLocalImport:
PROC [sti: STIndex]
RETURNS [STIndex] ~ {
OPEN localBases;
IF sti = stNull THEN RETURN [stNull];
UNTIL (sti ← stb[sti].link) = stNull
DO
IF stb[sti].imported THEN RETURN [sti] ENDLOOP;
RETURN [stNull]};
DeclareImportByName:
PROC [sti: STIndex, start: IMPIndex] ~ {
impi: IMPIndex;
maxNgfi: [1..4] ← 1;
firstImpi: IMPIndex ← IMPNull;
impLimit: IMPIndex ~ LOOPHOLE[table.Bounds[imptype].size];
name: NameRecord ~
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH p~~s
SELECT
FROM
file => BcdUtilDefs.NameForSti[sti],
instance => BcdUtilDefs.NameForSti[p.sti],
ENDCASE => ERROR LoadError,
unknown => BcdUtilDefs.NameForSti[sti],
ENDCASE => ERROR LoadError;
FOR impi ← start, impi+IMPRecord.
SIZE
UNTIL impi = impLimit
DO
IF localBases.itb[impi].name = name
THEN {
IF firstImpi = IMPNull THEN firstImpi ← impi;
maxNgfi ← MAX[maxNgfi, localBases.itb[impi].ngfi]};
ENDLOOP;
IF firstImpi = IMPNull
THEN {
BcdErrorDefs.ErrorName[$warning, "is not IMPORTed by any modules"L, name];
stb[sti].imported ← FALSE;
RETURN};
stb[sti].impi ← impi ← localBases.EnterImport[firstImpi, FALSE];
WITH s~~stb[sti]
SELECT
FROM
external =>
IF s.ptype = $instance
THEN {
BcdUtilDefs.CreateInstanceName[s.hti, [import[impi]]];
localBases.itb[impi].namedInstance ← TRUE};
ENDCASE;
localBases.itb[impi].ngfi ← maxNgfi;
localBases.itb[impi].gfi ← GetLocalGfi[maxNgfi];
IF stb[sti].type = $unknown
THEN
stb[sti].body ← external[
map~[unknown[]], pointer~file[localBases.itb[impi].file]]};
DeclareImport:
PROC [sti: STIndex, expi: EXPIndex] ~ {
OPEN localBases, exp~~localBases.etb[expi];
impi: IMPIndex ~ table.Words[imptype, IMPRecord.SIZE];
ngfi: [0..4) ~ (exp.size + (PrincOps.EPRange-1))/PrincOps.EPRange;
itb[impi] ← [
port~$interface, namedInstance~FALSE, file~exp.file, ngfi~ngfi,
name~BcdUtilDefs.NameForSti[sti], gfi~GetLocalGfi[ngfi]];
stb[sti].impi ← impi;
IF stb[sti].type = $unknown
THEN
stb[sti].body ← external[map~[unknown[]], pointer~file[exp.file]]};
Lookup:
PROC [hti: HTIndex]
RETURNS [sti: STIndex] ~ {
last: STIndex;
IF hti = htNull THEN RETURN [stNull];
FOR sti ← cxb[currentCx].link, stb[sti].link
UNTIL sti = stNull
DO
IF stb[sti].hti = hti THEN EXIT;
last ← sti;
REPEAT
FINISHED => {
sti ← BcdUtilDefs.NewSemanticEntry[hti];
stb[sti].hti ← hti; stb[last].link ← sti};
ENDLOOP;
RETURN};
PortableItem:
TYPE ~
RECORD [
SELECT type: *
FROM
interface => [expi: EXPIndex],
module => [mti: MTIndex],
unknown => [name: HTIndex],
null => NULL,
ENDCASE];
PortNull: PortableItem ~ [null[]];
HtiForPortable:
PROC [p: PortableItem]
RETURNS [HTIndex] ~ {
RETURN [
WITH p
SELECT
FROM
interface => bcd.HtiForName[bcd.etb[expi].name],
module => bcd.HtiForName[bcd.mtb[mti].name],
ENDCASE => htNull]};
EnumerateExports:
PROC [proc:
PROC [PortableItem]]
RETURNS [PortableItem] ~ {
OPEN localBases;
FindItem: Tree.Scan ~ {
sti: STIndex ~ FindSti[t];
IF stb[sti].exported
THEN
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH m~~s.map
SELECT
FROM
interface => proc[[interface[m.expi]]];
module => proc[[module[m.mti]]];
ENDCASE => proc[[unknown[s.hti]]];
ENDCASE => proc[[unknown[s.hti]]]};
SELECT
TRUE
FROM
(loadExpi # EXPNull) => proc[[interface[loadExpi]]];
(loadTree = Tree.nullIndex) =>
FOR eti: EXPIndex ← EXPIndex.
FIRST, eti+EXPRecord.
SIZE+bcd.etb[eti].size
UNTIL eti = limits.et
DO
proc[[interface[eti]]] ENDLOOP;
ENDCASE => {
IF exportsALL
THEN {
FOR sti: STIndex ← cxb[loadCx].link, stb[sti].link
UNTIL sti = stNull
DO
IF ~stb[sti].filename
THEN
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH m~~s.map
SELECT
FROM
interface => {s.exported ← TRUE; proc[[interface[m.expi]]]};
ENDCASE;
ENDCASE
ENDLOOP};
TreeOps.ScanList[tb[loadTree].son[2], FindItem]};
RETURN [PortNull]};
VerifyExports: ExportAssigner ~ {
VerifyExport:
PROC [p: PortableItem] ~ {
WITH p
SELECT
FROM
unknown => BcdErrorDefs.ErrorHti[$warning, "is not EXPORTed by any modules"L, name];
ENDCASE};
[] ← EnumerateExports[VerifyExport]};
NormalExports: ExportAssigner ~ {
NormalExport:
PROC [p: PortableItem] ~ {
CombineExport[Lookup[HtiForPortable[p]], p, currentOp]};
[] ← EnumerateExports[NormalExport]};
lhs: Tree.Link;
AssignedExports: ExportAssigner ~ {
port: TYPE ~ MACHINE DEPENDENT RECORD[in, out: UNSPECIFIED];
left: PORT [Tree.Link] RETURNS [Tree.Link];
right: PORT RETURNS [PortableItem];
t: Tree.Link;
p: PortableItem;
nExports: CARDINAL ← 0;
LOOPHOLE[left,port].out ← TreeOps.UpdateList;
LOOPHOLE[right,port].out ← EnumerateExports;
t ← LOOPHOLE[left,PORT[Tree.Link,POINTER] RETURNS [Tree.Link]][lhs, @left];
p ← LOOPHOLE[right,PORT[POINTER] RETURNS [PortableItem]][@right];
UNTIL p = PortNull
DO
nExports ← nExports+1;
WITH t
SELECT
FROM
symbol => CombineExport[index, p, currentOp];
subtree => {
OPEN tb[index];
IF name # $item THEN Error[];
WITH son[1]
SELECT
FROM
symbol => CombineExport[index, p, currentOp];
ENDCASE => Error[]};
ENDCASE => Error[];
t ← left[t]; p ← right[];
IF t = lhs THEN EXIT;
ENDLOOP;
UNTIL p = PortNull DO nExports ← nExports+1; p ← right[] ENDLOOP;
UNTIL t = lhs DO t ← left[t] ENDLOOP;
SELECT TreeOps.ListLength[lhs]
FROM
< nExports =>
BcdErrorDefs.Error[$error, "The right hand side exports more interfaces than required by the left hand side"L];
> nExports =>
BcdErrorDefs.Error[$error, "The left hand side requires more interfaces than exported by the right hand side"L];
ENDCASE};
LoadAssign:
PROC [t: Tree.Link] ~ {
node: Tree.Index ~ TreeOps.GetNode[t];
saveAssigner: ExportAssigner ~ processExports;
processExports ← AssignedExports;
lhs ← tb[node].son[1]; LoadRhs[tb[node].son[2]];
processExports ← saveAssigner};
NewExport:
PROC [expi: EXPIndex]
RETURNS [newExpi: EXPIndex] ~ {
newExpi ← bcd.EnterExport[expi, TRUE];
localBases.etb[newExpi].file ← MapFile[localBases.etb[newExpi].file]};
CombineExport:
PROC [sti: STIndex, p: PortableItem, op: InterfaceOp] ~ {
target: FTIndex ~ FileForSti[sti];
WITH p
SELECT
FROM
unknown => {
BcdErrorDefs.ErrorHti[$warning, "is not EXPORTed by any modules"L, name];
RETURN};
ENDCASE;
IF target = FTNull THEN DeclarePortableItem[sti, p]
ELSE {
source: FTIndex ~ FileForPortableItem[p];
IF ~BcdUtilDefs.EqVersions[source, target]
THEN
BcdErrorDefs.Error2Files[
class~$error,
s~"is being exported, but required version is"L,
ft1~source, ft2~target]};
WITH p
SELECT
FROM
interface => CombineInterface[sti, expi, op];
module => CombineModule[sti, mti, op];
ENDCASE};
CombineModule:
PROC [sti: STIndex, mti: MTIndex, op: InterfaceOp] ~ {
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH m~~s.map
SELECT
FROM
module =>
IF m.mti = MTNull THEN m.mti ← mti
ELSE
IF op = $plus
THEN
BcdErrorDefs.ErrorModule[$warning, "is a duplicate export"L, m.mti];
unknown => s.map ← [module[bcd.EnterModule[mti, htNull]]];
ENDCASE => Error[];
ENDCASE => Error[]};
CombineInterface:
PROC [sti: STIndex, eti: EXPIndex, op: InterfaceOp] ~ {
newEti: EXPIndex;
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH m~~s.map
SELECT
FROM
interface => {
IF m.expi = EXPNull THEN m.expi ← NewExport[eti];
newEti ← m.expi};
unknown => {
newEti ← NewExport[eti]; s.map ← [interface[newEti]]};
ENDCASE => NotOperand[sti];
ENDCASE => Error[];
BEGIN OPEN old~~bcd.etb[eti], new~~localBases.etb[newEti];
FOR i:
CARDINAL
IN [0..old.size)
DO
IF old.links[i] # NullLink
THEN
SELECT
TRUE
FROM
(old.links[i].vtag = $type) => {
cl: BcdDefs.Link ~ [type[
typeID~bcd.EnterType[old.links[i].typeID],
type~TRUE, proc~FALSE]];
IF new.links[i] # NullLink
AND new.links[i] # cl
THEN
BcdErrorDefs.ErrorItem[$error,
"is an incompatible type definition"L,
[name~localBases.etb[newEti].name, fti~localBases.etb[newEti].file], i];
new.links[i] ← cl};
(new.links[i] = NullLink) =>
new.links[i] ← RelocateExportLink[old.links[i]];
(op = $plus) =>
BcdErrorDefs.ErrorItem[$warning, "is a duplicate export"L,
[name~localBases.etb[newEti].name, fti~localBases.etb[newEti].file], i];
ENDCASE;
ENDLOOP;
END};
RelocateExportLink:
PROC [cl: BcdDefs.Link]
RETURNS [BcdDefs.Link] ~ {
IF loadExpi = EXPNull
AND loadCx = cxNull
THEN
SELECT cl.vtag
FROM
$var => cl.vgfi ← cl.vgfi + rel.firstgfi-1;
$proc0, $proc1 => cl.gfi ← cl.gfi + rel.firstgfi-1;
$type => ERROR;
ENDCASE;
RETURN [cl]};
LoadRhs:
PROC [exp: Tree.Link] ~ {
WITH exp
SELECT
FROM
subtree =>
SELECT tb[index].name
FROM
$module => {currentParms ← tb[index].son[2]; LoadItem[tb[index].son[1]]};
ENDCASE => LoadOperand[exp];
ENDCASE => LoadOperand[exp]};
LoadOperand:
PROC [exp: Tree.Link] ~ {
WITH exp
SELECT
FROM
symbol => LoadOperandSti[index];
subtree =>
SELECT tb[index].name
FROM
$item =>
WITH s1~~tb[index].son[1]
SELECT
FROM
symbol => LoadOperandSti[s1.index];
ENDCASE => Error[];
$module => {
BcdErrorDefs.ErrorSti[$error,
"must name an interface (no ""[]"")"L,
FindSti[tb[index].son[1]]];
currentParms ← tb[index].son[2]; LoadItem[tb[index].son[1]]};
$plus, $then => {
LoadOperand[tb[index].son[1]];
currentOp ← tb[index].name;
LoadOperand[tb[index].son[2]];
currentOp ← $plus};
ENDCASE => Error[];
ENDCASE => Error[]};
NotOperand:
PROC [sti: STIndex] ~ {
BcdErrorDefs.ErrorSti[$error, "must name an interface"L, sti];
LoadSti[sti, htNull]};
LoadOperandSti:
PROC [sti: STIndex] ~ {
WITH s~~stb[sti]
SELECT
FROM
external =>
WITH m~~s.map
SELECT
FROM
interface => {
IF m.expi = EXPNull THEN Error[];
loadExpi ← m.expi; processExports[]; loadExpi ← EXPNull};
unknown => BcdErrorDefs.ErrorSti[$error, "cannot be an operand"L, sti];
ENDCASE => NotOperand[sti];
unknown =>
IF s.imported
THEN
BcdErrorDefs.ErrorSti[$error, "is imported and cannot be an operand"L, sti]
ELSE NotOperand[sti];
ENDCASE => NotOperand[sti]};
}.