EvaluateImpl.mesa
Copyright © 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
Spreitzer, May 21, 1985 2:25:14 pm PDT
Russ Atkinson (RRA) January 28, 1986 6:06:32 pm PST
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, Coerce, Copy, Domain, Error, First, GroundStar, IndexToTV, IndexToType, IsComputed, IsInterface, IsOverlaid, Last, Length, NameToIndex, NComponents, New, Next, Prev, Range, Referent, Size, TVEqual, TVStatus, TVToType, TVType, TypeClass, UnderClass, UnderType, VariableType, Variant, GetEmptyTV, TV],
BackStop USING [Call, ResumeBackStop, SuspendBackStop],
EvalQuote USING [EvalQuoteProc, Lookup, NameClosure],
InterpreterOps USING [EvalHead, RopeOrTV, Ruminant, Tree, TreeToName],
InterpreterPrivate,
BBUrpEval USING [UrpFatal, UrpId, UrpSelector, UrpWrongType],
PPLeaves USING [HTIndex, LTIndex],
PPTree USING [Handle, Link, NodeName],
PPTreeOps,
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, AMMiniModel, AMModel, AMModelBridge, AMTypes, BackStop, BBUrpEval, EvalQuote, InterpreterOps, InterpreterPrivate, PPTreeOps, Real, Rope, SymTab, UserProfile, WorldVM
EXPORTS InterpreterOps, InterpreterPrivate
=
BEGIN
OPEN AMBridge, AMTypes, InterpreterOps, InterpreterPrivate, BBUrpEval, SafeStorage;
**** Useful types ****
CARD: TYPE = LONG CARDINAL;
LORope: TYPE = LIST OF ROPE;
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
underLORope: Type ← CODE[LORope];
underLORA: Type ← CODE[LORA];
underPROC: Type ← CODE[PROC];
underREF: Type ← CODE[REF];
underBOOL: Type ← CODE[BOOL];
underTYPE: Type ← CODE[Type];
underCARD: Type ← CODE[CARD];
underSIGANY: Type ← CODE[SIGNAL ANY RETURNS ANY];
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;
TVForUnderType:
PROC [under: Type]
RETURNS [
TV] =
TRUSTED {
RETURN [AMBridge.TVForReadOnlyReferent[NEW[Type ← UnderType[under]]]]
};
inner:
INTERNAL PROC =
TRUSTED {
lag: TV ← NIL;
true ← TVForReadOnlyReferent[NEW[BOOL ← TRUE]];
false ← TVForReadOnlyReferent[NEW[BOOL ← FALSE]];
NilTV ← TVForReadOnlyReferent[NEW[REF ← NIL]];
underLORope ← UnderType[underLORope];
underLORA ← UnderType[underLORA];
underPROC ← UnderType[underPROC];
underREF ← UnderType[underREF];
underBOOL ← UnderType[underBOOL];
underTYPE ← UnderType[underTYPE];
underCARD ← UnderType[underCARD];
underSIGANY ← UnderType[underSIGANY];
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["CHAR", lag ← TVForUnderType[CODE[CHAR]], " ... the TYPE"];
DoRegisterTV["CHARACTER", lag, " ... the TYPE"];
DoRegisterTV["CARD", TVForUnderType[CODE[CARD]], " ... the TYPE"];
DoRegisterTV["CARDINAL", TVForUnderType[CODE[CARDINAL]], " ... the TYPE"];
DoRegisterTV["INT", TVForUnderType[CODE[INT]], " ... the TYPE"];
DoRegisterTV["INTEGER", TVForUnderType[CODE[INTEGER]], " ... the TYPE"];
DoRegisterTV["NAT", TVForUnderType[CODE[NAT]], " ... the TYPE"];
DoRegisterTV["LORope", TVForUnderType[CODE[NAT]], " ... the TYPE"];
DoRegisterTV["LORA", TVForUnderType[underLORA], " ... the TYPE: LIST OF REF ANY"];
DoRegisterTV["LORope", TVForUnderType[underLORope], " ... the TYPE: LIST OF ROPE"];
DoRegisterTV["PROC", TVForUnderType[underPROC], " ... the TYPE: PROC"];
DoRegisterTV[
"PROCANY",
TVForUnderType[CODE[PROC ANY RETURNS ANY]],
" ... the TYPE: PROC ANY RETURNS ANY"
];
DoRegisterTV[
"SIGANY",
TVForUnderType[underSIGANY],
" ... the TYPE: SIGNALS 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
};
EnableBlock:
PUBLIC
PROC [head: EvalHead, handler: InterpreterPrivate.ErrorHandler, data:
REF] = {
IF head.specials #
NIL
THEN {
new: REF InterpreterPrivate.ErrorHandlerObj ← NEW[InterpreterPrivate.ErrorHandlerObj ← [handler, data]];
[] ← SymTab.Store[head.specials, "?ErrorHandler", new]
};
};
EvalAndNoteSignalling:
PROC [tree: Tree, head: EvalHead, target: Type]
RETURNS [rtn:
TV ←
NIL, signalled:
BOOL ←
FALSE] = {
WITH tree
SELECT
FROM
node: Node =>
IF node.name = apply
THEN {
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;
[rtn, signalled] ← EvalApply[son1, son2, head, target, node];
RETURN;
};
ENDCASE;
rtn ← EvalNoProps[tree, head, target];
};
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]];
};
signal, error => {
ans: TV;
signalled: BOOL;
[ans, signalled] ← EvalAndNoteSignalling[son1, head, target];
IF
NOT signalled
THEN
DO
SELECT UnderClass[TVType[ans]]
FROM
signal, error => {ans ← DoApply[head, ans, NIL, node, FALSE]; EXIT};
ENDCASE => ans ← UrpWrongType[head, son1, ans, underSIGANY, "not a SIGNAL or ERROR"];
ENDLOOP;
IF kind = error THEN UrpFatal[head, node, "returned from ERROR"];
RETURN [ans];
};
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];
ref, atom, rope => RETURN [tv1];
ENDCASE => GO TO NYI;
};
refTC => {
kind: PPTree.NodeName ← anyTC;
WITH son1
SELECT
FROM
node1: Node => kind ← anyTC;
ENDCASE;
IF kind # anyTC THEN GO TO NYI;
RETURN [globalSymTab.Fetch["REF"].val];
};
expressions
apply =>
RETURN [EvalApply[son1, son2, head, target, node].rtn];
signalx, errorx => {
ans: TV;
signalled: BOOL;
[ans, signalled] ← EvalAndNoteSignalling[son1, head, target];
IF NOT signalled THEN UrpFatal[head, son1, "not a signal call"];
IF kind = errorx THEN UrpFatal[head, node, "returned from ERROR"];
RETURN [ans];
};
syserrorx => {
SIGNAL BackStop.SuspendBackStop;
rtn ← ERROR;
SIGNAL BackStop.ResumeBackStop;
RETURN;
};
cons =>
RETURN [Cons[son2, target, head]];
listcons =>
RETURN [ListCons[son2, target, head]];
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 [EvalRelop[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 ← 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;
};
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;
};
pred, succ => {
tv: TV ← SubEval1[son1];
Discrete:
PROC [c: Class]
RETURNS [d:
BOOL] =
CHECKED {
d ←
SELECT c
FROM
cardinal, longCardinal, integer, longInteger, character, enumerated => TRUE,
ENDCASE => FALSE;
};
DO
SELECT
TRUE
FROM
Discrete[TypeClass[GroundStar[TVType[tv]]]] => RETURN [(SELECT kind FROM pred => Prev, succ => Next, ENDCASE => ERROR)[tv]];
Discrete[TypeClass[GroundStar[target]]] => tv ← UrpWrongType[head, son1, tv, target, "not SUCC or PRED-able"];
ENDCASE => UrpFatal[head, son1, "can't SUCC or PRED it"];
ENDLOOP;
};
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]
};
Cons:
PROC [args: Tree, target: Type, head: EvalHead]
RETURNS [rtn:
TV] = {
carTree: Tree ← ListElem[args, 1];
cdrTree: Tree ← ListElem[args, 2];
carTV: TV;
cdrTV: TV ← EvalNoProps[cdrTree, head, target];
listType, consType, carType: Type;
DO
listType ← UnderType[TVType[cdrTV]];
SELECT TypeClass[listType]
FROM
list => {NULL; EXIT};
nil => {
target ← UnderType[target];
SELECT TypeClass[target]
FROM
list => listType ← target;
ENDCASE => listType ← underLORA;
EXIT};
ENDCASE => cdrTV ← LocalCoerce[head, cdrTree, cdrTV, underLORA, 0, "invalid list"];
ENDLOOP;
consType ← Range[listType];
IF TypeClass[consType] # structure THEN ERROR;
carType ← IndexToType[consType, 1];
carTV ← EvalNoProps[carTree, head, carType];
rtn ← MakeCons[carTV, cdrTV, listType, consType, head];
};
MakeCons:
PROC [carTV, cdrTV:
TV, listType, consType: Type, head: EvalHead]
RETURNS [rtn:
TV] = {
consTV: TV ← New[type: consType, world: WorldFromHead[head]];
Assign[IndexToTV[consTV, 1], carTV];
Assign[IndexToTV[consTV, 2], cdrTV];
TRUSTED {rtn ← TVForReferent[NEW [REF ANY ← RefFromTV[consTV]]]};
rtn ← AMTypes.Coerce[rtn, listType];
};
ListCons:
PROC [args: Tree, target: Type, head: EvalHead]
RETURNS [rtn:
TV] = {
listType: Type ← underLORA;
consType, eltType: Type;
last: TV ← NIL;
PerSon:
PROC [t: Tree] = {
elt: TV ← EvalNoProps[t, head, eltType];
this: TV ← MakeCons[elt, NilTV, listType, consType, head];
IF last = NIL THEN rtn ← this ELSE Assign[last, this];
last ← IndexToTV[Referent[this], 2];
};
target ← UnderType[target];
SELECT TypeClass[target]
FROM
list => listType ← target;
ENDCASE;
consType ← Range[listType];
IF TypeClass[consType] # structure THEN ERROR;
eltType ← IndexToType[consType, 1];
rtn ← NilTV;
WITH args
SELECT
FROM
node: Node => IF node.name = list THEN {PPTreeOps.ScanSons[args, PerSon]; RETURN};
ENDCASE;
PerSon[args];
};
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];
SELECT UnderClass[TVType[rtn]]
FROM
real => {
real: REAL ← AMBridge.TVToReal[rtn];
SELECT kind
FROM
abs => real ← ABS[real];
uminus => real ← -real;
ENDCASE => ERROR;
RETURN [NewReal[real]];
};
integer, longInteger => {
int: INT ← AMBridge.TVToLI[rtn];
SELECT kind
FROM
abs => int ← ABS[int];
uminus => int ← -int;
ENDCASE => ERROR;
RETURN [NewInt[int]];
};
ENDCASE => {
card: CARD ← AMBridge.TVToLC[rtn];
SELECT kind
FROM
abs => card ← card;
uminus => card ← -card;
ENDCASE => ERROR;
RETURN [NewCard[card]];
};
};
EvalRelop:
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 ← AMTypes.TVType[lval];
ltype ← AMTypes.UnderType[ttype];
lclass ← AMTypes.TypeClass[ltype];
IF lclass = subrange
THEN {
ltype ← AMTypes.GroundStar[ltype];
lclass ← AMTypes.TypeClass[ltype];
lval ← AMTypes.Coerce[tv: lval, targetType: ltype];
};
IF target = nullType THEN target ← ttype;
rval ← EvalNoProps[right, head, ltype];
rtype ← AMTypes.UnderType[TVType[rval]];
rclass ← AMTypes.TypeClass[rtype];
IF rclass = subrange
THEN {
rtype ← AMTypes.GroundStar[rtype];
rclass ← AMTypes.TypeClass[rtype];
rval ← AMTypes.Coerce[tv: rval, targetType: rtype];
};
SELECT kind
FROM
relE, relN => {
SELECT lclass
FROM
cardinal, integer, character, longInteger, longCardinal, real, unspecified => {};
these values must be arithmetic
ENDCASE => {
eq: BOOL ← TVEqual[lval, rval];
IF kind = relN THEN eq ← NOT eq;
RETURN [IF eq THEN true ELSE false];
};
};
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];
SELECT
TRUE
FROM
alclass = real, arclass = real => {
raise conciousness to the real level
lreal: REAL ← TVToReal[lval];
rreal: REAL ← TVToReal[rval];
SELECT kind
FROM
relE => rtnBit ← lreal = rreal;
relN => rtnBit ← lreal # rreal;
relL => rtnBit ← lreal < rreal;
relGE => rtnBit ← lreal >= rreal;
relG => rtnBit ← lreal > rreal;
relLE => rtnBit ← lreal <= rreal;
ENDCASE => ERROR;
};
alclass = integer, alclass = longInteger, arclass = integer, arclass = longInteger => {
li: INT ← TVToLI[lval];
ri: INT ← TVToLI[rval];
SELECT kind
FROM
relE => rtnBit ← li = ri;
relN => rtnBit ← li # ri;
relL => rtnBit ← li < ri;
relGE => rtnBit ← li >= ri;
relG => rtnBit ← li > ri;
relLE => rtnBit ← li <= ri;
ENDCASE => ERROR;
};
ENDCASE => {
lc: CARD ← TVToLC[lval];
rc: CARD ← TVToLC[rval];
SELECT kind
FROM
relE => rtnBit ← lc = rc;
relN => rtnBit ← lc # rc;
relL => rtnBit ← lc < rc;
relGE => rtnBit ← lc >= rc;
relG => rtnBit ← lc > rc;
relLE => rtnBit ← lc <= rc;
ENDCASE => ERROR;
};
IF rtnBit THEN RETURN [true] ELSE RETURN [false];
};
EvalBinop:
PROC [left, right: Tree, kind: PPTree.NodeName, head: EvalHead, target: Type, parent: Tree]
RETURNS [rtn:
TV ←
NIL] =
TRUSTED {
altype, artype: Type;
alclass, arclass: Class;
lval: TV ← EvalNoProps[left, head, target];
ttype: Type ← AMTypes.TVType[lval];
ltype: Type ← AMTypes.UnderType[ttype];
lclass: Class ← AMTypes.TypeClass[ltype];
rval: TV ← EvalNoProps[right, head, ltype];
rtype: Type ← AMTypes.UnderType[TVType[rval]];
rclass: Class ← AMTypes.TypeClass[rtype];
IF lclass = subrange
THEN {
ltype ← AMTypes.GroundStar[ltype];
lclass ← AMTypes.TypeClass[ltype];
lval ← AMTypes.Coerce[tv: lval, targetType: ltype];
};
IF target = nullType THEN target ← ttype;
IF rclass = subrange
THEN {
rtype ← AMTypes.GroundStar[rtype];
rclass ← AMTypes.TypeClass[rtype];
rval ← AMTypes.Coerce[tv: rval, targetType: rtype];
};
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];
SELECT
TRUE
FROM
alclass = real, arclass = real => {
raise conciousness to the real level
lreal: REAL ← TVToReal[lval];
rreal: REAL ← TVToReal[rval];
SELECT kind
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;
RETURN [NewReal[lreal]];
};
alclass = integer, alclass = longInteger, arclass = integer, arclass = longInteger => {
li: INT ← TVToLI[lval];
ri: INT ← TVToLI[rval];
SELECT kind
FROM
plus => li ← li + ri;
minus => li ← li - ri;
times => li ← li * ri;
div => li ← li / ri;
mod => li ← li MOD ri;
min => li ← MIN[li, ri];
max => li ← MAX[li, ri]
ENDCASE => ERROR;
RETURN [NewInt[li]];
};
ENDCASE => {
lc: CARD ← TVToLC[lval];
rc: CARD ← TVToLC[rval];
SELECT kind
FROM
plus => lc ← lc + rc;
minus => lc ← lc - rc;
times => lc ← lc * rc;
div => lc ← lc / rc;
mod => lc ← lc MOD rc;
min => lc ← MIN[lc, rc];
max => lc ← MAX[lc, rc]
ENDCASE => ERROR;
RETURN [NewCard[lc]];
};
};
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 ← AMModelBridge.FrameFromContext[head.context];
GO TO valSearch;
};
interface => {
val ← AMModelBridge.IRFromContext[head.context];
GO TO valSearch;
};
ENDCASE => ERROR;
EXITS valSearch => {
val ← InterpreterPrivate.RecordSearch[val, name];
IF val # NIL THEN {ok ← TRUE; RETURN};
IF UserProfile.Boolean["Interpreter.SearchTheWorld",
TRUE]
THEN
inner[AMModel.RootContext[WorldFromHead[head]]];
};
};
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 {
WITH val
SELECT
FROM
nc: EvalQuote.NameClosure =>
val ← nc.proc[head: head, nameAsRope: name, nameAsTree: parent, target: target, data: nc.data];
ENDCASE;
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;
};
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
};
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 ← TVType[rtn ← StripSingleComponentRecord[val]];
ground: Type ← GroundStar[type];
class: Class ← TypeClass[ground];
SELECT class
FROM
real =>
IF type # ground THEN rtn ← NewReal[TVToReal[rtn]];
cardinal, character =>
rtn ← NewCard[TVToCardinal[rtn]];
integer =>
rtn ← NewInt[TVToInteger[rtn]];
longCardinal, longPointer, unspecified =>
rtn ← NewCard[TVToLC[rtn]];
longInteger =>
rtn ← NewInt[TVToLI[rtn]];
pointer => {
ptr:
LONG
POINTER ←
LOOPHOLE[TVToCardinal[rtn],
POINTER];
This extends the address, hopefully the same for all machines
rtn ← NewCard[LOOPHOLE[ptr, INT]];
};
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
};
DoApply:
PROC [head: EvalHead, proc, args:
TV, callTree: Tree, mayCatch:
BOOL]
RETURNS [rtn:
TV] = {
called: BOOL ← FALSE;
CallIt:
PROC =
TRUSTED {
called ← TRUE;
rtn ← AMEvents.Apply[proc, args];
};
SIGNAL BackStop.SuspendBackStop;
{
At this point we really want to call the procedure. We give the user a chance to wrap a level of call around our procedure call in order to better interpret catch phrases and the like.
IF head.specials #
NIL
THEN
WITH SymTab.Fetch[head.specials, "?ErrorHandler"].val
SELECT
FROM
hb:
REF InterpreterPrivate.ErrorHandlerObj => {
catch: Tree ← NIL;
IF mayCatch
AND PPTreeOps.NSons[callTree] >= 3
THEN
catch ← PPTreeOps.NthSon[callTree, 3];
hb.handler[CallIt, hb.data, callTree, catch, head];
GO TO handled;
};
ENDCASE;
CallIt[];
EXITS handled => {};
};
SIGNAL BackStop.ResumeBackStop;
IF
NOT called
THEN
UrpFatal[head, callTree, "procedure not called due to client handler error!"];
};
EvalApply:
PROC [proc, args: Tree, head: EvalHead, target: Type, parent: Tree]
RETURNS [rtn:
TV ←
NIL, signalled:
BOOL ←
FALSE] =
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, signal, error => {
argsRec: TV ← NIL;
argsType, rtnsType: Type;
signalled ←
SELECT pclass
FROM
procedure => FALSE,
signal, error => TRUE,
ENDCASE => ERROR;
IF pval =
NIL
OR AMBridge.TVToLC[pval] = 0
THEN
UrpFatal[head, parent, "NIL procedure?"];
argsType ← UnderType[Domain[ptype]];
rtnsType ←
SELECT pclass
FROM
procedure, signal => UnderType[Range[ptype]],
error => nullType,
ENDCASE => ERROR;
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]];
rtn ← DoApply[head, pval, argsRec, parent, TRUE];
IF pclass = error THEN UrpFatal[head, parent, "returned from ERROR"];
rtn ← IF rtnsType = nullType THEN empty ELSE 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];
};
NewCard:
PROC [card:
CARD]
RETURNS [
TV] =
TRUSTED {
RETURN [AMBridge.TVForReadOnlyReferent[NEW[CARD ← card]]];
};
START HERE
EnsureInit[];
END.