
<<SMBDriverImpl.mesa>>
<<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
<<last edit by Satterthwaite, May 26, 1986 1:38:06 pm PDT>>

DIRECTORY
Atom: TYPE USING [GetPName],
BasicTime: TYPE USING [GMT, Now, Period],
BcdDefs: TYPE USING [
Base, BcdBase, EXPHandle, EXPIndex, FTHandle, IMPHandle, IMPIndex, Link,
ModuleIndex, MTHandle, MTIndex, NullLink, NullModule, ProcLimit],
BcdOps: TYPE USING [ProcessExports, ProcessImports, ProcessModules],
FS: TYPE USING [OpenFile, StreamOpen],
IO: TYPE USING [atom, card, Close, PutF, rope, STREAM],
LoaderOps: TYPE USING [IthLink, LinkSegmentLength],
LoaderOpsExtras: TYPE USING [AcquireFileProc],
Rope: TYPE USING [ROPE, Concat],
SMFI: TYPE USING [BcdFileInfo, SrcFileInfo],
SMBind: TYPE USING [
AllocateIR, AllocateVIR, BuildInterface, BuildFramePtrInterface, ImportLink,
ImportMap, ImportMapSeq, IR, IRSeq, IRSeqRecord, RIR, VIR, BindInfo, BindInfoRecord,
RelocateLink],
SMLDriver: TYPE USING [LoadMod, LoadModRecord],
SMModelBcd: TYPE USING [
Bcd, MTHandle,
BuildBcd, CloseLiterals, DeclareControl, DeclareExport, DeclareImport, DeleteBcd,
FillImport, ImportLiterals, OpenLinks, OpenLiterals, ReadLink, RopeFromNS,
WriteBcd, WriteLink],
SMProj: TYPE USING [Available, Fill, Find, Proj, Read],
SMTree: TYPE Tree USING [
ApplOp, BindOp, Handle, Id, Link, Name, NodeName, null, nullName],
SMTreeOps: TYPE TreeOps USING [
GetExt, GetName, GetNode, NSons, NthSon, OpName, PutExt, Scan, ScanSons, TM],
SMVal: TYPE USING [
Binding, BtoD, BtoG, GetExtFromParse, IdName, IdType, OuterBody, PutExtInParse,
ValOf, ValOfNthSon, VisitNodes],
TimeStamp: TYPE USING [Stamp, Null],
VM: TYPE USING [AddressForPageNumber, Interval];

