<> <> DIRECTORY AMBridge USING [Loophole, TVForReadOnlyReferent], AMBridgeExtras USING [AssignNew], AMModel USING [RootContext], AMTypes USING [Assign, Class, DefaultInitialValue, Domain, Error, GroundStar, IndexToDefaultInitialValue, IndexToTV, IndexToType, NameToIndex, NComponents, New, TVType, TypeClass, UnderClass, UnderType, Value], BBApply USING [CoerceTV], BBContext USING [Context, GetContents], BBEmptyReturn USING [TheEmptyReturn], BBEval USING [AbortProc, Eval, EvalHead, RopeOrTV, Tree], BBEvalUtil USING [EvalNoProps, NilTV], BBSafety USING [Mother], BBUrpEval USING [UrpDefault, UrpFatal, UrpId, UrpWrongType], BBZones USING [GetPrefixedZone], Convert USING [ValueToRope], List USING [AList, DotCons], PPLeaves USING [HTIndex, LTIndex], PPTree USING [Handle, Link, NodeName], ProcessProps USING [GetPropList, PushPropList], Rope USING [Cat, Concat, ROPE], RTBasic USING [nullType, TV, Type], WorldVM USING [LocalWorld, World]; BBEvalUtilImpl: CEDAR PROGRAM IMPORTS AMBridge, AMBridgeExtras, AMModel, AMTypes, BBApply, BBContext, BBEmptyReturn, BBEval, BBEvalUtil, BBSafety, BBUrpEval, BBZones, Convert, List, ProcessProps, Rope, WorldVM EXPORTS BBEmptyReturn, BBEval, BBEvalUtil SHARES BBEval = BEGIN OPEN PPLeaves, Rope, RTBasic, WorldVM; Class: TYPE = AMTypes.Class; EvalHead: TYPE = BBEval.EvalHead; Node: TYPE = PPTree.Handle; Tree: TYPE = BBEval.Tree; pz: ZONE _ BBZones.GetPrefixedZone[]; empty: TV _ BBEmptyReturn.TheEmptyReturn[]; theEmptyReturn: RTBasic.TV _ NIL; TheEmptyReturn: PUBLIC PROC RETURNS [RTBasic.TV] = TRUSTED { <> IF theEmptyReturn = NIL THEN { ref: REF REF _ pz.NEW[REF _ NIL]; ref^ _ ref; theEmptyReturn _ AMBridge.TVForReadOnlyReferent[ref ! AMTypes.Error => CONTINUE]; }; RETURN [theEmptyReturn]; }; Eval: PUBLIC PROC [tree: Tree, head: EvalHead, target: Type] RETURNS [tv: TV _ NIL] = TRUSTED { props: List.AList _ ProcessProps.GetPropList[]; new: List.AList _ NIL; context: TV _ NIL; inner: PROC = TRUSTED { tv _ BBEvalUtil.EvalNoProps[tree, head, target]; }; FOR list: List.AList _ props, list.rest UNTIL list = NIL DO IF list.first.key = $EvalHead THEN { IF list.first.val = head THEN RETURN [BBEvalUtil.EvalNoProps[tree, head, target]]; EXIT; }; ENDLOOP; context _ BBContext.GetContents[head.context].lf; IF context = NIL THEN context _ BBContext.GetContents[head.context].gf; IF context = NIL THEN context _ BBContext.GetContents[head.globalContext].lf; IF context = NIL THEN context _ BBContext.GetContents[head.globalContext].gf; IF context = NIL THEN { world: WorldVM.World _ BBContext.GetContents[head.context].world; IF world = NIL THEN world _ WorldVM.LocalWorld[]; context _ AMModel.RootContext[world]; }; props _ CONS[List.DotCons[$EvalHead, head], props]; props _ CONS[List.DotCons[$Context, context], props]; ProcessProps.PushPropList[props, inner]; }; EvalRecord: PUBLIC PROC [ args: Tree, head: EvalHead, target: Type, parent: Tree, firstArg: TV _ NIL, targetWorld: World _ NIL] RETURNS [TV] = TRUSTED { <<... evaluates a record constructor. firstArg is the first TV in the constructor for object notation kludgery. IF targetWorld # NIL THEN the constructor should be made for the given world, even though the arguments get looked up according to the given head.>> under, original: Type _ target; class: Class; rec: TV _ NIL; nargs: NAT _ 0; implicitArg: BOOL _ firstArg # NIL; ngiven: NAT _ IF args = NIL THEN 0 ELSE 1; named: BOOL _ FALSE; listNode: Node _ NIL; commonLimit: NAT _ 0; variantPart: Tree _ NIL; listKind: PPTree.NodeName _ nil; validType: BOOL _ TRUE; unionType: Type _ nullType; tagName: ROPE _ NIL; tag: TV _ NIL; caution: BOOL _ FALSE; innerTargetType: PROC = TRUSTED { [under, class] _ UnderTypeAndClass[target]; SELECT class FROM record, structure => {nargs _ AMTypes.NComponents[under]; IF nargs > 0 THEN {lastType: Type _ AMTypes.IndexToType[under, nargs]; IF AMTypes.UnderClass[lastType] = union THEN unionType _ lastType; }; }; nil => {}; ENDCASE => validType _ FALSE; }; innerMake: PROC = TRUSTED { <> world: WorldVM.World _ IF targetWorld # NIL THEN targetWorld ELSE WorldFromHead[head]; rec _ BBEvalUtil.NilTV; IF unionType # nullType THEN { <> unionIndex: CARDINAL _ AMTypes.NameToIndex [unionType, tagName ! AMTypes.Error => GO TO noTag]; domain: Type _ AMTypes.Domain[unionType]; domainIndex: CARDINAL _ AMTypes.NameToIndex [domain, tagName ! AMTypes.Error => GO TO noTag]; tag _ AMTypes.Value[domain, domainIndex]; rec _ AMTypes.New[type: target, tag: tag, world: world]; unionIndex _ AMTypes.NameToIndex[unionType, tagName]; target _ AMTypes.IndexToType[unionType, unionIndex]; rec _ AMBridge.Loophole[rec, target]; IF unionIndex # domainIndex THEN caution _ TRUE; commonLimit _ ngiven - 1; [under, class] _ UnderTypeAndClass[target]; WITH variantPart SELECT FROM node: Node => IF node.name = list THEN ngiven _ commonLimit + node.sonLimit - 1; ENDCASE; nargs _ AMTypes.NComponents[under]; IF nargs + 1 = ngiven AND variantPart = NIL AND tagName # NIL THEN <> ngiven _ ngiven - 1; RETURN EXITS noTag => {}; }; IF under # nullType THEN rec _ AMTypes.New[type: target, world: world]; variantPart _ NIL; commonLimit _ ngiven; }; Momma[innerTargetType, head, parent, "constructor"]; IF NOT validType THEN BBUrpEval.UrpFatal[head, parent, "not a record"]; {WITH args SELECT FROM node: Node => SELECT (listKind _ node.name) FROM list, item => { <> son: Tree _ NIL; ngiven _ IF listKind = item THEN 1 ELSE node.sonLimit - 1; listNode _ node; FOR i: CARDINAL IN [1..ngiven] DO son _ IF listKind = item THEN listNode ELSE node[i]; IF son = NIL THEN IF named THEN GO TO mixed ELSE LOOP; WITH son SELECT FROM subnode: Node => { IF under = nullType THEN EXIT; SELECT subnode.name FROM item => { name: ROPE _ ForceSelector[subnode[1], head, under, son].name; val: Tree _ subnode[2]; subnode[1] _ name; -- fix up name if corrected IF implicitArg THEN GO TO mixed; IF i > 1 AND NOT named THEN GO TO mixed; named _ TRUE; LOOP}; apply => { <> IF i # nargs OR unionType = nullType THEN LOOP; <> tagName _ TreeToRope[subnode[1]]; variantPart _ subnode[2]; LOOP} ENDCASE}; ENDCASE; IF named THEN GO TO mixed ENDLOOP}; apply => IF unionType # nullType THEN { <> tagName _ TreeToRope[node[1]]; variantPart _ node[2]}; ENDCASE; ENDCASE; EXITS mixed => BBUrpEval.UrpFatal[head, parent, "mixed named and unnamed arguments"]}; <> IF implicitArg THEN ngiven _ ngiven + 1; <> Momma[innerMake, head, parent, "construtor"]; <> IF nargs < ngiven THEN {msg: ROPE _ NumberedMsg["too many arguments, ", nargs, " expected"]; BBUrpEval.UrpFatal[head, parent, msg]}; <> FOR i: CARDINAL IN [1..nargs] DO <> fetchArgTree: PROC [index: NAT] RETURNS [Tree] = TRUSTED { <> <> IF implicitArg THEN index _ index - 1; IF index > ngiven THEN RETURN [NIL]; IF index > commonLimit THEN { WITH variantPart SELECT FROM node: Node => { IF node.name # list THEN RETURN [variantPart]; RETURN [node[index - commonLimit]]}; ENDCASE => RETURN [variantPart]}; IF listNode # NIL THEN RETURN [listNode[index]]; RETURN [args]; }; destType: Type; dest: TV; val: TV _ NIL; needDefault: BOOL _ TRUE; son: Tree _ NIL; msg: ROPE _ NIL; inner: PROC = TRUSTED { destType _ AMTypes.IndexToType[under, i]; dest _ AMTypes.IndexToTV[rec, i]; }; Momma[inner, head, args, "bad record"]; SELECT TRUE FROM named => -- try to find the named argument in the list FOR j: CARDINAL IN [1..ngiven] DO each: Node _ IF listKind = item THEN listNode ELSE NARROW[listNode[j]]; index: CARDINAL _ ForceSelector[each[1], head, under, parent].index; IF index = i THEN {son _ each[2]; needDefault _ FALSE; EXIT} ENDLOOP; i <= ngiven => { <> SELECT TRUE FROM implicitArg AND i = 1 => val _ firstArg; ENDCASE => son _ fetchArgTree[i]; needDefault _ FALSE; IF son # NIL THEN WITH son SELECT FROM node: Node => SELECT node.name FROM null, void => needDefault _ TRUE ENDCASE ENDCASE} ENDCASE; SELECT TRUE FROM needDefault => val _ GetDefault[head, parent, under, i]; son = NIL => { <> }; ENDCASE => val _ BBEval.Eval[son, head, destType]; val _ LocalCoerce[head, parent, val, destType, i]; msg _ SafeAssignNew[dest, val, head, parent]; IF msg # NIL THEN { msg _ msg.Concat[NumberedMsg[" for argument ", i]]; BBUrpEval.UrpFatal[head, parent, msg]} ENDLOOP; IF target # original THEN { <> rec _ AMBridge.Loophole[rec, original, tag]}; RETURN [rec] }; EnumeratedValueFromRope: PUBLIC PROC [name: ROPE, type: Type] RETURNS [val: TV _ NIL] = TRUSTED { index: CARDINAL _ 0; under: Type _ AMTypes.GroundStar[type]; class: Class _ AMTypes.TypeClass[under]; IF class # enumerated OR name = NIL THEN RETURN; val _ AMTypes.Value [ under, AMTypes.NameToIndex [under, name ! AMTypes.Error => GO TO bye]]; EXITS bye => {}; }; ForceSelector: PUBLIC PROC [sel: Tree, head: EvalHead, type: Type, parent: Tree, target: Type _ nullType] RETURNS [name: ROPE, index: CARDINAL] = TRUSTED { <> <> typeTV: TV _ NIL; name _ TreeToRope[sel]; index _ 0; DO IF name # NIL THEN { index _ AMTypes.NameToIndex [type, name ! AMTypes.Error => CONTINUE]; IF index > 0 THEN RETURN [name, index]}; IF typeTV = NIL THEN { correct: BBEval.RopeOrTV _ BBUrpEval.UrpId[head, sel, name, type, target, "invalid selector"]; WITH c: correct SELECT FROM both => name _ c.rope; rope => name _ c.rope; ENDCASE => EXIT} ENDLOOP; BBUrpEval.UrpFatal[head, parent, "invalid selector"] }; SafeAssign: PUBLIC PROC [lhs, rhs: TV, head: EvalHead, parent: Tree] RETURNS [msg: ROPE] = TRUSTED { <> inner: PROC = TRUSTED {AMTypes.Assign[lhs, rhs]}; msg _ BBSafety.Mother[inner]; }; SafeAssignNew: PROC [lhs, rhs: TV, head: EvalHead, parent: Tree] RETURNS [msg: ROPE] = TRUSTED { <> inner: PROC = TRUSTED {AMBridgeExtras.AssignNew[lhs, rhs]}; msg _ BBSafety.Mother[inner]; }; NumberedMsg: PUBLIC PROC [r1: ROPE, num: INT, r2: ROPE _ NIL] RETURNS [ROPE] = { RETURN [r1.Concat[Convert.ValueToRope[[signed[num]]].Concat[r2]]] }; WorldFromHead: PUBLIC PROC [head: EvalHead] RETURNS [world: WorldVM.World _ NIL] = TRUSTED { world _ BBContext.GetContents[head.context].world; IF world = NIL THEN world _ WorldVM.LocalWorld[]; }; FirstComponent: PUBLIC PROC [tv: TV] RETURNS [TV] = TRUSTED { RETURN [AMTypes.IndexToTV[tv, 1]]; }; TreeToRope: PUBLIC PROC [t: Tree] RETURNS [name: ROPE] = { <> <> WITH t SELECT FROM hti: HTIndex => name _ hti.name; lti: LTIndex => WITH lti.value SELECT FROM rr: ROPE => name _ rr; ENDCASE; r: ROPE => name _ r ENDCASE => name _ NIL }; TestAbort: PUBLIC PROC [head: EvalHead, parent: Tree] = { IF head.abortProc # NIL AND head.abortProc[head.data] THEN BBUrpEval.UrpFatal[head, parent, "aborted"]; }; LocalCoerce: PUBLIC PROC [head: EvalHead, parent: Tree, current: TV, target: Type, index: CARDINAL _ 0, msg: ROPE _ NIL] RETURNS [val: TV] = TRUSTED { <> oops: BOOL _ FALSE; inner: PROC = TRUSTED { val _ BBApply.CoerceTV[current, target ! AMTypes.Error => { IF reason # incompatibleTypes THEN REJECT; oops _ TRUE; CONTINUE}] }; IF msg = NIL THEN msg _ "wrong type"; val _ current; Momma[inner, head, parent, "coerce"]; IF oops THEN { <> IF index # 0 THEN msg _ msg.Concat[NumberedMsg[" for argument ", index]]; val _ BBUrpEval.UrpWrongType[head, parent, current, target, msg]} }; GetDefault: PUBLIC PROC [head: EvalHead, parent: Tree, type: Type, index: CARDINAL] RETURNS [defval: TV _ NIL] = TRUSTED { <> oops: NAT _ 0; err: ROPE _ "can't hack default for argument "; inner: PROC = TRUSTED { defval _ AMTypes.IndexToDefaultInitialValue [type, index ! AMTypes.Error => { IF reason # notImplemented THEN REJECT; oops _ index; GO TO noGood}]; IF defval = NIL THEN { defval _ AMTypes.DefaultInitialValue [AMTypes.IndexToType[type, index] ! AMTypes.Error => { IF reason # notImplemented THEN REJECT; oops _ index; GO TO noGood}]; IF defval = NIL THEN { oops _ index; err _ "no default value for argument "; }; }; EXITS noGood => {}; }; Momma[inner, head, parent, "default value"]; IF oops > 0 THEN { <> msg: ROPE _ NumberedMsg[err, index]; defval _ BBUrpEval.UrpDefault[head, parent, type, index, msg]} }; Momma: PUBLIC PROC [proc: PROC, head: EvalHead, parent: Tree, prefix: ROPE _ NIL] = { <> msg: ROPE _ NIL; IF head.abortProc # NIL AND head.abortProc[head.data] THEN BBUrpEval.UrpFatal[head, parent, "aborted"]; msg _ BBSafety.Mother[proc]; IF msg # NIL THEN { IF prefix # NIL THEN msg _ msg.Cat[" (in ", prefix, ")"]; BBUrpEval.UrpFatal[head, parent, msg]; }; }; UnderWear: PUBLIC PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [type: Type, under: Type, class: Class] = { inner: PROC = TRUSTED { type _ AMTypes.TVType[tv]; [under, class] _ UnderTypeAndClass[type]; }; Momma[inner, head, parent, "UnderType"] }; LocalUnderTypeAndClass: PUBLIC PROC [type: Type, head: EvalHead, parent: Tree] RETURNS [under: Type, class: Class] = { inner: PROC = TRUSTED { [under, class] _ UnderTypeAndClass[type]; }; Momma[inner, head, parent, "UnderType"] }; UnderTypeAndClass: PUBLIC PROC [type: Type] RETURNS [under: Type, class: Class] = TRUSTED { under _ AMTypes.UnderType[type]; class _ AMTypes.TypeClass[under]; }; NewInt: PUBLIC PROC [int: INT] RETURNS [tv: TV] = TRUSTED { tv _ AMBridge.TVForReadOnlyReferent[pz.NEW[INT _ int]]; }; NewReal: PUBLIC PROC [real: REAL] RETURNS [TV] = TRUSTED { RETURN [AMBridge.TVForReadOnlyReferent[pz.NEW[REAL _ real]]] }; NewType: PUBLIC PROC [type: Type] RETURNS [TV] = TRUSTED { RETURN [AMBridge.TVForReadOnlyReferent[pz.NEW[Type _ type]]] }; [] _ TheEmptyReturn[]; END.