DIRECTORY
AMBridge USING
[FHFromTV, GetWorld, GFHFromTV, IsRemote, Loophole, PointerFromTV, RemoteFHFromTV, RemoteGFHFromTV, SetTVFromLC, SomeRefFromTV, TVForReadOnlyReferent, TVForReferent, TVToCardinal, TVToInteger, TVToLC, TVToLI, TVToReal],
AMBridgeExtras USING
[AssignNew],
AMTypes USING
[Apply, Class, Copy, Domain, Error, First, GroundStar, IndexToTV, IndexToType, IsComputed, IsOverlaid, Last, Length, NameToIndex, NComponents, New, Next, Range, Referent, Tag, TVEqual, TVSize, TVStatus, TVToType, TVType, TypeClass, TypeToName, UnderType, VariableType, Variant],
AtomsPrivate USING [GetAtom],
BBApply USING [ApplyProcToRecord, CalculateRecordSize],
BBContext USING
[Context, ContextForGlobalFrame, GlobalFrameSearch, RecordSearch, StackSearch],
BBEmptyReturn USING [TheEmptyReturn],
BBEval USING
[AbortProc, EvalHead, EvalHeadRep, HelpDefault, HelpFatal, HelpId, HelpSelector, HelpWrongType, RopeOrTV, Tree],
BBEvalQuote USING [EvalQuoteProc, Lookup],
BBEvalUtil USING
[EnumeratedValueFromRope, EvalRecord, FirstComponent, LocalCoerce, LocalUnderTypeAndClass, Momma, NewInt, NewReal, NewType, SafeAssign, TestAbort, TreeToRope, UnderTypeAndClass, UnderWear, WorldFromHead],
BBSafety USING [Mother],
BBUrpEval USING [UrpFatal, UrpId, UrpSelector, UrpWrongType],
PPLeaves USING [HTIndex, LTIndex],
PPTree USING [Handle, Link, NodeName],
Real USING [FRem],
Rope USING [Flatten, Match, ROPE, Size],
RTBasic USING [nullType, TV, Type],
RTMiniModel USING [AcquireIRInstance, AcquireIRType],
RTSymbolDefs USING [SymbolTableBase, symbolIndexForTYPE],
RTSymbolOps USING [AcquireType],
RTSymbols USING [GetTypeSymbols, ReleaseSTB],
SymTab USING [Create, Fetch, Ref, Store],
WorldVM USING [LocalWorld, World];

BBEvalImpl: CEDAR MONITOR
IMPORTS
AMBridge, AMBridgeExtras, AMTypes, AtomsPrivate, BBApply, BBContext, BBEmptyReturn, BBEvalQuote, BBEvalUtil, BBSafety, BBUrpEval, Real, Rope, RTMiniModel, RTSymbolOps, RTSymbols, SymTab, WorldVM
EXPORTS BBEval, BBEvalUtil
SHARES  BBEval
= BEGIN OPEN BBEval, BBEvalUtil, BBUrpEval, AMBridge, AMTypes;

CARD: TYPE = LONG CARDINAL;
Id: TYPE = REF IdRep;
IdRep: TYPE = RECORD [name: ROPE, value: TV];
LORA: TYPE = LIST OF REF; 
Node: TYPE = PPTree.Handle;
ROPE: TYPE = Rope.ROPE;
TV: TYPE = RTBasic.TV;
Type: TYPE = RTBasic.Type;
nullType: Type = RTBasic.nullType;


empty: TV _ BBEmptyReturn.TheEmptyReturn[];
stackSearchDepth: INTEGER _ 8;

underLORA: Type _ CODE[LORA];
underPROC: Type _ CODE[PROC];
underREF: Type _ CODE[REF];
underBOOL: Type _ CODE[BOOL];
underTYPE: Type _ CODE[Type];
underCARD: Type _ CODE[CARD];

trueCard: CARDINAL _ LOOPHOLE[TRUE, CARDINAL];
falseCard: CARDINAL _ LOOPHOLE[FALSE, CARDINAL]; 

true: TV _ NIL;
false: TV _ NIL;
NilTV: PUBLIC TV _ NIL;

symtab: SymTab.Ref _ NIL; 

tvWorldInit: BOOL _ FALSE;
tvWorldInitMsg: ROPE _ NIL; -- reason for failure to init (if any)


CantHandleRemote: ERROR = CODE;

EnsureInit: ENTRY PROC = {
ENABLE UNWIND => NULL;
inner: PROC = TRUSTED {
IF symtab = NIL THEN symtab _ SymTab.Create[151, TRUE];
true _ TVForReadOnlyReferent[NEW[BOOL _ TRUE]];
false _ TVForReadOnlyReferent[NEW[BOOL _ FALSE]];
NilTV _ TVForReadOnlyReferent[NEW[REF _ NIL]];
[] _ symtab.Store["TRUE", true];
[] _ symtab.Store["FALSE", false];
underLORA _ AMTypes.UnderType[underLORA];
underPROC _ AMTypes.UnderType[underPROC];
underREF _ AMTypes.UnderType[underREF];
underBOOL _ AMTypes.UnderType[underBOOL];
underTYPE _ AMTypes.UnderType[underTYPE];
underCARD _ AMTypes.UnderType[underCARD];
tvWorldInit _ TRUE;
};
IF NOT tvWorldInit THEN tvWorldInitMsg _ BBSafety.Mother[inner];
};

GetSymTab: PUBLIC PROC RETURNS [SymTab.Ref] = {
EnsureInit[];
RETURN [symtab]
}; 

NewEvalHead: PUBLIC PROC [
context: BBContext.Context,
helpFatal: HelpFatal,
helpWrongType: HelpWrongType _ NIL,
helpId: HelpId _ NIL,
helpSelector: HelpSelector _ NIL,
helpDefault: HelpDefault _ NIL,
data: REF _ NIL,
specials: SymTab.Ref _ NIL,
globalContext: BBContext.Context _ NIL,
abortProc: AbortProc _ NIL]
RETURNS [EvalHead] = {
RETURN [
NEW [
EvalHeadRep_ [
context: context,
helpFatal: helpFatal,
helpWrongType: helpWrongType,
helpId: helpId,
helpSelector: helpSelector,
helpDefault: helpDefault,
data: data,
specials: specials,
globalContext: globalContext,
abortProc: abortProc]]]
}; 

EvalNoProps: PUBLIC PROC
[tree: Tree, head: EvalHead, target: Type] RETURNS [TV] = {
IF tree = NIL THEN RETURN [NIL];
IF NOT tvWorldInit THEN EnsureInit[];
WITH tree SELECT FROM
hti: PPLeaves.HTIndex => RETURN [Lookup[hti.name, head, target, tree]];
name: ROPE => RETURN [Lookup[name, head, target, tree]];
lti: PPLeaves.LTIndex => RETURN [EvalLti[lti, head, target]];
node: Node => RETURN [EvalNode[node, head, target]]
ENDCASE => ERROR
}; 