SMBDriverImpl: CEDAR PROGRAM
IMPORTS
Atom, BasicTime, BcdOps, FS, IO, LoaderOps, Rope,
SMBind, SMModelBcd, SMProj, SMTreeOps, SMVal, VM
EXPORTS SMLDriver~{
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;

BS: TYPE~REF BinderState;
BinderState: TYPE~RECORD[    -- state information for the modeller's loader
z: ZONE_,
tm: TreeOps.TM_,
out: IO.STREAM_,
configBcd: SMModelBcd.Bcd_NIL,
configFormals: SMBind.IRSeq_NIL];

Create: PROC[z: ZONE, tm: TreeOps.TM, out: IO.STREAM] RETURNS[BS] ~ {
RETURN[z.NEW[BinderState _ [z~z, tm~tm, out~out]]]};

BindInfo: TYPE~SMBind.BindInfo;
BindInfoRecord: PUBLIC TYPE~SMBind.BindInfoRecord;


<<loading modules>>

Bind: PUBLIC PROC[
name: Rope.ROPE, stamp: BasicTime.GMT, root: Tree.Link,
z: ZONE, tm: TreeOps.TM, out: IO.STREAM, wDir: Rope.ROPE]
RETURNS[errors: BOOL _ FALSE] ~ {
startTime: BasicTime.GMT ~ BasicTime.Now[];
nBcds: NAT _ 0;
formals, body: Tree.Link;
bs: BS _ Create[z, tm, out];
<<read the component bcds and build a composite one to simulate a config>>

LoadBcds: PROC[
root: Tree.Link,
ProcessComponent: PROC[BcdDefs.BcdBase, Rope.ROPE]
RETURNS[BcdDefs.ModuleIndex]
] ~ {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN {
<<this is interesting if either an Apply of a source file whose bcd is valid>>
<<or an fiBcd for a .bcd mentioned directly in the model>>
bcd: SMProj.Proj _ NIL;
WITH SMVal.ValOfNthSon[node, 1] SELECT FROM
subNode: Tree.Handle =>
IF TreeOps.OpName[subNode] IN Tree.ApplOp THEN
bcd _ NARROW[TreeOps.GetExt[subNode]];
fiBcd: SMFI.BcdFileInfo => {    -- temporary (inefficient)
bcd _ SMProj.Find[fiBcd.stamp];
IF ~bcd.Available THEN bcd.Fill[fiBcd.fName, wDir, FALSE]};
ENDCASE;
IF bcd # NIL AND ~bcd.interface THEN {
loadMod: SMLDriver.LoadMod _ NARROW[SMVal.GetExtFromParse[node]];
IF loadMod = NIL THEN loadMod _ (bs.z).NEW[SMLDriver.LoadModRecord _ []];
IF ~bcd.Available THEN
bs.out.PutF["Error - can't bind %g (bcd not available)\n", IO.rope[bcd.localName]]
ELSE IF loadMod.bindInfo = NIL THEN {
bindInfo: SMBind.BindInfo ~ (bs.z).NEW[SMBind.BindInfoRecord _ []];
loadMod.bindInfo _ bindInfo;
<<IF loadMod.loadInfo # NIL THEN {>>
<<bindInfo.bcdSpace _ loadMod.loadInfo.bcdSpace;>>
<<bindInfo.bcd _ loadMod.loadInfo.bcd}>>
<<ELSE [bindInfo.bcdSpace, bindInfo.bcd] _ bcd.Read;>>
[bindInfo.bcdSpace, bindInfo.bcd] _ bcd.Read;
bindInfo.moduleIndex _ ProcessComponent[bindInfo.bcd, bcd.localName];
bindInfo.nModules _ 1;    -- **** a fudge for now
nBcds _ nBcds + 1}
ELSE ERROR;
SMVal.PutExtInParse[node, loadMod]};
};
};

SMVal.VisitNodes[bs.tm, root, ForEachApply]};

[formals, body] _ SMVal.OuterBody[root];
bs.configBcd _ SMModelBcd.BuildBcd[name, stamp, body, LoadBcds, NIL];

TRUSTED {
<<ls.cm _ LoaderOps.AssignControlModules[ls.config];>>
InputActuals[bs, formals];
CollectExports[bs, body];
ProcessPlusAndThen[bs, body];
ResolveImports[bs, body];
ExportToBcd[bs, body];
AssignControls[bs, body];
};    -- end TRUSTED
IF nBcds = 0 THEN bs.out.PutF["Nothing was bound.\n\n"]
ELSE {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN {
<<release binding info and associated structures>>
loadMod: SMLDriver.LoadMod _ NIL;
WITH SMVal.ValOfNthSon[node, 1] SELECT FROM
subNode: Tree.Handle =>
IF TreeOps.OpName[subNode] IN Tree.ApplOp THEN
loadMod  _ NARROW[SMVal.GetExtFromParse[node]];
fiBcd: SMFI.BcdFileInfo =>    loadMod  _ NARROW[SMVal.GetExtFromParse[node]];
ENDCASE;
IF loadMod # NIL THEN {
<<unmap bcd, etc.>>
(bs.z).FREE[@loadMod.bindInfo]};
};
};

