DIRECTORY
AMBridge USING [Loophole, TVForReadOnlyReferent],
AMBridgeExtras USING [AssignNew],
AMModel USING [RootContext],
AMTypes
USING
[Assign, Class, DefaultInitialValue, Domain, Error, GroundStar, IndexToDefaultInitialValue, IndexToTV, IndexToType, NameToIndex, NComponents, New, TVType, TypeClass, UnderClass, UnderType, Value],
BBApply USING [CoerceTV],
BBContext USING [Context, GetContents],
BBEmptyReturn USING [TheEmptyReturn],
BBEval USING [AbortProc, Eval, EvalHead, RopeOrTV, Tree],
BBEvalUtil USING [EvalNoProps, NilTV],
BBSafety USING [Mother],
BBUrpEval USING [UrpDefault, UrpFatal, UrpId, UrpWrongType],
BBZones USING [GetPrefixedZone],
Convert USING [ValueToRope],
List USING [AList, DotCons],
PPLeaves USING [HTIndex, LTIndex],
PPTree USING [Handle, Link, NodeName],
ProcessProps USING [GetPropList, PushPropList],
Rope USING [Cat, Concat, ROPE],
RTBasic USING [nullType, TV, Type],
WorldVM USING [LocalWorld, World];
BBEvalUtilImpl:
CEDAR
PROGRAM
IMPORTS AMBridge, AMBridgeExtras, AMModel, AMTypes, BBApply, BBContext, BBEmptyReturn, BBEval, BBEvalUtil, BBSafety, BBUrpEval, BBZones, Convert, List, ProcessProps, Rope, WorldVM
EXPORTS BBEmptyReturn, BBEval, BBEvalUtil
SHARES BBEval
= BEGIN OPEN PPLeaves, Rope, RTBasic, WorldVM;
Class: TYPE = AMTypes.Class;
EvalHead: TYPE = BBEval.EvalHead;
Node: TYPE = PPTree.Handle;
Tree: TYPE = BBEval.Tree;
pz: ZONE ← BBZones.GetPrefixedZone[];
empty: TV ← BBEmptyReturn.TheEmptyReturn[];
theEmptyReturn: RTBasic.TV ← NIL;
TheEmptyReturn:
PUBLIC
PROC
RETURNS [RTBasic.
TV] =
TRUSTED {
returns the special empty TV
IF theEmptyReturn =
NIL
THEN {
ref: REF REF ← pz.NEW[REF ← NIL];
ref^ ← ref;
theEmptyReturn ← AMBridge.TVForReadOnlyReferent[ref ! AMTypes.Error => CONTINUE];
};
RETURN [theEmptyReturn];
};
Eval:
PUBLIC
PROC
[tree: Tree, head: EvalHead, target: Type] RETURNS [tv: TV ← NIL] = TRUSTED {
props: List.AList ← ProcessProps.GetPropList[];
new: List.AList ← NIL;
context: TV ← NIL;
inner:
PROC =
TRUSTED {
tv ← BBEvalUtil.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 [BBEvalUtil.EvalNoProps[tree, head, target]];
EXIT;
};
ENDLOOP;
context ← BBContext.GetContents[head.context].lf;
IF context = NIL THEN context ← BBContext.GetContents[head.context].gf;
IF context = NIL THEN context ← BBContext.GetContents[head.globalContext].lf;
IF context = NIL THEN context ← BBContext.GetContents[head.globalContext].gf;
IF context =
NIL
THEN {
world: WorldVM.World ← BBContext.GetContents[head.context].world;
IF world = NIL THEN world ← WorldVM.LocalWorld[];
context ← AMModel.RootContext[world];
};
props ← CONS[List.DotCons[$EvalHead, head], props];
props ← CONS[List.DotCons[$Context, context], props];
ProcessProps.PushPropList[props, inner];
};
EvalRecord:
PUBLIC
PROC [
args: Tree, head: EvalHead, target: Type, parent: Tree,
firstArg: TV ← NIL, targetWorld: World ← NIL]
RETURNS [TV] = TRUSTED {
... evaluates a record constructor. firstArg is the first TV in the constructor for object notation kludgery. 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;
implicitArg: BOOL ← firstArg # NIL;
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;
innerTargetType:
PROC =
TRUSTED {
[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;
};
innerMake:
PROC =
TRUSTED {
this routine makes up the new record
world: WorldVM.World ←
IF targetWorld # NIL THEN targetWorld ELSE WorldFromHead[head];
rec ← BBEvalUtil.NilTV;
IF unionType # nullType
THEN {
at this point we try to bind the variant
unionIndex:
CARDINAL ← AMTypes.NameToIndex
[unionType, tagName ! AMTypes.Error => GO TO noTag];
domain: Type ← AMTypes.Domain[unionType];
domainIndex:
CARDINAL ← AMTypes.NameToIndex
[domain, tagName ! AMTypes.Error => GO TO noTag];
tag ← AMTypes.Value[domain, domainIndex];
rec ← AMTypes.New[type: target, tag: tag, world: world];
unionIndex ← AMTypes.NameToIndex[unionType, tagName];
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
Kludge for null variant part
ngiven ← ngiven - 1;
RETURN
EXITS noTag => {};
};
IF under # nullType THEN rec ← AMTypes.New[type: target, world: world];
variantPart ← NIL;
commonLimit ← ngiven;
};
Momma[innerTargetType, head, parent, "constructor"];
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 implicitArg THEN GO TO mixed;
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 ← TreeToRope[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 ← TreeToRope[node[1]];
variantPart ← node[2]};
ENDCASE;
ENDCASE;
EXITS
mixed =>
BBUrpEval.UrpFatal[head, parent, "mixed named and unnamed arguments"]};
remember to count the implicit argument (if any)
IF implicitArg THEN ngiven ← ngiven + 1;
now try to create the record (we think that we may know the tag)
Momma[innerMake, head, parent, "construtor"];
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 implicitArg THEN index ← index - 1;
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;
msg: ROPE ← NIL;
inner:
PROC =
TRUSTED {
destType ← AMTypes.IndexToType[under, i];
dest ← AMTypes.IndexToTV[rec, i];
};
Momma[inner, head, args, "bad record"];
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
SELECT
TRUE
FROM
implicitArg AND i = 1 => val ← firstArg;
ENDCASE => 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 ← BBEval.Eval[son, head, destType];
val ← LocalCoerce[head, parent, val, destType, i];
msg ← SafeAssignNew[dest, val, head, parent];
IF msg #
NIL
THEN {
msg ← msg.Concat[NumberedMsg[" for argument ", i]];
BBUrpEval.UrpFatal[head, parent, msg]}
ENDLOOP;
IF target # original
THEN {
promote this sucker to the original record type (sigh)
rec ← AMBridge.Loophole[rec, original, tag]};
RETURN [rec]
};
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 => GO TO bye]];
EXITS bye => {};
};
ForceSelector:
PUBLIC
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
typeTV: TV ← NIL;
name ← TreeToRope[sel];
index ← 0;
DO
IF name #
NIL
THEN {
index ← AMTypes.NameToIndex
[type, name
! AMTypes.Error => CONTINUE];
IF index > 0 THEN RETURN [name, index]};
IF typeTV =
NIL
THEN {
correct: BBEval.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"]
};
SafeAssign:
PUBLIC
PROC
[lhs, rhs: TV, head: EvalHead, parent: Tree] RETURNS [msg: ROPE] = TRUSTED {
a relatively safe kind of assignment, protected against harm (I hope)
inner: PROC = TRUSTED {AMTypes.Assign[lhs, rhs]};
msg ← BBSafety.Mother[inner];
};
SafeAssignNew:
PROC
[lhs, rhs: TV, head: EvalHead, parent: Tree] RETURNS [msg: ROPE] = TRUSTED {
ONLY for assignments to NEW TVs (and otherwise uninitialized components)
inner: PROC = TRUSTED {AMBridgeExtras.AssignNew[lhs, rhs]};
msg ← BBSafety.Mother[inner];
};
NumberedMsg:
PUBLIC
PROC
[r1: ROPE, num: INT, r2: ROPE ← NIL]
RETURNS [ROPE] = {
RETURN [r1.Concat[Convert.ValueToRope[[signed[num]]].Concat[r2]]]
};
WorldFromHead:
PUBLIC
PROC
[head: EvalHead] RETURNS [world: WorldVM.World ← NIL] = TRUSTED {
world ← BBContext.GetContents[head.context].world;
IF world = NIL THEN world ← WorldVM.LocalWorld[];
};
FirstComponent:
PUBLIC
PROC [tv:
TV]
RETURNS [
TV] =
TRUSTED {
RETURN [AMTypes.IndexToTV[tv, 1]];
};
TreeToRope:
PUBLIC
PROC [t: Tree]
RETURNS [name:
ROPE] = {
returns the rope constant from the given tree
NIL will be returned when this cannot be done
WITH t
SELECT
FROM
hti: HTIndex => name ← hti.name;
lti: LTIndex =>
WITH lti.value
SELECT
FROM
rr: ROPE => name ← rr;
ENDCASE;
r: ROPE => name ← r
ENDCASE => name ← NIL
};
TestAbort:
PUBLIC
PROC [head: EvalHead, parent: Tree] = {
IF head.abortProc #
NIL
AND head.abortProc[head.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;
inner:
PROC =
TRUSTED {
val ← BBApply.CoerceTV[current, target
! AMTypes.Error => {
IF reason # incompatibleTypes THEN REJECT;
oops ← TRUE;
CONTINUE}]
};
IF msg = NIL THEN msg ← "wrong type";
val ← current;
Momma[inner, head, parent, "coerce"];
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: NAT ← 0;
err: ROPE ← "can't hack default for argument ";
inner:
PROC =
TRUSTED {
defval ← AMTypes.IndexToDefaultInitialValue
[type, index
! AMTypes.Error => {
IF reason # notImplemented THEN REJECT;
oops ← index;
GO TO noGood}];
IF defval =
NIL
THEN {
defval ← AMTypes.DefaultInitialValue
[AMTypes.IndexToType[type, index]
! AMTypes.Error => {
IF reason # notImplemented THEN REJECT;
oops ← index;
GO TO noGood}];
IF defval =
NIL
THEN {
oops ← index;
err ← "no default value for argument ";
};
};
EXITS noGood => {};
};
Momma[inner, head, parent, "default value"];
IF oops > 0
THEN {
Try to get a default value from the callback proc.
msg: ROPE ← NumberedMsg[err, index];
defval ← BBUrpEval.UrpDefault[head, parent, type, index, msg]}
};
Momma:
PUBLIC
PROC
[proc: PROC, head: EvalHead, parent: Tree, prefix: ROPE ← NIL] = {
A very protective procedure evaluator.
msg: ROPE ← NIL;
IF head.abortProc #
NIL
AND head.abortProc[head.data]
THEN
BBUrpEval.UrpFatal[head, parent, "aborted"];
msg ← BBSafety.Mother[proc];
IF msg #
NIL
THEN {
IF prefix # NIL THEN msg ← msg.Cat[" (in ", prefix, ")"];
BBUrpEval.UrpFatal[head, parent, msg];
};
};
UnderWear:
PUBLIC
PROC
[tv: TV, head: EvalHead, parent: Tree] RETURNS [type: Type, under: Type, class: Class] = {
inner:
PROC =
TRUSTED {
type ← AMTypes.TVType[tv];
[under, class] ← UnderTypeAndClass[type];
};
Momma[inner, head, parent, "UnderType"]
};
LocalUnderTypeAndClass:
PUBLIC
PROC
[type: Type, head: EvalHead, parent: Tree] RETURNS [under: Type, class: Class] = {
inner:
PROC =
TRUSTED {
[under, class] ← UnderTypeAndClass[type];
};
Momma[inner, head, parent, "UnderType"]
};
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[pz.NEW[INT ← int]];
};
NewReal:
PUBLIC
PROC [real:
REAL]
RETURNS [
TV] =
TRUSTED {
RETURN [AMBridge.TVForReadOnlyReferent[pz.NEW[REAL ← real]]]
};
NewType:
PUBLIC
PROC [type: Type]
RETURNS [
TV] =
TRUSTED {
RETURN [AMBridge.TVForReadOnlyReferent[pz.NEW[Type ← type]]]
};
END.