EvalNode: PROC
[node: Node, head: EvalHead, target: Type] RETURNS [rtn: TV _ NIL] = TRUSTED {
errmsg: ROPE _ NIL;
rtnRef: REF _ NIL;
kind: PPTree.NodeName = node.name;
nSons: CARDINAL _ node.sonLimit - 1;
son1: Tree _ IF nSons > 0 THEN node.son[1] ELSE NIL;
son2: Tree _ IF nSons > 1 THEN node.son[2] ELSE NIL;
SubEval: PROC [tree: Tree, target: Type] RETURNS [TV] = TRUSTED {
RETURN [EvalNoProps[tree, head, target]];
};
SubEval0: PROC [tree: Tree] RETURNS [TV] = TRUSTED {
RETURN [EvalNoProps[tree, head, nullType]];
};
SubEval1: PROC [tree: Tree] RETURNS [TV] = TRUSTED {
RETURN [EvalNoProps[tree, head, target]];
};
GentleRef: PROC [tv: TV] RETURNS [ref: REF _ NIL] = TRUSTED {
IF AMBridge.IsRemote[tv] THEN ERROR CantHandleRemote;
SELECT UnderWear[tv, head, node].class FROM
nil => ref _ NIL;
ref, list, rope, atom => ref _ LOOPHOLE[TVToLC[tv]];
ENDCASE => ref _ SomeRefFromTV[tv];
RETURN [ref]
};
Listify: PROC [tv: TV] RETURNS [LORA] = TRUSTED {
RETURN [LIST[GentleRef[tv]]]
};
EvalBool: PROC [tree: Tree] RETURNS [BOOL] = TRUSTED {
RETURN [ForceBoolean[SubEval[tree, underBOOL], head, tree]]
};
{SELECT kind FROM
assignx, assign, extractx, extract =>
RETURN [EvalAssign[son1, son2, head, target, node]];
if, ifx => {
test: BOOL _ EvalBool[son1];
IF NOT test THEN
son2 _ IF nSons > 2 THEN node.son[3] ELSE NIL;
RETURN [SubEval1[son2]]};

processTC =>
RETURN [Lookup["PROCESS", head, target, node]];
longTC => {
tv1: TV _ SubEval0[son1];
type: Type _ ForceType[tv1, head, son1];
SELECT LocalUnderTypeAndClass[type, head, node].class FROM
cardinal => RETURN [symtab.Fetch["CARD"].val];
integer => RETURN [symtab.Fetch["INT"].val];
ENDCASE => GO TO NYI;
};
apply =>
RETURN [EvalApply[son1, son2, head, target, node]];
cons => {
elemTree: Tree _ ListElem[son2, 1];
listTree: Tree _ ListElem[son2, 2];
top: LORA _ Listify[SubEval[elemTree, underREF]];
rest: TV _ SubEval[listTree, underLORA];
rtnRef _ NEW[LORA _ top];
DO restUnder: Type;
restClass: Class;
[, restUnder, restClass] _ UnderWear[rest, head, node];
IF restClass = nil THEN GO TO forRef;
IF restUnder = underLORA THEN EXIT;
rest _ LocalCoerce
[head, listTree, rest, underLORA, 0, "invalid list"];
ENDLOOP;
top.rest _ NARROW[GentleRef[rest], LORA];
GO TO forRef};
listcons => {
elems: Tree _ son2;
pos: CARDINAL _ 1;
top, last: LORA _ NIL;
IF elems = NIL THEN RETURN [NIL];
WITH elems SELECT FROM
n: Node =>
IF n.name = list THEN
FOR i: CARDINAL IN [1..n.sonLimit) DO
etv: TV _ SubEval[n.son[i], underREF];
elist: LORA _ Listify[etv];
IF top = NIL THEN top _ elist ELSE last.rest _ elist;
last _ elist
ENDLOOP
ENDCASE;
IF top = NIL THEN
top _ Listify[SubEval[elems, underREF]];
rtnRef _ NEW[LORA _ top];
GO TO forRef};
or, and => {
bool: BOOL _ EvalBool[son1];
IF kind = and AND NOT bool THEN RETURN [false];
IF kind = or AND bool THEN RETURN [true];
RETURN [IF EvalBool[son2] THEN true ELSE false]};
not =>
RETURN [IF EvalBool[son1] THEN false ELSE true];
relE, relN, relL, relGE, relG, relLE =>
RETURN [EvalBinop[son1, son2, kind, head, underBOOL, node]];
plus, minus, times, div, mod =>
RETURN [EvalBinop[son1, son2, kind, head, target, node]];
min, max => {
bestUnder: Type _ nullType;
bestClass: Class _ nil;
bestCard: CARD _ 0;
listNode: Node _ NIL;
WITH son1 SELECT FROM
n: Node => {listNode _ n; nSons _ n.sonLimit - 1};
ENDCASE => nSons _ 1;
FOR i: NAT IN [1..nSons] DO
arg: Tree _ IF listNode # NIL THEN listNode.son[i] ELSE son1;
each: TV _ SubEval1[arg];
eachUnder: Type;
eachClass: Class _ UnderWear[each, head, node].class;
eachCard: CARD;
swap: BOOL _ kind = min;  -- if each > best, then swap _ NOT swap
IF eachClass = subrange THEN {
groungHog: PROC = TRUSTED {
eachUnder _ AMTypes.GroundStar[eachUnder];
eachClass _ AMTypes.TypeClass[eachUnder];
};
Momma[groungHog, head, node, "GroundStar"];
};
SELECT eachClass FROM
cardinal, longCardinal, character => {
eachCard _ AMBridge.TVToLC[each];
IF eachClass # longCardinal THEN eachClass _ longCardinal;
SELECT bestClass FROM
longCardinal => {
IF eachCard > bestCard THEN swap _ NOT swap;
};
longInteger => {
IF LOOPHOLE[bestCard, INT] < 0 OR eachCard > bestCard THEN
swap _ NOT swap;
};
real => {
real: REAL _ eachCard; -- force the conversion
IF real > LOOPHOLE[bestCard, REAL] THEN swap _ NOT swap;
};
nil => swap _ TRUE;
ENDCASE => GO TO notComparable;
};
enumerated => {
eachCard _ AMBridge.TVToLC[each];
SELECT bestClass FROM
enumerated => {
IF eachCard > bestCard THEN swap _ NOT swap;
};
nil => swap _ TRUE;
ENDCASE => GO TO notComparable;
};
integer, longInteger =>  {
eachInt: INT _ AMBridge.TVToLI[each];
eachCard _ LOOPHOLE[eachInt];
IF eachClass # longInteger THEN eachClass _ longInteger;
SELECT bestClass FROM
longCardinal =>
IF eachInt > 0 AND eachCard > bestCard THEN swap _ NOT swap;
longInteger =>
IF eachInt > LOOPHOLE[bestCard, INT] THEN swap _ NOT swap;
real => {
real: REAL _ eachInt; -- force the conversion
IF real > LOOPHOLE[bestCard, REAL] THEN swap _ NOT swap;
};
nil => swap _ TRUE;
ENDCASE => GO TO notComparable;
};
real => {
eachReal,bestReal: REAL;
eachCard _ AMBridge.TVToLC[each];
eachReal _ LOOPHOLE[eachCard];
SELECT bestClass FROM
longCardinal => bestReal _ bestCard;
longInteger => bestReal _ LOOPHOLE[bestCard, INT];
real => bestReal _ LOOPHOLE[bestCard];
nil => GO TO noCompare;
ENDCASE => GO TO notComparable;
IF eachReal > bestReal THEN swap _ NOT swap;
EXITS noCompare => {swap _ TRUE};
};
ENDCASE => GO TO notOrdered;
IF swap THEN {
rtn _ each;
bestUnder _ eachUnder;
bestClass _ eachClass;
bestCard _ eachCard};
ENDLOOP;
RETURN;
EXITS
notOrdered => UrpFatal[head, node, "not an ordered type"];
notComparable => UrpFatal[head, node, "incomparable types"];
};
dot =>
RETURN [EvalDot[son1, son2, node, head, target].tv];
uminus, abs =>
RETURN [EvalUnop[son1, kind, head, target]];
all =>
RETURN [EvalArray[son1, head, target, node, TRUE]];
addr => {
tv: TV _ SubEval0[son1];
lp: LONG POINTER _ NIL;
lp _ PointerFromTV[tv ! AMTypes.Error => CONTINUE];
IF lp # NIL THEN
{rtnRef _ NEW[LONG POINTER _ lp];
GO TO forRef};
IF (rtnRef _ GentleRef[tv]) # NIL THEN
{rtnRef _ NEW[REF _ rtnRef]; GO TO forRef};
errmsg _ "could not get address";
GO TO fatal};
uparrow =>
RETURN[SafeReferent[SubEval0[son1], head, node]];
lengthen, mwconst, clit, llit =>
GO TO evalSon;
size, typecode, first, last => {
type: Type _ ForceType[SubEval0[son1], head, node];
SELECT kind FROM
size => {
rtnRef _ NEW[CARDINAL _ BBApply.CalculateRecordSize[type]];
GO TO forRef};
typecode =>
RETURN[NewType[type]];
first =>
RETURN [First[type]];
last =>
RETURN [Last[type]]
ENDCASE => ERROR};
loophole => {
IF son2 # NIL THEN
target _ ForceType[SubEval0[son2], head, node];
RETURN [LocalLoophole[head, node, SubEval[son1, target], target]];
};
nil => RETURN [NilTV];
new => {
world: WorldVM.World _ BBEvalUtil.WorldFromHead[head];
IF world # WorldVM.LocalWorld[]
THEN GO TO notRemote
ELSE {
son3: Tree _ IF nSons > 2 THEN node.son[3] ELSE NIL;
repType: Type _ ForceType[SubEval0[son2], head, node];
rtn: TV _ IF son3 = NIL THEN NIL ELSE SubEval[son3, repType];
ref: REF _ NIL;
innerNew: PROC = TRUSTED {
IF son3 = NIL
THEN rtn _ AMTypes.New[type: repType, world: world]
ELSE rtn _ AMTypes.Copy[rtn];
ref _ AMBridge.SomeRefFromTV[rtn];
rtnRef _ NEW[REF _ ref];
};
Momma[innerNew, head, node, "NEW"];
GO TO forRef;
};
};
atom => {
name: ROPE _ TreeToRope[son1];
atom: ATOM _ AtomsPrivate.GetAtom
[name.Flatten[IF Rope.Match["$*", name] THEN 1 ELSE 0]];
IF atom = NIL THEN {
errmsg _ "invalid atom";
GO TO fatal};
rtnRef _ NEW[ATOM _ atom];
GO TO forRef};
length => {
tv: TV _ SubEval0[son1];
type,under: Type;
class: Class;
DO
[type,under,class] _ UnderWear[tv, head, son1];
SELECT class FROM
descriptor, longDescriptor, rope =>
RETURN [NewInt[AMTypes.Length[tv]]];
ENDCASE =>
tv _ UrpWrongType[head, son1, tv, target, "not a descriptor"];
ENDLOOP
};
ENDCASE => GO TO NYI
EXITS
evalSon =>
RETURN [SubEval1[son1]];
forRef =>
RETURN [TVForReferent[rtnRef]];
fatal =>
UrpFatal[head, node, errmsg];
notRemote =>
UrpFatal[head, node, "not implemented for remote"];
NYI =>
UrpFatal[head, node, "not implemented"]};
ERROR
}; 

ListElem: PROC [tree: Tree, n: CARDINAL _ 1] RETURNS [Tree] = {
IF n = 0 THEN RETURN [tree];
WITH tree SELECT FROM
node: Node =>
IF node.name = list THEN {
IF n IN [1..node.sonLimit) THEN RETURN [node[n]];
RETURN [NIL]}
ENDCASE;
IF n = 1 THEN RETURN [tree] ELSE RETURN [NIL]
}; 