SMVal.VisitNodes[bs.tm, body, ForEachApply];
{
outName: Rope.ROPE ~ name.Concat[".bcd"];
output: IO.STREAM _ FS.StreamOpen[
fileName~outName, accessOptions~$create, wDir~wDir];

AcquireFile: LoaderOpsExtras.AcquireFileProc ~ {
bcd: SMProj.Proj ~ SMProj.Find[version];
IF ~bcd.Available THEN bcd.Fill[name, wDir, FALSE];
RETURN[bcd.file]};

bs.configBcd.WriteBcd[output, AcquireFile];
output.Close[];
bs.out.PutF["%d modules bound\n", IO.card[nBcds]];
bs.out.PutF["bcd file written on %g\n", IO.rope[outName]]
}; 
bs.configBcd.DeleteBcd[];
bs.out.PutF[
"Total time to bind: %d seconds.\n\n", IO.card[startTime.Period[BasicTime.Now[]]]]
};
z.FREE[@bs]};


<<internal procedures>>

BaseAddress: PROC[interval: VM.Interval] RETURNS[BcdDefs.BcdBase] ~ TRUSTED {
RETURN[VM.AddressForPageNumber[interval.page]]};


<<fill in exported interface records from the bcd>>

CollectExports: PROC[bs: BS, root: Tree.Link] ~ {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
WITH SMVal.GetExtFromParse[node] SELECT FROM
loadMod: SMLDriver.LoadMod => {
bindInfo: SMBind.BindInfo ~ loadMod.bindInfo;
IF bindInfo.exports = NIL THEN SetUpExports[bs, bindInfo]}
ENDCASE => NULL;
};

SMVal.VisitNodes[bs.tm, root, ForEachApply]};

SetUpExports: PROC[bs: BS, bindInfo: SMBind.BindInfo] ~ TRUSTED {
bcd: BcdDefs.BcdBase ~ bindInfo.bcd;
n: NAT _ 1;

ForEachExport: PROC[eth: BcdDefs.EXPHandle, eti: BcdDefs.EXPIndex]
RETURNS[stop: BOOL_FALSE] ~ CHECKED {
ir: SMBind.IR ~ SMBind.BuildInterface[bindInfo, eth];
bindInfo.exports[n] _ ir;
n _ n+1};

bindInfo.exports _ (bs.z).NEW[SMBind.IRSeqRecord[bcd.nExports+1]];
IF bcd.nModules = 1 THEN
<<build interface record for a compiler produced module>>
bindInfo.exports[0] _ SMBind.BuildFramePtrInterface[bindInfo];
[] _ BcdOps.ProcessExports[bcd, ForEachExport]};


<<merge exported records for import>>

ProcessPlusAndThen: PROC[bs: BS, root: Tree.Link] ~ {

Eval: PROC[t: Tree.Link] RETURNS[SMBind.IR] ~ {
SELECT TreeOps.OpName[t] FROM
IN Tree.ApplOp => {
<<this is a coercion not made explicit by the evaluator; simply use the first export>>
loadMod: SMLDriver.LoadMod ~ NARROW[SMVal.GetExtFromParse[t]];
IF loadMod # NIL THEN {
bindInfo: SMBind.BindInfo ~ loadMod.bindInfo;
RETURN[bindInfo.exports[1]]}    -- check size before allowing coercion?
ELSE RETURN[NIL]};
$subscript, $then, $union =>
WITH TreeOps.GetExt[t] SELECT FROM
ir: SMBind.IR => RETURN[ir];
ENDCASE => {
ApplyOp[TreeOps.GetNode[t]];  RETURN[NARROW[TreeOps.GetExt[t]]]};
$nil => RETURN[NIL];
ENDCASE => RETURN[NIL]        -- ERROR?
};

