<> <> <> <> DIRECTORY AMBridge USING [Loophole, TVForReadOnlyReferent], AMTypes USING [AssignNew, Class, DefaultInitialValue, Domain, Error, GroundStar, IndexToDefaultInitialValue, IndexToTV, IndexToType, NameToIndex, NComponents, New, TV, TypeClass, UnderClass, UnderType, Value], InterpreterOps USING [EvalHead, RopeOrTV, Tree, WorldFromHead], InterpreterPrivate USING [EvalNoProps, GetNilTV, CoerceTV], IO USING [PutR], BBUrpEval USING [UrpDefault, UrpFatal, UrpId, UrpWrongType], List USING [AList, DotCons], PPLeaves USING [HTIndex, LTIndex], PPTree USING [Handle, Link, NodeName], PPTreeOps USING [NSons, NthSon, OpName], ProcessProps USING [GetPropList, PushPropList], Rope USING [Concat, ROPE], SafeStorage USING [nullType, Type], WorldVM USING [World]; InterpreterPrivateImpl: CEDAR PROGRAM IMPORTS AMBridge, AMTypes, BBUrpEval, InterpreterOps, InterpreterPrivate, IO, List, PPTreeOps, ProcessProps, Rope EXPORTS InterpreterOps, InterpreterPrivate = BEGIN OPEN PPLeaves, Rope, SafeStorage, WorldVM; Class: TYPE = AMTypes.Class; EvalHead: TYPE = InterpreterOps.EvalHead; Node: TYPE = PPTree.Handle; Tree: TYPE = InterpreterOps.Tree; TV: TYPE = AMTypes.TV; GetArg: PUBLIC PROC [tree: InterpreterOps.Tree, which: NAT] RETURNS [son: InterpreterOps.Tree _ NIL] = { args: InterpreterOps.Tree _ PPTreeOps.NthSon[tree, 2]; IF PPTreeOps.OpName[args] = list THEN { IF which IN [1..PPTreeOps.NSons[args]] THEN son _ PPTreeOps.NthSon[args, which]} ELSE IF which = 1 THEN son _ args; }; Eval: PUBLIC PROC [tree: Tree, head: EvalHead, target: Type] RETURNS [tv: TV _ NIL] = TRUSTED { props: List.AList _ ProcessProps.GetPropList[]; new: List.AList _ NIL; inner: PROC = TRUSTED {tv _ InterpreterPrivate.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 [InterpreterPrivate.EvalNoProps[tree, head, target]]; EXIT; }; ENDLOOP; props _ CONS[List.DotCons[$EvalHead, head], props]; ProcessProps.PushPropList[props, inner]; }; EvalRecord: PUBLIC PROC [ args: Tree, head: EvalHead, target: Type, parent: Tree, targetWorld: World _ NIL] RETURNS [TV] = TRUSTED { <<... evaluates a record constructor. 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; 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; <<>> <> [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; 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 i > 1 AND NOT named THEN GO TO mixed; named _ TRUE; LOOP}; apply => { <> IF i # nargs OR unionType = nullType THEN LOOP; <> tagName _ TreeToName[subnode[1]]; variantPart _ subnode[2]; LOOP} ENDCASE}; ENDCASE; IF named THEN GO TO mixed ENDLOOP; }; apply => IF unionType # nullType THEN { <> tagName _ TreeToName[node[1]]; variantPart _ node[2]; }; ENDCASE; ENDCASE; EXITS mixed => BBUrpEval.UrpFatal[head, parent, "mixed named and unnamed arguments"]; }; <> { world: WorldVM.World _ IF targetWorld # NIL THEN targetWorld ELSE InterpreterOps.WorldFromHead[head]; rec _ InterpreterPrivate.GetNilTV[]; IF unionType # nullType THEN { <> unionIndex: CARDINAL; domain: Type; domainIndex: CARDINAL; unionIndex _ AMTypes.NameToIndex[unionType, tagName ! AMTypes.Error => IF reason = badName THEN GOTO noTag]; domain _ AMTypes.Domain[unionType]; domainIndex _ AMTypes.NameToIndex[domain, tagName ! AMTypes.Error => IF reason = badName THEN GOTO noTag]; tag _ AMTypes.Value[domain, domainIndex]; rec _ AMTypes.New[type: target, tag: tag, world: world]; 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; EXITS noTag => {}; } ELSE { -- target is a vanilla record type IF under # nullType THEN rec _ AMTypes.New[type: target, world: world]; variantPart _ NIL; commonLimit _ ngiven; }; }; <> 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 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; destType _ AMTypes.IndexToType[under, i]; dest _ AMTypes.IndexToTV[rec, i]; 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 => { <> 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 => {}; --no action is necessary, val has the right value ENDCASE => val _ Eval[son, head, destType]; val _ LocalCoerce[head, parent, val, destType, i]; AMTypes.AssignNew[dest, val]; ENDLOOP; IF target # original THEN rec _ AMBridge.Loophole[rec, original, tag]; <> RETURN [rec] }; -- end EvalRecord 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 => IF reason = badName THEN CONTINUE]]; }; ForceSelector: PROC [sel: Tree, head: EvalHead, type: Type, parent: Tree, target: Type _ nullType] RETURNS [name: ROPE, index: CARDINAL] = TRUSTED { <> <> name _ TreeToName[sel]; index _ 0; DO IF name # NIL THEN { index _ AMTypes.NameToIndex[type, name ! AMTypes.Error => IF reason = badName THEN CONTINUE]; IF index > 0 THEN RETURN [name, index]; }; { correct: InterpreterOps.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"] }; NumberedMsg: PUBLIC PROC [r1: ROPE, num: INT, r2: ROPE _ NIL] RETURNS [ROPE] = { RETURN [IO.PutR[ [rope[r1]], [integer[num]], [rope[r2]] ]]; }; TreeToName: PUBLIC PROC [t: Tree] RETURNS [name: ROPE] = { <> <> WITH t SELECT FROM hti: HTIndex => name _ hti.name; lti: LTIndex => WITH lti.value SELECT FROM r: ROPE => name _ r; rr: REF ROPE => name _ rr^; ENDCASE => name _ NIL; r: ROPE => name _ r; ENDCASE => name _ NIL }; TestAbort: PUBLIC PROC [head: EvalHead, parent: Tree] = { IF head.abortClosure.proc # NIL AND head.abortClosure.proc[head.abortClosure.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; IF msg = NIL THEN msg _ "wrong type"; val _ current; val _ InterpreterPrivate.CoerceTV[current, target ! AMTypes.Error => IF reason = incompatibleTypes THEN {oops _ TRUE; CONTINUE}]; 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: BOOL _ FALSE; err: ROPE _ "can't hack default for argument "; { defval _ AMTypes.IndexToDefaultInitialValue [type, index ! AMTypes.Error => IF reason = notImplemented THEN {oops _ TRUE; GOTO noGood}]; IF defval = NIL THEN { defval _ AMTypes.DefaultInitialValue [AMTypes.IndexToType[type, index] ! AMTypes.Error => IF reason = notImplemented THEN {oops _ TRUE; GOTO noGood}]; IF defval = NIL THEN { oops _ TRUE; err _ "no default value for argument "; }; }; EXITS noGood => {}; }; IF oops THEN { <> msg: ROPE _ NumberedMsg[err, index]; defval _ BBUrpEval.UrpDefault[head, parent, type, index, msg]} }; 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[NEW[INT _ int]]; }; NewReal: PUBLIC PROC [real: REAL] RETURNS [TV] = TRUSTED { RETURN [AMBridge.TVForReadOnlyReferent[NEW[REAL _ real]]] }; NewType: PUBLIC PROC [type: Type] RETURNS [TV] = TRUSTED { RETURN [AMBridge.TVForReadOnlyReferent[NEW[Type _ type]]] }; END.