EvalUnop: PROC
[tree: Tree, kind: PPTree.NodeName, head: EvalHead, target: Type]
RETURNS [rtn: TV _ NIL] = TRUSTED {
int: INT _ 0;
rtn _ ForceArithmetic[EvalNoProps[tree, head, target], head, tree];
IF UnderWear[rtn, head, tree].class = real THEN {
real: REAL _ LOOPHOLE[AMBridge.TVToLC[rtn]];
SELECT kind FROM
abs => real _ ABS[real];
uminus => real _ -real;
ENDCASE => ERROR;
RETURN [NewReal[real]];
};
int _ TVToLI[rtn];
SELECT kind FROM
abs => int _ ABS[int];
uminus => int _ -int;
ENDCASE => ERROR;
rtn _ NewInt[int];
}; 

EvalBinop: PROC
[left, right: Tree, kind: PPTree.NodeName, head: EvalHead, target: Type, parent: Tree]
RETURNS [rtn: TV _ NIL] = TRUSTED {
op: PPTree.NodeName _ kind;
lval, rval: TV _ NIL;
ltype, rtype, ttype, altype, artype: Type;
lclass, rclass, alclass, arclass: Class;
rtnBit: BOOL;
lval _ EvalNoProps[left, head, target];
[ttype, ltype, lclass] _ UnderWear[lval, head, left];
IF target = nullType THEN target _ ttype;
rval _ EvalNoProps[right, head, ltype];
[, rtype, rclass] _ UnderWear[rval, head, right];
SELECT kind FROM
relE, relN =>
SELECT lclass FROM
subrange, cardinal, integer, character, longInteger, longCardinal,
real, unspecified => -- these values must be arithmetic
op _ minus
ENDCASE => {
inner: PROC = TRUSTED {eq _ TVEqual[lval, rval]};
lc1,lc2: CARD _ 0;
eq: BOOL _ FALSE;
{ENABLE ANY => GO TO tryLong;
eq _ TVToLC[lval] = TVToLC[rval];
EXITS tryLong =>
Momma[inner, head, parent, "equal test"]};
IF kind = relN THEN eq _ NOT eq;
RETURN [IF eq THEN true ELSE false]};
relL, relGE, relG, relLE => op _ minus
ENDCASE; 


lval _ ForceArithmetic[lval, head, left];
[, altype, alclass] _ UnderWear[lval, head, left];
rval _ ForceArithmetic[rval, head, right];
[, artype, arclass] _ UnderWear[rval, head, right];
IF alclass = real OR arclass = real THEN {
-- raise conciousness to the real level
lreal: REAL _ TVToReal[lval];
rreal: REAL _ TVToReal[rval];
IF lclass # real THEN lreal _ TVToLI[lval];
IF rclass # real THEN rreal _ TVToLI[rval];
SELECT op FROM
plus => lreal _ lreal + rreal;
minus => lreal _ lreal - rreal;
times => lreal _ lreal * rreal;
div => lreal _ lreal / rreal;
mod => lreal _ Real.FRem[lreal, rreal];
min => lreal _ MIN[lreal, rreal];
max => lreal _ MAX[lreal, rreal]
ENDCASE => ERROR;
SELECT kind FROM
relE => rtnBit _ lreal = 0.0;
relN => rtnBit _ lreal # 0.0;
relL => rtnBit _ lreal < 0.0;
relGE => rtnBit _ lreal >= 0.0;
relG => rtnBit _ lreal > 0.0;
relLE => rtnBit _ lreal <= 0.0;
ENDCASE => RETURN [NewReal[lreal]];
IF rtnBit THEN RETURN [true] ELSE RETURN [false];
};
{
lint: INT _ TVToLI[lval];
rint: INT _ TVToLI[rval];
SELECT op FROM
plus => lint _ lint + rint;
minus => lint _ lint - rint;
times => lint _ lint * rint;
div => lint _ lint / rint;
mod => lint _ lint MOD rint;
min => lint _ MIN[lint, rint];
max => lint _ MAX[lint, rint]
ENDCASE => ERROR;
SELECT kind FROM
relE => rtnBit _ lint = 0;
relN => rtnBit _ lint # 0;
relL => rtnBit _ lint < 0;
relGE => rtnBit _ lint >= 0;
relG => rtnBit _ lint > 0;
relLE => rtnBit _ lint <= 0;
ENDCASE => RETURN [NewInt[lint]];
IF rtnBit THEN RETURN [true] ELSE RETURN [false];
}
}; 

Lookup: PROC
[name: ROPE, head: EvalHead, target: Type, parent: Tree]
RETURNS [val: TV _ NIL] = TRUSTED {
ok: BOOL _ FALSE;
tab: SymTab.Ref _ IF head.specials = NIL THEN symtab ELSE head.specials;
inner: PROC = TRUSTED {
gf, lf: TV _ NIL;
IF target # nullType THEN {
val _ EnumeratedValueFromRope[name, target];
IF val # NIL THEN {ok _ TRUE; RETURN}};
IF head.context # NIL THEN {
[gf, lf, val] _ BBContext.StackSearch[head.context, name, TRUE, stackSearchDepth];
IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN}};
[gf, lf, val] _ BBContext.StackSearch
[head.globalContext, name, TRUE, stackSearchDepth];
IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN};
};
DO
IF name.Size[] = 0 THEN UrpFatal[head, parent, "invalid name"];
[ok, val] _ tab.Fetch[name];
IF ok THEN RETURN;
IF tab # symtab THEN {
[ok, val] _ symtab.Fetch[name];
IF ok THEN RETURN};
IF NOT Rope.Match["*&*", name] THEN {
Momma[inner, head, name, "lookup"];
IF ok THEN RETURN;
};
{
correct: RopeOrTV _ UrpId[head, parent, name, nullType, target, "undefined"];
WITH c: correct SELECT FROM
both => {val _ c.tv; FixHti[parent, name _ c.rope]; RETURN};
rope => FixHti[parent, name _ c.rope];
tv => {val _ c.tv; RETURN};
ENDCASE};
ENDLOOP;
}; 

LookupTryIR: PROC
[name: ROPE, head: EvalHead, target: Type, parent: Tree]
RETURNS [val: TV _ NIL, IRfound: BOOL _ FALSE] = TRUSTED {
ok: BOOL _ FALSE;
tab: SymTab.Ref _ IF head.specials = NIL THEN symtab ELSE head.specials;
inner: PROC = TRUSTED {
gf, lf: TV _ NIL;
IF target # nullType THEN {
val _ EnumeratedValueFromRope[name, target];
IF val # NIL THEN {ok _ TRUE; RETURN}};
IF head.context # NIL THEN {
[gf, lf, val] _ BBContext.StackSearch[head.context, name, TRUE, stackSearchDepth];
IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN}};
[gf, lf, val] _ BBContext.StackSearch
[head.globalContext, name, TRUE, stackSearchDepth];
IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN};
};
DO
IF name.Size[] = 0 THEN UrpFatal[head, parent, "invalid name"];
[ok, val] _ tab.Fetch[name];
IF ok THEN RETURN;
IF tab # symtab THEN {
[ok, val] _ symtab.Fetch[name];
IF ok THEN RETURN};
IF NOT Rope.Match["*&*", name] THEN {
val _ TryForIRInstance[name, head, parent];
IF val # NIL THEN {IRfound _ TRUE; RETURN};
Momma[inner, head, name, "lookup"];
IF ok THEN RETURN;
};
{
correct: RopeOrTV _ UrpId[head, parent, name, nullType, target, "undefined"];
WITH c: correct SELECT FROM
both => {val _ c.tv; FixHti[parent, name _ c.rope]; RETURN};
rope => FixHti[parent, name _ c.rope];
tv => {val _ c.tv; RETURN};
ENDCASE};
ENDLOOP;
}; 

FixHti: PROC [tree: Tree, fix: ROPE] = {
WITH tree SELECT FROM
hti: PPLeaves.HTIndex => hti.name _ fix.Flatten[]
ENDCASE
}; 

EvalLti: PROC
[lti: PPLeaves.LTIndex, head: EvalHead, target: Type]
RETURNS [TV] = TRUSTED {
val: REF _ lti.value;
WITH val SELECT FROM
rope: ROPE => val _ NEW[ROPE _ rope];
text: REF TEXT => val _ NEW[REF TEXT _ text]
ENDCASE;
RETURN [TVForReadOnlyReferent[val]]
}; 

TryForIRInstance: PROC
[irName: ROPE, head: EvalHead, parent: Tree] RETURNS [irTV: TV _ NIL] = {
inner: PROC = TRUSTED {
world: WorldVM.World = BBEvalUtil.WorldFromHead[head];
irTV _ RTMiniModel.AcquireIRInstance[
irName, world
! ANY -- Should be: AMTypes.Error -- => CONTINUE];
IF irTV = NIL THEN {
irt: Type = RTMiniModel.AcquireIRType[irName, world
 ! AMTypes.Error => GO TO none];
irTV _ CopyToGivenWorld[world, TVForType[irt], TRUE];
EXITS none => {};
};
};
Momma[inner, head, parent, "interface lookup"];
};

