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 {
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.


InterpreterPrivateImpl.mesa
Copyright c 1985 by Xerox Corporation.  All rights reserved.
Russ Atkinson, February 12, 1985 3:43:18 pm PST
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.
ΚY˜
codeš
œ™Kšœ
Οm
œ1™<Kš
œ/™/Kš
œ&™&—K˜š
Οk	˜	Kšœ	žœ#˜1Kšœžœ—
žœ)˜Ρ
Kšœžœ+˜?Kšœžœ#˜;Kšžœ
žœ˜Kšœ
žœ-˜<Kšœžœ˜Kšœ	žœ˜"Kšœžœ˜&Kšœ
žœ˜(Kšœ
žœ˜/Kšœžœ
žœ˜Kšœžœ˜#Kšœžœ	˜K˜—šœžœ
ž˜%KšžœCžœ%˜qKšžœ#˜*Kšœžœ
žœ&˜2K˜Kšœžœ˜Kšœ
žœ˜)Kšœžœ˜Kšœžœ˜!Kšžœžœžœ
˜K˜š
Οnœžœ$žœ
žœžœ˜hK˜6šžœ˜ šžœ˜šžœžœž˜+K˜$——Kšžœ
žœžœ˜"—K˜K˜—šŸœžœ
žœ,žœžœžœžœ˜_Kš
œ/˜/Kšœžœ
˜Kšœžœžœ<˜Qšžœ%žœžœ
ž˜;šžœžœ˜$Kšžœžœ
žœ6˜ZKšžœ
˜K˜—Kšžœ
˜—Kšœžœ'˜3Kš
œ(˜(K˜K˜—šŸ
œžœ
žœPžœ
žœžœžœ˜„
Kš
œ·
™·
K˜K˜
Kšœžœžœ
˜Kšœžœ˜Kšœžœžœžœ
žœžœ˜*Kšœžœžœ
˜Kšœžœ
˜Kšœ
žœ˜Kšœžœ
˜K˜ Kšœžœžœ
˜K˜Kšœ	žœžœ
˜Kšœžœžœ
˜Kšœ	žœžœ
˜K™K™K˜+šžœž˜˜K˜#šžœžœ˜K˜3Kšžœ&žœ˜BK˜—K˜—K˜
Kšžœžœ
˜—Kšžœ
žœžœ2˜Gš
œ
˜
šžœžœ
ž˜˜
šžœž˜"š
œ˜Kš
œ™Kšœžœ
˜Kšœ	žœžœžœ˜:K˜šžœžœ
žœ
ž˜!Kšœžœžœ
žœ	˜4šžœžœ
ž˜Kšžœžœ
žœ
žœžœ
žœ
˜$—šžœžœ
ž˜š
œ˜Kšžœžœ
žœ
˜šžœž˜š
œ	˜	Kšœžœ˜K˜1K˜KšœΟc˜.Kšžœžœ
žœžœ
žœ
žœ˜(Kšœžœ
˜
Kšžœ˜—š
œ
˜
Kš
œ1™1Kšžœžœžœ
žœ
˜/Kš
œ:™:Kš
œ!˜!K˜Kšžœ
˜—Kšžœ˜	——Kšžœ
˜—Kšžœžœ
žœ
žœ˜Kš
ž˜—Kš
œ˜—˜šžœžœ˜Kš
œ5™5Kš
œ˜K˜K˜——Kšžœ
˜——Kšžœ
˜—š
ž˜˜K˜F———K˜Kš
œ@™@š
œ
˜
š
œ˜Kšžœžœ
žœ
žœ$˜N—Kš
œ$˜$šžœ˜šžœ˜Kš
œ(™(Kšœžœ
˜K˜
Kšœ
žœ
˜š
œ
˜
š
œ(˜(Kšœžœžœ
žœ˜8——K˜#š
œ˜š
œ%˜%Kšœžœžœ
žœ˜8——K˜)K˜8K˜4K˜%Kšžœžœžœ
˜0K˜K˜+šžœ
žœ
ž˜˜
Kšžœžœ*˜B—Kšžœ
˜—K˜#š	žœžœžœ
žœž˜=Kš
œ™Kšžœ˜—Kšžœ
˜K˜
—šžœ "˜*Kšžœžœ/˜GKšœžœ
˜K˜K˜——K˜—Kš
œ)™)šžœžœ˜Kšœžœ;˜DK˜&K˜—Kš
œ.™.šžœžœ
žœž˜ Kš
œ™š	œžœ	žœžœ
žœ˜:Kš
œD™DKš
œ3™3Kšžœžœ
žœžœ˜$šžœžœ˜šžœ
žœ
ž˜š
œ˜Kšžœžœ
žœ˜.Kšžœ˜$—Kšžœžœ˜!——Kšžœžœ
žœ
žœ˜0Kšžœ˜K˜—K˜Kšœžœ
˜	Kšœžœžœ
˜Kšœ
žœžœ
˜Kšœžœ
˜K˜)K˜!šžœ
žœ
ž˜šœ	 -˜6šžœžœ
žœ
ž˜!Kš	œ
žœžœ
žœ
žœ˜GKšœžœ5˜Dšžœžœ˜K˜Kšœžœ
˜Kš
ž˜Kš
œ
˜
—Kšžœ
˜——š
œ˜Kš
œ"™"Kš
œ˜Kšœžœ
˜šžœžœ
ž˜šžœžœ
ž˜˜
šžœž˜Kšœž˜ Kš
ž˜——Kšžœ
˜———Kšžœ
˜—šžœ
žœ
ž˜K˜8Kšœžœ	 1˜CKšžœ$˜+—K˜2Kš
œ˜Kšžœ
˜—šžœžœ-˜FKš
œ6™6—Kšžœ˜Kšœ ˜K˜—šŸœžœ
žœžœžœžœžœžœ˜aKšœžœ˜K˜'K˜(Kš
žœžœžœ
žœ
žœ
˜0˜K˜š
œ˜Kšœžœžœ
žœ˜7——K˜K˜—šŸ
œžœOžœžœ	žœžœ˜”
Kš
œ0™0Kš
œ*™*Kš
œ˜K˜
š
ž˜šžœžœ
žœ˜š
œ&˜&Kšœžœžœ
žœ˜6—Kšžœžœ
žœ˜'Kš
œ˜—š
œ
˜
š
œ"˜"K˜C—šžœžœ
ž˜K˜K˜Kšžœž˜——Kš
œ˜Kšžœ
˜—K˜4K˜K˜—šŸœžœ
žœžœžœžœžœ
žœžœ˜PKšžœžœ1˜;K˜K˜—š
Ÿ
œžœ
žœžœžœ˜:Kš
œ,™,Kš
œ0™0šžœžœ
ž˜K˜ š
œ˜šžœžœ
ž˜Kšœžœ
˜Kšœžœ˜Kšžœžœ
˜——Kšœžœ
˜Kšžœž˜—K˜K˜—šŸ	œžœ
žœ#˜9šžœžœ
žœ0ž˜WK˜,—K˜K˜—šŸœžœ
žœ)žœžœžœžœ
žœžœžœ˜–
Kš
œt™tKšœžœžœ
˜Kšžœžœ
žœ˜%K˜˜1Kš	œžœžœ	žœžœ˜O—šžœžœ˜Kš
œ/™/Kšžœžœ8˜IK˜AK˜
—K˜K˜—šŸ
œžœ
ž˜Kšœ2žœ
˜;Kšžœ
žœžœ˜&Kš
œr™rKšœžœžœ
˜Kšœžœ&˜/š
œ
˜
˜+˜š
œ˜Kšžœžœ	žœžœ
˜<———šžœ
žœ
žœ˜˜$˜!š
œ˜Kšžœžœ	žœžœ
˜<———šžœ
žœ
žœ˜Kšœžœ
˜Kš
œ'˜'K˜—Kš
œ˜—Kšžœ˜—K˜šžœžœ˜Kš
œ2™2Kšœžœ˜$K˜>—K˜K˜—šŸœžœ
ž˜Kšœ
žœžœ˜<K˜ K˜!K˜K˜—šŸœžœ
žœžœžœžœžœ˜;Kšœ$žœ
žœ	˜4K˜K˜—šŸœžœ
žœžœžœžœžœ˜:Kšžœ!žœ
žœ
˜9K˜K˜—šŸœžœ
žœžœžœžœ˜:Kšžœ!žœ˜9K˜K˜—Kšžœ
˜K˜K˜——…—'d;Χ