
<<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]]^]};

}.