EvalDot: PROC
[left, right, parent: Tree, head: EvalHead, target: Type, useDotNotation: BOOL _ FALSE]
RETURNS [tv: TV _ NIL, procTV: TV _ NIL] = TRUSTED {
name: ROPE _ TreeToRope[right];
record: TV _ NIL;
lname: ROPE _ TreeToRope[left];
lnSize: INT _ lname.Size[];
recTV, irTV: TV _ NIL;
msg: ROPE _ NIL;
IRfound: BOOL _ FALSE;
SELECT TRUE FROM
lnSize # 0 => [record, IRfound] _ LookupTryIR[lname, head, nullType, left];
ENDCASE => record _ EvalNoProps[left, head, nullType];
FOR i: NAT IN [1..100] DO
fatal: ROPE _ NIL;
inner: PROC = TRUSTED {
[recTV, tv] _ BBContext.RecordSearch[record, name];
IF IRfound THEN
SELECT UnderClass[AMTypes.TVType[tv]] FROM
procedure, error, signal, program, port =>
IF AMBridge.TVToLC[tv] = 0 THEN fatal _ "NIL procedure from interface";
ENDCASE;
};
innerSearch: PROC = TRUSTED {
modName: REF ROPE _ NEW[ROPE _ NIL];
recType: Type _ AMTypes.TVType[record];
tv _ NIL;
[] _ AMTypes.TypeToName[recType, modName];
IF modName^ = NIL THEN
SELECT UnderClass[recType] FROM
rope => modName^ _ "Rope";
atom => modName^ _ "Atom";
list => modName^ _ "List";
ENDCASE => RETURN;
irTV _ TryForIRInstance[modName^, head, parent];
IF irTV # NIL THEN {
[irTV, tv] _ BBContext.RecordSearch[irTV, name];
};
IF irTV = NIL THEN {
[irTV, tv] _ BBContext.GlobalFrameSearch[head.context, modName^, name];
};
SELECT UnderClass[AMTypes.TVType[tv]] FROM
procedure =>
IF AMBridge.TVToLC[tv] = 0 THEN fatal _ "NIL procedure from interface";
ENDCASE => tv _ NIL;
};
irTV _ recTV _ NIL;
Momma[inner, head, parent, "selection"];
IF fatal # NIL THEN UrpFatal[head, parent, fatal];
IF useDotNotation AND recTV = NIL THEN {
Momma[innerSearch, head, parent, "dotNotation"];
IF fatal # NIL THEN UrpFatal[head, parent, fatal];
IF tv # NIL THEN {
RETURN [record, tv];
};
};
IF recTV = NIL THEN {
correct: RopeOrTV _
UrpSelector[head, parent, name, record, target, "selection failed"];
WITH c: correct SELECT FROM
both => {FixHti[right, name _ c.rope]; tv _ c.tv; EXIT};
rope => FixHti[right, name _ c.rope];
tv => {tv _ c.tv; EXIT};
ENDCASE;
LOOP};
SELECT UnderWear[tv, head, parent].class FROM
union => {
IF OverlaidOrComputed[AMTypes.TVType[tv]] THEN
UrpFatal[head, parent, "Can't handle OVERLAID or COMPUTED"];
tv _ Variant[tv]};
ENDCASE;
RETURN [tv]
ENDLOOP;
}; 

ForceArithmetic: PROC
[val: TV, head: EvalHead, parent: Tree] RETURNS [rtn: TV] = TRUSTED {
oops: BOOL _ FALSE;
inner: PROC = TRUSTED {
ref: REF _ NIL;
int: INT _ 0;
type: Type _ TVType[rtn];
ground: Type _ GroundStar[type];
class: Class _ TypeClass[ground];
SELECT class FROM
real =>
IF type # ground THEN rtn _ NewReal[TVToReal[rtn]];
cardinal, character, unspecified =>
rtn _ NewInt[TVToCardinal[rtn]];
integer =>
rtn _ NewInt[TVToInteger[rtn]];
longCardinal =>
rtn _ NewInt[LOOPHOLE[TVToLC[rtn], INT]];
longInteger =>
IF type # ground THEN rtn _ NewInt[TVToLI[rtn]]
ENDCASE => oops _ TRUE
};
rtn _ StripSingleComponentRecord[val, head, parent];
Momma[inner, head, parent, "arithmetic"];
IF oops THEN UrpFatal[head, parent, "not a number"]
}; 

StripSingleComponentRecord: PROC
[tv: TV, head: EvalHead, parent: Tree, max: NAT _ 100]
RETURNS [rtn: TV] = TRUSTED {
inner: PROC = TRUSTED {
THROUGH [0..max) DO
type, under: Type;
class: Class;
[type, under, class] _ UnderWear[rtn, head, parent];
IF (class # record AND class # structure) THEN EXIT;
IF NComponents[under] # 1 THEN EXIT;
rtn _ FirstComponent[rtn];
ENDLOOP;
};
rtn _ tv;
Momma[inner, head, parent];
}; 

ForceBoolean: PROC
[tv: TV, head: EvalHead, parent: Tree] RETURNS [BOOL] = TRUSTED {
rtn: TV _ tv;
DO
rtn _ StripSingleComponentRecord[rtn, head, parent];
IF AMTypes.UnderType[AMTypes.TVType[tv]] = underBOOL THEN {
card: CARDINAL _ TVToCardinal[rtn];
IF card = trueCard THEN RETURN [TRUE];
IF card = falseCard THEN RETURN [FALSE]};
rtn _ UrpWrongType[head, parent, rtn, underBOOL, "not boolean"]
ENDLOOP
}; 

ForceType: PROC
[tv: TV, head: EvalHead, parent: Tree] RETURNS [type: Type] = TRUSTED {
rtn: TV _ tv;
DO type, under: Type;
class: Class;
[type, under, class] _ UnderWear[rtn, head, parent];
IF class = type THEN RETURN [AMTypes.TVToType[rtn]];
IF under = underTYPE THEN RETURN [LOOPHOLE[AMBridge.TVToCardinal[rtn]]];
UrpFatal[head, parent, "not a TYPE"];
ENDLOOP
}; 

EvalApply: PROC
[proc, args: Tree, head: EvalHead, target: Type, parent: Tree]
RETURNS [rtn: TV _ NIL] = TRUSTED {
pval, firstArg: TV _ NIL;
ptype: Type;
pclass: Class;
triesLeft: INTEGER _ 32;
procName: ROPE _ TreeToRope[proc];

IF procName # NIL THEN {
proc: BBEvalQuote.EvalQuoteProc _ NIL;
data: REF _ NIL;
[proc, data] _ BBEvalQuote.Lookup[procName];
IF proc # NIL THEN {
-- we got it, now its not our job anymore!
RETURN [proc[head, parent, target, data]];
};
};

WITH proc SELECT FROM
node: Node =>
IF node.name = dot
THEN {
[firstArg, pval] _ EvalDot[node[1], node[2], node, head, underPROC, TRUE];
IF pval = NIL THEN {pval _ firstArg; firstArg _ NIL};
}
ELSE pval _ EvalNoProps[proc, head, underPROC];
ENDCASE => pval _ EvalNoProps[proc, head, underPROC];
DO
TestAbort[head, parent];
[, ptype, pclass] _ UnderWear[pval, head, parent];
IF (triesLeft _ triesLeft - 1) < 0 THEN
UrpFatal[head, proc, "too many indirections"]; 

IF pval = NIL AND proc = NIL THEN
SELECT LocalUnderTypeAndClass[target, head, parent].class FROM
array => RETURN [EvalArray[args, head, target, parent]];
record, structure => RETURN [EvalRecord[args, head, target, parent]];
ENDCASE => UrpFatal[head, proc, "invalid constructor"];

