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;
**** Useful types ****
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;
**** Global variables BEGIN ****
empty: TV ← BBEmptyReturn.TheEmptyReturn[];
stackSearchDepth: INTEGER ← 8;
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: PUBLIC TV ← NIL;
symtab: SymTab.Ref ← NIL;
tvWorldInit: BOOL ← FALSE;
tvWorldInitMsg: ROPE ← NIL; -- reason for failure to init (if any)
**** Global variables END ****
CantHandleRemote: ERROR = CODE;
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 should degrade gracefully.
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
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 ← 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;
};
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, 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 => {
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, 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 => {
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].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 => {
son1 is the zone, which we completely ignore
son2 is the type
son3 is the initialization expression (if any)
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 {
NOTE: no handling of arithmetic faults yet
int: INT ← 0;
rtn ← ForceArithmetic[EvalNoProps[tree, head, target], head, tree];
IF UnderWear[rtn, head, tree].class = 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, 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 => {
NOTE: TVEqual is too generous about types
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;
At this point the values must be arithmetic.
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 {
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.
ok: BOOL ← FALSE;
tab: SymTab.Ref ← IF head.specials = NIL THEN symtab ELSE head.specials;
inner:
PROC =
TRUSTED {
This routine performs dynamic lookup in the stack.
gf, lf: TV ← NIL;
The constants of an enumerated type take precedence over variables in the stack.
IF target # nullType
THEN {
val ← EnumeratedValueFromRope[name, target];
IF val # NIL THEN {ok ← TRUE; RETURN}};
The local environment takes precedence over the global environment, but there is no point in searching it if it is NIL.
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}};
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.
[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 {
try the default table
[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 {
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.
ok: BOOL ← FALSE;
tab: SymTab.Ref ← IF head.specials = NIL THEN symtab ELSE head.specials;
inner:
PROC =
TRUSTED {
This routine performs dynamic lookup in the stack.
gf, lf: TV ← NIL;
The constants of an enumerated type take precedence over variables in the stack.
IF target # nullType
THEN {
val ← EnumeratedValueFromRope[name, target];
IF val # NIL THEN {ok ← TRUE; RETURN}};
The local environment takes precedence over the global environment, but there is no point in searching it if it is NIL.
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}};
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.
[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 {
try the default table
[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] = {
"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, target: Type]
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]]
};
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 {
Try for the interface type, then make a TV for it
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 {
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
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;
First, try to acquire the left-hand side as a TV, either through lookup or full eval.
SELECT
TRUE
FROM
lnSize # 0 => [record, IRfound] ← LookupTryIR[lname, head, nullType, left];
ENDCASE => record ← EvalNoProps[left, head, nullType];
Now we have a good guy for the left side, try for the selection
FOR i:
NAT
IN [1..100]
DO
keep trying, possibly correcting
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 {
innerSearch tries to determine if there is an interface for the record object.
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;
First try the interface.
irTV ← TryForIRInstance[modName^, head, parent];
IF irTV #
NIL
THEN {
[irTV, tv] ← BBContext.RecordSearch[irTV, name];
};
IF irTV =
NIL
THEN {
Well, the module is not an interface, so try a global frame search
[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 {
Perhaps it is a dot notation kludge
Momma[innerSearch, head, parent, "dotNotation"];
IF fatal # NIL THEN UrpFatal[head, parent, fatal];
IF tv #
NIL
THEN {
glory be! a dotNotation procedure!
RETURN [record, tv];
};
};
IF recTV =
NIL
THEN {
maybe a callback procedure can help us?
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 {
ForceArithmetic forces the given value to be arithmetic; the result is a TV with class = real or class = longInteger.
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
Try to get the right stuff.
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];
First try for a registered EvalQuoteProc.
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]];
};
};
Now look at the proc expr to see if it might be dot notation (like r.Fetch[0])
WITH proc
SELECT
FROM
node: Node =>
IF node.name = dot
THEN {
Could be dot notation, so try this special hack
[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
Until we get to definitely applicable or not.
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
This is a target-typed record or array constructor.
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 a normal variant record, bind the variant and loop
IF
NOT OverlaidOrComputed[ptype]
THEN {
pval ← AMTypes.Variant[pval]; LOOP}
ELSE {
now try to bind the specified variant
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 => {
possibly a variant record type binder, possibly a record constructor
IF name #
NIL
THEN {
possibly we are trying to bind a variant type
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
it is really a variant record type binder!
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 => {
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 ← nil;
getInfo:
PROC =
TRUSTED {
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.
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 {
a local debug var, so no checking necessary; we copy to avoid problems with unretained frames
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 => {
set the default search context if right hand side is simple
IF TreeToRope[right] #
NIL
THEN
head.globalContext ← BBContext.ContextForGlobalFrame[rval];
};
localFrame, sequence, nil, any, union => {
dont try to copy these
}
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]};
Now left MUST be a TV
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 {
returns coercion of value to new value of given type
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 => {
be especially nice to frames
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 => {
go for broke
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.