<> <> <> 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; <> underLORA: Type _ CODE[LORA]; underPROC: Type _ CODE[PROC]; underREF: Type _ CODE[REF]; underBOOL: Type _ CODE[BOOL]; underTYPE: Type _ CODE[Type]; underCARD: Type _ CODE[CARD]; trueCard: CARDINAL _ LOOPHOLE[TRUE, CARDINAL]; falseCard: CARDINAL _ LOOPHOLE[FALSE, CARDINAL]; <> <> true: TV _ NIL; false: TV _ NIL; NilTV: PUBLIC TV _ NIL; symtab: SymTab.Ref _ NIL; tvWorldInit: BOOL _ FALSE; tvWorldInitMsg: ROPE _ NIL; -- reason for failure to init (if any) <<**** Global variables END ****>> CantHandleRemote: ERROR = CODE; EnsureInit: ENTRY PROC = { <> ENABLE UNWIND => NULL; inner: PROC = TRUSTED { IF symtab = NIL THEN symtab _ SymTab.Create[151, TRUE]; true _ TVForReadOnlyReferent[NEW[BOOL _ TRUE]]; false _ TVForReadOnlyReferent[NEW[BOOL _ FALSE]]; NilTV _ TVForReadOnlyReferent[NEW[REF _ NIL]]; [] _ symtab.Store["TRUE", true]; [] _ symtab.Store["FALSE", false]; underLORA _ AMTypes.UnderType[underLORA]; underPROC _ AMTypes.UnderType[underPROC]; underREF _ AMTypes.UnderType[underREF]; underBOOL _ AMTypes.UnderType[underBOOL]; underTYPE _ AMTypes.UnderType[underTYPE]; underCARD _ AMTypes.UnderType[underCARD]; tvWorldInit _ TRUE; }; IF NOT tvWorldInit THEN tvWorldInitMsg _ BBSafety.Mother[inner]; }; GetSymTab: PUBLIC PROC RETURNS [SymTab.Ref] = { EnsureInit[]; RETURN [symtab] }; NewEvalHead: PUBLIC PROC [ context: BBContext.Context, helpFatal: HelpFatal, helpWrongType: HelpWrongType _ NIL, helpId: HelpId _ NIL, helpSelector: HelpSelector _ NIL, helpDefault: HelpDefault _ NIL, data: REF _ NIL, specials: SymTab.Ref _ NIL, globalContext: BBContext.Context _ NIL, abortProc: AbortProc _ NIL] RETURNS [EvalHead] = { RETURN [ NEW [ EvalHeadRep_ [ context: context, helpFatal: helpFatal, helpWrongType: helpWrongType, helpId: helpId, helpSelector: helpSelector, helpDefault: helpDefault, data: data, specials: specials, globalContext: globalContext, abortProc: abortProc]]] }; EvalNoProps: PUBLIC PROC [tree: Tree, head: EvalHead, target: Type] RETURNS [TV] = { IF tree = NIL THEN RETURN [NIL]; IF NOT tvWorldInit THEN EnsureInit[]; WITH tree SELECT FROM hti: PPLeaves.HTIndex => RETURN [Lookup[hti.name, head, target, tree]]; name: ROPE => RETURN [Lookup[name, head, target, tree]]; lti: PPLeaves.LTIndex => RETURN [EvalLti[lti, head, target]]; node: Node => RETURN [EvalNode[node, head, target]] ENDCASE => ERROR }; EvalNode: PROC [node: Node, head: EvalHead, target: Type] RETURNS [rtn: TV _ NIL] = TRUSTED { errmsg: ROPE _ NIL; rtnRef: REF _ NIL; kind: PPTree.NodeName = node.name; nSons: CARDINAL _ node.sonLimit - 1; son1: Tree _ IF nSons > 0 THEN node.son[1] ELSE NIL; son2: Tree _ IF nSons > 1 THEN node.son[2] ELSE NIL; SubEval: PROC [tree: Tree, target: Type] RETURNS [TV] = TRUSTED { RETURN [EvalNoProps[tree, head, target]]; }; SubEval0: PROC [tree: Tree] RETURNS [TV] = TRUSTED { RETURN [EvalNoProps[tree, head, nullType]]; }; SubEval1: PROC [tree: Tree] RETURNS [TV] = TRUSTED { RETURN [EvalNoProps[tree, head, target]]; }; GentleRef: PROC [tv: TV] RETURNS [ref: REF _ NIL] = TRUSTED { IF AMBridge.IsRemote[tv] THEN ERROR CantHandleRemote; SELECT UnderWear[tv, head, node].class FROM nil => ref _ NIL; ref, list, rope, atom => ref _ LOOPHOLE[TVToLC[tv]]; ENDCASE => ref _ SomeRefFromTV[tv]; RETURN [ref] }; Listify: PROC [tv: TV] RETURNS [LORA] = TRUSTED { RETURN [LIST[GentleRef[tv]]] }; EvalBool: PROC [tree: Tree] RETURNS [BOOL] = TRUSTED { RETURN [ForceBoolean[SubEval[tree, underBOOL], head, tree]] }; {SELECT kind FROM <> assignx, assign, extractx, extract => RETURN [EvalAssign[son1, son2, head, target, node]]; if, ifx => { test: BOOL _ EvalBool[son1]; IF NOT test THEN son2 _ IF nSons > 2 THEN node.son[3] ELSE NIL; RETURN [SubEval1[son2]]}; <> processTC => RETURN [Lookup["PROCESS", head, target, node]]; longTC => { tv1: TV _ SubEval0[son1]; type: Type _ ForceType[tv1, head, son1]; SELECT LocalUnderTypeAndClass[type, head, node].class FROM cardinal => RETURN [symtab.Fetch["CARD"].val]; integer => RETURN [symtab.Fetch["INT"].val]; ENDCASE => GO TO NYI; }; <> apply => RETURN [EvalApply[son1, son2, head, target, node]]; cons => { elemTree: Tree _ ListElem[son2, 1]; listTree: Tree _ ListElem[son2, 2]; top: LORA _ Listify[SubEval[elemTree, underREF]]; rest: TV _ SubEval[listTree, underLORA]; rtnRef _ NEW[LORA _ top]; DO restUnder: Type; restClass: Class; [, restUnder, restClass] _ UnderWear[rest, head, node]; IF restClass = nil THEN GO TO forRef; IF restUnder = underLORA THEN EXIT; rest _ LocalCoerce [head, listTree, rest, underLORA, 0, "invalid list"]; ENDLOOP; top.rest _ NARROW[GentleRef[rest], LORA]; GO TO forRef}; listcons => { elems: Tree _ son2; pos: CARDINAL _ 1; top, last: LORA _ NIL; IF elems = NIL THEN RETURN [NIL]; WITH elems SELECT FROM n: Node => IF n.name = list THEN FOR i: CARDINAL IN [1..n.sonLimit) DO etv: TV _ SubEval[n.son[i], underREF]; elist: LORA _ Listify[etv]; IF top = NIL THEN top _ elist ELSE last.rest _ elist; last _ elist ENDLOOP ENDCASE; IF top = NIL THEN top _ Listify[SubEval[elems, underREF]]; rtnRef _ NEW[LORA _ top]; GO TO forRef}; or, and => { <> bool: BOOL _ EvalBool[son1]; IF kind = and AND NOT bool THEN RETURN [false]; IF kind = or AND bool THEN RETURN [true]; RETURN [IF EvalBool[son2] THEN true ELSE false]}; not => RETURN [IF EvalBool[son1] THEN false ELSE true]; relE, relN, relL, relGE, relG, relLE => RETURN [EvalBinop[son1, son2, kind, head, underBOOL, node]]; plus, minus, times, div, mod => RETURN [EvalBinop[son1, son2, kind, head, target, node]]; min, max => { bestUnder: Type _ nullType; bestClass: Class _ nil; bestCard: CARD _ 0; listNode: Node _ NIL; WITH son1 SELECT FROM n: Node => {listNode _ n; nSons _ n.sonLimit - 1}; ENDCASE => nSons _ 1; FOR i: NAT IN [1..nSons] DO arg: Tree _ IF listNode # NIL THEN listNode.son[i] ELSE son1; each: TV _ SubEval1[arg]; eachUnder: Type; eachClass: Class _ UnderWear[each, head, node].class; eachCard: CARD; swap: BOOL _ kind = min; -- if each > best, then swap _ NOT swap IF eachClass = subrange THEN { groungHog: PROC = TRUSTED { eachUnder _ AMTypes.GroundStar[eachUnder]; eachClass _ AMTypes.TypeClass[eachUnder]; }; Momma[groungHog, head, node, "GroundStar"]; }; SELECT eachClass FROM cardinal, longCardinal, character => { eachCard _ AMBridge.TVToLC[each]; IF eachClass # longCardinal THEN eachClass _ longCardinal; SELECT bestClass FROM longCardinal => { IF eachCard > bestCard THEN swap _ NOT swap; }; longInteger => { IF LOOPHOLE[bestCard, INT] < 0 OR eachCard > bestCard THEN swap _ NOT swap; }; real => { real: REAL _ eachCard; -- force the conversion IF real > LOOPHOLE[bestCard, REAL] THEN swap _ NOT swap; }; nil => swap _ TRUE; ENDCASE => GO TO notComparable; }; enumerated => { eachCard _ AMBridge.TVToLC[each]; SELECT bestClass FROM enumerated => { <> IF eachCard > bestCard THEN swap _ NOT swap; }; nil => swap _ TRUE; ENDCASE => GO TO notComparable; }; integer, longInteger => { eachInt: INT _ AMBridge.TVToLI[each]; eachCard _ LOOPHOLE[eachInt]; IF eachClass # longInteger THEN eachClass _ longInteger; SELECT bestClass FROM longCardinal => IF eachInt > 0 AND eachCard > bestCard THEN swap _ NOT swap; longInteger => IF eachInt > LOOPHOLE[bestCard, INT] THEN swap _ NOT swap; real => { real: REAL _ eachInt; -- force the conversion IF real > LOOPHOLE[bestCard, REAL] THEN swap _ NOT swap; }; nil => swap _ TRUE; ENDCASE => GO TO notComparable; }; real => { eachReal,bestReal: REAL; eachCard _ AMBridge.TVToLC[each]; eachReal _ LOOPHOLE[eachCard]; SELECT bestClass FROM longCardinal => bestReal _ bestCard; longInteger => bestReal _ LOOPHOLE[bestCard, INT]; real => bestReal _ LOOPHOLE[bestCard]; nil => GO TO noCompare; ENDCASE => GO TO notComparable; IF eachReal > bestReal THEN swap _ NOT swap; EXITS noCompare => {swap _ TRUE}; }; ENDCASE => GO TO notOrdered; IF swap THEN { rtn _ each; bestUnder _ eachUnder; bestClass _ eachClass; bestCard _ eachCard}; ENDLOOP; RETURN; EXITS notOrdered => UrpFatal[head, node, "not an ordered type"]; notComparable => UrpFatal[head, node, "incomparable types"]; }; dot => RETURN [EvalDot[son1, son2, node, head, target].tv]; uminus, abs => RETURN [EvalUnop[son1, kind, head, target]]; all => RETURN [EvalArray[son1, head, target, node, TRUE]]; addr => { tv: TV _ SubEval0[son1]; lp: LONG POINTER _ NIL; lp _ PointerFromTV[tv ! AMTypes.Error => CONTINUE]; IF lp # NIL THEN {rtnRef _ NEW[LONG POINTER _ lp]; GO TO forRef}; IF (rtnRef _ GentleRef[tv]) # NIL THEN {rtnRef _ NEW[REF _ rtnRef]; GO TO forRef}; errmsg _ "could not get address"; GO TO fatal}; uparrow => RETURN[SafeReferent[SubEval0[son1], head, node]]; lengthen, mwconst, clit, llit => GO TO evalSon; size, typecode, first, last => { type: Type _ ForceType[SubEval0[son1], head, node]; SELECT kind FROM size => { rtnRef _ NEW[CARDINAL _ BBApply.CalculateRecordSize[type]]; GO TO forRef}; typecode => RETURN[NewType[type]]; first => RETURN [First[type]]; last => RETURN [Last[type]] ENDCASE => ERROR}; loophole => { IF son2 # NIL THEN target _ ForceType[SubEval0[son2], head, node]; RETURN [LocalLoophole[head, node, SubEval[son1, target], target]]; }; nil => RETURN [NilTV]; new => { <> <> <> world: WorldVM.World _ BBEvalUtil.WorldFromHead[head]; IF world # WorldVM.LocalWorld[] THEN GO TO notRemote ELSE { son3: Tree _ IF nSons > 2 THEN node.son[3] ELSE NIL; repType: Type _ ForceType[SubEval0[son2], head, node]; rtn: TV _ IF son3 = NIL THEN NIL ELSE SubEval[son3, repType]; ref: REF _ NIL; innerNew: PROC = TRUSTED { IF son3 = NIL THEN rtn _ AMTypes.New[type: repType, world: world] ELSE rtn _ AMTypes.Copy[rtn]; ref _ AMBridge.SomeRefFromTV[rtn]; rtnRef _ NEW[REF _ ref]; }; Momma[innerNew, head, node, "NEW"]; GO TO forRef; }; }; atom => { name: ROPE _ TreeToRope[son1]; atom: ATOM _ AtomsPrivate.GetAtom [name.Flatten[IF Rope.Match["$*", name] THEN 1 ELSE 0]]; IF atom = NIL THEN { errmsg _ "invalid atom"; GO TO fatal}; rtnRef _ NEW[ATOM _ atom]; GO TO forRef}; length => { tv: TV _ SubEval0[son1]; type,under: Type; class: Class; DO [type,under,class] _ UnderWear[tv, head, son1]; SELECT class FROM descriptor, longDescriptor, rope => RETURN [NewInt[AMTypes.Length[tv]]]; ENDCASE => tv _ UrpWrongType[head, son1, tv, target, "not a descriptor"]; ENDLOOP }; ENDCASE => GO TO NYI EXITS evalSon => RETURN [SubEval1[son1]]; forRef => RETURN [TVForReferent[rtnRef]]; fatal => UrpFatal[head, node, errmsg]; notRemote => UrpFatal[head, node, "not implemented for remote"]; NYI => UrpFatal[head, node, "not implemented"]}; ERROR }; ListElem: PROC [tree: Tree, n: CARDINAL _ 1] RETURNS [Tree] = { IF n = 0 THEN RETURN [tree]; WITH tree SELECT FROM node: Node => IF node.name = list THEN { IF n IN [1..node.sonLimit) THEN RETURN [node[n]]; RETURN [NIL]} ENDCASE; IF n = 1 THEN RETURN [tree] ELSE RETURN [NIL] }; EvalUnop: PROC [tree: Tree, kind: PPTree.NodeName, head: EvalHead, target: Type] RETURNS [rtn: TV _ NIL] = TRUSTED { <> int: INT _ 0; rtn _ ForceArithmetic[EvalNoProps[tree, head, target], head, tree]; IF UnderWear[rtn, head, tree].class = real THEN { <> real: REAL _ LOOPHOLE[AMBridge.TVToLC[rtn]]; SELECT kind FROM abs => real _ ABS[real]; uminus => real _ -real; ENDCASE => ERROR; RETURN [NewReal[real]]; }; int _ TVToLI[rtn]; SELECT kind FROM abs => int _ ABS[int]; uminus => int _ -int; ENDCASE => ERROR; rtn _ NewInt[int]; }; EvalBinop: PROC [left, right: Tree, kind: PPTree.NodeName, head: EvalHead, target: Type, parent: Tree] RETURNS [rtn: TV _ NIL] = TRUSTED { op: PPTree.NodeName _ kind; lval, rval: TV _ NIL; ltype, rtype, ttype, altype, artype: Type; lclass, rclass, alclass, arclass: Class; rtnBit: BOOL; lval _ EvalNoProps[left, head, target]; [ttype, ltype, lclass] _ UnderWear[lval, head, left]; IF target = nullType THEN target _ ttype; rval _ EvalNoProps[right, head, ltype]; [, rtype, rclass] _ UnderWear[rval, head, right]; SELECT kind FROM relE, relN => SELECT lclass FROM subrange, cardinal, integer, character, longInteger, longCardinal, real, unspecified => -- these values must be arithmetic op _ minus ENDCASE => { <> inner: PROC = TRUSTED {eq _ TVEqual[lval, rval]}; lc1,lc2: CARD _ 0; eq: BOOL _ FALSE; {ENABLE ANY => GO TO tryLong; eq _ TVToLC[lval] = TVToLC[rval]; EXITS tryLong => Momma[inner, head, parent, "equal test"]}; IF kind = relN THEN eq _ NOT eq; RETURN [IF eq THEN true ELSE false]}; relL, relGE, relG, relLE => op _ minus ENDCASE; <> lval _ ForceArithmetic[lval, head, left]; [, altype, alclass] _ UnderWear[lval, head, left]; rval _ ForceArithmetic[rval, head, right]; [, artype, arclass] _ UnderWear[rval, head, right]; IF alclass = real OR arclass = real THEN { -- raise conciousness to the real level lreal: REAL _ TVToReal[lval]; rreal: REAL _ TVToReal[rval]; IF lclass # real THEN lreal _ TVToLI[lval]; IF rclass # real THEN rreal _ TVToLI[rval]; SELECT op FROM plus => lreal _ lreal + rreal; minus => lreal _ lreal - rreal; times => lreal _ lreal * rreal; div => lreal _ lreal / rreal; mod => lreal _ Real.FRem[lreal, rreal]; min => lreal _ MIN[lreal, rreal]; max => lreal _ MAX[lreal, rreal] ENDCASE => ERROR; SELECT kind FROM relE => rtnBit _ lreal = 0.0; relN => rtnBit _ lreal # 0.0; relL => rtnBit _ lreal < 0.0; relGE => rtnBit _ lreal >= 0.0; relG => rtnBit _ lreal > 0.0; relLE => rtnBit _ lreal <= 0.0; ENDCASE => RETURN [NewReal[lreal]]; IF rtnBit THEN RETURN [true] ELSE RETURN [false]; }; { lint: INT _ TVToLI[lval]; rint: INT _ TVToLI[rval]; SELECT op FROM plus => lint _ lint + rint; minus => lint _ lint - rint; times => lint _ lint * rint; div => lint _ lint / rint; mod => lint _ lint MOD rint; min => lint _ MIN[lint, rint]; max => lint _ MAX[lint, rint] ENDCASE => ERROR; SELECT kind FROM relE => rtnBit _ lint = 0; relN => rtnBit _ lint # 0; relL => rtnBit _ lint < 0; relGE => rtnBit _ lint >= 0; relG => rtnBit _ lint > 0; relLE => rtnBit _ lint <= 0; ENDCASE => RETURN [NewInt[lint]]; IF rtnBit THEN RETURN [true] ELSE RETURN [false]; } }; Lookup: PROC [name: ROPE, head: EvalHead, target: Type, parent: Tree] RETURNS [val: TV _ NIL] = TRUSTED { <> ok: BOOL _ FALSE; tab: SymTab.Ref _ IF head.specials = NIL THEN symtab ELSE head.specials; inner: PROC = TRUSTED { <> gf, lf: TV _ NIL; <> IF target # nullType THEN { val _ EnumeratedValueFromRope[name, target]; IF val # NIL THEN {ok _ TRUE; RETURN}}; <> IF head.context # NIL THEN { [gf, lf, val] _ BBContext.StackSearch[head.context, name, TRUE, stackSearchDepth]; IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN}}; <> [gf, lf, val] _ BBContext.StackSearch [head.globalContext, name, TRUE, stackSearchDepth]; IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN}; }; DO IF name.Size[] = 0 THEN UrpFatal[head, parent, "invalid name"]; [ok, val] _ tab.Fetch[name]; IF ok THEN RETURN; IF tab # symtab THEN { <> [ok, val] _ symtab.Fetch[name]; IF ok THEN RETURN}; IF NOT Rope.Match["*&*", name] THEN { Momma[inner, head, name, "lookup"]; IF ok THEN RETURN; }; { correct: RopeOrTV _ UrpId[head, parent, name, nullType, target, "undefined"]; WITH c: correct SELECT FROM both => {val _ c.tv; FixHti[parent, name _ c.rope]; RETURN}; rope => FixHti[parent, name _ c.rope]; tv => {val _ c.tv; RETURN}; ENDCASE}; ENDLOOP; }; LookupTryIR: PROC [name: ROPE, head: EvalHead, target: Type, parent: Tree] RETURNS [val: TV _ NIL, IRfound: BOOL _ FALSE] = TRUSTED { <> ok: BOOL _ FALSE; tab: SymTab.Ref _ IF head.specials = NIL THEN symtab ELSE head.specials; inner: PROC = TRUSTED { <> gf, lf: TV _ NIL; <> IF target # nullType THEN { val _ EnumeratedValueFromRope[name, target]; IF val # NIL THEN {ok _ TRUE; RETURN}}; <> IF head.context # NIL THEN { [gf, lf, val] _ BBContext.StackSearch[head.context, name, TRUE, stackSearchDepth]; IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN}}; <> [gf, lf, val] _ BBContext.StackSearch [head.globalContext, name, TRUE, stackSearchDepth]; IF gf # NIL OR lf # NIL THEN {ok _ TRUE; RETURN}; }; DO IF name.Size[] = 0 THEN UrpFatal[head, parent, "invalid name"]; [ok, val] _ tab.Fetch[name]; IF ok THEN RETURN; IF tab # symtab THEN { <> [ok, val] _ symtab.Fetch[name]; IF ok THEN RETURN}; IF NOT Rope.Match["*&*", name] THEN { val _ TryForIRInstance[name, head, parent]; IF val # NIL THEN {IRfound _ TRUE; RETURN}; Momma[inner, head, name, "lookup"]; IF ok THEN RETURN; }; { correct: RopeOrTV _ UrpId[head, parent, name, nullType, target, "undefined"]; WITH c: correct SELECT FROM both => {val _ c.tv; FixHti[parent, name _ c.rope]; RETURN}; rope => FixHti[parent, name _ c.rope]; tv => {val _ c.tv; RETURN}; ENDCASE}; ENDLOOP; }; FixHti: PROC [tree: Tree, fix: ROPE] = { <<"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 { <> val: REF _ lti.value; WITH val SELECT FROM rope: ROPE => val _ NEW[ROPE _ rope]; text: REF TEXT => val _ NEW[REF TEXT _ text] ENDCASE; RETURN [TVForReadOnlyReferent[val]] }; TryForIRInstance: PROC [irName: ROPE, head: EvalHead, parent: Tree] RETURNS [irTV: TV _ NIL] = { inner: PROC = TRUSTED { world: WorldVM.World = BBEvalUtil.WorldFromHead[head]; irTV _ RTMiniModel.AcquireIRInstance[ irName, world ! ANY -- Should be: AMTypes.Error -- => CONTINUE]; IF irTV = NIL THEN { <> irt: Type = RTMiniModel.AcquireIRType[irName, world ! AMTypes.Error => GO TO none]; irTV _ CopyToGivenWorld[world, TVForType[irt], TRUE]; EXITS none => {}; }; }; Momma[inner, head, parent, "interface lookup"]; }; EvalDot: PROC [left, right, parent: Tree, head: EvalHead, target: Type, useDotNotation: BOOL _ FALSE] RETURNS [tv: TV _ NIL, procTV: TV _ NIL] = TRUSTED { <> name: ROPE _ TreeToRope[right]; record: TV _ NIL; lname: ROPE _ TreeToRope[left]; lnSize: INT _ lname.Size[]; recTV, irTV: TV _ NIL; msg: ROPE _ NIL; IRfound: BOOL _ FALSE; <<>> <> SELECT TRUE FROM lnSize # 0 => [record, IRfound] _ LookupTryIR[lname, head, nullType, left]; ENDCASE => record _ EvalNoProps[left, head, nullType]; <<>> <> FOR i: NAT IN [1..100] DO <> fatal: ROPE _ NIL; inner: PROC = TRUSTED { [recTV, tv] _ BBContext.RecordSearch[record, name]; IF IRfound THEN SELECT UnderClass[AMTypes.TVType[tv]] FROM procedure, error, signal, program, port => IF AMBridge.TVToLC[tv] = 0 THEN fatal _ "NIL procedure from interface"; ENDCASE; }; innerSearch: PROC = TRUSTED { <> modName: REF ROPE _ NEW[ROPE _ NIL]; recType: Type _ AMTypes.TVType[record]; tv _ NIL; [] _ AMTypes.TypeToName[recType, modName]; IF modName^ = NIL THEN SELECT UnderClass[recType] FROM rope => modName^ _ "Rope"; atom => modName^ _ "Atom"; list => modName^ _ "List"; ENDCASE => RETURN; <> irTV _ TryForIRInstance[modName^, head, parent]; IF irTV # NIL THEN { [irTV, tv] _ BBContext.RecordSearch[irTV, name]; }; IF irTV = NIL THEN { <> [irTV, tv] _ BBContext.GlobalFrameSearch[head.context, modName^, name]; }; SELECT UnderClass[AMTypes.TVType[tv]] FROM procedure => IF AMBridge.TVToLC[tv] = 0 THEN fatal _ "NIL procedure from interface"; ENDCASE => tv _ NIL; }; irTV _ recTV _ NIL; Momma[inner, head, parent, "selection"]; IF fatal # NIL THEN UrpFatal[head, parent, fatal]; IF useDotNotation AND recTV = NIL THEN { <> Momma[innerSearch, head, parent, "dotNotation"]; IF fatal # NIL THEN UrpFatal[head, parent, fatal]; IF tv # NIL THEN { <> RETURN [record, tv]; }; }; IF recTV = NIL THEN { <> correct: RopeOrTV _ UrpSelector[head, parent, name, record, target, "selection failed"]; WITH c: correct SELECT FROM both => {FixHti[right, name _ c.rope]; tv _ c.tv; EXIT}; rope => FixHti[right, name _ c.rope]; tv => {tv _ c.tv; EXIT}; ENDCASE; LOOP}; SELECT UnderWear[tv, head, parent].class FROM union => { IF OverlaidOrComputed[AMTypes.TVType[tv]] THEN UrpFatal[head, parent, "Can't handle OVERLAID or COMPUTED"]; tv _ Variant[tv]}; ENDCASE; RETURN [tv] ENDLOOP; }; ForceArithmetic: PROC [val: TV, head: EvalHead, parent: Tree] RETURNS [rtn: TV] = TRUSTED { <> oops: BOOL _ FALSE; inner: PROC = TRUSTED { ref: REF _ NIL; int: INT _ 0; type: Type _ TVType[rtn]; ground: Type _ GroundStar[type]; class: Class _ TypeClass[ground]; SELECT class FROM real => IF type # ground THEN rtn _ NewReal[TVToReal[rtn]]; cardinal, character, unspecified => rtn _ NewInt[TVToCardinal[rtn]]; integer => rtn _ NewInt[TVToInteger[rtn]]; longCardinal => rtn _ NewInt[LOOPHOLE[TVToLC[rtn], INT]]; longInteger => IF type # ground THEN rtn _ NewInt[TVToLI[rtn]] ENDCASE => oops _ TRUE }; rtn _ StripSingleComponentRecord[val, head, parent]; Momma[inner, head, parent, "arithmetic"]; IF oops THEN UrpFatal[head, parent, "not a number"] }; StripSingleComponentRecord: PROC [tv: TV, head: EvalHead, parent: Tree, max: NAT _ 100] RETURNS [rtn: TV] = TRUSTED { inner: PROC = TRUSTED { THROUGH [0..max) DO type, under: Type; class: Class; [type, under, class] _ UnderWear[rtn, head, parent]; IF (class # record AND class # structure) THEN EXIT; IF NComponents[under] # 1 THEN EXIT; rtn _ FirstComponent[rtn]; ENDLOOP; }; rtn _ tv; Momma[inner, head, parent]; }; ForceBoolean: PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [BOOL] = TRUSTED { rtn: TV _ tv; DO <> rtn _ StripSingleComponentRecord[rtn, head, parent]; IF AMTypes.UnderType[AMTypes.TVType[tv]] = underBOOL THEN { card: CARDINAL _ TVToCardinal[rtn]; IF card = trueCard THEN RETURN [TRUE]; IF card = falseCard THEN RETURN [FALSE]}; rtn _ UrpWrongType[head, parent, rtn, underBOOL, "not boolean"] ENDLOOP }; ForceType: PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [type: Type] = TRUSTED { rtn: TV _ tv; DO type, under: Type; class: Class; [type, under, class] _ UnderWear[rtn, head, parent]; IF class = type THEN RETURN [AMTypes.TVToType[rtn]]; IF under = underTYPE THEN RETURN [LOOPHOLE[AMBridge.TVToCardinal[rtn]]]; UrpFatal[head, parent, "not a TYPE"]; ENDLOOP }; EvalApply: PROC [proc, args: Tree, head: EvalHead, target: Type, parent: Tree] RETURNS [rtn: TV _ NIL] = TRUSTED { pval, firstArg: TV _ NIL; ptype: Type; pclass: Class; triesLeft: INTEGER _ 32; procName: ROPE _ TreeToRope[proc]; <> IF procName # NIL THEN { proc: BBEvalQuote.EvalQuoteProc _ NIL; data: REF _ NIL; [proc, data] _ BBEvalQuote.Lookup[procName]; IF proc # NIL THEN { -- we got it, now its not our job anymore! RETURN [proc[head, parent, target, data]]; }; }; <> WITH proc SELECT FROM node: Node => IF node.name = dot THEN { <> [firstArg, pval] _ EvalDot[node[1], node[2], node, head, underPROC, TRUE]; IF pval = NIL THEN {pval _ firstArg; firstArg _ NIL}; } ELSE pval _ EvalNoProps[proc, head, underPROC]; ENDCASE => pval _ EvalNoProps[proc, head, underPROC]; DO <> TestAbort[head, parent]; [, ptype, pclass] _ UnderWear[pval, head, parent]; IF (triesLeft _ triesLeft - 1) < 0 THEN UrpFatal[head, proc, "too many indirections"]; IF pval = NIL AND proc = NIL THEN <> SELECT LocalUnderTypeAndClass[target, head, parent].class FROM array => RETURN [EvalArray[args, head, target, parent]]; record, structure => RETURN [EvalRecord[args, head, target, parent]]; ENDCASE => UrpFatal[head, proc, "invalid constructor"]; SELECT pclass FROM procedure => { getArgsType: PROC = TRUSTED { argsType _ AMTypes.UnderType[AMTypes.Domain[ptype]]; rtnsType _ AMTypes.UnderType[AMTypes.Range[ptype]]; }; argsRec: TV _ NIL; argsType, rtnsType: Type; IF pval = NIL OR AMBridge.TVToLC[pval] = 0 THEN UrpFatal[head, parent, "NIL procedure?"]; Momma[getArgsType, head, parent, "arguments type"]; IF argsType = nullType THEN { IF args # NIL THEN UrpFatal[head, parent, "too many arguments given, 0 expected"]} ELSE { argsRec _ BBEvalUtil.EvalRecord[ args, head, argsType, parent, firstArg, AMBridge.GetWorld[pval]]; }; rtn _ BBApply.ApplyProcToRecord[pval, argsRec]; IF rtnsType = nullType THEN RETURN [empty]; rtn _ StripSingleComponentRecord[rtn, head, parent, 1]; RETURN}; record, structure => -- try to get the array/sequence part, then loop pval _ LastComponent[pval, head, parent]; union => <> IF NOT OverlaidOrComputed[ptype] THEN { pval _ AMTypes.Variant[pval]; LOOP} ELSE { <> ENABLE AMTypes.Error => GO TO foo; index: CARDINAL = AMTypes.NameToIndex[ptype, TreeToRope[args]]; IF index = 0 THEN GO TO foo; ptype _ AMTypes.IndexToType[ptype, index]; RETURN [AMBridge.Loophole[pval, ptype]]; EXITS foo => UrpFatal[head, parent, "invalid tag"]; }; ref, pointer, longPointer => -- try to get the referent, then loop pval _ SafeReferent[pval, head, parent]; basePointer => { relPtr: TV _ EvalNoProps[args, head, nullType]; inner: PROC = TRUSTED { rtn _ AMTypes.Referent[relPtr, pval]; }; Momma[inner, head, parent, "relative dereference"]; RETURN; }; array, sequence, descriptor, longDescriptor => { domain: Type; index: TV _ NIL; inner1: PROC = TRUSTED { SELECT pclass FROM descriptor, longDescriptor => ptype _ AMTypes.Range[ptype]; ENDCASE; domain _ AMTypes.Domain[ptype]; }; inner2: PROC = TRUSTED { rtn _ AMTypes.Apply[pval, index]; }; Momma[inner1, head, parent, "subscripting"]; index _ EvalNoProps[args, head, domain]; index _ LocalCoerce[head, parent, index, domain, 0, "invalid index type"]; Momma[inner2, head, parent, "subscripting"]; RETURN; }; type => { tval: Type _ AMTypes.TVToType[pval]; tunder: Type; tclass: Class; name: ROPE _ TreeToRope[args]; [tunder, tclass] _ LocalUnderTypeAndClass[tval, head, parent]; SELECT tclass FROM array => -- well, try for the constructor RETURN [EvalArray[args, head, tval, parent]]; record, structure => { <> IF name # NIL THEN { <> onion: Type; onionClass: Class; boundTV: TV _ NIL; innerOnion: PROC = TRUSTED { [onion, onionClass] _ AMTypes.VariableType[tval]; IF onionClass = union THEN { index: CARDINAL _ AMTypes.NameToIndex[ onion, name ! AMTypes.Error => GO TO notHere]; IF index # 0 THEN <> boundTV _ TVForType[AMTypes.IndexToType[onion, index]]; EXITS notHere => {}; }; }; Momma[innerOnion, head, parent, "constructor"]; IF boundTV # NIL THEN RETURN [boundTV]; }; RETURN [EvalRecord[args, head, tval, parent]]; }; enumerated => { <> rtn _ EnumeratedValueFromRope[name, tval]; IF rtn # NIL THEN RETURN; UrpFatal[head, parent, "invalid name"]} ENDCASE => UrpFatal[head, parent, "not implemented"]; } ENDCASE => pval _ UrpWrongType[head, parent, pval, underPROC, "not applicable"] ENDLOOP; }; EvalArray: PROC [args: Tree, head: EvalHead, target: Type, parent: Tree, all: BOOL _ FALSE] RETURNS [new: TV _ NIL] = TRUSTED { domain, range: Type; first, last, each: TV _ NIL; elements, firstLI: INT _ 0; lastLI: INT _ -1; nGiven: INT _ 1; listNode: Node _ NIL; underClass: Class _ nil; getInfo: PROC = TRUSTED { <> underClass _ UnderClass[target]; IF underClass # array THEN RETURN; range _ AMTypes.Range[target]; first _ AMTypes.First[domain _ AMTypes.Domain[target]]; last _ AMTypes.Last[domain]; firstLI _ AMBridge.TVToLI[first]; lastLI _ AMBridge.TVToLI[last]; elements _ lastLI - firstLI + 1; new _ AMTypes.New[type: target, world: BBEvalUtil.WorldFromHead[head]]; IF all THEN nGiven _ elements ELSE WITH args SELECT FROM node: Node => SELECT node.name FROM list => {listNode _ node; nGiven _ node.sonLimit - 1}; ENDCASE; ENDCASE; }; BBEvalUtil.Momma[getInfo, head, parent, "array constructor"]; IF underClass # array THEN UrpFatal[head, parent, "target not an array"]; each _ first; IF elements # nGiven THEN UrpFatal[head, parent, "Wrong # of elements"]; FOR i: INT IN [1..nGiven] DO elemTV: TV _ NIL; valueTV: TV _ EvalNoProps[IF listNode # NIL THEN listNode[i] ELSE args, head, range]; inner: PROC = TRUSTED { elemTV _ AMTypes.Apply[new, each]; AMBridgeExtras.AssignNew[elemTV, valueTV]; each _ AMTypes.Next[each]; }; BBEvalUtil.Momma[inner, head, parent, "array constructor"]; ENDLOOP; }; EvalAssign: PROC [left, right: Tree, head: EvalHead, target: Type, parent: Tree] RETURNS [TV] = TRUSTED { lval, rval: TV _ NIL; name: ROPE _ TreeToRope[left]; nameSize: INT _ name.Size[]; tab: SymTab.Ref _ IF head.specials = NIL THEN symtab ELSE head.specials; IF Rope.Match["*&*", name] THEN { <> lval _ rval _ EvalNoProps[right, head, target]; -- default to no copy IF lval = empty THEN RETURN [empty]; WHILE rval # NIL DO type, under: Type; class: Class; safeCase: PROC = TRUSTED { lval _ rval; SELECT class FROM globalFrame => { <> IF TreeToRope[right] # NIL THEN head.globalContext _ BBContext.ContextForGlobalFrame[rval]; }; localFrame, sequence, nil, any, union => { <> } ENDCASE => IF TVStatus[rval] # const AND rval # empty THEN lval _ AMTypes.Copy[rval]; }; [type, under, class] _ UnderWear[rval, head, parent]; Momma[safeCase, head, parent, "assign"]; EXIT ENDLOOP; IF nameSize > 1 THEN [] _ tab.Store[name, lval]; [] _ tab.Store["&", lval]; [] _ symtab.Store["&&", lval]; RETURN [lval]}; <> IF left # NIL THEN { lval _ EvalNoProps[left, head, target]; target _ UnderWear[lval, head, left].type}; rval _ EvalNoProps[right, head, target]; IF left = NIL THEN RETURN [empty]; RETURN [DoAssign[lval, rval, head, target, parent]] }; DoAssign: PROC [lhs, rhs: TV, head: EvalHead, target: Type, parent: Tree] RETURNS [TV] = { fullType, ltype, rtype: Type; lclass, rclass: Class; msg: ROPE _ NIL; [fullType, ltype, lclass] _ UnderWear[lhs, head, parent]; [, rtype, rclass] _ UnderWear[rhs, head, parent]; IF ltype # rtype THEN rhs _ LocalCoerce[head, parent, rhs, fullType]; msg _ SafeAssign[lhs, rhs, head, parent]; IF msg # NIL THEN UrpFatal[head, parent, msg]; RETURN [rhs] }; LocalLoophole: PROC [head: EvalHead, parent: Tree, current: TV, target: Type] RETURNS [tv: TV _ NIL] = TRUSTED { <> innerLoophole: PROC = TRUSTED { type: Type _ TVType[current]; under, tunder: Type; class, tclass: Class; isRemote: BOOL _ AMBridge.IsRemote[current]; [tunder, tclass] _ UnderTypeAndClass[target]; [under, class] _ UnderTypeAndClass[type]; IF under = tunder THEN {tv _ current; RETURN}; SELECT class FROM globalFrame => { <> IF isRemote THEN lc _ AMBridge.RemoteGFHFromTV[current].gfh ELSE lc _ LOOPHOLE[AMBridge.GFHFromTV[current], CARDINAL]; GO TO common}; localFrame => { IF isRemote THEN lc _ AMBridge.RemoteFHFromTV[current].fh ELSE lc _ LOOPHOLE[AMBridge.FHFromTV[current], CARDINAL]; GO TO common}; ENDCASE; IF current = NIL THEN current _ NilTV ELSE current _ CopyToImpliedWorld[head, current, TRUE]; tv _ AMBridge.Loophole[current, target ! AMTypes.Error => CONTINUE]; IF tv # NIL THEN RETURN; SELECT tclass FROM list, ref, atom, rope, countedZone, uncountedZone => tv _ LocalCoerce[head, parent, current, target]; ENDCASE => { <> lc _ TVToLC[current]; GO TO common}; EXITS common => SetTVFromLC[tv _ New[target], lc] }; lc: CARD _ 0; IF target = nullType THEN target _ underCARD; Momma[innerLoophole, head, parent, "LOOPHOLE"]; }; SafeReferent: PROC [ref: TV, head: EvalHead, parent: Tree] RETURNS [referent: TV _ NIL] = TRUSTED { type, under: Type; class: Class; msg: ROPE _ NIL; innerReferent: PROC = TRUSTED { IF AMBridge.TVToLC[ref] = 0 THEN { msg _ "can't dereference NIL"; RETURN}; SELECT UnderClass[AMTypes.Range[under]] FROM unspecified => {msg _ "unspecified range"; RETURN}; ENDCASE; referent _ AMTypes.Referent[ref]; }; DO ref _ StripSingleComponentRecord[ref, head, parent]; [type, under, class] _ UnderWear[ref, head, parent]; SELECT class FROM pointer, longPointer, basePointer, ref, list, nil => { Momma[innerReferent, head, parent, "dereference"]; IF msg # NIL THEN UrpFatal[head, parent, msg]; RETURN; }; ENDCASE => EXIT; ENDLOOP; UrpFatal[head, parent, "invalid type for dereference"]; }; CopyToImpliedWorld: PROC [head: EvalHead, tv: TV, noCopyIfSameWorld: BOOL _ FALSE] RETURNS [ntv: TV _ NIL] = TRUSTED { ntv _ CopyToGivenWorld[BBEvalUtil.WorldFromHead[head], tv, noCopyIfSameWorld]; }; CopyToGivenWorld: PROC [world: WorldVM.World, tv: TV, noCopyIfSameWorld: BOOL _ FALSE] RETURNS [ntv: TV _ NIL] = TRUSTED { IF world = AMBridge.GetWorld[tv] THEN { ntv _ IF noCopyIfSameWorld THEN tv ELSE AMTypes.Copy[tv]; RETURN}; { tag: TV _ NIL; type: Type _ AMTypes.TVType[tv]; SELECT AMTypes.VariableType[type].c FROM union, sequence => tag _ AMTypes.Tag[AMTypes.IndexToTV[tv, AMTypes.NComponents[type]]]; ENDCASE; ntv _ AMTypes.New[type: type, world: world, tag: tag]; IF AMTypes.TVSize[tv] <= 2 AND AMBridge.TVToLC[tv] = AMBridge.TVToLC[ntv] THEN RETURN; -- no assignment necessary AMBridgeExtras.AssignNew[ntv, tv]}; }; UnderClass: PROC [type: Type] RETURNS [Class] = TRUSTED { RETURN [AMTypes.TypeClass[AMTypes.UnderType[type]]]; }; OverlaidOrComputed: PROC [type: Type] RETURNS [BOOL] = TRUSTED { type _ AMTypes.UnderType[type]; RETURN [AMTypes.IsComputed[type] OR AMTypes.IsOverlaid[type]]; }; LastComponent: PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [comp: TV] = TRUSTED { inner: PROC = TRUSTED { comp _ AMTypes.IndexToTV[tv, AMTypes.NComponents[AMTypes.TVType[tv]]]; }; Momma[inner, head, parent, "last component"]; }; TVForType: PROC [type: Type] RETURNS [ntv: TV _ NIL] = TRUSTED { stb: RTSymbolDefs.SymbolTableBase = RTSymbols.GetTypeSymbols[type].stb; { ENABLE UNWIND => RTSymbols.ReleaseSTB[stb]; ntv _ AMBridge.Loophole[ tv: AMBridge.TVForReferent[NEW[CARDINAL _ type]], type: RTSymbolOps.AcquireType[stb, LOOPHOLE[RTSymbolDefs.symbolIndexForTYPE]]]; RTSymbols.ReleaseSTB[stb]; }; }; END.