SELECT pclass FROM
procedure => {
getArgsType: PROC = TRUSTED {
argsType _ AMTypes.UnderType[AMTypes.Domain[ptype]];
rtnsType _ AMTypes.UnderType[AMTypes.Range[ptype]];
};
argsRec: TV _ NIL;
argsType, rtnsType: Type;
IF pval = NIL OR AMBridge.TVToLC[pval] = 0 THEN
UrpFatal[head, parent, "NIL procedure?"];
Momma[getArgsType, head, parent, "arguments type"];
IF argsType = nullType
THEN {
IF args # NIL THEN
UrpFatal[head, parent, "too many arguments given, 0 expected"]}
ELSE {
argsRec _ BBEvalUtil.EvalRecord[
args, head, argsType, parent, firstArg, AMBridge.GetWorld[pval]];
};
rtn _ BBApply.ApplyProcToRecord[pval, argsRec];
IF rtnsType = nullType THEN RETURN [empty];
rtn _ StripSingleComponentRecord[rtn, head, parent, 1];
RETURN};
record, structure => -- try to get the array/sequence part, then loop
pval _ LastComponent[pval, head, parent];
union =>
IF NOT OverlaidOrComputed[ptype]
THEN {
pval _ AMTypes.Variant[pval]; LOOP}
ELSE {
ENABLE AMTypes.Error => GO TO foo;
index: CARDINAL = AMTypes.NameToIndex[ptype, TreeToRope[args]];
IF index = 0 THEN GO TO foo;
ptype _ AMTypes.IndexToType[ptype, index];
RETURN [AMBridge.Loophole[pval, ptype]];
EXITS foo => UrpFatal[head, parent, "invalid tag"];
};
ref, pointer, longPointer => -- try to get the referent, then loop
pval _ SafeReferent[pval, head, parent];
basePointer => {
relPtr: TV _ EvalNoProps[args, head, nullType];
inner: PROC = TRUSTED {
rtn _ AMTypes.Referent[relPtr, pval];
};
Momma[inner, head, parent, "relative dereference"];
RETURN;
};
array, sequence, descriptor, longDescriptor => {
domain: Type;
index: TV _ NIL;
inner1: PROC = TRUSTED {
SELECT pclass FROM
descriptor, longDescriptor => ptype _ AMTypes.Range[ptype];
ENDCASE;
domain _ AMTypes.Domain[ptype];
};
inner2: PROC = TRUSTED {
rtn _ AMTypes.Apply[pval, index];
};
Momma[inner1, head, parent, "subscripting"];
index _ EvalNoProps[args, head, domain];
index _ LocalCoerce[head, parent, index, domain, 0, "invalid index type"];
Momma[inner2, head, parent, "subscripting"];
RETURN;
};
type => {
tval: Type _ AMTypes.TVToType[pval];
tunder: Type;
tclass: Class;
name: ROPE _ TreeToRope[args];
[tunder, tclass] _ LocalUnderTypeAndClass[tval, head, parent];
SELECT tclass FROM
array => -- well, try for the constructor
RETURN [EvalArray[args, head, tval, parent]];
record, structure => {
IF name # NIL THEN {
onion: Type;
onionClass: Class;
boundTV: TV _ NIL;
innerOnion: PROC = TRUSTED {
[onion, onionClass] _ AMTypes.VariableType[tval];
IF onionClass = union THEN {
index: CARDINAL _
AMTypes.NameToIndex[
onion, name
! AMTypes.Error => GO TO notHere];
IF index # 0 THEN
boundTV _ TVForType[AMTypes.IndexToType[onion, index]];
EXITS notHere => {};
};
};
Momma[innerOnion, head, parent, "constructor"];
IF boundTV # NIL THEN RETURN [boundTV];
};
RETURN [EvalRecord[args, head, tval, parent]];
};
enumerated => {
rtn _ EnumeratedValueFromRope[name, tval];
IF rtn # NIL THEN RETURN;
UrpFatal[head, parent, "invalid name"]}
ENDCASE => UrpFatal[head, parent, "not implemented"];
}
ENDCASE =>
pval _ UrpWrongType[head, parent, pval, underPROC, "not applicable"]
ENDLOOP;
}; 

EvalArray: PROC
[args: Tree, head: EvalHead, target: Type, parent: Tree, all: BOOL _ FALSE]
RETURNS [new: TV _ NIL] = TRUSTED {
domain, range: Type;
first, last, each: TV _ NIL;
elements, firstLI: INT _ 0;
lastLI: INT _ -1;
nGiven: INT _ 1;
listNode: Node _ NIL;
underClass: Class _ nil;
getInfo: PROC = TRUSTED {
underClass _ UnderClass[target];
IF underClass # array THEN RETURN;
range _ AMTypes.Range[target];
first _ AMTypes.First[domain _ AMTypes.Domain[target]];
last _ AMTypes.Last[domain];
firstLI _ AMBridge.TVToLI[first];
lastLI _ AMBridge.TVToLI[last];
elements _ lastLI - firstLI + 1;
new _ AMTypes.New[type: target, world: BBEvalUtil.WorldFromHead[head]];
IF all
THEN nGiven _ elements
ELSE
WITH args SELECT FROM
node: Node =>
SELECT node.name FROM
list => {listNode _ node; nGiven _ node.sonLimit - 1};
ENDCASE;
ENDCASE;
};
BBEvalUtil.Momma[getInfo, head, parent, "array constructor"];
IF underClass # array THEN
UrpFatal[head, parent, "target not an array"];
each _ first;
IF elements # nGiven THEN
UrpFatal[head, parent, "Wrong # of elements"];
FOR i: INT IN [1..nGiven] DO
elemTV: TV _ NIL;
valueTV: TV _ EvalNoProps[IF listNode # NIL THEN listNode[i] ELSE args, head, range];
inner: PROC = TRUSTED {
elemTV _ AMTypes.Apply[new, each];
AMBridgeExtras.AssignNew[elemTV, valueTV];
each _ AMTypes.Next[each];
};
BBEvalUtil.Momma[inner, head, parent, "array constructor"];
ENDLOOP;
}; 

EvalAssign: PROC
[left, right: Tree, head: EvalHead, target: Type, parent: Tree] RETURNS [TV] = TRUSTED {
lval, rval: TV _ NIL;
name: ROPE _ TreeToRope[left];
nameSize: INT _ name.Size[];
tab: SymTab.Ref _ IF head.specials = NIL THEN symtab ELSE head.specials;
IF Rope.Match["*&*", name] THEN {
lval _ rval _ EvalNoProps[right, head, target]; -- default to no copy
IF lval = empty THEN RETURN [empty];
WHILE rval # NIL DO
type, under: Type;
class: Class;
safeCase: PROC = TRUSTED {
lval _ rval;
SELECT class FROM
globalFrame => {
IF TreeToRope[right] # NIL THEN
head.globalContext _ BBContext.ContextForGlobalFrame[rval];
};
localFrame, sequence, nil, any, union => {
}
ENDCASE =>
IF TVStatus[rval] # const AND rval # empty THEN
lval _ AMTypes.Copy[rval];
};
[type, under, class] _ UnderWear[rval, head, parent];
Momma[safeCase, head, parent, "assign"];
EXIT
ENDLOOP;
IF nameSize > 1 THEN [] _ tab.Store[name, lval];
[] _ tab.Store["&", lval];
[] _ symtab.Store["&&", lval];
RETURN [lval]};
IF left # NIL THEN {
lval _ EvalNoProps[left, head, target];
target _ UnderWear[lval, head, left].type};
rval _ EvalNoProps[right, head, target];
IF left = NIL THEN RETURN [empty];
RETURN [DoAssign[lval, rval, head, target, parent]]
}; 

DoAssign: PROC
[lhs, rhs: TV, head: EvalHead, target: Type, parent: Tree] RETURNS [TV] = {
fullType, ltype, rtype: Type;
lclass, rclass: Class;
msg: ROPE _ NIL;
[fullType, ltype, lclass] _ UnderWear[lhs, head, parent];
[, rtype, rclass] _ UnderWear[rhs, head, parent];
IF ltype # rtype THEN
rhs _ LocalCoerce[head, parent, rhs, fullType];
msg _ SafeAssign[lhs, rhs, head, parent];
IF msg # NIL THEN UrpFatal[head, parent, msg];
RETURN [rhs]
}; 

LocalLoophole: PROC
[head: EvalHead, parent: Tree, current: TV, target: Type]
RETURNS [tv: TV _ NIL] = TRUSTED {
innerLoophole: PROC = TRUSTED {
type: Type _ TVType[current];
under, tunder: Type;
class, tclass: Class;
isRemote: BOOL _ AMBridge.IsRemote[current];
[tunder, tclass] _ UnderTypeAndClass[target];
[under, class] _ UnderTypeAndClass[type];
IF under = tunder THEN {tv _ current; RETURN};
SELECT class FROM
globalFrame => {
IF isRemote
THEN lc _ AMBridge.RemoteGFHFromTV[current].gfh
ELSE lc _ LOOPHOLE[AMBridge.GFHFromTV[current], CARDINAL];
GO TO common};
localFrame => {
IF isRemote
THEN lc _ AMBridge.RemoteFHFromTV[current].fh
ELSE lc _ LOOPHOLE[AMBridge.FHFromTV[current], CARDINAL];
GO TO common};
ENDCASE;
IF current = NIL
THEN current _ NilTV
ELSE current _ CopyToImpliedWorld[head, current, TRUE];
tv _ AMBridge.Loophole[current, target ! AMTypes.Error => CONTINUE];
IF tv # NIL THEN RETURN;
SELECT tclass FROM
list, ref, atom, rope, countedZone, uncountedZone =>
tv _ LocalCoerce[head, parent, current, target];
ENDCASE => {
lc _ TVToLC[current];
GO TO common};
EXITS
common => SetTVFromLC[tv _ New[target], lc]
};
lc: CARD _ 0;
IF target = nullType THEN target _ underCARD;
Momma[innerLoophole, head, parent, "LOOPHOLE"];
};

SafeReferent: PROC
[ref: TV, head: EvalHead, parent: Tree] RETURNS [referent: TV _ NIL] = TRUSTED {
type, under: Type;
class: Class;
msg: ROPE _ NIL;
innerReferent: PROC = TRUSTED {
IF AMBridge.TVToLC[ref] = 0 THEN {
msg _ "can't dereference NIL"; RETURN};
SELECT UnderClass[AMTypes.Range[under]] FROM
unspecified => {msg _ "unspecified range"; RETURN};
ENDCASE;
referent _ AMTypes.Referent[ref];
};
DO
ref _ StripSingleComponentRecord[ref, head, parent];
[type, under, class] _ UnderWear[ref, head, parent];
SELECT class FROM
pointer, longPointer, basePointer, ref, list, nil => {
Momma[innerReferent, head, parent, "dereference"];
IF msg # NIL THEN UrpFatal[head, parent, msg];
RETURN;
};
ENDCASE => EXIT;
ENDLOOP;
UrpFatal[head, parent, "invalid type for dereference"];
};  

CopyToImpliedWorld: PROC
[head: EvalHead, tv: TV, noCopyIfSameWorld: BOOL _ FALSE]
RETURNS [ntv: TV _ NIL] = TRUSTED {
ntv _ CopyToGivenWorld[BBEvalUtil.WorldFromHead[head], tv, noCopyIfSameWorld];
};