ApplyOp: PROC[node: Tree.Link] ~ {
SELECT TreeOps.OpName[node] FROM
$union, $then => {
left: SMBind.IR ~ Eval[SMVal.ValOfNthSon[node, 1]];
right: SMBind.IR ~ Eval[SMVal.ValOfNthSon[node, 2]];
TreeOps.PutExt[node, BinaryOp[left, right, TreeOps.OpName[node]]]};    -- ****
$subscript => {
gb: Tree.Link ~ TreeOps.NthSon[node, 1];
selector: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[node, 2]];
left: Tree.Link ~ SMVal.ValOf[gb];
SELECT TreeOps.OpName[left] FROM
IN Tree.ApplOp => {
typeName: Tree.Name ~ IndexToType[gb, selector];
desiredName: Tree.Name ~
(IF typeName # Tree.nullName THEN typeName ELSE selector);
WITH SMVal.GetExtFromParse[left] SELECT FROM
loadMod: SMLDriver.LoadMod => {
exports: SMBind.IRSeq ~ loadMod.bindInfo.exports;
FOR i: NAT IN [0 .. exports.size) DO
IF exports[i] # NIL AND exports[i].name = desiredName THEN
GOTO found;
REPEAT
found => TreeOps.PutExt[node, exports[i]];                -- ****
FINISHED =>
IF typeName # $CONTROL THEN
bs.out.PutF["Error - %g is not exported by %g.\n",
IO.atom[selector], IO.rope[loadMod.proj.localName]];
ENDLOOP;
};
ENDCASE => NULL;
};
ENDCASE => NULL
};
ENDCASE => NULL;
};

BinaryOp: PROC[left, right: SMBind.IR, mode: Tree.NodeName]
  RETURNS[result: SMBind.IR] ~ {
IF left = NIL THEN RETURN[right];
IF right = NIL THEN RETURN[left];
IF left.stamp ~= right.stamp THEN {
<<a TYPE CHECK>>
bs.out.PutF["Interface mismatch between %g and %g.\n",
IO.atom[left.name], IO.atom[right.name]];
RETURN[left]};
WITH left SELECT FROM
rLeft: SMBind.RIR =>
WITH right SELECT FROM
rRight: SMBind.RIR => {
ir: SMBind.RIR ~ SMBind.AllocateIR[rLeft.stamp, rLeft.name, rLeft.size];
FOR i: NAT IN [0 .. rLeft.size) DO
SELECT mode FROM
$then =>
ir[i] _ (IF EmptyLink[rLeft[i].link] THEN rRight[i] ELSE rLeft[i]);
$union => {    -- +
IF ~EmptyLink[rLeft[i].link] AND ~EmptyLink[rRight[i].link] THEN
bs.out.PutF["Multiple exports of item %d in interface %g.\n",
IO.card[i], IO.atom[rLeft.name]];
ir[i] _ (IF EmptyLink[rLeft[i].link] THEN rRight[i] ELSE rLeft[i])};
ENDCASE => ERROR;        -- other operators not yet implemented
ENDLOOP;
result _ ir};
vRight: SMBind.VIR => {
ir: SMBind.RIR ~ SMBind.AllocateIR[rLeft.stamp, rLeft.name, rLeft.size];
FOR i: NAT IN [0 .. rLeft.size) DO
ir[i] _ (IF EmptyLink[rLeft[i].link] THEN
[SMBind.ImportLink[vRight.dummyGfi, i]] ELSE rLeft[i]);
ENDLOOP;
result _ ir};
ENDCASE => result _ left;    -- right = NIL
vLeft: SMBind.VIR =>
WITH right SELECT FROM    -- can't even approximate this well
rRight: SMBind.RIR => {
bs.out.PutF["Warning: commuting local and formal instances of interface %g.\n",
IO.atom[vLeft.name]];
result _ BinaryOp[left~right, right~left, mode~mode]};
vRight: SMBind.VIR => {
bs.out.PutF["Cannot merge multiple formal instances of interface %g.\n",
IO.atom[vLeft.name]];
result _ left};
ENDCASE => result _ left;    -- right = NIL
ENDCASE => result _ right;    -- left = NIL
RETURN};

