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, int], 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 [Cat, Concat, ROPE], SafeStorage USING [nullType, Type], WorldVM USING [LocalWorld, World]; InterpreterPrivateImpl: CEDAR PROGRAM IMPORTS AMBridge, AMTypes, BBUrpEval, InterpreterOps, InterpreterPrivate, IO, List, PPTreeOps, ProcessProps, Rope, WorldVM 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 { 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[Rope.Cat[r1, IO.PutR[IO.int[num]], 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. ÒInterpreterPrivateImpl.mesa Russ Atkinson, April 27, 1983 1:12 pm Paul Rovner, November 1, 1983 10:06 pm ... 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. START EvalRecord HERE check for named arguments check for liklihood of variant record constructor it passes the main test, so save the tag name & extra args this is a single-component variant record constructor now try to create the record (we think that we may know the tag) at this point we try to bind the variant Kludge for null variant part check for over-specification of arguments now fill in the record, component by component get an argument from somewhere note that we either get the argument tree from the original arg list or (if a variant record), from the variantPart tree an argument was given positionally promote this sucker to the original record type (sigh) forces 'sel' to be a selector for the given type an error will occur if this cannot be done returns the name described by the given tree returns NIL if the tree does not describe a name LocalCoerce returns coercion of value to type, calls appropriate helper routine if we can't hack it for some reason. Ask the correction routines for a better value. GetDefault returns default value for the component of the type; calls appropriate helper routine if not available. Try to get a default value from the callback proc. Ê„˜Jšœ™Jšœ%™%Jšœ&™&J˜šÏk ˜ Jšœ œ#˜1šœ˜ Jšœ–œ)˜Ã—Jšœœ+˜?Jšœœ#˜;Jšœœ ˜Jšœ œ-˜—J˜J˜—šžœœ˜Jšœ œœ˜