-- BcdLoad.mesa
-- Last edited by Satterthwaite on August 1, 1983 12:08 pm
-- Last edited by Lewis on 27-Mar-81 9:49:56
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, zone],
BcdControlDefs: TYPE USING [],
BcdDefs: TYPE USING [
rftype, BCD, CTIndex, CTNull, CTRecord, cttype, cxtype, EPLimit,
evtype, EXPIndex, EXPNull, EXPRecord, exptype, FPIndex, FPNull, FPRecord, fptype,
FTIndex, FTNull, FTRecord, FTSelf, fttype, GFTIndex,
IMPIndex, IMPNull, IMPRecord, imptype, lftype, Link, LinkLocation,
MTIndex, MTNull, MTRecord, mttype, Namee, 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],
BcdOps: TYPE USING [BcdBase],
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],
File: TYPE USING [Capability, Unknown],
Inline: TYPE USING [LongCOPY],
OSMiscOps: TYPE USING [MergeStamps, TimeToStamp],
Space: TYPE USING [
Handle, nullHandle, virtualMemory, Create, Delete, Error, LongPointer, Map],
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];
BcdLoad: PROGRAM
IMPORTS
Alloc, BcdErrorDefs, BcdFileDefs, BcdUtilDefs, BcdLiterals,
File, Inline, OSMiscOps, Space, TreeOps,
data: BcdComData
EXPORTS BcdControlDefs = {
OPEN BcdDefs, Symbols;
Zero: PROC [p: LONG POINTER, l: CARDINAL] ~ INLINE {
IF l # 0 THEN {p↑ ← 0; Inline.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.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: Namee, 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*Namee.SIZE];
BEGIN OPEN newConfig~~localBases.ctb[currentCti];
i: CARDINAL ← 0;
AssignControl: PROC [item: Namee, 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 [Namee, STIndex]] ~ {
Item: Tree.Scan ~ {
sti: STIndex ~ NARROW[t, Tree.Link.symbol].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: 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];
--+ config =>
--+ 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];
--+ config =>
--+ 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};
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];
sti: STIndex ~ NARROW[tb[node].son[1], Tree.Link.symbol].index;
IF tb[node].name # $item THEN Error[];
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)]};
BcdRelocations: TYPE ~ BcdBindDefs.Relocations;
relocationHead: BcdBindDefs.RelocHandle;
rel: BcdBindDefs.RelocHandle;
FileMap: TYPE ~ RECORD [SEQUENCE length: CARDINAL OF FTIndex];
fileMap: LONG POINTER TO 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 ~ (data.zone).NEW[BcdRelocations];
Zero[p, BcdRelocations.SIZE];
p.link ← NIL;
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 ← (data.zone).NEW[FileMap[nFiles]];
FOR i: CARDINAL IN [0..fileMap.length) DO fileMap[i] ← FTNull ENDLOOP;
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;
BcdLiterals.UnloadLiterals[];
UnloadBcd[];
(data.zone).FREE[@fileMap]};
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: File.Capability;
bcdSpace: Space.Handle ← Space.nullHandle;
bcdFti: FTIndex;
bHeader: BcdOps.BcdBase;
EmptyBcdFile: ERROR ~ CODE;
DefsFile: ERROR ~ CODE;
NonDefsFile: ERROR ~ CODE;
IncompatibleVersion: ERROR ~ CODE;
LoadBcd: PROC [fti: FTIndex] ~ {
bcdPages: CARDINAL ← 8;
DeleteHeader: PROC ~ {
IF bcdSpace # Space.nullHandle THEN {
Space.Delete[bcdSpace]; bcdSpace ← Space.nullHandle}};
bcdSpace ← Space.nullHandle;
bcdFile ← BcdFileDefs.CapabilityForFile[fti];
DO
bcdSpace ← Space.Create[size~bcdPages, parent~Space.virtualMemory];
bcdSpace.Map[window~[file~bcdFile, base~1]
! Space.Error, File.Unknown => {GO TO fail}];
bHeader ← bcdSpace.LongPointer[];
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;
Space.Delete[bcdSpace]; bcdSpace ← Space.nullHandle;
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 ← (data.zone).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 ~ {
Space.Delete[bcdSpace]; bcdSpace ← Space.nullHandle;
(data.zone).FREE[@bcd];
bcd ← @localBases};
CTRecordSize: PROC [base: BcdUtilDefs.BcdBasePtr, cti: CTIndex] RETURNS [NAT] ~ INLINE {
RETURN [CTRecord.SIZE + base.ctb[cti].nControls*Namee.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 [base: BcdUtilDefs.BcdBasePtr, mti: MTIndex] RETURNS [NAT] ~ INLINE {
RETURN [MTRecord.SIZE]};
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;
-- BcdErrorDefs.ErrorModule[
-- warning,
-- "has already been bound with a different link location"L,
-- newMti];
SELECT TRUE FROM
new.tableCompiled => NULL;
(~bHeader.spare1) => BcdErrorDefs.ErrorModule[$error, " has obsolete format"L, mti];
ENDCASE;
BcdLiterals.MapTypeLinks[new.types];
BcdLiterals.MapLitLinks[new.refLiterals];
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: 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 + (EPLimit-1))/EPLimit;
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 =>
LoadOperandSti[NARROW[tb[index].son[1], Tree.Link.symbol].index];
$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]};
}.