ForEachNode: PROC[node, parent: Tree.Link] ~ {
SELECT TreeOps.OpName[node] FROM
$union, $then, $subscript =>
WITH TreeOps.GetExt[node] SELECT FROM
ir: SMBind.IR => NULL;
ENDCASE => ApplyOp[node];
ENDCASE => NULL;
};

SMVal.VisitNodes[bs.tm, root, ForEachNode]};

IndexToType: PROC[gb: Tree.Link, index: Tree.Name]
RETURNS[typeName: Tree.Name _ Tree.nullName] ~ {
WITH gb SELECT FROM
id: Tree.Id => {
d: Tree.Link ~ SMVal.IdType[id];

FindIndexType: TreeOps.Scan ~ {
elemName: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[t, 1]];
IF elemName = index THEN {
type: Tree.Link ~ TreeOps.NthSon[t, 2];
WITH type SELECT FROM
typeId: Tree.Id => typeName _ SMVal.IdName[typeId];
ENDCASE =>    -- temporary
IF TreeOps.OpName[type] = $control THEN typeName _ $CONTROL
ELSE NULL;    -- for now
};
};

IF TreeOps.OpName[d] # $decl THEN ERROR;
TreeOps.ScanSons[d, FindIndexType]};
ENDCASE => NULL;    -- for now
};


EmptyLink: PROC[link: BcdDefs.Link] RETURNS[BOOL] ~ {
RETURN[link = BcdDefs.NullLink]};


<<fill in links>>

InputActuals: PROC[bs: BS, formals: Tree.Link] ~ {
n: NAT ~ TreeOps.NSons[formals];
IF n = 0 THEN bs.configFormals _ NIL
ELSE {
bs.configFormals _ (bs.z).NEW[SMBind.IRSeqRecord[n+1]];
bs.configFormals[0] _ NIL;        -- not used
FOR i: NAT IN [1 .. n] DO
id: Tree.Id ~ NARROW[TreeOps.GetExt[TreeOps.NthSon[formals, i]]];
formalName: Tree.Name ~ SMVal.IdName[id];
type: Tree.Link ~ SMVal.IdType[id];
typeName: Tree.Name ~ (WITH type SELECT FROM
id: Tree.Id => SMVal.IdName[id],
ENDCASE => formalName);
stamp: TimeStamp.Stamp _ TimeStamp.Null;
ir: SMBind.VIR;
<<examine first son, it is either an apply for a mesa or fiBcd for a bcd in the model>>
WITH SMVal.ValOf[type] SELECT FROM
node: Tree.Handle =>
WITH SMVal.ValOfNthSon[SMVal.ValOf[node], 1] SELECT FROM
fiSrc: SMFI.SrcFileInfo =>
stamp _ NARROW[TreeOps.GetExt[node], SMProj.Proj].stamp;
subNode: Tree.Handle =>
IF TreeOps.OpName[subNode] IN Tree.ApplOp THEN
stamp _ NARROW[TreeOps.GetExt[subNode], SMProj.Proj].stamp;
fiBcd: SMFI.BcdFileInfo => stamp _ fiBcd.stamp;
ENDCASE;
fiBcd: SMFI.BcdFileInfo => stamp _ fiBcd.stamp;
ENDCASE;
bs.configFormals[i] _ ir _ SMBind.AllocateVIR[stamp, typeName];
ir.index _ (bs.configBcd).DeclareImport[
Atom.GetPName[formalName], Atom.GetPName[typeName], stamp];
ENDLOOP;
};
};

GetInterface: PROC[bs: BS, bcdVersion: TimeStamp.Stamp] RETURNS[ir: SMBind.IR] ~ {
FOR i: NAT IN [1 .. bs.configFormals.size) DO
IF bcdVersion = bs.configFormals[i].stamp THEN RETURN[bs.configFormals[i]];
ENDLOOP;
<<IF linkerIR = NIL THEN {>>
<<this is one of>>
<<1) an imported module from the loadstate (done lazily: see LookupFrame)>>
<<2) an imported interface that is all inlines>>
<<3) an imported interface that has not been exported to the load state (error)>>
<<ir _ NIL};>>
RETURN[NIL]};


