SMEvalImpl.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
last edit by Satterthwaite, June 2, 1986 11:43:35 am PDT
DIRECTORY
Atom: TYPE USING [MakeAtom],
Convert: TYPE USING [RopeFromCard],
CS: TYPE USING [DirectoryPart, EndsIn, PartialName],
FS: TYPE USING [Error, StreamOpen],
IO: TYPE USING [STREAM, atom, card, rope, PutF, PutRope],
Rope: TYPE USING [Concat, Equal, ROPE],
SMBcd: TYPE USING [ReadModelBcdPrefix],
SMEval: TYPE USING [],
SMFI: TYPE USING [BcdFileInfo, SrcFileInfo],
SMFIOps: TYPE USING [EvaluateUnitId, UnitToRope],
SMOps: TYPE USING [MS, NewModel],
SMTree: TYPE Tree USING [
ApplOp, BindOp, Handle, Id, IdInfo, Info, Link, Name, NodeName, SonId, Stamp, Text,
null, nullHandle, nullId],
SMTreeOps: TYPE TreeOps USING [
Map, Scan, TM,
CopyTree, Finalize, GetExt, GetName, IdentityMap, Initialize, OpName,
MakeNode, NSons, NthSon, PopTree, PushId, PushName, PushNode, PushTree,
PutExt, PutNthSon, ScanSons, SetAttr, SetExt, Zone],
SMUtil: TYPE USING [ParseStream],
TimeStamp: TYPE USING [Stamp];
SMEvalImpl: CEDAR PROGRAM
IMPORTS Atom, Convert, CS, FS, IO, Rope, SMBcd, SMFIOps, SMOps, SMTreeOps, SMUtil
EXPORTS SMEval ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;
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["%g at %d: ",
IO.rope[IF severity=$warning THEN "Warning" ELSE "Error"],
IO.card[m.loc]];
};
environment representation and management
Env: TYPE ~ REF ScopeDescriptor;
ScopeDescriptor: PUBLIC TYPE ~ RECORD[
db: Tree.Handle, -- decl or binding
level: NAT,
parent: Env];
Closure: TYPE ~ REF ClosureObject;
ClosureObject: TYPE ~ RECORD[
body: Tree.Link,      -- the lambda body
e: Env];        -- its environment (no formals)
ConsEnv: PROC[tm: TreeOps.TM, db: Tree.Handle, parent: Env] RETURNS[Env] ~ {
level: NAT ~ (IF parent = NIL THEN 1 ELSE parent.level+1);
RETURN[(tm.Zone).NEW[ScopeDescriptor ← [parent~parent, level~level, 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, several procs in this module know about Tree.Node and Tree.Id internals
DBtoD: PROC[db: Tree.Handle] RETURNS[Tree.Handle] ~ INLINE {
RETURN[IF db.name = $decl THEN db ELSE NARROW[db.son[1]]]}; -- BindOp
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.Concat[Convert.RopeFromCard[n]]]]};
MakeIds: PROC[tm: TreeOps.TM, db: Tree.Handle, mark: BOOL] ~ {
d: Tree.Handle ~ DBtoD[db];
FOR p: Tree.SonId 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: Tree.SonId 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: Tree.SonId 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]};
IdName: PROC[id: Tree.Id] RETURNS[Tree.Name] ~ {
RETURN[DeclName[DBtoD[id.db].son[id.p]]]};
IdDB: PROC[id: Tree.Id] RETURNS[Tree.Link] ~ INLINE {
RETURN[id.db]};
IdP: PROC[id: Tree.Id] RETURNS[NAT] ~ INLINE {
RETURN[id.p]};
scope evaluation
BindDecl: PROC[m: SMOps.MS, elem: Tree.Link, e: Env] ~ {
t: Tree.Link ~ DeclType[elem];
v: Tree.Link;
IF TreeOps.OpName[t] = $type AND TreeOps.NthSon[t, 1] = Tree.null THEN {
(m.tm).PushName[DeclName[elem]];
v ← (m.tm).MakeNode[$type, 1]}
ELSE v ← Eval[m, t, e];
TreeOps.PutNthSon[elem, 2, v]};
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 for legal circularity
};
EvalDecl: PROC[m: SMOps.MS, decl: Tree.Link, e: Env] ~ {
d: Tree.Handle ~ NARROW[decl];
FOR p: Tree.SonId 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: Tree.SonId IN [1 .. g.sonLimit) DO
g.son[p] ← Eval[m, g.son[p], e];
ENDLOOP;
CheckBinding[m, b]};
EvalRecBinding: PROC[m: SMOps.MS, binding: Tree.Link, e: Env] ~ {
b: Tree.Handle ~ NARROW[binding];
d: Tree.Handle ~ DBtoD[b];
FOR p: Tree.SonId IN [1 .. d.sonLimit) DO
EvalId[m, NARROW[TreeOps.GetExt[d.son[p]]]];
ENDLOOP;
CheckBinding[m, b]};
CheckBinding: PROC[m: SMOps.MS, b: Tree.Handle] ~ {
d: Tree.Handle ~ DBtoD[b];
v: Tree.Handle ← NARROW[b.son[2]];
WHILE v.name = $let DO
CheckBinding[m, NARROW[v.son[1]]];
v ← NARROW[v.son[2]]
ENDLOOP;
FOR p: Tree.SonId IN [1 .. v.sonLimit) DO
t: Tree.Link ~ DeclType[d.son[p]];
IF t # Tree.null AND ~CheckArgType[m, ValOf[m, v.son[p]], t] THEN {
ErrorLoc[m, $warning];
m.out.PutF[
"Value of %g incompatible with its declared type\n", IO.atom[DeclName[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[Tree.Link] ~ {
name: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[t, 2]];
SubIndex: PROC[b: Tree.Link] RETURNS[v: Tree.Link] ~ {
bv: Tree.Link ~ ValOf[m, b];
SELECT TRUE FROM
IsBinding[bv] => {
b: Tree.Handle ~ NARROW[bv];
p: NAT ~ SearchD[name, DBtoD[b]];
v ← (IF p # 0 THEN TreeOps.NthSon[DBtoG[b], p] ELSE t)};
TreeOps.OpName[bv] = $let => {
s: Tree.Link ~ SubIndex[TreeOps.NthSon[bv, 2]];
v ← (IF s # t THEN s ELSE t)};
ENDCASE => v ← t;
RETURN};
RETURN[SubIndex[TreeOps.NthSon[t, 1]]]};
argument checking and filling
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] AND ~m.errors 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 %g 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: Tree.SonId 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 %g for %g 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["%g for %g has wrong type\n",
IO.rope[IF p # 0 THEN "Actual" 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: Tree.SonId IN [1 .. nD] DO
type: Tree.Link ~ ValOf[m, DeclType[d.son[i]]];
v: Tree.Link;
n: NAT;
[v, n] ← MatchByType[m, g, type];
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 %g has wrong type\n", IO.atom[name]]};
n ← 1};
};
IF n # 1 THEN {
ErrorLoc[m];
m.out.PutF["%d values have type compatible with %g in argument list\n",
IO.card[n], IO.atom[DeclName[d.son[i]]]];
};
tm.PushTree[v];
ENDLOOP;
FOR i: Tree.SonId IN [1 .. g.sonLimit) DO
IF g.son[i] # Tree.null THEN {
ErrorLoc[m];
m.out.PutF["Actual %d is not type compatible with any formal\n", IO.card[i]]};
ENDLOOP;
tm.PushNode[$group, nD]};
ENDCASE => {
ErrorLoc[m]; m.out.PutRope["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]
RETURNS[v: Tree.Link, matches: NAT ← 0] ~ {
FOR i: Tree.SonId IN [1 .. g.sonLimit) DO
IF g.son[i] # Tree.null AND HasType[m, g.son[i], type] THEN {
IF matches = 0 THEN v ← g.son[i];
matches ← matches + 1; g.son[i] ← Tree.null};
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] RETURNS[BOOL] ~ {
vType: Tree.Link ~ ValOf[m, Type[m, v]];
RETURN[
Eq[vType, type]
OR
(SELECT TreeOps.OpName[type] FROM
$typeSTRING =>
(TreeOps.OpName[vType] = $typeSTRING OR ISTYPE[ValOf[m, v], Tree.Text]),
$decl => ImpliesAll[m, v, vType, type],
ENDCASE => CoercesTo[m, v, vType, type]
)
OR
TreeOps.OpName[ValOf[m, v]] = $nil]
};
beta reduction
IsLambda: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[BOOL] ~ {
RETURN[SELECT TreeOps.OpName[ValOf[m, t]] FROM
$lambda => TRUE,
$let => IsLambda[m, TreeOps.NthSon[t, 2]],
ENDCASE => FALSE]
};
BetaReduce: PROC[m: SMOps.MS, rator, rands: Tree.Link, e: Env] RETURNS[Tree.Link] ~ {
tm: TreeOps.TM ~ m.tm;
operator: Tree.Link ~ ValOf[m, rator];
SELECT TreeOps.OpName[operator] FROM
$lambda => {
decl: Tree.Link ~ ValOf[m, TreeOps.NthSon[operator, 1]];
closure: Closure ~ NARROW[TreeOps.GetExt[operator]];
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]]]};
$let => {
tm.PushTree[TreeOps.NthSon[operator, 1]];
tm.PushTree[BetaReduce[m, TreeOps.NthSon[operator, 2], rands, e]]};
ENDCASE => ERROR;
RETURN[tm.MakeNode[$let, 2]]};
infix operators
ToInterface: PROC[m: SMOps.MS, type: Tree.Link] RETURNS[Tree.Link] ~ {
t: Tree.Link ~ ValOf[m, type];
SELECT TreeOps.OpName[t] FROM
$cross => {
s: Tree.Link ~ ValOf[m, TreeOps.NthSon[t, 1]];
RETURN[SELECT TreeOps.OpName[s] FROM
IN Tree.ApplOp, $stamp => s,
$cross => ToInterface[m, TreeOps.NthSon[s, 1]],
ENDCASE => t]
};
ENDCASE;
RETURN[t]};
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["%g 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 { -- require literal decl for now
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 {
ErrorLoc[m]; m.out.PutRope["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.PutRope["binding required in LET\n"];
tm.PushTree[binding];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], e]]};
v ← tm.MakeNode[$let, 2]};
$arrow, $arrow2 => {
decl: Tree.Link ~ EvalToDecl[m, TreeOps.NthSon[node, 1], e];
tm.PushTree[decl];
IF IsDecl[decl] THEN { -- require literal decl for now
d: Tree.Handle ~ NARROW[decl];
MakeIds[tm, d, TRUE];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], ConsEnv[tm, d, e]]]}
ELSE {
ErrorLoc[m]; m.out.PutRope["decl required in ->\n"];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], e]]};
v ← tm.MakeNode[node.name, 2];
IF node.name = $arrow2 THEN
TreeOps.PutExt[v, ConsClosure[tm, TreeOps.NthSon[node, 2], e]];
};
$apply, $applyDefault => v ← Appl[m, node, e, node.name=$applyDefault];
$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 %g\n", IO.atom[name]]};
};
tm.PushTree[binding]; tm.PushName[name];
v ← tm.MakeNode[$subscript, 2]};
$union, $then => {
rand1: Tree.Link ~ Eval[m, TreeOps.NthSon[node, 1], e];
rand2: Tree.Link ~ Eval[m, TreeOps.NthSon[node, 2], e];
IF ~HasType[m, rand2, ToInterface[m, Type[m, rand1]]] THEN {
ErrorLoc[m]; m.out.PutF["Invalid argument type for + or THEN\n"]};
tm.PushTree[rand1]; tm.PushTree[rand2];
v ← tm.MakeNode[node.name, 2]};
$group => v ← tm.CopyTree[t, BindSon];
$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]]]};
$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]};
$env => {v ← tm.MakeNode[$env, 0]; TreeOps.PutExt[v, e]};
$nil, $control => v ← tm.MakeNode[node.name, 0];
$unitId => v ← BindFile[m, t];
$typeSTRING, $stamp, $cross => v ← tm.CopyTree[t, BindSon];
$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 { -- require literal decl for now
ErrorLoc[m]; m.out.PutRope["decl required in xx\n"];
tm.PushTree[Eval[m, TreeOps.NthSon[node, 2], e]]};
v ← tm.MakeNode[$cross2, 2];
TreeOps.PutExt[v, ConsClosure[tm, TreeOps.NthSon[node, 2], e]]};
$locator => v ← Eval[m, node.son[1], e];
ENDCASE => {
ErrorLoc[m]; m.out.PutF["Unimplemented construct\n"];
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]};
file expansion
BindFile: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[v: Tree.Link] ~ {
shortName: Rope.ROPE ~ NARROW[TreeOps.NthSon[t, 3]];
SELECT TRUE FROM
CS.EndsIn[shortName, ".mesa"], CS.EndsIn[shortName, ".bcd"] => {
tree: Tree.Link ~ SMFIOps.EvaluateUnitId[m, t];
v ← Eval[m, tree, NIL];  -- currently a no-op
IF Type[m, v] = Tree.null THEN {
ErrorLoc[m]; m.out.PutF["%g has unknown type\n", IO.rope[SMFIOps.UnitToRope[t]]]};
};
CS.EndsIn[shortName, ".model"], CS.EndsIn[shortName, ".modelBcd"] => {
unitId: Rope.ROPE ~ SMFIOps.UnitToRope[t];
subModel: Tree.Link ← NARROW[TreeOps.GetExt[t]];
IF subModel = Tree.null THEN {
source: IO.STREAM ← NIL;
source ← FS.StreamOpen[fileName~unitId, wDir~m.wDir ! FS.Error => {CONTINUE}];
IF source = NIL THEN {
ErrorLoc[m]; m.out.PutF["%g could not be opened\n", IO.rope[unitId]];
v ← t}
ELSE {
newM: SMOps.MS ~ SMOps.NewModel[in~m.in, out~m.out, msgout~m.msgOut];
newM.wDir ← (IF CS.PartialName[unitId] THEN m.wDir ELSE CS.DirectoryPart[unitId]);
(newM.tm).Initialize;
IF CS.EndsIn[unitId, ".modelBcd"] THEN -- advance input stream
SMBcd.ReadModelBcdPrefix[newM, source];
subModel ← SMUtil.ParseStream[newM, source];
TreeOps.PutExt[t, subModel];
v ← Eval[newM, subModel, NIL];
IF newM.errors THEN m.errors ← TRUE;
(newM.tm).Finalize}
}
ELSE v ← Eval[m, subModel, NIL]};
ENDCASE => v ← t
};
type attributres and predicates
Type: PROC[m: SMOps.MS, t: Tree.Link] RETURNS[type: Tree.Link] ~ {
WITH t SELECT FROM
id: Tree.Id => {
d: Tree.Handle;
IF ~id.mark2 THEN EvalId[m, id];
d ← 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 => {
type ← node.type;
IF type = Tree.null THEN {
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 => {
rator: Tree.Link ~ TreeOps.NthSon[node, 1];
type ← Range[m, Type[m, rator], node]};
$subscript => {
s: Tree.Link ~ Select[m, t];
IF s # t THEN type ← Type[m, s]
ELSE {
subType: Tree.Link ~ Type[m, TreeOps.NthSon[t, 1]];
index: Tree.Name ~ TreeOps.GetName[TreeOps.NthSon[t, 2]];
IF IsDecl[subType] THEN {
d: Tree.Handle ~ NARROW[subType];
p: NAT ~ SearchD[index, d];
type ← (IF p#0 THEN DeclType[d.son[p]] ELSE Tree.null)}
ELSE {
(m.tm).PushTree[subType]; (m.tm).PushName[index];
type ← Select[m, (m.tm).MakeNode[$subscript, 2]]};
};
};
$union, $then => type ← ToInterface[m, Type[m, TreeOps.NthSon[t, 1]]];
$decl => type ← (m.tm).MakeNode[$typeDECL, 0];
IN Tree.BindOp => type ← DBtoD[node];
ENDCASE => type ← Tree.null;
node.type ← type};
};
fiSrc: SMFI.SrcFileInfo => type ← fiSrc.type;
fiBcd: SMFI.BcdFileInfo => type ← fiBcd.type;
ENDCASE => type ← Tree.null;
RETURN};
type attributes
Domain: PROC[t: Tree.Link] RETURNS[Tree.Link] ~ {
RETURN[SELECT TreeOps.OpName[t] FROM
$arrow, $arrow2 => TreeOps.NthSon[t, 1],
ENDCASE => Tree.null]
};
Range: PROC[m: SMOps.MS, type, t: Tree.Link] RETURNS[range: Tree.Link] ~ {
SELECT TreeOps.OpName[type] FROM
$arrow => range ← TreeOps.NthSon[type, 2];
$arrow2 => {
tm: TreeOps.TM ~ m.tm;
decl: Tree.Link ~ TreeOps.NthSon[type, 1];
rands: Tree.Link ~ ValOf[m, TreeOps.NthSon[t, 2]];
protoRange: Closure ~ NARROW[TreeOps.GetExt[type]];
b: Tree.Handle;
e: Env;
tm.PushTree[tm.CopyTree[decl, TreeOps.IdentityMap]]; tm.SetAttr[1, FALSE];
tm.PushTree[rands];
b ← NARROW[tm.MakeNode[$nBind, 2]];
e ← ConsEnv[tm, b, protoRange.e]; TreeOps.PutExt[b, e];
MakeIds[tm, b, TRUE];
range ← Eval[m, protoRange.body, e]};
ENDCASE => range ← Tree.null;
RETURN};
type predicates
ValOfNthSon: PROC[m: SMOps.MS, t: Tree.Link, n: Tree.SonId] RETURNS[Tree.Link] ~ {
RETURN[ValOf[m, TreeOps.NthSon[t, n]]]};
Eq: PROC[type1, type2: Tree.Link] RETURNS[BOOL] ~ INLINE {
RETURN[type1 = type2]};
Equiv: PUBLIC PROC[m: SMOps.MS, type1, type2: Tree.Link] RETURNS[BOOL] ~ {
RETURN[Equal[m, type1, type2 ! MatchedDB => {RESUME[FALSE]}]]};
MatchedDB: SIGNAL[d1, d2: Tree.Link] RETURNS[BOOL] ~ CODE;
Equal: PROC[m: SMOps.MS, type1, type2: Tree.Link] RETURNS[BOOL] ~ {
OpPair: TYPE = RECORD[op1, op2: Tree.NodeName];
RETURN[
Eq[type1, type2]
OR
(SELECT OpPair[TreeOps.OpName[type1], TreeOps.OpName[type2]] FROM
[$arrow, $arrow] =>
EquivDecls[m, ValOfNthSon[m, type1, 1], ValOfNthSon[m, type2, 1]]
AND
Equal[m, ValOfNthSon[m, type1, 2], ValOfNthSon[m, type2, 2]],
[$arrow2, $arrow2] =>
EquivDecls[m, ValOfNthSon[m, type1, 1], ValOfNthSon[m, type2, 1]]
AND
Equal[m, ValOfNthSon[m, type1, 2], ValOfNthSon[m, type2, 2]
! MatchedDB => {
IF d1 = ValOfNthSon[m, type1, 1] AND d2 = ValOfNthSon[m, type2, 1] THEN
RESUME[TRUE]}
],
[$cross, $cross] =>
Equal[m, ValOfNthSon[m, type1, 1], ValOfNthSon[m, type2, 1]]
AND
Equal[m, ValOfNthSon[m, type1, 2], ValOfNthSon[m, type2, 2]],
[$cross2, $cross2] =>
EquivDecls[m, ValOfNthSon[m, type1, 1], ValOfNthSon[m, type2, 1]]
AND
Equal[m, ValOfNthSon[m, type1, 2], ValOfNthSon[m, type2, 2]
! MatchedDB => {
IF d1 = ValOfNthSon[m, type1, 1] AND d2 = ValOfNthSon[m, type2, 1] THEN
RESUME[TRUE]}
],
[$type, $type] => EquivTypes[m, type1, type2],
[$typeSTRING, $typeSTRING] => TRUE,
[$apply, $apply] => EquivAppls[m, type1, type2],
[$apply, $stamp] => Equal[m, type2, type1],
[$stamp, $stamp] => EquivStamps[m, type1, type2],
[$stamp, $apply] => TRUE, -- temporary loophole, to avoid stamp computation here
[$stamp, $none] => Equal[m, type2, type1],
[$subscript, $subscript] =>
TreeOps.GetName[TreeOps.NthSon[type1, 2]] =
TreeOps.GetName[TreeOps.NthSon[type2, 2]]
AND
Equal[m, ValOfNthSon[m, type1, 1], ValOfNthSon[m, type2, 1]],
[$control, $control] => TRUE,
[$nil, $nil] => TRUE,
ENDCASE =>
WITH type1 SELECT FROM
id1: Tree.Id =>
WITH type2 SELECT FROM
id2: Tree.Id =>
(IdP[id1] = IdP[id2]) AND (SIGNAL MatchedDB[IdDB[id1], IdDB[id2]]),
ENDCASE => FALSE,
fiBcd: SMFI.BcdFileInfo =>
SELECT TreeOps.OpName[type2] FROM
$stamp => GetStamp[TreeOps.NthSon[type2, 1]]^ = fiBcd.stamp,
ENDCASE => FALSE,
ENDCASE => FALSE
)]
};
Implies: PUBLIC PROC[m: SMOps.MS, type1, type2: Tree.Link] RETURNS[BOOL] ~ {
RETURN[
Eq[type1, type2] OR Equal[m, type1, type2 ! MatchedDB => {RESUME[FALSE]}]
OR
(SELECT TreeOps.OpName[type1] FROM
$type =>
(SELECT TreeOps.OpName[type2] FROM
$type => TreeOps.NthSon[type2, 1] = Tree.null,
ENDCASE => FALSE),
ENDCASE => FALSE)]
};
CoercesTo: PROC[m: SMOps.MS, v1, type1, type2: Tree.Link] RETURNS[BOOL] ~ {
RETURN[
Implies[m, type1, type2]
OR
(SELECT TreeOps.OpName[type1] FROM
$decl => OneImplies[m, type1, type2],
$cross =>
CoercesTo[m, v1, ValOfNthSon[m, type1, 1], type2]
OR
CoercesTo[m, v1, ValOfNthSon[m, type1, 2], type2],
$cross2 =>
TreeOps.OpName[type2] = $control
OR
OneImplies[m, TreeOps.NthSon[type1, 1], type2]
OR
CoercesTo[m, v1, ValOf[m, BindCross2[m, type1, v1]], type2], -- v1 not right here
ENDCASE => FALSE)]
};
BindCross2: PROC[m: SMOps.MS, type, t: Tree.Link] RETURNS[Tree.Link] ~ {
tm: TreeOps.TM ~ m.tm;
decl: Tree.Link ~ TreeOps.NthSon[type, 1];
index: Tree.Name ~ IdName[NthId[NARROW[decl], 1]];
protoRange: Closure ~ NARROW[TreeOps.GetExt[type]];
b: Tree.Handle;
e: Env;
tm.PushTree[tm.CopyTree[decl, TreeOps.IdentityMap]]; tm.SetAttr[1, FALSE];
tm.PushTree[t]; tm.PushName[index]; tm.PushNode[$subscript, 2];
tm.PushNode[$group, 1];
b ← NARROW[tm.MakeNode[$nBind, 2]];
e ← ConsEnv[tm, b, protoRange.e]; TreeOps.PutExt[b, e];
MakeIds[tm, b, TRUE];
RETURN[Eval[m, protoRange.body, e]]};
OneImplies: PROC[m: SMOps.MS, type1, type2: Tree.Link] RETURNS[BOOL] ~ {
SELECT TreeOps.OpName[type1] FROM
$decl => {
FOR i: Tree.SonId IN [1 .. TreeOps.NSons[type1]] DO
subType: Tree.Link ~ ValOf[m, DeclType[TreeOps.NthSon[type1, i]]];
IF Implies[m, subType, type2] THEN RETURN[TRUE]
ENDLOOP;
RETURN[FALSE]}
ENDCASE => RETURN[FALSE]
};
ImpliesAll: PROC[m: SMOps.MS, v1, type1, type2: Tree.Link] RETURNS[BOOL] ~ {
SELECT TreeOps.OpName[type2] FROM
$decl => {
FOR i: Tree.SonId IN [1 .. TreeOps.NSons[type2]] DO
subType: Tree.Link ~ ValOf[m, DeclType[TreeOps.NthSon[type2, i]]];
IF ~CoercesTo[m, v1, type1, subType] THEN RETURN[FALSE]
ENDLOOP;
RETURN[TRUE]}
ENDCASE => RETURN[FALSE]
};
EquivTypes: PROC[m: SMOps.MS, t1, t2: Tree.Link] RETURNS[BOOL] ~ {
name1: Tree.Link ~ TreeOps.NthSon[t1, 1];
name2: Tree.Link ~ TreeOps.NthSon[t2, 1];
RETURN[
((name1 = Tree.null) = (name2 = Tree.null))
AND
(name1 = Tree.null OR TreeOps.GetName[name1] = TreeOps.GetName[name2])]
};
EquivDecls: PROC[m: SMOps.MS, decl1, decl2: Tree.Link] RETURNS[BOOL] ~ {
n: NAT ~ TreeOps.NSons[decl1];
IF n # TreeOps.NSons[decl2] THEN RETURN[FALSE];
FOR i: Tree.SonId IN [1 .. n] DO
elem1: Tree.Link ~ ValOfNthSon[m, decl1, i];
elem2: Tree.Link ~ ValOfNthSon[m, decl2, i];
IF --(TreeOps.NthSon[elem1, 1] # TreeOps.NthSon[elem2, 1])
OR
~Equal[m, ValOfNthSon[m, elem1, 2], ValOfNthSon[m, elem2, 2]]
THEN RETURN[FALSE]
ENDLOOP;
RETURN[TRUE]};
EquivAppls: PROC[m: SMOps.MS, t1, t2: Tree.Link] RETURNS[BOOL] ~ {
rator1: Tree.Link ~ ValOfNthSon[m, t1, 1];
rator2: Tree.Link ~ ValOfNthSon[m, t2, 1];
RETURN[WITH rator1 SELECT FROM
fiSrc1: SMFI.SrcFileInfo =>
(WITH rator2 SELECT FROM
fiSrc2: SMFI.SrcFileInfo =>
fiSrc1.create = fiSrc2.create
AND
EquivArgs[m, ValOfNthSon[m, t1, 2], ValOfNthSon[m, t2, 2]],
ENDCASE => FALSE),
fiBcd1: SMFI.BcdFileInfo =>
(WITH rator2 SELECT FROM
fiBcd2: SMFI.BcdFileInfo => fiBcd1.stamp = fiBcd2.stamp,
ENDCASE => FALSE),
node1: Tree.Handle =>
(WITH rator2 SELECT FROM
node2: Tree.Handle =>
TreeOps.OpName[node1] IN Tree.ApplOp AND TreeOps.OpName[node2] IN Tree.ApplOp
AND
EquivAppls[m, rator1, rator2],
ENDCASE => FALSE),
ENDCASE => FALSE]
};
EquivArgs: PROC[m: SMOps.MS, args1, args2: Tree.Link] RETURNS[BOOL] ~ {
IF TreeOps.OpName[args1] # $group OR TreeOps.OpName[args2] # $group THEN
RETURN[FALSE];
IF TreeOps.NSons[args1] # TreeOps.NSons[args2] THEN RETURN[FALSE];
FOR i: Tree.SonId IN [1 .. TreeOps.NSons[args1]] DO
arg1: Tree.Link ~ ValOfNthSon[m, args1, i];
arg2: Tree.Link ~ ValOfNthSon[m, args2, i];
WITH arg1 SELECT FROM
node: Tree.Handle =>
IF TreeOps.OpName[arg1] NOT IN Tree.ApplOp
OR TreeOps.OpName[arg2] NOT IN Tree.ApplOp
OR ~EquivAppls[m, arg1, arg2]
THEN RETURN[FALSE];
switches1: Tree.Text =>
WITH arg2 SELECT FROM
switches2: Tree.Text =>
IF ~switches1.Equal[switches2, FALSE] THEN RETURN[FALSE];
ENDCASE => RETURN[FALSE];
ENDCASE => RETURN[FALSE]
ENDLOOP;
RETURN[TRUE]
};
GetStamp: PROC[t: Tree.Link] RETURNS[Tree.Stamp] ~ INLINE {
RETURN[NARROW[t]]};
EquivStamps: PROC[m: SMOps.MS, t1, t2: Tree.Link] RETURNS[BOOL] ~ {
RETURN[GetStamp[TreeOps.NthSon[t1, 1]]^ = GetStamp[TreeOps.NthSon[t2, 1]]^]};
}.