CopyToGivenWorld: PROC
[world: WorldVM.World, tv: TV, noCopyIfSameWorld: BOOL _ FALSE]
RETURNS [ntv: TV _ NIL] = TRUSTED {
IF world = AMBridge.GetWorld[tv] THEN {
ntv _ IF noCopyIfSameWorld THEN tv ELSE AMTypes.Copy[tv];
RETURN};
{
tag: TV _ NIL;
type: Type _ AMTypes.TVType[tv];
SELECT AMTypes.VariableType[type].c FROM
union, sequence => 
tag _ AMTypes.Tag[AMTypes.IndexToTV[tv, AMTypes.NComponents[type]]];
ENDCASE;
ntv _ AMTypes.New[type: type, world: world, tag: tag];
IF AMTypes.TVSize[tv] <= 2 AND AMBridge.TVToLC[tv] = AMBridge.TVToLC[ntv]
THEN RETURN;  -- no assignment necessary
AMBridgeExtras.AssignNew[ntv, tv]};
};

UnderClass: PROC [type: Type] RETURNS [Class] = TRUSTED {
RETURN [AMTypes.TypeClass[AMTypes.UnderType[type]]];
};

OverlaidOrComputed: PROC [type: Type] RETURNS [BOOL] = TRUSTED {
type _ AMTypes.UnderType[type];
RETURN [AMTypes.IsComputed[type] OR AMTypes.IsOverlaid[type]];
};

LastComponent: PROC
[tv: TV, head: EvalHead, parent: Tree] RETURNS [comp: TV] = TRUSTED {
inner: PROC = TRUSTED {
comp _ AMTypes.IndexToTV[tv, AMTypes.NComponents[AMTypes.TVType[tv]]];
};
Momma[inner, head, parent, "last component"];
};

TVForType: PROC [type: Type] RETURNS [ntv: TV _ NIL] = TRUSTED {
stb: RTSymbolDefs.SymbolTableBase = RTSymbols.GetTypeSymbols[type].stb;
{ ENABLE UNWIND => RTSymbols.ReleaseSTB[stb];
ntv _ AMBridge.Loophole[
tv: AMBridge.TVForReferent[NEW[CARDINAL _ type]],
type: RTSymbolOps.AcquireType[stb, LOOPHOLE[RTSymbolDefs.symbolIndexForTYPE]]];
RTSymbols.ReleaseSTB[stb];
};
};

END.



��¬��BBEvalImpl.mesa
Russ Atkinson, July 1, 1983 4:33 pm
Paul Rovner, March 4, 1983 4:58 pm
**** Useful types ****
**** Global variables BEGIN ****
these should be undertypes, but that cannot be guaranteed
these should be properly initialized, but that is not guaranteed
unless tvWorldInit = TRUE
**** Global variables END ****
EnsureInit tries to get symbols for the debugger.  If the symbols are not available, then the results of evaluation are undefined, but should degrade gracefully.
statements (and some expressions)
some funny type constructors
expressions
conditional evaluation AND and OR
really should check for type equality
son1 is the zone, which we completely ignore
son2 is the type
son3 is the initialization expression (if any)
NOTE: no handling of arithmetic faults yet
raise conciousness to the real level
NOTE: TVEqual is too generous about types
At this point the values must be arithmetic.
Lookup evaluates the identifier and return the value.  We have a special case for &id, since those identifiers have funny semantics.  We MAY try to use an interface record, based on tryIR.  If correction occurs, the parent is corrected.
This routine performs dynamic lookup in the stack.
The constants of an enumerated type take precedence over variables in the stack.
The local environment takes precedence over the global environment, but there is no point in searching it if it is NIL.
Even if the global context is NIL, we still need to search it.  Otherwise, we will not find stuff in the local global environment, since it is conventional that the NIL context means use the default local context.
try the default table
Lookup evaluates the identifier and return the value.  We have a special case for &id, since those identifiers have funny semantics.  We will try to use an interface record if it seems reasonable.  If correction occurs, the parent is corrected.
This routine performs dynamic lookup in the stack.
The constants of an enumerated type take precedence over variables in the stack.
The local environment takes precedence over the global environment, but there is no point in searching it if it is NIL.
Even if the global context is NIL, we still need to search it.  Otherwise, we will not find stuff in the local global environment, since it is conventional that the NIL context means use the default local context.
try the default table
"repairs" the tree IFF it is an hti leaf
return the literal as a TV
Try for the interface type, then make a TV for it
if useDotNotation & the dot notation wins where the other loses then procTV will be the procedure, and tv the first argument; otherwise, procTV = NIL, and arg is the selection

First, try to acquire the left-hand side as a TV, either through lookup or full eval.