ResolveImports: PROC[bs: BS, root: Tree.Link] ~ {

ForEachApply: PROC[node, parent: Tree.Link] ~ {
IF TreeOps.OpName[node] IN Tree.ApplOp THEN
WITH SMVal.GetExtFromParse[node] SELECT FROM
loadMod: SMLDriver.LoadMod =>
IF ~loadMod.bindInfo.linksResolved THEN {
rand: Tree.Link ~ SMVal.ValOfNthSon[node, 2];
args: Tree.Link ~ (IF SMVal.Binding[rand] THEN SMVal.BtoG[rand] ELSE rand);
FillInImports[loadMod, args]};
ENDCASE => NULL;
};

FillInImports: PROC[loadMod: SMLDriver.LoadMod, args: Tree.Link] ~ TRUSTED {
bindInfo: SMBind.BindInfo ~ loadMod.bindInfo;
bcd: BcdDefs.BcdBase ~ bindInfo.bcd;
firstDummy: NAT ~ bcd.firstdummy;
importMap: SMBind.ImportMap ~
(bs.z).NEW[SMBind.ImportMapSeq[bcd.nDummies] _ [bias~firstDummy, map~]];
import: NAT _ 1;
relGfi: NAT _ 0;

ForEachImport: PROC[ith: BcdDefs.IMPHandle, iti: BcdDefs.IMPIndex]
  RETURNS[stop: BOOL_FALSE] ~ TRUSTED {
fth: BcdDefs.FTHandle ~ @LOOPHOLE[bcd + bcd.ftOffset, BcdDefs.Base][ith.file];
FOR i: NAT IN [0 .. ith.ngfi) DO
importMap[(ith.gfi-firstDummy)+i] _ [index~import, whichOne~i];
ENDLOOP;
bindInfo.imports[import] _ (IF import > TreeOps.NSons[args] THEN
HiddenImport[bs, args, fth.version] ELSE LookupInterface[bs, args, import]);
WITH bindInfo.imports[import] SELECT FROM
formal: SMBind.VIR =>
IF formal.dummyGfi = BcdDefs.NullModule THEN
formal.dummyGfi _ (bs.configBcd).FillImport[formal.index, bcd, iti];
ENDCASE;
IF FALSE AND bindInfo.imports[import] = NIL THEN {
<<would get spurious warnings for NIL implementations>>
sym: Rope.ROPE ~ SMModelBcd.RopeFromNS[bcd, ith.name];
bs.out.PutF["Warning - cannot find exporter of %g anywhere.\n", IO.rope[sym]]};
import _ import + 1};

moduleBase: BcdDefs.ModuleIndex ~ bindInfo.moduleIndex;

ForEachModule: PROC[mth: BcdDefs.MTHandle, mti: BcdDefs.MTIndex]
RETURNS[stop: BOOL_FALSE] ~ TRUSTED {
resolved: BOOL _ TRUE;
nLinks: NAT ~ LoaderOps.LinkSegmentLength[mth, bcd];
module: SMModelBcd.MTHandle ~ (bs.configBcd).OpenLinks[moduleBase, relGfi, nLinks];
FOR i: CARDINAL IN [0..nLinks) DO
bound: BOOL;
link: BcdDefs.Link;
[link, bound] _ NewLink[
bcdLink~LoaderOps.IthLink[mth, i, bcd],
oldLink~(bs.configBcd).ReadLink[mth~module, offset~i],
bindInfo~loadMod.bindInfo, importMap~importMap];
IF bound THEN (bs.configBcd).WriteLink[mth~module, offset~i, link~link]
ELSE resolved _ FALSE;
ENDLOOP;
IF ~resolved THEN bindInfo.linksResolved _ FALSE;
(bs.configBcd).ImportLiterals[module, bcd, mti];
relGfi _ relGfi + mth.ngfi};

<<IF bcd.nImports = 0 THEN RETURN;    ** Loader crock - can't handle LFNull !!!>>
bindInfo.imports _ (bs.z).NEW[SMBind.IRSeqRecord[bcd.nImports+1]];
bindInfo.imports[0] _ NIL;    -- not used
[] _ BcdOps.ProcessImports[bcd, ForEachImport];
bindInfo.linksResolved _ TRUE;
(bs.configBcd).OpenLiterals[bcd];
[] _ BcdOps.ProcessModules[bcd, ForEachModule];
(bs.configBcd).CloseLiterals[bcd]};

SMVal.VisitNodes[bs.tm, root, ForEachApply]};


