-- file SMEvalImpl.mesa
-- last edited by Satterthwaite, August 11, 1983 1:17 pm
DIRECTORY
Atom: TYPE USING [MakeAtom],
CS: TYPE USING [RopeFromCard],
FileIO: TYPE USING [Open, OpenFailed],
IO: TYPE USING [STREAM, atom, card, PutF, rope],
Rope: TYPE USING [ROPE, Cat, Equal, Length],
SMBcd: TYPE USING [ReadModelBcdPrefix],
SMEval: TYPE USING [],
SMFI: TYPE USING [BcdFileInfo, SrcFileInfo],
SMFIOps: TYPE USING [EvaluateUnitId],
SMOps: TYPE USING [MS, NewModel],
SMUtil: TYPE USING [ParseStream],
SMTree: TYPE Tree USING [
ApplOp, BindOp, Handle, Id, IdInfo, Info, Link, Name, NodeName, Text,
null, nullHandle, nullId, nullName],
SMTreeOps: TYPE --TreeOps-- USING [
Map, Scan, TM,
CopyTree, Finalize, GetExt, GetName, IdentityMap, Initialize, MakeNode,
NSons, NthSon, OpName, PopTree, PushId, PushName, PushNode, PushTree,
PutExt, PutNthSon, ScanSons, SetAttr, SetExt, Zone];
SMEvalImpl: CEDAR PROGRAM
IMPORTS Atom, CS, FileIO, IO, Rope, SMBcd, SMFIOps, SMOps, SMUtil, SMTreeOps
EXPORTS SMEval ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;
-- file utilities
UnitToRope: PUBLIC PROC[unitId: Tree.Link] RETURNS[r: Rope.ROPE ← ""] ~ {
AppendPart: PROC[t: Tree.Link] ~ {
WITH t SELECT FROM
part: Tree.Text => {
IF r.Length # 0 THEN r ← r.Cat["."];
r ← r.Cat[part]};
node: Tree.Handle =>
SELECT TreeOps.OpName[node] FROM
$uiList => TreeOps.ScanSons[node, AppendPart];
ENDCASE;
ENDCASE};
TreeOps.ScanSons[unitId, AppendPart];
RETURN};
-- error handling (move to a new module)
ErrorLoc: PROC[m: SMOps.MS, severity: {warning, error}←$error] ~ {
IF severity = $error THEN m.errors ← TRUE;
m.out.PutF["%s at %d: ",
IO.rope[IF severity=$warning THEN "Warning" ELSE "Error"],
IO.card[m.loc]];
};
-- the main evaluator
Eval: PUBLIC PROC[m: SMOps.MS, t: Tree.Link, e: Env] RETURNS[v: Tree.Link] ~ {
WITH t SELECT FROM
name: Tree.Name => {
v ← LookUp[name, e];
IF v = Tree.nullId THEN {
ErrorLoc[m]; m.out.PutF["%s is undeclared\n", IO.atom[name]]};
};
id: Tree.Id => v ← id;
node: Tree.Handle => {
tm: TreeOps.TM ~ m.tm;
BindSon: TreeOps.Map~{RETURN[Eval[m, t, e]]};
saveLoc: Tree.Info ~ m.loc;
m.loc ← node.info;
SELECT node.name FROM -- can't use OpName (see $locator)
$lambda => {
-- type of result is NOT currently checked
decl: Tree.Link ~ EvalToDecl[m, TreeOps.NthSon[node, 1], e];
tm.PushTree[decl];
IF IsDecl[decl] THEN {
d: Tree.Handle ~ NARROW[decl];
newE: Env;
MakeIds[tm, d, TRUE];
newE ← ConsEnv[tm, d, e];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], newE]];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 3], newE]]}
ELSE { -- require literal decl for now
ErrorLoc[m]; m.out.PutF["decl required in LAMBDA\n"];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], e]];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 3], e]]};
v ← tm.MakeNode[$lambda, 3];
TreeOps.PutExt[v, ConsClosure[tm, TreeOps.NthSon[node, 3], e]]};
$let => {
binding: Tree.Link ~ Eval[m, TreeOps.NthSon[node, 1], e];
IF NullGroup[binding] THEN {
tm.PushNode[$bind, 0];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], e]]}
ELSE IF IsBinding[binding] THEN { -- require literal binding
b: Tree.Handle ~ NARROW[binding];
tm.PushTree[binding];
IF TreeOps.OpName[b] # $nBindRec THEN MakeIds[tm, b, TRUE];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], ConsEnv[tm, b, e]]]}
ELSE {
ErrorLoc[m]; m.out.PutF["binding required in LET\n"];
tm.PushTree[binding];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], e]]};
v ← tm.MakeNode[$let, 2]};
$arrow => {
decl: Tree.Link ~ EvalToDecl[m, TreeOps.NthSon[node, 1], e];
tm.PushTree[decl];
IF IsDecl[decl] THEN {
d: Tree.Handle ~ NARROW[decl];
MakeIds[tm, d, TRUE];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], ConsEnv[tm, d, e]]]}
ELSE { -- require literal decl for now
ErrorLoc[m]; m.out.PutF["decl required in ->\n"];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], e]]};
v ← tm.MakeNode[$arrow, 2]};
$apply, $applyDefault => v ← Appl[m, node, e, node.name=$applyDefault];
$decl => {
IF node.attrs[1] THEN { -- not part of a binding
v ← NormalizeDecl[tm, t, e];
EvalDecl[m, v, e]}
ELSE NULL}; -- part of binding, scope already created and included in e
$bind => {
v ← NormalizeBinding[tm, t, e];
EvalBinding[m, v, e]};
$bindRec => {
b: Tree.Handle;
v ← NormalizeBinding[tm, t, e];
b ← NARROW[v];
MakeIds[tm, b, FALSE];
EvalRecBinding[m, v, NARROW[TreeOps.GetExt[v]]]};
IN Tree.BindOp => v ← t; -- ever found?
$cross2 => {
decl: Tree.Link ~ EvalToDecl[m, TreeOps.NthSon[node, 1], e];
tm.PushTree[decl];
IF IsDecl[decl] THEN {
d: Tree.Handle ~ NARROW[decl];
MakeIds[tm, d, TRUE];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], ConsEnv[tm, d, e]]]}
ELSE ERROR; -- botch within the modeller
v ← tm.MakeNode[$cross2, 2]};
$subscript => {
binding: Tree.Link ~ Eval[m, TreeOps.NthSon[node, 1], e];
bv: Tree.Link ~ ValOf[m, binding];
name: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[node, 2]]; -- treat as quoted
IF IsBinding[bv] THEN {
b: Tree.Handle ~ NARROW[bv];
p: NAT ~ SearchD[name, DBtoD[b]];
IF p = 0 THEN {
ErrorLoc[m]; m.out.PutF["Invalid field %s\n", IO.atom[name]]};
};
tm.PushTree[binding]; tm.PushName[name];
v ← tm.MakeNode[$subscript, 2]};
$env => {v ← tm.MakeNode[$env, 0]; TreeOps.PutExt[v, e]};
$type => {
qn: Tree.Link ~ TreeOps.NthSon[node, 1];
IF qn = Tree.null THEN tm.PushTree[qn] ELSE tm.PushName[TreeOps.GetName[qn]];
v ← tm.MakeNode[$type, 1]};
$unitId => v ← BindFile[m, t];
$locator => v ← Eval[m, node.son[1], e]; -- can't use NthSon
ENDCASE => v ← tm.CopyTree[t, BindSon];
m.loc ← saveLoc};
ENDCASE => v ← t;
RETURN};
EvalToDecl: PROC[m: SMOps.MS, t: Tree.Link, e: Env] RETURNS[Tree.Link] ~ {
v: Tree.Link ~ Eval[m, t, e];
RETURN[IF NullGroup[v] THEN (m.tm).MakeNode[$decl, 0] ELSE v]};
-- environment representation and management
Env: TYPE ~ REF ScopeDescriptor;
ScopeDescriptor: PUBLIC TYPE ~ RECORD[
db: Tree.Handle, -- decl or binding
parent: Env];
ClosureObject: TYPE~RECORD[
body: Tree.Link, -- the lambda body
e: Env]; -- its environment (no formals)
Closure: TYPE ~ REF ClosureObject;
ConsEnv: PROC[tm: TreeOps.TM, db: Tree.Handle, parent: Env] RETURNS[Env] ~ {
RETURN[(tm.Zone).NEW[ScopeDescriptor ← [parent~parent, db~db]]]};
ConsClosure: PROC[tm: TreeOps.TM, body: Tree.Link, e: Env] RETURNS[Closure] ~ {
RETURN[(tm.Zone).NEW[ClosureObject ← [body~body, e~e]]]};
-- note: to expedite Id handling, a several procs in this module know about Tree.Node internals
DBtoD: PROC[db: Tree.Handle] RETURNS[Tree.Handle] ~ INLINE {
RETURN[IF db.name = $decl THEN db ELSE NARROW[db.son[1]]]}; -- BindOp or cross2
DBtoG: PROC[db: Tree.Handle] RETURNS[g: Tree.Handle] ~ {
IF db.name IN Tree.BindOp THEN {
node: Tree.Handle ~ NARROW[db.son[2]];
SELECT node.name FROM
$group => g ← node;
$let => g ← NARROW[node.son[2]];
ENDCASE => ERROR;
}
ELSE g ← Tree.nullHandle;
RETURN};
GenSym: PROC[n: NAT] RETURNS[Tree.Name] ~ { -- move to SMUtil
prefix: Rope.ROPE ~ "&";
RETURN[Atom.MakeAtom[prefix.Cat[CS.RopeFromCard[n]]]]};
MakeIds: PROC[tm: TreeOps.TM, db: Tree.Handle, mark: BOOL] ~ {
d: Tree.Handle ~ DBtoD[db];
FOR p: NAT IN [1 .. d.sonLimit) DO
-- all Id's should be allocated here to preserve sharing
TreeOps.PutExt[d.son[p],
(tm.Zone).NEW[Tree.IdInfo ← [db~db, p~p, mark1~mark, mark2~mark]]]
ENDLOOP;
};
NthId: PROC[db: Tree.Handle, n: NAT] RETURNS[Tree.Id] ~ {
RETURN[NARROW[TreeOps.GetExt[DBtoD[db].son[n]]]]};
SearchD: PROC[name: Tree.Name, d: Tree.Handle] RETURNS[NAT] ~ {
FOR p: NAT IN [1 .. d.sonLimit) DO
declElem: Tree.Handle ~ NARROW[d.son[p]];
IF declElem.son[1] = name THEN RETURN[p];
ENDLOOP;
RETURN[0]};
SearchDB: PROC[name: Tree.Name, db: Tree.Handle] RETURNS[Tree.Id] ~ {
d: Tree.Handle ~ DBtoD[db];
FOR p: NAT IN [1 .. d.sonLimit) DO
declElem: Tree.Handle ~ NARROW[d.son[p]];
IF declElem.son[1] = name THEN RETURN[NARROW[declElem.ext]];
ENDLOOP;
RETURN[Tree.nullId]};
LookUp: PROC[name: Tree.Name, e: Env] RETURNS[Tree.Id] ~ {
FOR scope: Env ← e, scope.parent UNTIL scope = NIL DO
id: Tree.Id ~ SearchDB[name, scope.db];
IF id # Tree.nullId THEN RETURN[id];
ENDLOOP;
RETURN[Tree.nullId]};
DeclName: PROC[declElem: Tree.Link] RETURNS[Tree.Name] ~ INLINE {
RETURN[TreeOps.GetName[TreeOps.NthSon[declElem, 1]]]};
DeclType: PROC[declElem: Tree.Link] RETURNS[Tree.Link] ~ INLINE {
RETURN[TreeOps.NthSon[declElem, 2]]};
PushDeclElem: PROC[tm: TreeOps.TM, declElem: Tree.Link] ~ {
-- make a copy of the declElem node
tm.PushName[DeclName[declElem]];
tm.PushTree[DeclType[declElem]];
tm.PushNode[$declElem, 2]};
NormalizeDecl: PROC[tm: TreeOps.TM, d: Tree.Link, e: Env] RETURNS[Tree.Link] ~ {
nD: NAT ← 0;
PushD: TreeOps.Scan ~ {
PushDeclElem[tm, t]; nD ← nD + 1};
TreeOps.ScanSons[d, PushD];
tm.PushNode[$decl, nD]; tm.SetAttr[1, TRUE]; tm.SetExt[e];
RETURN[tm.PopTree]};
NormalizeBinding: PROC[tm: TreeOps.TM, b: Tree.Link, e: Env] RETURNS[Tree.Link] ~ {
nLB: NAT ← 0;
letB: Tree.Handle ← Tree.nullHandle;
LBindElemD: PROC[bindElem: Tree.Link] ~ {
decl: Tree.Link ~ TreeOps.NthSon[bindElem, 1];
IF TreeOps.NSons[decl] # 1 THEN {
nLB ← nLB + 1;
tm.PushName[GenSym[nLB]];
tm.PushTree[decl]; tm.SetAttr[1, TRUE];
tm.PushNode[$declElem, 2]};
};
LBindElemV: PROC[bindElem: Tree.Link] ~ {
decl: Tree.Link ~ TreeOps.NthSon[bindElem, 1];
IF TreeOps.NSons[decl] # 1 THEN tm.PushTree[TreeOps.NthSon[bindElem, 2]]};
nD, nLV: NAT ← 0;
BindElemD: PROC[bindElem: Tree.Link] ~ {
decl: Tree.Link ~ TreeOps.NthSon[bindElem, 1];
PushD: TreeOps.Scan ~ {PushDeclElem[tm, t]; nD ← nD + 1};
TreeOps.ScanSons[decl, PushD]};
BindElemV: PROC[bindElem: Tree.Link] ~ {
decl: Tree.Link ~ TreeOps.NthSon[bindElem, 1];
IF TreeOps.NSons[decl] # 1 THEN {
PushIndexed: PROC[declElem: Tree.Link] ~ {
tm.PushId[NthId[letB, nLV]];
tm.PushName[DeclName[declElem]];
tm.PushNode[$subscript, 2]};
nLV ← nLV + 1;
TreeOps.ScanSons[decl, PushIndexed]}
ELSE tm.PushTree[TreeOps.NthSon[bindElem, 2]]};
newE: Env;
newB: Tree.Link;
TreeOps.ScanSons[b, LBindElemD];
IF nLB # 0 THEN {
tm.PushNode[$decl, nLB]; tm.SetAttr[1, FALSE];
TreeOps.ScanSons[b, LBindElemV];
tm.PushNode[$group, nLB];
letB ← NARROW[tm.MakeNode[$nBind, 2]];
MakeIds[tm, letB, FALSE]};
TreeOps.ScanSons[b, BindElemD];
tm.PushNode[$decl, nD]; tm.SetAttr[1, FALSE];
TreeOps.ScanSons[b, BindElemV];
tm.PushNode[$group, nD];
IF nLB # 0 THEN {tm.PushTree[letB]; tm.PushNode[$let, -2]};
IF TreeOps.OpName[b]=$bindRec THEN {
newB ← tm.MakeNode[$nBindRec, 2];
newE ← ConsEnv[tm, NARROW[newB], e]}
ELSE {newB ← tm.MakeNode[$nBind, 2]; newE ← e};
TreeOps.PutExt[newB, newE];
IF letB # Tree.nullHandle THEN TreeOps.PutExt[letB, newE];
RETURN[newB]};
IsBinding: PROC[t: Tree.Link] RETURNS[BOOL] ~ INLINE {
RETURN[TreeOps.OpName[t] IN Tree.BindOp]};
IsDecl: PROC[t: Tree.Link] RETURNS[BOOL] ~ INLINE {
RETURN[TreeOps.OpName[t] = $decl]};
NullGroup: PROC[t: Tree.Link] RETURNS[BOOL] ~ INLINE {
RETURN[TreeOps.OpName[t] = $group AND TreeOps.NSons[t] = 0]};
-- scope evaluation
BindDecl: PROC[m: SMOps.MS, elem: Tree.Link, e: Env] ~ {
TreeOps.PutNthSon[elem, 2, Eval[m, TreeOps.NthSon[elem, 2], e]]};
EvalId: PROC[m: SMOps.MS, id: Tree.Id] ~ {
IF ~id.mark2 THEN {
IF ~id.mark1 THEN {
d: Tree.Handle ~ DBtoD[id.db];
idE: Env ~ NARROW[TreeOps.GetExt[id.db]];
id.mark1 ← TRUE;
BindDecl[m, d.son[id.p], idE];
IF id.db.name IN Tree.BindOp THEN {
g: Tree.Handle ~ DBtoG[id.db];
g.son[id.p] ← Eval[m, g.son[id.p], idE]};
id.mark2 ← TRUE}
ELSE NULL}; -- check if legal circularity?
};
EvalDecl: PROC[m: SMOps.MS, decl: Tree.Link, e: Env] ~ {
d: Tree.Handle ~ NARROW[decl];
FOR p: NAT IN [1 .. d.sonLimit) DO
BindDecl[m, d.son[p], e];
ENDLOOP;
};
EvalBinding: PROC[m: SMOps.MS, binding: Tree.Link, e: Env] ~ {
b: Tree.Handle ~ NARROW[binding];
g: Tree.Handle ~ DBtoG[b];
EvalDecl[m, DBtoD[b], e];
FOR p: NAT IN [1 .. g.sonLimit) DO
g.son[p] ← Eval[m, g.son[p], e];
ENDLOOP;
};
EvalRecBinding: PROC[m: SMOps.MS, binding: Tree.Link, e: Env] ~ {
d: Tree.Handle ~ DBtoD[NARROW[binding]];
FOR p: NAT IN [1 .. d.sonLimit) DO
EvalId[m, NARROW[TreeOps.GetExt[d.son[p]]]]
ENDLOOP;
};
-- simplification
ValOf: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[Tree.Link] ~ {
WITH t SELECT FROM
id: Tree.Id => {
IF ~id.mark2 THEN EvalId[m, id];
RETURN[IF id.mark2 AND id.db.name IN Tree.BindOp
THEN ValOf[m, DBtoG[id.db].son[id.p]]
ELSE id]
};
node: Tree.Handle =>
RETURN[IF TreeOps.OpName[node] = $subscript THEN Select[m, node] ELSE t];
ENDCASE => RETURN[t]
};
Select: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[v: Tree.Link] ~ {
bv: Tree.Link ~ ValOf[m, TreeOps.NthSon[t, 1]];
IF IsBinding[bv] THEN {
b: Tree.Handle ~ NARROW[bv];
p: NAT ~ SearchD[TreeOps.GetName[TreeOps.NthSon[t, 2]], DBtoD[b]];
v ← (IF p # 0 THEN TreeOps.NthSon[DBtoG[b], p] ELSE t)}
ELSE v ← t;
RETURN};
-- file expansion
BindFile: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[v: Tree.Link] ~ {
nameList: Tree.Link ~ TreeOps.NthSon[t, 3]; -- other parts ignored for now
version: Tree.Text ~ NARROW[TreeOps.NthSon[t, 4]];
ext: Tree.Text ~ NARROW[TreeOps.NthSon[nameList, TreeOps.NSons[nameList]]];
SELECT TRUE FROM
ext.Equal["mesa", FALSE], ext.Equal["bcd", FALSE] => {
tree: Tree.Link ~ SMFIOps.EvaluateUnitId[m, UnitToRope[nameList], version];
v ← Eval[m, tree, NIL]};
ext.Equal["model", FALSE], ext.Equal["modelBcd", FALSE] => {
subModel: Tree.Link ← NARROW[TreeOps.GetExt[t]];
IF subModel = Tree.null THEN {
source: IO.STREAM ← NIL;
source ← FileIO.Open[UnitToRope[nameList] ! FileIO.OpenFailed => {CONTINUE}];
IF source = NIL THEN v ← t
ELSE { -- new model to keep comments separate
newM: SMOps.MS ~ SMOps.NewModel[in~m.in, out~m.out, msgout~m.msgOut];
(newM.tm).Initialize;
IF ext.Equal["modelBcd", FALSE] THEN -- advance input stream
SMBcd.ReadModelBcdPrefix[newM, source];
subModel ← SMUtil.ParseStream[newM, source];
TreeOps.PutExt[t, subModel];
v ← Eval[newM, subModel, NIL];
(newM.tm).Finalize};
}
ELSE v ← Eval[m, subModel, NIL]};
ENDCASE => v ← t};
-- type attributes and predicates
Type: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[type: Tree.Link] ~ {
WITH t SELECT FROM
id: Tree.Id => {
d: Tree.Handle ~ DBtoD[id.db];
type ← DeclType[d.son[id.p]];
IF type = Tree.null THEN {
v: Tree.Link ~ ValOf[m, id];
IF v # id THEN type ← Type[m, v]};
};
node: Tree.Handle =>
SELECT TreeOps.OpName[node] FROM
$lambda => {
(m.tm).PushTree[TreeOps.NthSon[node, 1]];
(m.tm).PushTree[TreeOps.NthSon[node, 2]];
type ← (m.tm).MakeNode[$arrow, 2]};
$let => type ← Type[m, TreeOps.NthSon[node, 2]];
IN Tree.ApplOp => type ← Range[Type[m, TreeOps.NthSon[node, 1]]];
$decl => type ← (m.tm).MakeNode[$typeDECL, 0];
IN Tree.BindOp => type ← DBtoD[node];
ENDCASE => type ← Tree.null; -- for now
fiSrc: SMFI.SrcFileInfo => type ← fiSrc.type;
fiBcd: SMFI.BcdFileInfo => type ← fiBcd.type;
ENDCASE => type ← Tree.null;
RETURN};
Domain: PROC[t: Tree.Link] RETURNS[Tree.Link] ~ {
RETURN[SELECT TreeOps.OpName[t] FROM
$arrow => TreeOps.NthSon[t, 1],
ENDCASE => Tree.null]};
Range: PROC[t: Tree.Link] RETURNS[Tree.Link] ~ {
RETURN[SELECT TreeOps.OpName[t] FROM
$arrow => TreeOps.NthSon[t, 2],
ENDCASE => Tree.null]};
FormalRange: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[Tree.Link] ~ {
-- does not bind from domain(s)
RETURN[WITH ValOf[m, t] SELECT FROM
node: Tree.Handle =>
SELECT TreeOps.OpName[node] FROM
IN Tree.ApplOp => Type[m, node],
$subscript => FormalRange[m, TreeOps.NthSon[node, 1]],
ENDCASE => Tree.null,
ENDCASE => Tree.null]};
HasName: PROC[type: Tree.Link, name: Tree.Name] RETURNS[BOOL] ~ {
SELECT TreeOps.OpName[type] FROM
$type => RETURN[TreeOps.GetName[TreeOps.NthSon[type, 1]] = name];
$cross =>
RETURN[
HasName[TreeOps.NthSon[type, 1], name] OR
HasName[TreeOps.NthSon[type, 2], name]];
$cross2 => {
decl: Tree.Link ~ TreeOps.NthSon[type, 1];
FOR i: NAT IN [1..TreeOps.NSons[decl]] DO
IF HasName[DeclType[TreeOps.NthSon[decl, i]], name] THEN RETURN[TRUE];
ENDLOOP;
RETURN[HasName[TreeOps.NthSon[type, 2], name]]};
ENDCASE => NULL;
RETURN[FALSE]};
Implies: PROC[m: SMOps.MS, type1, type2: Tree.Link] RETURNS[BOOL] ~ {
IF TreeOps.OpName[type2] = $type THEN {
name: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[type2, 1]];
RETURN[name = Tree.nullName OR HasName[FormalRange[m, type1], name]]}
ELSE RETURN[TRUE]}; -- for now
-- MORE TO BE WRITTEN
-- argument filling and checking
Appl: PROC[m: SMOps.MS, node: Tree.Handle, e: Env, default: BOOL]
RETURNS[v: Tree.Link] ~ {
rator: Tree.Link ~ Eval[m, TreeOps.NthSon[node, 1], e];
rands: Tree.Link ~
CheckArgs[m, Eval[m, TreeOps.NthSon[node, 2], e], Domain[Type[m, rator]], e, default];
IF IsLambda[m, rator] THEN v ← BetaReduce[m~m, rator~rator, rands~rands, e~e]
ELSE {
(m.tm).PushTree[rator]; (m.tm).PushTree[rands];
v ← (m.tm).MakeNode[$apply, 2]; TreeOps.PutExt[v, node]};
RETURN};
CheckArgs: PROC[m: SMOps.MS, args: Tree.Link, decl: Tree.Link, e: Env, default: BOOL]
RETURNS[Tree.Link] ~ {
tm: TreeOps.TM ~ m.tm;
IF decl = Tree.null THEN tm.PushTree[args]
ELSE {
d: Tree.Handle ~ NARROW[decl];
nD: NAT ~ TreeOps.NSons[decl];
CheckLength: PROC[n: NAT] ~ {
IF n # nD THEN {
ErrorLoc[m];
m.out.PutF["%d too %s elements in argument list\n",
IO.card[(nD-n).ABS], IO.rope[IF n > nD THEN "many" ELSE "few"]];
};
};
SELECT TreeOps.OpName[args] FROM
IN Tree.BindOp => {
bD: Tree.Handle ~ DBtoD[NARROW[args]];
bG: Tree.Handle ~ DBtoG[NARROW[args]];
nG: NAT ~ TreeOps.NSons[bG];
IF ~default THEN CheckLength[nG];
FOR i: NAT IN [1 .. nD] DO
name: Tree.Name ~ DeclName[d.son[i]];
p: NAT ~ SearchD[name, bD];
v: Tree.Link ~ (SELECT TRUE FROM
p # 0 => bG.son[p],
default => BindDefault[m, name, e],
ENDCASE => Tree.null);
IF v = Tree.null THEN {
ErrorLoc[m];
m.out.PutF["No %s for %s in argument list\n",
IO.rope[IF default THEN "available default" ELSE "binding"], IO.atom[name]]}
ELSE IF ~CheckArgType[m, v, DeclType[d.son[i]]] THEN {
ErrorLoc[m]; m.out.PutF["%s for %s has wrong type\n",
IO.rope[IF p #0 THEN "Acutal" ELSE "Default"], IO.atom[name]];
};
tm.PushTree[v];
ENDLOOP;
tm.PushNode[$group, nD]};
$group => {
g: Tree.Handle ~ NARROW[args];
IF ~default THEN CheckLength[TreeOps.NSons[args]];
FOR i: NAT IN [1 .. nD] DO
type: Tree.Link ~ ValOf[m, DeclType[d.son[i]]];
v: Tree.Link;
n: NAT;
[v, n] ← MatchByType[m, g, type, i];
IF n = 0 AND default THEN {
-- take care of possible binding-to-binding coercion directly
name: Tree.Name ~ DeclName[d.son[i]];
v ← BindDefault[m, name, e];
IF v # Tree.null THEN {
IF ~HasType[m, v, type] THEN {
ErrorLoc[m]; m.out.PutF["Default for %s has wrong type\n", IO.atom[name]]};
n ← 1};
};
IF n # 1 THEN {
ErrorLoc[m];
m.out.PutF["%d values have type compatible with %s in argument list\n",
IO.card[n], IO.atom[DeclName[d.son[i]]]];
};
tm.PushTree[v];
ENDLOOP;
tm.PushNode[$group, nD]};
ENDCASE => {
ErrorLoc[m]; m.out.PutF["Group or binding required in appl\n"];
tm.PushTree[args]};
};
RETURN[tm.PopTree]};
BindDefault: PROC[m: SMOps.MS, name: Tree.Name, e: Env] RETURNS[Tree.Link] ~ {
v: Tree.Link ~ LookUp[name, e];
RETURN[IF v # Tree.nullId THEN v ELSE Tree.null]};
MatchByType: PROC[m: SMOps.MS, g: Tree.Handle, type: Tree.Link, p: NAT]
RETURNS[v: Tree.Link, matches: NAT ← 0] ~ {
FOR i: NAT IN [1 .. g.sonLimit) DO
IF HasType[m, g.son[i], type, i=p] THEN { -- fudge positional for don't know cases
IF matches = 0 THEN v ← g.son[i];
matches ← matches + 1};
ENDLOOP;
RETURN};
CheckArgType: PROC[m: SMOps.MS, arg, type: Tree.Link] RETURNS[BOOL] ~ INLINE {
RETURN[HasType[m, arg, ValOf[m, type]]]};
HasType: PROC[m: SMOps.MS, v: Tree.Link, type: Tree.Link, default: BOOL←TRUE]
RETURNS[BOOL] ~ {
-- temporary code, adequate to check compile-time args (only)
RETURN[SELECT TreeOps.OpName[type] FROM
$type => Implies[m, v, type],
$typeSTRING =>
(TreeOps.OpName[ValOf[m, Type[m, v]]] = $typeSTRING
OR ISTYPE[ValOf[m, v], Tree.Text]), -- fudge until Type does literals
ENDCASE => default] -- temporary fudge for don't know cases
};
-- beta reduction
IsLambda: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[BOOL] ~ {
RETURN[TreeOps.OpName[ValOf[m, t]] = $lambda]};
BetaReduce: PROC[m: SMOps.MS, rator, rands: Tree.Link, e: Env] RETURNS[Tree.Link] ~ {
lambda: Tree.Link ~ ValOf[m, rator];
decl: Tree.Link ~ ValOf[m, TreeOps.NthSon[lambda, 1]];
tm: TreeOps.TM ~ m.tm;
closure: Closure ~ NARROW[TreeOps.GetExt[lambda]];
b: Tree.Handle;
tm.PushTree[tm.CopyTree[decl, TreeOps.IdentityMap]]; tm.SetAttr[1, FALSE];
tm.PushTree[rands];
b ← NARROW[tm.MakeNode[$nBind, 2]]; TreeOps.PutExt[b, e];
MakeIds[tm, b, TRUE];
tm.PushTree[b];
tm.PushTree[Eval[m, closure.body, ConsEnv[tm, b, closure.e]]];
RETURN[tm.MakeNode[$let, 2]]};
}.