Now we have a good guy for the left side, try for the selection
keep trying, possibly correcting
innerSearch tries to determine if there is an interface for the record object.
First try the interface.
Well, the module is not an interface, so try a global frame search
Perhaps it is a dot notation kludge
glory be! a dotNotation procedure!
maybe a callback procedure can help us?
ForceArithmetic forces the given value to be arithmetic; the result is a TV with class = real or class = longInteger.
Try to get the right stuff.
First try for a registered EvalQuoteProc.
Now look at the proc expr to see if it might be dot notation (like r.Fetch[0])
Could be dot notation, so try this special hack
Until we get to definitely applicable or not.
This is a target-typed record or array constructor.
if a normal variant record, bind the variant and loop
now try to bind the specified variant
possibly a variant record type binder, possibly a record constructor
possibly we are trying to bind a variant type
it is really a variant record type binder!
try to get the value designated
This procedure discovers the domain of the array, saving the low and high bounds, and creates a new TV for the array, but does not initialize it.
a local debug var, so no checking necessary; we copy to avoid problems with unretained frames
set the default search context if right hand side is simple
dont try to copy these
Now left MUST be a TV
returns coercion of value to new value of given type
be especially nice to frames
go for broke
Ê/]��˜�šœ™Jšœ#™#Jšœ"™"—J˜�šÏk	˜	šœ	˜J˜Û—šœ˜Jšœ˜—šœ˜
Jšœ–˜–—Jšœ
œ˜Jšœœ*˜7šœ
˜J˜O—Jšœœ˜%šœ˜J˜p—Jšœœ˜*šœ˜J˜Ì—Jšœ	œ
˜Jšœ
œ.˜=Jšœ	œ˜"Jšœœ˜&Jšœœ˜Jšœœœ˜(Jšœœœ˜#Jšœœ$˜5Jšœ
œ'˜9Jšœœ˜ Jšœ
œ˜-Jšœœ˜)Jšœœ˜"J˜�—šœœ˜š˜JšœÂ˜Â—Jšœ˜Jšœ˜šœœœ2˜>J˜�—šœ™Jšœœœœ˜Jšœœœ˜Jš	œœœœ	œ˜-Jš
œœœœœ˜Jšœœ˜Jšœœœ˜Jšœœœ˜šœœ˜Jšœ"˜"——J˜�Jšœ ™ ˜�Jšœœ"˜+Jšœœ˜J˜�Jšœ9™9Jšœœœ˜Jšœœœ˜Jšœœœ˜Jšœœœ˜Jšœœ˜Jšœœœ˜J˜�Jš	œ
œœœœ˜.Jš	œœœœœ˜1J˜�Jšœ@™@Jšœ™Jšœœœ˜Jšœœœ˜Jšœœœœ˜J˜�Jšœœ˜J˜�Jšœ
œœ˜JšœœœÏc&˜BJ˜�Jšœ™—J˜�Jšœœœ˜J˜�šÏn
œœœ˜Jšœ¡™¡Jšœœœ˜šœœœ˜Jšœ
œœœ˜7Jšœœœœ˜/Jšœœœœ˜1Jšœœœœ˜.J˜ J˜"J˜)J˜)J˜'J˜)J˜)J˜)Jšœœ˜J˜—Jšœœ
œ)˜@J˜J˜�—šŸ	œœœœ˜/J˜
Jšœ	˜J˜J˜�—šŸœœœ˜Jšœ˜J˜Jšœœ˜#Jšœœ˜Jšœœ˜!Jšœœ˜Jšœœœ˜Jšœœ˜Jšœ#œ˜'Jšœœ˜Jšœ˜šœ˜šœ˜šœ˜J˜J˜J˜J˜J˜J˜J˜J˜J˜J˜———J˜J˜�—šŸœ˜Jšœ*œœ˜;Jš
œœœœœ˜ Jšœœ
œ˜%šœœ˜Jšœœ(˜GJšœœœ$˜8Jšœœ˜=Jšœœ˜3Jšœ˜—J˜J˜�—šŸœ˜Jš	œ+œœœœ˜NJšœœœ˜Jšœœœ˜J˜"Jšœœ˜$Jš	œ
œœ
œœ˜4Jš	œ
œœ
œœ˜4š
Ÿœœœœœ˜AJšœ#˜)Jšœ˜—š
Ÿœœœœœ˜4Jšœ%˜+Jšœ˜—š
Ÿœœœœœ˜4Jšœ#˜)Jšœ˜—šŸ	œœœœœœœ˜=Jšœœœ˜5šœ!˜+Jšœ
œ˜Jšœœ
˜4Jšœ˜#—Jšœ˜J˜—šŸœœœœœœ˜1Jšœœ˜J˜—š
Ÿœœœœœ˜6Jšœ5˜;J˜—šœœ˜Jšœ!™!˜%Jšœ.˜4—šœ˜Jšœœ˜šœœ˜Jš	œœœ
œœ˜.—Jšœ˜J˜�—J™šœ˜Jšœ)˜/—šœ˜Jšœœ˜Jšœ(˜(šœ0˜:Jšœœ˜.Jšœœ˜,Jšœœœœ˜—Jšœ˜—Jšœ™˜Jšœ-˜3—˜	J˜#J˜#Jšœœ(˜1Jšœœ ˜(Jšœ	œœ˜šœ˜J˜J˜7Jšœœœœ˜%Jšœœœ˜#˜J˜5—Jšœ˜—Jšœœœ˜)Jšœœ	˜—˜
J˜Jšœœ˜Jšœœœ˜Jš
œ	œœœœ˜!šœœ˜˜
šœ˜šœœœ˜%Jšœœ˜&Jšœœ˜Jšœœœ
œ˜5J˜Jš˜———Jšœ˜—šœœ˜J˜(—Jšœ	œœ˜Jšœœ	˜—šœ˜Jšœ!™!Jšœœ˜Jš
œœœœœ	˜/Jšœœœœ˜)Jšœœœœ	˜1—˜Jšœœœœ˜0—˜'Jšœ6˜<—˜Jšœ3˜9—˜
J˜J˜Jšœ
œ˜Jšœœ˜šœœ˜J˜2Jšœ˜—šœœœ˜Jš	œœœœœ˜=Jšœœ˜J˜J˜5Jšœ
œ˜Jšœœž'˜Ašœœ˜šœœœ˜Jšœ*˜*Jšœ)˜)J˜—Jšœ+˜+J˜—šœ˜šœ&˜&Jšœ!˜!Jšœœ˜:šœ˜šœ˜Jšœœœ˜,J˜—šœ˜š	œœœœ˜:Jšœœ˜—J˜—šœ	˜	Jšœœ
ž˜.Jš
œœœœœ˜8J˜—Jšœœ˜Jšœœœ˜—J˜—šœ˜Jšœ!˜!šœ˜šœ˜Jšœ%™%Jšœœœ˜,J˜—Jšœœ˜Jšœœœ˜—J˜—šœ˜Jšœ	œ˜%Jšœœ
˜Jšœœ˜8šœ˜šœ˜Jšœ
œœœ˜<—šœ˜Jš
œœœœœ˜:—šœ	˜	Jšœœž˜-Jš
œœœœœ˜8J˜—Jšœœ˜Jšœœœ˜—J˜—šœ	˜	Jšœœ˜Jšœ!˜!Jšœœ˜šœ˜Jšœ$˜$Jšœœœ˜2Jšœœ˜&Jšœœœ˜Jšœœœ˜—Jšœœœ˜,Jšœœ˜!J˜—Jšœœœ˜—šœœ˜Jšœ˜Jšœ˜Jšœ˜Jšœ˜—Jšœ˜—Jšœ˜š˜Jšœ:˜:Jšœ<˜<—Jšœ˜—˜Jšœ.˜4—˜Jšœ&˜,—˜Jšœ&œ˜3—šœ	˜	Jšœœ˜Jšœœœœ˜Jšœ)œ˜3šœœ˜šœ
œœœ˜!Jšœœ	˜——šœœ˜&Jš	œ
œœœœ	˜+—J˜!Jšœœ˜
—˜
Jšœ+˜1—˜ Jšœœ	˜—˜ Jšœ3˜3šœ˜šœ	˜	Jšœ	œœ&˜;Jšœœ	˜—˜Jšœ˜—˜Jšœ˜—˜Jšœ
˜—Jšœœ˜——šœ
˜
šœœ˜Jšœ/˜/—Jšœ<˜BJ˜—Jšœœ	˜šœ˜Jšœ,™,Jšœ™Jšœ.™.Jšœ6˜6šœ˜Jšœœœ
˜šœ˜Jš	œ
œœ
œœ˜4Jšœ6˜6Jš
œœœœœœœ˜=Jšœœœ˜šœ
œœ˜šœ˜
Jšœ/˜3Jšœ˜—Jšœ"˜"Jšœ	œœ˜J˜—Jšœ#˜#Jšœœ˜
Jšœ˜——Jšœ˜—šœ	˜	Jšœœ˜šœœ˜!Jšœœœœ˜8—šœœœ˜Jšœ˜Jšœœ˜
—Jšœ	œœ	˜Jšœœ	˜—šœ˜Jšœœ˜J˜J˜
š˜J˜/šœ˜˜#Jšœ˜$—šœ˜
J˜>——Jš˜—J˜—Jšœœœ˜š˜˜
Jšœ˜—˜	Jšœ˜—˜J˜—˜J˜3—šœ˜J˜)———Jš˜J˜J˜�—šŸœœœœ˜?Jšœœœ˜šœœ˜˜
šœœ˜Jšœœœœ˜1Jšœœ˜
——Jšœ˜—Jšœœœœœœ˜-J˜J˜�—šŸœ˜J˜AJšœœœœ˜#Jšœ*™*Jšœœ˜
JšœC˜Cšœ)œ˜1Jšœ$™$Jšœœœ˜,šœ˜Jšœœ˜Jšœ˜Jšœœ˜—Jšœ˜J˜—Jšœ˜šœ˜Jšœ
œ˜Jšœ˜Jšœœ˜—Jšœ˜J˜J˜�—šŸ	œ˜J˜VJšœœœœ˜#J˜Jšœœœ˜J˜*J˜(Jšœœ˜
J˜'J˜5Jšœœ˜)J˜'J˜1šœ˜˜
šœ˜J˜Bšœž"˜7J˜
—šœ˜Jšœ)™)Jšœœœ˜1Jšœ	œ˜Jšœœœ˜š	œœœœœ	˜J˜!šœ˜J˜*——Jšœ
œœ˜ Jšœœœœ	˜%———J˜&Jšœ˜	J˜�—Jšœ,™,J˜�J˜)J˜2J˜*J˜3šœœœ˜*Jšž'˜'Jšœœ˜Jšœœ˜Jšœœ˜+Jšœœ˜+šœ˜J˜J˜J˜J˜J˜'Jšœœ˜!Jšœœ˜ Jšœœ˜—šœ˜Jšœœ
˜Jšœœ
˜Jšœœ
˜Jšœœ˜Jšœœ
˜Jšœœ˜Jšœ˜#—Jš
œœœœœ	˜1Jšœ˜—šœ˜Jšœœ˜Jšœœ˜šœ˜J˜J˜J˜J˜Jšœœ˜Jšœœ
˜Jšœœ˜Jšœœ˜—šœ˜Jšœ˜Jšœ˜Jšœ˜Jšœ˜Jšœ˜Jšœ˜Jšœœ˜!—Jš
œœœœœ	˜1Jšœ˜—J˜J˜�—šŸœ˜Jšœœ-˜8Jšœœœœ˜#Jšœì™ìJšœœœ˜Jš	œœœœœ˜Hšœœœ˜Jšœ2™2Jšœœœ˜JšœP™Pšœœ˜Jšœ,˜,Jš
œœœœœ˜'—Jšœw™wšœœœ˜Jšœ:œ˜RJšœœœœœœœ˜2—JšœÕ™Õšœ%˜%Jšœœ˜3—Jšœœœœœœœ˜1J˜—š˜Jšœœ(˜?J˜Jšœœœ˜šœœ˜Jšœ™J˜Jšœœœ˜—šœœœ˜%J˜#Jšœœœ˜J˜—˜J˜Mšœœ˜Jšœ4œ˜<J˜&Jšœœ˜Jšœ˜	——Jš˜—J˜J˜�—šŸœ˜Jšœœ-˜8Jšœœœœœœ˜:Jšœô™ôJšœœœ˜Jš	œœœœœ˜Hšœœœ˜Jšœ2™2Jšœœœ˜JšœP™Pšœœ˜Jšœ,˜,Jš
œœœœœ˜'—Jšœw™wšœœœ˜Jšœ:œ˜RJšœœœœœœœ˜2—JšœÕ™Õšœ%˜%Jšœœ˜3—Jšœœœœœœœ˜1J˜—š˜Jšœœ(˜?J˜Jšœœœ˜šœœ˜Jšœ™J˜Jšœœœ˜—šœœœ˜%Jšœ+˜+Jš
œœœœœ˜+J˜#Jšœœœ˜J˜—˜J˜Mšœœ˜Jšœ4œ˜<J˜&Jšœœ˜Jšœ˜	——Jš˜—J˜J˜�—šŸœœœ˜(Jšœ(™(šœœ˜Jšœ1˜1Jš˜—J˜J˜�—šŸœ˜
Jšœ5˜5Jšœœœ˜Jšœ™Jšœœ
˜šœœ˜Jšœœ
œœ	˜%Jšœœœ
œœœ˜,Jšœ˜—Jšœ˜#J˜J˜�—šŸœ˜Jš	œ	œ œœœ˜Išœœœ˜J˜6šœ%˜%Jšœ
˜
Jšœœžœœ˜2—šœœœ˜Jšœ1™1Jšœ3˜3Jšœœœ˜ Jšœ/œ˜5Jšœ˜J˜—J˜—J˜/J˜J˜�—šŸœ˜
JšœJœœ˜WJšœœœ
œœœ˜4Jšœ¯™¯Jšœœ˜Jšœœœ˜Jšœœ˜Jšœœ˜Jšœ
œœ˜Jšœœœ˜Jšœ	œœ˜J™�JšœU™Ušœœ˜JšœK˜KJšœ/˜6—J™�Jšœ?™?šœœœ
˜Jšœ ™ Jšœœœ˜šœœœ˜J˜3šœ˜šœ ˜*šœ*˜*Jšœœ(˜G—Jšœ˜——J˜—šœ
œœ˜JšœN™NJšœ	œœœœœ˜$J˜'Jšœœ˜	Jšœ*˜*šœœ˜šœ˜Jšœ˜J˜J˜Jšœœ˜——Jšœ™J˜0šœœ˜J˜0J˜—šœœœ˜JšœB™BJ˜GJ˜—šœ ˜*šœ˜Jšœœ(˜G—Jšœ	œ˜—J˜—Jšœœ˜J˜(Jšœ	œœ˜2šœœ	œœ˜(Jšœ#™#J˜0Jšœ	œœ˜2šœœœ˜Jšœ"™"Jšœ˜J˜—J˜—šœ	œœ˜Jšœ'™'˜J˜D—šœœ˜Jšœ2œ˜8J˜%Jšœœ˜Jšœ˜—Jšœ˜—šœ#˜-šœ
˜
šœ(˜.Jšœ<˜<—Jšœ˜—Jšœ˜—Jšœ˜Jšœ˜—J˜J˜�—šŸœ˜Jš	œœœœœ˜EJšœu™uJšœœœ˜šœœœ˜Jšœœœ˜Jšœœ˜
J˜J˜ J˜!šœ˜˜Jšœœ˜3—˜#J˜ —˜
J˜—˜Jšœ
œœ˜)—˜Jšœœ˜/—Jšœ˜—J˜—Jšœ4˜4J˜)Jšœœ'˜3J˜J˜�—šŸœ˜ Jšœœ%œ˜6Jšœœœ˜šœœœ˜šœ
˜J˜J˜
J˜4Jšœœœœ˜4Jšœœœ˜$J˜Jšœ˜—J˜—Jšœ	˜	J˜J˜J˜�—šŸœ˜Jš	œœ œœœ˜AJšœœ˜
š˜Jšœ™Jšœ4˜4šœ3œ˜;Jšœœ˜#Jšœœœœ˜&Jšœœœœ˜)—J˜?Jš˜—J˜J˜�—šŸ	œ˜Jšœœ œœ˜GJšœœ˜
šœ˜J˜
J˜4Jšœœœ˜4Jšœœœœ˜HJ˜%Jš˜—J˜J˜�—šŸ	œ˜Jšœ>˜>Jšœœœœ˜#Jšœœœ˜J˜J˜Jšœœ˜Jšœ
œ˜"J˜�Jšœ)™)šœœœ˜Jšœ"œ˜&Jšœœœ˜J˜,šœœœ˜Jšž*˜*Jšœ$˜*J˜—J˜J˜�—JšœN™Nšœœ˜˜
šœ˜šœ˜Jšœ/™/JšœDœ˜JJšœœœœ˜5J˜—Jšœ+˜/——Jšœ.˜5—š˜Jšœ-™-J˜J˜2šœ!˜'J˜/J˜�—š	œœœœ˜!Jšœ3™3šœ4˜>Jšœ	œ)˜8Jšœœ*˜EJšœ0˜7—J˜�—šœ˜šœ˜šœ
œœ˜J˜4J˜3J˜—Jšœ	œœ˜J˜šœœœ˜/J˜)—J˜3šœ˜šœ˜šœœ˜J˜?——šœ˜šœ ˜ JšœA˜A—J˜——Jšœ/˜/Jšœœœ	˜+Jšœ7˜7Jšœ˜—šœž0˜EJ˜)—šœ˜Jšœ5™5šœœ˜ šœ˜Jšœœ˜#—šœ˜Jšœ%™%Jšœœœ˜"Jšœœ0˜?Jšœœœœ˜Jšœ*˜*Jšœ"˜(Jšœ.˜3J˜———šœž%˜BJ˜(—šœ˜Jšœœ%˜/šœœœ˜J˜%J˜—J˜3Jšœ˜J˜—˜0J˜
Jšœœœ˜šœœœ˜šœ˜J˜;Jšœ˜—J˜J˜—šœœœ˜J˜!J˜—J˜,J˜(J˜JJ˜,Jšœ˜J˜—˜	J˜$J˜
J˜Jšœœ˜J˜>šœ˜šœ	ž ˜)Jšœ'˜-—šœ˜JšœD™Dšœœœ˜Jšœ-™-J˜J˜Jšœ	œœ˜šœœœ˜Jšœ1˜1šœœ˜šœœ˜šœ˜Jšœ˜Jšœœœ
˜"——šœ˜Jšœ*™*Jšœ7˜7—Jšœ˜J˜—J˜—Jšœ/˜/Jšœœœœ˜'J˜—Jšœ(˜.Jšœ˜—šœ˜Jšœ™Jšœ*˜*Jšœœœœ˜J˜'—Jšœ*˜5—J˜—šœ˜
J˜D——Jšœ˜—J˜J˜�—šŸ	œ˜Jšœ>œœ˜KJšœœœ˜#Jšœ˜Jšœœœ˜Jšœœ˜Jšœœ˜Jšœœ˜Jšœœ˜J˜šœ	œœ˜Jšœ‘™‘Jšœ ˜ Jšœœœ˜"Jšœ˜Jšœ7˜7Jšœ˜Jšœ!˜!Jšœ˜Jšœ ˜ JšœG˜Gšœ˜Jšœ˜š˜šœœ˜šœ
˜
šœ˜Jšœ6˜6Jšœ˜——Jšœ˜———J˜—Jšœ=˜=šœ˜Jšœ.˜.—Jšœ
˜
šœ˜Jšœ.˜.—šœœœ
˜Jšœœœ˜Jšœ	œœœœ
œ˜Ušœœœ˜Jšœ"˜"Jšœ*˜*J˜J˜—Jšœ;˜;Jšœ˜—J˜J˜�—šŸ
œ˜Jšœ?œœœ˜XJšœœœ˜Jšœœ˜Jšœ
œ˜Jš	œœœœœ˜Hšœœ˜!Jšœ]™]Jšœ0ž˜EJšœœœ	˜$šœœ˜J˜J˜
šœ
œœ˜J˜šœ˜šœ˜Jšœ;™;šœœ˜J˜;—J˜—šœ*˜*Jšœ™J˜—šœ˜
šœœ˜/J˜———J˜—J˜5J˜(Jš˜Jšœ˜—Jšœœ˜0J˜J˜Jšœ	˜—Jšœ™šœœœ˜Jšœ'˜'J˜+—J˜(Jšœœœœ	˜"Jšœ-˜3J˜J˜�—šŸœ˜Jšœœ-œœ˜KJ˜J˜Jšœœœ˜J˜9J˜1šœ˜J˜/—J˜)Jšœœœ˜.Jšœ˜J˜J˜�—šŸ
œ˜Jšœ(œ˜9Jšœœœœ˜"Jšœ4™4šœœœ˜J˜J˜J˜Jšœ
œ˜,J˜-J˜)Jšœœœ˜.šœ˜šœ˜Jšœ™šœ	˜Jšœ+˜/Jšœœœ˜:—Jšœœ	˜—˜šœ	˜Jšœ)˜-Jšœœœ˜9—Jšœœ	˜—Jšœ˜—šœ˜Jšœ˜Jšœ-œ˜7—Jšœ:œ˜DJšœœœœ˜šœ˜˜4J˜0—šœ˜Jšœ™Jšœ˜Jšœœ	˜——š˜Jšœ+˜+—J˜—Jšœœ˜
Jšœœ˜-J˜/J˜J˜�—šŸœ˜Jšœœ œœœœ˜PJ˜J˜
Jšœœœ˜šœœœ˜šœœ˜"Jšœœ˜'—šœ"˜,Jšœ+œ˜3Jšœ˜—J˜!J˜—š˜Jšœ4˜4J˜4šœ˜šœ6˜6J˜2Jšœœœ˜.Jšœ˜J˜—Jšœœ˜—Jšœ˜—J˜7J˜J˜�—šŸœ˜Jšœœœœ˜9Jšœœœœ˜#JšœN˜NJ˜J˜�—šŸœ˜Jšœœœœ˜?Jšœœœœ˜#šœœ˜'Jšœœœœ˜9Jšœ˜—šœ˜Jšœœœ˜J˜ šœ˜(˜JšœD˜D—Jšœ˜—J˜6šœœ+˜IJšœœž˜(—Jšœ#˜#—J˜J˜�—šŸ
œœœœ˜9Jšœ.˜4J˜J˜�—š
Ÿœœœœœ˜@Jšœ˜Jšœœ˜>J˜J˜�—šŸ
œ˜Jš	œœ œœœ˜Ešœœœ˜JšœF˜FJšœ˜—Jšœ-˜-J˜J˜�—šŸ	œœœœœœ˜@JšœG˜Gšœœœ˜-šœ˜Jšœœœ
˜1Jšœ#œ$˜O—Jšœ˜J˜—J˜J˜�—Jšœ˜J˜�J˜�J˜�——�…—����ˆ^��Èg��