DIRECTORY
AMBridge
USING
[FHFromTV, GetWorld, GFHFromTV, IsRemote, Loophole, PointerFromTV, RemoteFHFromTV, RemoteGFHFromTV, SetTVFromLC, SomeRefFromTV, TVForReadOnlyReferent, TVForReferent, TVForType, TVToCardinal, TVToInteger, TVToLC, TVToLI, TVToReal, RefFromTV, TVToRef],
AMEvents USING [Apply],
AMMiniModel USING [AcquireIRType, GetInterfaceRecord, GetInterfaceRecordFromType],
AMModel USING [Context, ContextWorld, ContextClass, MostRecentNamedContext, RootContext],
AMModelBridge USING [FrameFromContext, IRFromContext],
AMTypes
USING
[Apply, Assign, AssignNew, Class, Copy, Domain, Error, First, GroundStar, IndexToTV, IndexToType, IsComputed, IsInterface, IsOverlaid, Last, Length, NameToIndex, NComponents, New, Next, Range, Referent, Size, TVEqual, TVStatus, TVToType, TVType, TypeClass, UnderClass, UnderType, VariableType, Variant, GetEmptyTV, TV],
BackStop USING [Call, ResumeBackStop, SuspendBackStop],
EvalQuote USING [EvalQuoteProc, Lookup],
InterpreterOps USING [EvalHead, RopeOrTV, Ruminant, Tree, TreeToName],
InterpreterPrivate
USING
[EnumeratedValueFromRope, EvalRecord, LocalCoerce, NewInt, NewReal, NewType, TestAbort, UnderTypeAndClass, RecordSearch],
BBUrpEval USING [UrpFatal, UrpId, UrpSelector, UrpWrongType],
PPLeaves USING [HTIndex, LTIndex],
PPTree USING [Handle, Link, NodeName],
Real USING [FRem],
Rope USING [Flatten, Match, ROPE, Size, Substr, Fetch],
SafeStorage USING [nullType, Type],
SymTab USING [Create, EachPairAction, Pairs, Fetch, Ref, Store],
UserProfile USING [Boolean],
WorldVM USING [LocalWorld, World];
EvaluateImpl:
CEDAR
MONITOR
IMPORTS
AMBridge, AMEvents, AMModel, AMModelBridge, AMTypes, BackStop, InterpreterOps, InterpreterPrivate, EvalQuote, BBUrpEval, Real, Rope, AMMiniModel, SymTab, UserProfile, WorldVM
EXPORTS InterpreterOps, InterpreterPrivate
=
BEGIN
OPEN AMBridge, AMTypes, InterpreterOps, InterpreterPrivate, BBUrpEval, SafeStorage;
**** Useful types ****
CARD: TYPE = LONG CARDINAL;
LORA: TYPE = LIST OF REF;
Node: TYPE = PPTree.Handle;
ROPE: TYPE = Rope.ROPE;
**** Global variables BEGIN ****
empty: TV ← GetEmptyTV[];
these should be undertypes, but that cannot be guaranteed
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];
these should be properly initialized, but that is not guaranteed unless tvWorldInit = TRUE
true: TV ← NIL;
false: TV ← NIL;
NilTV: TV ← NIL;
globalSymTab: SymTab.Ref ← SymTab.Create[];
helpTable: SymTab.Ref ← SymTab.Create[];
tvWorldInit: BOOL ← FALSE;
tvWorldInitMsg: ROPE ← NIL; -- reason for failure to init (if any)
**** Global variables END ****
GetNilTV:
PUBLIC
PROC
RETURNS [
TV] = {
IF NOT tvWorldInit THEN EnsureInit[];
RETURN[NilTV];
};
GetGlobalSymTab:
PUBLIC
PROC
RETURNS [SymTab.Ref] = {
IF NOT tvWorldInit THEN EnsureInit[];
RETURN[globalSymTab];
};
GetTypeOfSafeStorageDotType:
PUBLIC
PROC
RETURNS [Type] = {
IF NOT tvWorldInit THEN EnsureInit[];
RETURN[underTYPE];
};
WorldFromHead:
PUBLIC
PROC
[head: EvalHead] RETURNS [world: WorldVM.World ← NIL] = TRUSTED {
IF head # NIL THEN world ← AMModel.ContextWorld[head.context];
IF world = NIL THEN world ← WorldVM.LocalWorld[];
};
EnsureInit:
ENTRY
PROC = {
EnsureInit tries to get symbols for the debugger. If the symbols are not available, then the results of evaluation are undefined, but interpreter functionality should degrade gracefully.
ENABLE UNWIND => NULL;
inner:
INTERNAL PROC =
TRUSTED {
TVForUnderType:
PROC [under: Type]
RETURNS [
TV] =
TRUSTED {
RETURN [AMBridge.TVForReadOnlyReferent[NEW[Type ← UnderType[under]]]]
};
lag: TV ← NIL;
true ← TVForReadOnlyReferent[NEW[BOOL ← TRUE]];
false ← TVForReadOnlyReferent[NEW[BOOL ← FALSE]];
NilTV ← TVForReadOnlyReferent[NEW[REF ← NIL]];
underLORA ← UnderType[underLORA];
underPROC ← UnderType[underPROC];
underREF ← UnderType[underREF];
underBOOL ← UnderType[underBOOL];
underTYPE ← UnderType[underTYPE];
underCARD ← UnderType[underCARD];
DoRegisterTV["TRUE", true, "Boolean value"];
DoRegisterTV["FALSE", false, "Boolean value"];
DoRegisterTV["ATOM", TVForUnderType[CODE[ATOM]], " ... the TYPE"];
DoRegisterTV["BOOL", lag ← TVForUnderType[CODE[BOOL]], " ... the TYPE"];
DoRegisterTV["BOOLEAN", lag, " ... the TYPE"];
DoRegisterTV["CARD", TVForUnderType[CODE[CARD]], " ... the TYPE"];
DoRegisterTV["CARDINAL", TVForUnderType[CODE[CARDINAL]], " ... the TYPE"];
DoRegisterTV["CHAR", lag ← TVForUnderType[CODE[CHAR]], " ... the TYPE"];
DoRegisterTV["CHARACTER", lag, " ... the TYPE"];
DoRegisterTV["INT", TVForUnderType[CODE[INT]], " ... the TYPE"];
DoRegisterTV["INTEGER", TVForUnderType[CODE[INTEGER]], " ... the TYPE"];
DoRegisterTV["PROC", TVForUnderType[CODE[PROC]], " ... the TYPE: PROC"];
DoRegisterTV[
"PROCANY",
TVForUnderType[CODE[PROC ANY RETURNS ANY]],
" ... the TYPE: PROC ANY RETURNS ANY"
];
DoRegisterTV["PROCESS", TVForUnderType[CODE[PROCESS]], " ... the TYPE: PROCESS"];
DoRegisterTV["REAL", TVForUnderType[CODE[REAL]], " ... the TYPE"];
DoRegisterTV["REF", TVForUnderType[CODE[REF]], " ... the TYPE: REF ANY"];
DoRegisterTV["ROPE", TVForUnderType[CODE[ROPE]], " ... the TYPE"];
DoRegisterTV["WORD", TVForUnderType[CODE[WORD]], " ... the TYPE"];
tvWorldInit ← TRUE;
};
IF NOT tvWorldInit THEN tvWorldInitMsg ← BackStop.Call[inner];
};
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]];
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]];
};
Listify:
PROC [tv:
TV]
RETURNS [
LORA] =
TRUSTED {
RETURN [LIST[AMBridge.TVToRef[tv]]]
};
EvalBool:
PROC [tree: Tree]
RETURNS [
BOOL] =
TRUSTED {
RETURN [ForceBoolean[SubEval[tree, underBOOL], head, tree]]
};
START EvalNode HERE
{
SELECT kind
FROM
statements (and some expressions)
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]]};
some funny type constructors
processTC =>
RETURN [Lookup["PROCESS", head, target, node]];
longTC => {
tv1: TV ← SubEval0[son1];
type: Type ← TVToType[tv1];
SELECT UnderClass[type]
FROM
cardinal => RETURN [globalSymTab.Fetch["CARD"].val];
integer => RETURN [globalSymTab.Fetch["INT"].val];
ENDCASE => GO TO NYI;
};
expressions
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 ← AMTypes.UnderType[AMTypes.TVType[rest]];
restClass ← AMTypes.TypeClass[restUnder];
IF restClass = nil THEN GOTO forRef;
IF restUnder = underLORA THEN EXIT;
rest ← LocalCoerce[head, listTree, rest, underLORA, 0, "invalid list"];
ENDLOOP;
top.rest ← NARROW[AMBridge.TVToRef[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 => {
conditional evaluation AND and OR
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, target--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 ← UnderType[TVType[each]];
eachClass: Class ← TypeClass[eachUnder];
eachCard: CARD;
swap: BOOL ← kind = min; -- if each > best, then swap ← NOT swap
IF eachClass = subrange
THEN {
eachUnder ← GroundStar[eachUnder];
eachClass ← TypeClass[eachUnder];
};
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 => {
really should check for type equality
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]];
uminus, abs =>
RETURN [EvalUnop[son1, kind, head, target]];
all =>
RETURN [EvalArray[son1, head, target, node, TRUE]];
addr => {rtnRef ←
NEW[
LONG
POINTER ← PointerFromTV[SubEval0[son1]]];
GOTO forRef};
{
tv: TV ← SubEval0[son1];
lp: LONG POINTER ← NIL;
lp ← PointerFromTV[tv];
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";
GOTO fatal;
};
uparrow =>
RETURN[SafeReferent[SubEval0[son1], head, node]];
lengthen, mwconst, clit, llit =>
GO TO evalSon;
size, typecode, first, last => {
type: Type ← TVToType[SubEval0[son1]];
SELECT kind
FROM
size => {
rtnRef ← NEW[CARDINAL ← Size[type]];
GO TO forRef};
typecode =>
RETURN[NewType[type]];
first =>
RETURN [First[type]];
last =>
RETURN [Last[type]]
ENDCASE => ERROR};
loophole => {
IF son2 # NIL THEN target ← TVToType[SubEval0[son2]];
RETURN [LocalLoophole[head, node, SubEval[son1, target], target]];
};
nil => RETURN [NilTV];
new => {
son1 is the zone, which we completely ignore
son2 is the type
son3 is the initialization expression (if any)
world: WorldVM.World ← WorldFromHead[head];
IF world # WorldVM.LocalWorld[]
THEN GOTO notRemote
ELSE {
son3: Tree ← IF nSons > 2 THEN node.son[3] ELSE NIL;
repType: Type ← TVToType[SubEval0[son2]];
rtn: TV ← New[type: repType, world: world];
ref: REF ← NIL;
IF son3 #
NIL
THEN {
init: TV ← SubEval[son3, repType];
init ← LocalCoerce[head, son3, init, repType, 0, "invalid init"];
AMTypes.Assign[rtn, init];
};
ref ← AMBridge.SomeRefFromTV[rtn];
rtnRef ← NEW[REF ← ref];
GOTO forRef;
};
};
atom => {
WITH son1
SELECT
FROM
lti: PPLeaves.LTIndex => {
rtnRef ← lti.value;
GO TO forRef;
};
ENDCASE;
errmsg ← "invalid atom";
GO TO fatal};
length => {
tv: TV ← SubEval0[son1];
DO
SELECT TypeClass[UnderType[TVType[tv]]]
FROM
descriptor, longDescriptor, rope =>
RETURN [NewInt[Length[tv]]];
ENDCASE =>
tv ← UrpWrongType[head, son1, tv, target, "not a descriptor"];
ENDLOOP
};
ENDCASE => GOTO 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 {
NOTE: no handling of arithmetic faults yet
int: INT ← 0;
rtn ← ForceArithmetic[EvalNoProps[tree, head, target], head, tree];
IF TypeClass[UnderType[TVType[rtn]]] = real
THEN {
raise conciousness to the real level
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 ← TVType[lval];
ltype ← UnderType[ttype];
lclass ← TypeClass[ltype];
IF target = nullType THEN target ← ttype;
rval ← EvalNoProps[right, head, ltype];
rtype ← UnderType[TVType[rval]];
rclass ← TypeClass[rtype];
SELECT kind
FROM
relE, relN =>
SELECT lclass
FROM
subrange, cardinal, integer, character, longInteger, longCardinal,
real, unspecified =>
-- these values must be arithmetic
op ← minus
ENDCASE => {
eq: BOOL ← TVEqual[lval, rval];
IF kind = relN THEN eq ← NOT eq;
RETURN [IF eq THEN true ELSE false];
};
relL, relGE, relG, relLE => op ← minus
ENDCASE;
At this point the values must be arithmetic.
lval ← ForceArithmetic[lval, head, left];
altype ← UnderType[TVType[lval]];
alclass ← TypeClass[altype];
rval ← ForceArithmetic[rval, head, right];
artype ← UnderType[TVType[rval]];
arclass ← TypeClass[artype];
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 {
Lookup evaluates the identifier and returns the value. We have a special case for &id, since those identifiers have funny semantics. If correction occurs, the parent is corrected.
ok: BOOL ← FALSE;
useWorldContext: BOOL ← FALSE;
inner:
PROC [context: AMModel.Context] =
TRUSTED {
The constants of an enumerated type take precedence over variables.
IF target # nullType
THEN {
val ← EnumeratedValueFromRope[name, target];
IF val # NIL THEN {ok ← TRUE; RETURN};
};
IF useWorldContext THEN context ← AMModel.RootContext[WorldFromHead[head]];
SELECT AMModel.ContextClass[context]
FROM
world => {
try for an IR
val ← AMMiniModel.GetInterfaceRecord[name, WorldFromHead[head]
! Error => IF reason = notImplemented THEN CONTINUE];
IF val # NIL THEN {ok ← TRUE; RETURN};
Nope. try for a PROGRAM
val ← AMModelBridge.FrameFromContext
[AMModel.MostRecentNamedContext[name, context]];
IF val # NIL THEN {ok ← TRUE; RETURN};
Nope. try for the interface type, then make a TV for it
{
irt: Type = AMMiniModel.AcquireIRType[name ! Error => GOTO return];
val ← CopyToImpliedWorld[head, TVForType[irt]]; -- NOTE Hmm.
EXITS return => NULL;
};
IF val # NIL THEN {ok ← TRUE; RETURN};
};
prog, proc => {
val ← InterpreterPrivate.RecordSearch
[AMModelBridge.FrameFromContext[head.context], name];
IF val # NIL THEN {ok ← TRUE; RETURN};
IF UserProfile.Boolean["Interpreter.SearchTheWorld",
FALSE]
THEN inner[AMModel.RootContext[WorldFromHead[head]]];
};
interface => {
val ← InterpreterPrivate.RecordSearch
[AMModelBridge.IRFromContext[head.context], name];
IF val # NIL THEN {ok ← TRUE; RETURN};
IF UserProfile.Boolean["Interpreter.SearchTheWorld",
FALSE]
THEN inner[AMModel.RootContext[WorldFromHead[head]]];
};
ENDCASE => ERROR;
}; -- end inner
START Lookup HERE
DO
IF head.specials = NIL THEN ERROR;
IF name.Size[] = 0 THEN UrpFatal[head, parent, "invalid name"];
IF name.Fetch[0] = '% THEN {useWorldContext ← TRUE; name ← name.Substr[1]};
IF name.Size[] = 0 THEN UrpFatal[head, parent, "invalid name"];
[ok, val] ← head.specials.Fetch[name];
IF ok THEN RETURN;
try the global TV table
[ok, val] ← globalSymTab.Fetch[name];
IF ok THEN RETURN;
IF
NOT Rope.Match["&*", name]
THEN {
inner[head.context];
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;
}; -- end Lookup
FixHti:
PROC [tree: Tree, fix:
ROPE] = {
"repairs" the tree IFF it is an hti leaf
WITH tree
SELECT
FROM
hti: PPLeaves.HTIndex => hti.name ← fix.Flatten[]
ENDCASE
};
EvalLti:
PROC [lti: PPLeaves.LTIndex, head: EvalHead]
RETURNS [TV] = TRUSTED {
return the literal as a TV
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]]
};
EvalDot:
PROC [left, right, parent: Tree, head: EvalHead, target: Type]
RETURNS [tv: TV ← NIL] = TRUSTED {
lName: ROPE ← TreeToName[left];
rName: ROPE ← TreeToName[right];
record: TV ← NIL;
msg: ROPE ← NIL;
world: WorldVM.World ← WorldFromHead[head];
... First, acquire the left-hand side as a TV, either through lookup or full eval.
IF lName =
NIL
THEN record ← EvalNoProps[left, head, nullType]
ELSE record ← Lookup[lName, head, nullType, left];
IF AMTypes.TypeClass[AMTypes.UnderType[AMTypes.TVType[record]]] = type
THEN {
typeValue: Type ← AMTypes.TVToType[record];
IF AMTypes.IsInterface[typeValue]
THEN {
We have to make a real interface record here, since InterpreterPrivate.RecordSearch can't hack it if the interface type is in a remote world. If we get an error when dealing with this, we allow it to propagate up.
temp: TV = AMMiniModel.GetInterfaceRecordFromType[typeValue, world];
IF temp #
NIL
THEN record ← temp;
RRA: It appears that for defnitions modules that don't export anything there is no interface record kept (sigh). We are currently assuming that the best indication of this is a returned value of NIL and no error indication from AMMiniModel. This is really a crock!
};
};
... Now we have the left side in "record". Do the selection.
FOR i:
NAT
IN [1..4]
DO
-- keep trying, possibly correcting
tv ← InterpreterPrivate.RecordSearch[record, rName
! AMTypes.Error =>
IF reason = typeFault
OR reason = badName
THEN
CONTINUE];
keep failure from emerging as a signal from here
IF tv =
NIL
THEN {
-- maybe a callback procedure can help?
correct: RopeOrTV
= UrpSelector[head, parent, rName, record, target, "selection failed"];
WITH c: correct
SELECT
FROM
both => {FixHti[right, c.rope]; RETURN [c.tv]};
rope => FixHti[right, rName ← c.rope]; -- and try again
tv => RETURN [c.tv];
ENDCASE =>
RETURN [InterpreterPrivate.RecordSearch[record, rName]]; -- let failure emerge
}
ELSE {
SELECT UnderClass[TVType[tv]]
FROM
union => {
IF OverlaidOrComputed[TVType[tv]]
THEN UrpFatal[head, parent, "Can't handle OVERLAID or COMPUTED"];
tv ← Variant[tv];
};
ENDCASE;
RETURN [tv];
};
ENDLOOP; -- of keep trying, possibly correcting
RETURN [InterpreterPrivate.RecordSearch[record, rName]]; -- let failure emerge
}; -- end EvalDot
ForceArithmetic:
PROC
[val: TV, head: EvalHead, parent: Tree] RETURNS [rtn: TV] = TRUSTED {
ForceArithmetic forces the given value to be arithmetic; the result is a TV with class = real or class = longInteger.
type: Type;
ground: Type;
class: Class;
rtn ← StripSingleComponentRecord[val];
type ← TVType[rtn];
ground ← GroundStar[type];
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 => UrpFatal[head, parent, "not a number"];
};
StripSingleComponentRecord:
PROC [tv:
TV, max:
NAT ← 100]
RETURNS [rtn: TV] = TRUSTED {
rtn ← tv;
THROUGH [0..max)
DO
under: Type = UnderType[TVType[rtn]];
class: Class ← UnderClass[under];
IF (class # record AND class # structure) OR (NComponents[under] # 1) THEN EXIT;
rtn ← IndexToTV[rtn, 1];
ENDLOOP;
};
ForceBoolean:
PROC
[tv: TV, head: EvalHead, parent: Tree] RETURNS [BOOL] = TRUSTED {
rtn: TV ← tv;
DO
Try to get the right stuff.
rtn ← StripSingleComponentRecord[rtn];
IF UnderType[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
};
EvalApply:
PROC
[proc, args: Tree, head: EvalHead, target: Type, parent: Tree]
RETURNS [rtn: TV ← NIL] = TRUSTED {
pval: TV ← NIL;
ptype: Type;
pclass: Class;
triesLeft: INTEGER ← 32;
procName: ROPE ← TreeToName[proc];
First try for a registered EvalQuoteProc.
IF procName #
NIL
THEN {
proc: EvalQuote.EvalQuoteProc ← NIL;
data: REF ← NIL;
[proc, data] ← EvalQuote.Lookup[head.specials, procName];
IF proc #
NIL
THEN {
-- we got it, now its not our job anymore!
RETURN [proc[head, parent, target, data]];
};
};
pval ← EvalNoProps[proc, head, underPROC];
DO
Until we get to definitely applicable or not.
TestAbort[head, parent];
ptype ← UnderType[TVType[pval]];
pclass ← TypeClass[ptype];
IF (triesLeft ← triesLeft - 1) < 0
THEN
UrpFatal[head, proc, "too many indirections"];
IF pval =
NIL
AND proc =
NIL
THEN
This is a target-typed record or array constructor.
SELECT UnderClass[target]
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 => {
argsRec: TV ← NIL;
argsType, rtnsType: Type;
IF pval =
NIL
OR AMBridge.TVToLC[pval] = 0
THEN
UrpFatal[head, parent, "NIL procedure?"];
argsType ← UnderType[Domain[ptype]];
rtnsType ← UnderType[Range[ptype]];
IF argsType = nullType
THEN {
IF args #
NIL
THEN
UrpFatal[head, parent, "too many arguments given, 0 expected"]}
ELSE
argsRec ← EvalRecord[args, head, argsType, parent, AMBridge.GetWorld[pval]];
SIGNAL BackStop.SuspendBackStop;
rtn ← AMEvents.Apply[pval, argsRec];
SIGNAL BackStop.ResumeBackStop;
IF rtnsType = nullType THEN RETURN [empty];
rtn ← StripSingleComponentRecord[rtn, 1];
RETURN};
record, structure =>
-- try to get the array/sequence part, then loop
pval ← IndexToTV[pval, NComponents[TVType[pval]]];
union =>
if a normal variant record, bind the variant and loop
IF
NOT OverlaidOrComputed[ptype]
THEN {
pval ← Variant[pval]; LOOP}
ELSE {
now try to bind the specified variant
index: CARDINAL ← 0;
index ← NameToIndex[ptype, TreeToName[args]
! Error => IF reason = badName THEN CONTINUE];
IF index = 0 THEN UrpFatal[head, parent, "invalid tag"];
ptype ← IndexToType[ptype, index];
RETURN [AMBridge.Loophole[pval, ptype]];
};
ref, pointer, longPointer =>
-- try to get the referent, then loop
pval ← SafeReferent[pval, head, parent];
basePointer => {
relPtr: TV ← EvalNoProps[args, head, nullType];
rtn ← Referent[relPtr, pval];
RETURN;
};
array, sequence, descriptor, longDescriptor => {
domain: Type;
index: TV ← NIL;
SELECT pclass
FROM
descriptor, longDescriptor => ptype ← Range[ptype];
ENDCASE;
domain ← Domain[ptype];
index ← EvalNoProps[args, head, domain];
index ← LocalCoerce[head, parent, index, domain, 0, "invalid index type"];
rtn ← Apply[pval, index];
RETURN;
};
type => {
tval: Type ← TVToType[pval];
tunder: Type;
tclass: Class;
name: ROPE ← TreeToName[args];
tunder ← AMTypes.UnderType[tval];
tclass ← AMTypes.TypeClass[tunder];
SELECT tclass
FROM
array =>
-- well, try for the constructor
RETURN [EvalArray[args, head, tval, parent]];
record, structure => {
possibly a variant record type binder, possibly a record constructor
IF name #
NIL
THEN {
we are trying either to construct a record or to bind a variant type
onion: Type;
onionClass: Class;
boundTV: TV ← NIL;
[onion, onionClass] ← VariableType[tval];
IF onionClass = union
THEN {
index: CARDINAL ← 0;
index ← NameToIndex[onion, name
! Error => IF reason = badName THEN CONTINUE];
IF index # 0
THEN
--it is a variant record type binder
RETURN[TVForType[IndexToType[onion, index]]];
};
};
RETURN [EvalRecord[args, head, tval, parent]];
};
enumerated => {
try to get the value designated
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 ← UnderClass[target];
Discover the domain of the array, save the low and high bounds, and create a new TV for the array (not initialized).
IF underClass # array THEN UrpFatal[head, parent, "target not an array"];
range ← Range[target];
first ← First[domain ← Domain[target]];
last ← Last[domain];
firstLI ← AMBridge.TVToLI[first];
lastLI ← AMBridge.TVToLI[last];
elements ← lastLI - firstLI + 1;
new ← New[type: target, world: 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;
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];
elemTV ← Apply[new, each];
AssignNew[elemTV, valueTV];
each ← Next[each];
ENDLOOP;
};
EvalAssign:
PROC
[left, right: Tree, head: EvalHead, target: Type, parent: Tree] RETURNS [TV] = TRUSTED {
lval, rval: TV ← NIL;
name: ROPE ← TreeToName[left];
nameSize: INT ← name.Size[];
IF head.specials = NIL THEN ERROR;
IF Rope.Match["&*", name]
THEN {
a local debug var: we copy to avoid problems with (unretained) frames as heads
lval ← rval ← EvalNoProps[right, head, target];
IF lval = empty THEN RETURN [empty];
IF lval #
NIL
THEN {
SELECT TypeClass[UnderType[TVType[rval]]]
FROM
localFrame, globalFrame, sequence, nil, any, union => {
dont try to copy these
}
ENDCASE => IF TVStatus[rval] # const THEN lval ← Copy[rval];
};
IF nameSize > 1 THEN [] ← head.specials.Store[name, lval];
[] ← head.specials.Store["&", lval];
[] ← globalSymTab.Store["&&", lval];
RETURN [rval];
};
Now left MUST be a TV
IF left #
NIL
THEN {
lval ← EvalNoProps[left, head, target];
target ← TVType[lval]};
rval ← EvalNoProps[right, head, target];
IF left = NIL THEN RETURN [empty];
RETURN [DoAssign[lval, rval, head, parent]]
};
DoAssign:
PROC
[lhs, rhs: TV, head: EvalHead, parent: Tree] RETURNS [TV] = {
fullType, ltype, rtype: Type;
fullType ← TVType[rhs];
ltype ← UnderType[fullType];
rtype ← UnderType[TVType[rhs]];
IF ltype # rtype THEN rhs ← LocalCoerce[head, parent, rhs, fullType];
AMTypes.Assign[lhs, rhs];
RETURN [rhs]
};
LocalLoophole:
PROC [head: EvalHead, parent: Tree, current:
TV, target: Type]
RETURNS [tv: TV ← NIL] = TRUSTED {
returns coercion of value to new value of given type
lc: CARD ← 0;
type: Type ← TVType[current];
under, tunder: Type;
class, tclass: Class;
isRemote: BOOL ← AMBridge.IsRemote[current];
IF target = nullType THEN target ← underCARD;
[tunder, tclass] ← UnderTypeAndClass[target];
[under, class] ← UnderTypeAndClass[type];
IF under = tunder THEN {tv ← current; RETURN};
{
SELECT class
FROM
-- be especially nice to frames
globalFrame => {
IF isRemote
THEN lc ← AMBridge.RemoteGFHFromTV[current].gfh
ELSE lc ← LOOPHOLE[AMBridge.GFHFromTV[current], CARDINAL];
GOTO common};
localFrame => {
IF isRemote
THEN lc ← AMBridge.RemoteFHFromTV[current].fh
ELSE lc ← LOOPHOLE[AMBridge.FHFromTV[current], CARDINAL];
GOTO common};
ENDCASE;
IF current =
NIL
THEN current ← NilTV
ELSE current ← CopyToImpliedWorld[head, current];
tv ← AMBridge.Loophole[current, target ! Error => CONTINUE];
IF tv # NIL THEN RETURN;
SELECT tclass
FROM
list, ref, atom, rope, countedZone, uncountedZone =>
tv ← LocalCoerce[head, parent, current, target];
ENDCASE => {
go for broke
lc ← TVToLC[current];
GOTO common};
EXITS
common => SetTVFromLC[tv ← New[target], lc]
};
};
SafeReferent:
PROC [ref:
TV, head: EvalHead, parent: Tree]
RETURNS [referent: TV ← NIL] = TRUSTED {
type, under: Type;
class: Class;
msg: ROPE ← NIL;
DO
ref ← StripSingleComponentRecord[ref];
type ← TVType[ref];
under ← UnderType[type];
class ← UnderClass[TVType[ref]];
SELECT class
FROM
pointer, longPointer, basePointer, ref, list, nil => {
IF AMBridge.TVToLC[ref] = 0
THEN {
msg ← "can't dereference NIL"; RETURN};
SELECT UnderClass[Range[under]]
FROM
unspecified => {msg ← "unspecified range"; RETURN};
ENDCASE;
referent ← Referent[ref];
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]
RETURNS [ntv: TV ← NIL] = TRUSTED {
world: WorldVM.World = WorldFromHead[head];
IF world = AMBridge.GetWorld[tv] THEN ntv ← tv ELSE ntv ← Copy[tv];
};
OverlaidOrComputed:
PROC [type: Type]
RETURNS [
BOOL] =
TRUSTED {
type ← UnderType[type];
RETURN [IsComputed[type] OR IsOverlaid[type]];
};
RegisterTVEntry:
ENTRY PROC [name: ROPE, tv: TV, help: ROPE, symTab: SymTab.Ref] = {
ENABLE UNWIND => NULL;
DoRegisterTV[name, tv, help, symTab];
};
DoRegisterTV:
INTERNAL PROC[name: ROPE, tv: TV, help: ROPE, symTab: SymTab.Ref ← NIL] = {
Registers the TV under the given name in the global TV table. It is recommended that the name contain the & character to avoid obscuring variables names. (it is perfectly OK to have NIL as a TV).
IF symTab = NIL THEN symTab ← globalSymTab;
[] ← symTab.Store[name, tv];
IF help #
NIL
THEN {
found: BOOL;
sttv: TV;
helpTable: SymTab.Ref;
[found, sttv] ← symTab.Fetch["&HelpSymTab"];
TRUSTED{
IF found THEN helpTable ← LOOPHOLE[AMBridge.RefFromTV[sttv], SymTab.Ref]
ELSE {
helpTable ← SymTab.Create[];
[] ← symTab.Store["&HelpSymTab", AMBridge.TVForReferent[helpTable]];
};
};
[] ← helpTable.Store[name, help];
};
};
RegisterTV:
PUBLIC PROC [name:
ROPE, tv:
TV, help:
ROPE ←
NIL, symTab: SymTab.Ref] = {
Registers the TV under the given name in the specified SymTab. The name must start with the & character. tv = NIL is OK.
IF NOT tvWorldInit THEN EnsureInit[];
IF symTab = NIL OR name.Size[] = 0 OR name.Fetch[0] # '& THEN ERROR;
RegisterTVEntry[name, tv, help, symTab];
};
EnumerateSymbols:
PUBLIC PROC
[proc: Ruminant, data: REF ← NIL, symTab: SymTab.Ref ← NIL] RETURNS [stopped: BOOL] = {
Enumerates the symbols in the specified table (in no particular order). IF symTab = NIL then the global SymTab is used. Returns TRUE if the client stopped the enumeration, FALSE if not.
Ruminant: TYPE = PROC
[name: ROPE, help: ROPE, tv: TV, data: REF] RETURNS [stop: BOOL]
localAction: SymTab.EachPairAction = {
[key: Key, val: Val] RETURNS [quit: BOOL]
helpRope: ROPE ← NIL;
found: BOOL;
sttv: TV;
[found, sttv] ← symTab.Fetch["&HelpSymTab"];
IF found
THEN {
helpTab: SymTab.Ref;
TRUSTED{helpTab ← LOOPHOLE[AMBridge.RefFromTV[sttv], SymTab.Ref]};
helpRope ← NARROW[helpTab.Fetch[key].val, ROPE];
};
quit ← proc[key, helpRope, val, data];
};
IF NOT tvWorldInit THEN EnsureInit[];
IF symTab = NIL THEN symTab ← globalSymTab;
stopped ← symTab.Pairs[localAction];
};
START HERE
EnsureInit[];
END.