PossibleCoercion: PROC[t: Tree.Link] RETURNS[SMBind.IR] ~ {
SELECT TreeOps.OpName[t] FROM
IN Tree.ApplOp => {
<<this is a coercion not made explicit by the evaluator; simply use the first export>>
loadMod: SMLDriver.LoadMod ~ NARROW[SMVal.GetExtFromParse[t]];
IF loadMod # NIL THEN {
bindInfo: SMBind.BindInfo ~ loadMod.bindInfo;
RETURN[bindInfo.exports[1]]}    -- check size before allowing coercion?
ELSE RETURN[NIL]};
$subscript, $then, $union => RETURN[NARROW[TreeOps.GetExt[t]]];
$nil => RETURN[NIL];
ENDCASE => RETURN[NIL]        -- ERROR?
};


LookupInterface: PROC[bs: BS, args: Tree.Link, import: NAT] RETURNS[SMBind.IR] ~ {

LookupOutside: PROC[id: Tree.Id] RETURNS[ir: SMBind.IR] ~ {
ir _ bs.configFormals[id.p];    -- id must be a formal
IF ir = NIL THEN
bs.out.PutF["Can't import %g from loadstate\n.", IO.atom[SMVal.IdName[id]]];
RETURN};

RETURN [WITH SMVal.ValOfNthSon[args, import] SELECT FROM
node: Tree.Handle => PossibleCoercion[node],
id: Tree.Id => LookupOutside[id],
ENDCASE => ERROR]
};

HiddenImport: PROC[bs: BS, args: Tree.Link, version: TimeStamp.Stamp]
RETURNS[ir: SMBind.IR _ NIL] ~ {

CheckArg: TreeOps.Scan ~ {
v: Tree.Link ~ SMVal.ValOf[t];
SELECT TreeOps.OpName[v] FROM
IN Tree.ApplOp => {

CheckImport: TreeOps.Scan ~ {
WITH SMVal.ValOf[t] SELECT FROM
node: Tree.Handle => {
argIr: SMBind.IR ~ PossibleCoercion[node];
IF argIr ~= NIL AND argIr.stamp = version THEN {
IF ir ~= NIL AND ir ~= argIr THEN
bs.out.PutF["Ambiguous implicit import of %g\n", IO.atom[ir.name]];
ir _ argIr};
};
ENDCASE;
<<could be an export too?>>
};

TreeOps.ScanSons[SMVal.ValOfNthSon[v, 2], CheckImport]};
$subscript => CheckArg[TreeOps.NthSon[v, 1]];
$then, $union => {
CheckArg[TreeOps.NthSon[v, 1]];  CheckArg[TreeOps.NthSon[v, 2]]};
$nil => NULL;
ENDCASE;
};

TreeOps.ScanSons[args, CheckArg];
<<ir will be NIL here only if implicitly importing instance is a formal>>
IF ir = NIL THEN ir _ GetInterface[bs, version];
RETURN};


