<> <> <> <> 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[]; <> 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]; <> 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 = { <> 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]] }; <> {SELECT kind FROM <> assignx, assign, extractx, extract => RETURN [EvalAssign[son1, son2, head, target, node]]; if, ifx => { test: BOOL _ EvalBool[son1]; IF NOT test THEN son2 _ IF nSons > 2 THEN node.son[3] ELSE NIL; RETURN [SubEval1[son2]]; }; 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]; }; <<>> <> 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]; }; <> 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 => { <> 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 => <> 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 => { <> <> <> 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 { <> 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 => {}; <> ENDCASE => { eq: BOOL _ TVEqual[lval, rval]; IF kind = relN THEN eq _ NOT eq; RETURN [IF eq THEN true ELSE false]; }; }; ENDCASE; <> 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 => { <> 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]; }; <> 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 => { <> 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 { <> ok: BOOL _ FALSE; useWorldContext: BOOL _ FALSE; inner: PROC [context: AMModel.Context] = TRUSTED { <> 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 => { <> val _ AMMiniModel.GetInterfaceRecord[name, WorldFromHead[head] ! Error => IF reason = notImplemented THEN CONTINUE]; IF val # NIL THEN {ok _ TRUE; RETURN}; <> val _ AMModelBridge.FrameFromContext[ AMModel.MostRecentNamedContext[name, context]]; IF val # NIL THEN {ok _ TRUE; RETURN}; { <> 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]]]; }; }; <> 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}; <> [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 { <> 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 { <> temp: TV = AMMiniModel.GetInterfaceRecordFromType[typeValue, world]; IF temp # NIL THEN record _ temp; <> }; }; <<... 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]; <> 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 { <> 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]; <> 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 <> 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; { <> 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]; <> IF procName # NIL THEN { proc: EvalQuote.EvalQuoteProc _ NIL; data: REF _ NIL; [proc, data] _ EvalQuote.Lookup[head.specials, procName]; IF proc # NIL THEN <> RETURN [proc[head, parent, target, data]]; }; pval _ EvalNoProps[proc, head, underPROC]; DO <> 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 <> 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 => <> pval _ IndexToTV[pval, NComponents[TVType[pval]]]; union => <> IF NOT OverlaidOrComputed[ptype] THEN { pval _ Variant[pval]; LOOP} ELSE { <> 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 => <> 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 => <> RETURN [EvalArray[args, head, tval, parent]]; record, structure => { <> IF name # NIL THEN { <> 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 <> RETURN[TVForType[IndexToType[onion, index]]]; }; }; RETURN [EvalRecord[args, head, tval, parent]]; }; enumerated => { <> rtn _ EnumeratedValueFromRope[name, tval]; IF rtn # NIL THEN RETURN; UrpFatal[head, parent, "invalid name"]} ENDCASE => UrpFatal[head, parent, "not implemented"]; } ENDCASE => pval _ UrpWrongType[head, parent, pval, underPROC, "not applicable"] ENDLOOP; }; EvalArray: PROC [args: Tree, head: EvalHead, target: Type, parent: Tree, all: BOOL _ FALSE] RETURNS [new: TV _ NIL] = TRUSTED { domain, range: Type; first, last, each: TV _ NIL; elements, firstLI: INT _ 0; lastLI: INT _ -1; nGiven: INT _ 1; listNode: Node _ NIL; underClass: Class _ UnderClass[target]; <> 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 { <> 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 => { <> } 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]; }; <> 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 { <> 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 => { <> 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] = { <> 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] = { <> 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] = { <> <> <<[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]]]; }; <> EnsureInit[]; END.