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šœ�œ˜&Jšœ
�œ˜(Jšœ
�œ˜/Jšœ�œ�œ˜Jšœ�œ˜#Jšœ�œ˜"J˜—šœ�œ
�˜%Jš�œC�œ.˜zJš�œ#˜*Jšœ�œ
�œ&˜2J˜Jšœ�œ˜Jšœ
�œ˜)Jšœ�œ˜Jšœ�œ˜!Jš�œ�œ�œ
˜J˜šÏnœ�œ$�œ
˜;Jš�œ�œ˜,J˜6š�œ˜ š�œ˜š�œ�œ�˜+J˜$——Jš�œ
�œ�œ˜"—J˜J˜—šžœ�œ
�˜Jš	œ+�œ�œ�œ�œ˜MJš
œ/˜/Jšœ�œ
˜Jšœ�œ�œ<˜Qš�œ%�œ�œ
�˜;š�œ�œ˜$Jš�œ�œ
�œ6˜ZJš�œ
˜J˜—Jš�œ
˜—Jšœ�œ'˜3Jš
œ(˜(J˜J˜—šž
œ�œ
�œ˜JšœM�œ
˜Qš�œ�œ�œ˜Jš
œ·
™·
—J˜J˜
Jšœ�œ�œ
˜Jšœ�œ˜Jšœ�œ�œ�œ
�œ�œ˜*Jšœ�œ�œ
˜Jšœ�œ
˜Jšœ
�œ˜Jšœ�œ
˜J˜ Jšœ�œ�œ
˜J˜Jšœ	�œ�œ
˜Jšœ�œ�œ
˜Jšœ	�œ�œ
˜J™J™J˜+š�œ�˜˜J˜#š�œ�œ˜J˜3Jš�œ&�œ˜BJ˜—J˜—J˜
Jš�œ�œ
˜—Jš�œ
�œ�œ2˜Gš
œ
˜
š�œ�œ
�˜˜
š�œ�˜"š
œ˜Jš
œ™Jšœ�œ
˜Jšœ	�œ�œ�œ˜:J˜š�œ�œ
�œ
�˜!Jšœ�œ�œ
�œ	˜4š�œ�œ
�˜Jš�œ�œ
�œ
�œ�œ
�œ
˜$—š�œ�œ
�˜š
œ˜Jš�œ�œ
�œ
˜š�œ�˜š
œ	˜	Jšœ�œ˜J˜1J˜JšœÏc˜.Jš�œ�œ
�œ�œ
�œ
�œ˜(Jšœ�œ
˜
Jš�œ˜—š
œ
˜
Jš
œ1™1Jš�œ�œ�œ
�œ
˜/Jš
œ:™:Jš
œ!˜!J˜Jš�œ
˜—Jš�œ˜	——Jš�œ
˜—Jš�œ�œ
�œ
�œ˜Jš
�˜—Jš
œ˜—˜š�œ�œ˜Jš
œ5™5Jš
œ˜J˜J˜——Jš�œ
˜——Jš�œ
˜—š
�˜˜J˜F———J˜Jš
œ@™@š
œ
˜
š
œ˜Jš�œ�œ
�œ
�œ$˜N—Jš
œ$˜$š�œ˜š�œ˜Jš
œ(™(Jšœ�œ
˜J˜
Jšœ
�œ
˜š
œ
˜
š
œ(˜(Jšœ�œ�œ
�œ˜8——J˜#š
œ˜š
œ%˜%Jšœ�œ�œ
�œ˜8——J˜)J˜8J˜4J˜%Jš�œ�œ�œ
˜0J˜J˜+š�œ
�œ
�˜˜
Jš�œ�œ*˜B—Jš�œ
˜—J˜#š	�œ�œ�œ
�œ�˜=Jš
œ™Jš�œ˜—Jš�œ
˜J˜
—š�œŸ"˜*Jš�œ�œ/˜GJšœ�œ
˜J˜J˜——J˜—Jš
œ)™)š�œ�œ˜Jšœ�œ;˜DJ˜&J˜—Jš
œ.™.š�œ�œ
�œ�˜ Jš
œ™š	œ�œ	�œ�œ
�œ˜:Jš
œD™DJš
œ3™3Jš�œ�œ
�œ�œ˜$š�œ�œ˜š�œ
�œ
�˜š
œ˜Jš�œ�œ
�œ˜.Jš�œ˜$—Jš�œ�œ˜!——Jš�œ�œ
�œ
�œ˜0Jš�œ˜J˜—J˜Jšœ�œ
˜	Jšœ�œ�œ
˜Jšœ
�œ�œ
˜Jšœ�œ
˜J˜)J˜!š�œ
�œ
�˜šœ	Ÿ-˜6š�œ�œ
�œ
�˜!Jš	œ
�œ�œ
�œ
�œ˜GJšœ�œ5˜Dš�œ�œ˜J˜Jšœ�œ
˜Jš
�˜Jš
œ
˜
—Jš�œ
˜——š
œ˜Jš
œ"™"Jš
œ˜Jšœ�œ
˜š�œ�œ
�˜š�œ�œ
�˜˜
š�œ�˜Jšœ�˜ Jš
�˜——Jš�œ
˜———Jš�œ
˜—š�œ
�œ
�˜J˜8Jšœ�œ	Ÿ1˜CJš�œ$˜+—J˜2Jš
œ˜Jš�œ
˜—š�œ�œ-˜FJš
œ6™6—Jš�œ˜JšœŸ˜J˜—šžœ�œ
�˜$Jšœ�œ�œ�œ�œ�œ˜<Jšœ�œ˜J˜'J˜(Jš
�œ�œ�œ
�œ
�œ
˜0˜J˜š
œ˜Jšœ�œ�œ
�œ˜7——J˜J˜—šž
œ�˜J˜NJš�œ�œ	�œ�œ˜1Jš
œ0™0Jš
œ*™*Jš
œ˜J˜
š
�˜š�œ�œ
�œ˜š
œ&˜&Jšœ�œ�œ
�œ˜6—Jš�œ�œ
�œ˜'Jš
œ˜—š
œ
˜
š
œ"˜"J˜C—š�œ�œ
�˜J˜J˜Jš�œ�˜——Jš
œ˜Jš�œ
˜—J˜4J˜J˜—šžœ�œ
�˜Jš	œ�œ�œ�œ�œ
˜$Jš
�œ�œ�œ�œ�œ˜BJ˜—š
ž
œ�œ
�œ�œ�œ˜:Jš
œ,™,Jš
œ0™0š�œ�œ
�˜J˜ š
œ˜š�œ�œ
�˜Jšœ�œ
˜Jšœ�œ˜Jš�œ�œ
˜——Jšœ�œ
˜Jš�œ�˜—J˜J˜—šž	œ�œ
�œ#˜9š�œ�œ
�œ0�˜WJ˜,—J˜J˜—šžœ�œ
�˜šœ(�œ˜9Jšœ�œ�œ�œ
˜%—Jš�œ�œ�œ˜Jš
œt™tJšœ�œ�œ
˜Jš�œ�œ
�œ˜%J˜˜1Jš	œ�œ�œ	�œ�œ˜O—š�œ�œ˜Jš
œ/™/Jš�œ�œ8˜IJ˜AJ˜
—J˜J˜—šž
œ�œ
�˜Jšœ2�œ
˜;Jš�œ
�œ�œ˜&Jš
œr™rJšœ�œ�œ
˜Jšœ�œ&˜/š
œ
˜
˜+˜š
œ˜Jš�œ�œ	�œ�œ
˜<———š�œ
�œ
�œ˜˜$˜!š
œ˜Jš�œ�œ	�œ�œ
˜<———š�œ
�œ
�œ˜Jšœ�œ
˜Jš
œ'˜'J˜—Jš
œ˜—Jš�œ˜—J˜š�œ�œ˜Jš
œ2™2Jšœ�œ˜$J˜>—J˜J˜—šžœ�œ
�˜Jšœ
�œ�œ˜<J˜ J˜!J˜J˜—šžœ�œ
�œ�œ�œ�œ�œ˜;Jšœ$�œ
�œ	˜4J˜J˜—šžœ�œ
�œ�œ�œ�œ�œ˜:Jš�œ!�œ
�œ
˜9J˜J˜—šžœ�œ
�œ�œ�œ�œ˜:Jš�œ!�œ˜9J˜J˜—Jš�œ
˜J˜J˜——…—'t;Ê