NewLink: PROC[
bcdLink: BcdDefs.Link, oldLink: BcdDefs.Link,
bindInfo: SMBind.BindInfo, importMap: SMBind.ImportMap]
RETURNS[link: BcdDefs.Link, resolved: BOOL] ~ {

FindLink: PROC[bcdLink: BcdDefs.Link]
RETURNS[link: BcdDefs.Link, resolved: BOOL] ~ TRUSTED {
bcdGfi: BcdDefs.ModuleIndex ~ (SELECT bcdLink.vtag FROM
$var => bcdLink.vgfi,
$proc0, $proc1 => bcdLink.gfi,
ENDCASE => ERROR);
IF bcdGfi < importMap.bias THEN {
link _ SMBind.RelocateLink[bindInfo, bcdLink];
resolved _ ~EmptyLink[link]}
ELSE {
relGfi: NAT ~ bcdGfi - importMap.bias;
index: NAT ~ importMap[relGfi].index;
entryNo: CARDINAL ~ bcdLink.ep + (importMap[relGfi].whichOne*BcdDefs.ProcLimit);
WITH bindInfo.imports[index] SELECT FROM
ir: SMBind.RIR => {
resolved _ ~EmptyLink[ir[entryNo].link];
IF resolved THEN link _ ir[entryNo].link};
ir: SMBind.VIR => {
link _ SMBind.ImportLink[ir.dummyGfi, entryNo];  resolved _ TRUE};
ENDCASE => resolved _ FALSE;
IF ~resolved THEN {
<<****  warning message here?>>
};
};
RETURN[link, resolved]};

RETURN (SELECT bcdLink.vtag FROM
$proc0, $proc1,
$var =>
IF EmptyLink[oldLink] THEN FindLink[bcdLink] ELSE [oldLink, TRUE],
ENDCASE => [LOOPHOLE[bcdLink.typeID], TRUE])                            -- ***
};


ExportToBcd: PROC[bs: BS, body: Tree.Link] ~ {

ForEachItem: PROC[t: Tree.Link] ~ {
WITH PossibleCoercion[SMVal.ValOf[t]] SELECT FROM
ir: SMBind.RIR => {

IthLink: SAFE PROC[i: NAT] RETURNS[BcdDefs.Link] ~ TRUSTED {
RETURN[ir[i].link]};

(bs.configBcd).DeclareExport[
name~Atom.GetPName[ir.name], stamp~ir.stamp, size~ir.size, getLink~IthLink]};
ir: SMBind.VIR =>
NULL   -- ****
ENDCASE
};

SELECT TreeOps.OpName[body] FROM
$group => TreeOps.ScanSons[body, ForEachItem];
IN Tree.BindOp => {TreeOps.ScanSons[SMVal.BtoG[body], ForEachItem]};
$let => ExportToBcd[bs, TreeOps.NthSon[body, 2]];
ENDCASE => ForEachItem[body];
};


AssignControls: PROC[bs: BS, body: Tree.Link] ~ {

ForEachNode: PROC[node, parent: Tree.Link] ~ {
IF SMVal.Binding[node] THEN {
d: Tree.Link ~ SMVal.BtoD[node];
g: Tree.Link ~ SMVal.BtoG[node];
p: NAT _ 0;

CheckElem: TreeOps.Scan ~ {
p _ p+1;
IF TreeOps.OpName[SMVal.ValOfNthSon[t, 2]] = $control THEN
AssignControl[SMVal.ValOfNthSon[g, p]]
};

TreeOps.ScanSons[d, CheckElem]};
};

AssignControl: PROC[t: Tree.Link] ~ {
WITH t SELECT FROM
node: Tree.Handle =>
SELECT TreeOps.OpName[node] FROM
IN Tree.ApplOp =>
WITH SMVal.GetExtFromParse[node] SELECT FROM
loadMod: SMLDriver.LoadMod => {    -- *** not right for configs
bindInfo: SMBind.BindInfo ~ loadMod.bindInfo;
(bs.configBcd).DeclareControl[bindInfo.moduleIndex]};
ENDCASE;
$subscript => AssignControl[SMVal.ValOfNthSon[node, 1]];
ENDCASE;
ENDCASE => NULL;
};

SMVal.VisitNodes[bs.tm, body, ForEachNode]};

}.