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;
START EvalRecord HERE
[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 => {
check for named arguments
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 => {
check for liklihood of variant record constructor
IF i # nargs OR unionType = nullType THEN LOOP;
it passes the main test, so save the tag name & extra args
tagName ← TreeToName[subnode[1]];
variantPart ← subnode[2];
LOOP}
ENDCASE};
ENDCASE;
IF named THEN GO TO mixed
ENDLOOP;
};
apply =>
IF unionType # nullType
THEN {
this is a single-component variant record constructor
tagName ← TreeToName[node[1]];
variantPart ← node[2];
};
ENDCASE;
ENDCASE;
EXITS
mixed =>
BBUrpEval.UrpFatal[head, parent, "mixed named and unnamed arguments"];
};
now try to create the record (we think that we may know the tag)
{
world: WorldVM.World ←
IF targetWorld # NIL THEN targetWorld ELSE InterpreterOps.WorldFromHead[head];
rec ← InterpreterPrivate.GetNilTV[];
IF unionType # nullType
THEN {
at this point we try to bind the variant
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
Kludge for null variant part
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;
};
};
check for over-specification of arguments
IF nargs < ngiven
THEN {
msg: ROPE ← NumberedMsg["too many arguments, ", nargs, " expected"];
BBUrpEval.UrpFatal[head, parent, msg];
};
now fill in the record, component by component
FOR i:
CARDINAL
IN [1..nargs]
DO
get an argument from somewhere
fetchArgTree:
PROC [index:
NAT]
RETURNS [Tree] =
TRUSTED {
note that we either get the argument tree from the original arg list
or (if a variant record), from the variantPart tree
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 => {
an argument was given positionally
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];
promote this sucker to the original record type (sigh)
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 {
forces 'sel' to be a selector for the given type
an error will occur if this cannot be done
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] = {
returns the name described by the given tree
returns NIL if the tree does not describe a name
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 {
LocalCoerce returns coercion of value to type, calls appropriate helper routine if we can't hack it for some reason.
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 {
Ask the correction routines for a better value.
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 {
GetDefault returns default value for the component of the type; calls appropriate helper routine if not available.
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 {
Try to get a default value from the callback proc.
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.