TransferStatements.Mesa
Last Edited by: Spreitzer, January 7, 1985 10:49:31 pm PST
DIRECTORY AMBridge, AMModel, AMTypes, BackStop, BBUrpEval, CBinary, Commander, CommandExtras, CommandTool, EvalQuote, Interpreter, InterpreterOps, InterpreterPrivate, IO, List, PPLeaves, PPP1, PPTree, PPTreeOps, PrincOps, PrincOpsUtils, PrintTV, ProcessProps, Real, Rope, SafeStorage, StatementInterpreter, StatementInterpreterPrivate, SymTab, WorldVM;
TransferStatements:
CEDAR
PROGRAM
IMPORTS AMBridge, AMTypes, BBUrpEval, InterpreterOps, IO, PPTreeOps, PrincOpsUtils, PrintTV, Rope, SafeStorage, StatementInterpreterPrivate, SymTab, WorldVM
EXPORTS StatementInterpreter, StatementInterpreterPrivate =
BEGIN OPEN StatementInterpreterPrivate;
emptyFields: Fields ← NEW[FieldsRep[0]];
CatchSeries: TYPE = REF CatchSeriesRep;
CatchSeriesRep:
TYPE =
RECORD [
arms: SEQUENCE length: NAT OF CatchArm];
CatchArm: TYPE = REF CatchArmRep;
CatchArmRep:
TYPE =
RECORD [
stmt: Tree,
theSigType: Type,
multipleSigTypes: BOOL,
signals: SEQUENCE length: NAT--0 is for the ANY arm-- OF Signal
];
Signal: TYPE = ERROR ANY RETURNS ANY;
Decide:
PROC [catchSeries: CatchSeries, sig: Signal, lftv:
TV, head: EvalHead]
RETURNS [sd: SignalDecision] = {
TryCatch:
PROC [catch: CatchArm]
RETURNS [caught:
BOOL] = {
caught ← FALSE;
IF catch.length = 0
THEN caught ← TRUE
ELSE
FOR i:
NAT
IN [0 .. catch.length)
WHILE
NOT caught
DO
IF catch.signals[i] = sig THEN caught ← TRUE;
ENDLOOP;
IF caught
THEN sd ← ProcessStmt[
catch.stmt,
IF catch.multipleSigTypes THEN nullType ELSE catch.theSigType,
lftv,
head];
};
FOR i:
NAT
IN [0 .. catchSeries.length)
DO
IF TryCatch[catchSeries[i]] THEN RETURN;
ENDLOOP;
sd ← [Reject];
};
ProcessStmt:
PROC [stmt: Tree, sigType: Type, lftv:
TV, head: EvalHead]
RETURNS [sd: SignalDecision] = {
subHead: EvalHead ← NestHead[head];
argsType, resultsType: Type ← nullType;
IF sigType # nullType
THEN {
argsType ← AMTypes.Domain[sigType];
SELECT AMTypes.TypeClass[sigType]
FROM
signal => resultsType ← AMTypes.Range[sigType];
error => resultsType ← nullType;
ENDCASE => ERROR;
SetupFrame[subHead, argsType, resultsType, lftv];
};
sd ← [Reject];
InterpNoProps[stmt, subHead !
DecideSignal => {sd ← [decision]; CONTINUE};
Resume => {sd ← [type: Resume, fields: fields]; CONTINUE};
Return =>
The language prohibits this, so we
BBUrpEval.UrpFatal[subHead, stmt, "Can't RETURN out of a catch phrase"];
but wouldn't it be nice if we could
{sd ← [type: Return, fields: fields]; CONTINUE};
Exit => {sd ← [Exit]; CONTINUE};
Loop => {sd ← [Loop]; CONTINUE};
GoTo => {sd ← [type: GoTo, label: label]; CONTINUE};
];
IF sd.type = Resume
THEN {
CloseupFrame[resultsType, sd.fields, lftv, "Catch phrase", subHead, stmt, subHead.specials];
};
};
DigestCatchSeries:
PROC [catch: Node, head: EvalHead]
RETURNS [cs: CatchSeries] = {
catchRegular: Node ← NARROW[catch.son[1]];
catchAny: Node ← NARROW[catch.son[2]];
anyPresent: BOOL ← catchAny # NIL;
numRegulars: NAT ← PPTreeOps.ListLength[catchRegular];
armIndex: NAT ← 0;
PerCatch:
PROC [t: Tree] = {
item: Node ← NARROW[t];
names: Tree ← item.son[1];
stmt: Tree ← item.son[2];
numNames: NAT ← PPTreeOps.ListLength[names];
nameIndex: NAT ← 0;
PerName:
PROC [t: Tree] = {
armtv: TV;
armType: Type;
armtv ← EvalExpr[tree: t, head: head, target: cs[armIndex].theSigType];
armType ← AMTypes.UnderType[AMTypes.TVType[armtv]];
IF NOT AMTypes.TypeClass[armType] IN [signal .. error] THEN BBUrpEval.UrpFatal[head, t, "Not a signal or error"];
TRUSTED {cs[armIndex].signals[nameIndex] ← AMBridge.TVToSignal[armtv]};
IF cs[armIndex].theSigType = nullType THEN cs[armIndex].theSigType ← armType ELSE
IF cs[armIndex].multipleSigTypes THEN NULL ELSE
IF NOT SafeStorage.EquivalentTypes[cs[armIndex].theSigType, armType] THEN cs[armIndex].multipleSigTypes ← TRUE;
nameIndex ← nameIndex + 1;
};
cs[armIndex] ← NEW [CatchArmRep[numNames]];
cs[armIndex].stmt ← stmt;
cs[armIndex].theSigType ← nullType;
cs[armIndex].multipleSigTypes ← FALSE;
PPTreeOps.ScanList[names, PerName];
IF nameIndex # numNames THEN ERROR;
armIndex ← armIndex + 1;
};
cs ← NEW [CatchSeriesRep[numRegulars + (IF anyPresent THEN 1 ELSE 0)]];
PPTreeOps.ScanList[catchRegular, PerCatch];
IF armIndex # numRegulars THEN ERROR;
IF anyPresent
THEN {
cs[armIndex] ← NEW [CatchArmRep[0]];
cs[armIndex].stmt ← catchAny;
cs[armIndex].theSigType ← nullType;
cs[armIndex].multipleSigTypes ← FALSE;
armIndex ← armIndex + 1;
};
};
Enable:
PUBLIC
PROC [catches: Node, head: EvalHead, inner:
PROC] = {
catchSeries: CatchSeries;
sd: SignalDecision ← [Continue];
IF catches.name # catch THEN ERROR;
catchSeries ← DigestCatchSeries[catches, head];
inner[!
UNWIND => {
lf: PrincOps.FrameHandle;
lftv: TV;
TRUSTED {
lf ← PrincOpsUtils.MyLocalFrame[];
lftv ← AMBridge.TVForFrame[fh: lf];
};
sd ← Decide[catchSeries: catchSeries, sig: UNWIND, lftv: lftv, head: head];
SELECT sd.type
FROM
Reject => REJECT;
Retry => RETRY;
Continue, Return, Exit, Loop, GoTo => CONTINUE;
Resume => BBUrpEval.UrpFatal[head, catches, "RESUMEing not yet implemented"];
ENDCASE => ERROR;
};
ANY => {
lf: PrincOps.FrameHandle;
lftv, sigtv: TV;
sig: Signal;
TRUSTED {
lf ← PrincOpsUtils.MyLocalFrame[];
lftv ← AMBridge.TVForFrame[fh: lf];
sigtv ← AMTypes.Signal[lftv];
sig ← AMBridge.TVToSignal[sigtv];
};
sd ← Decide[catchSeries: catchSeries, sig: sig, lftv: lftv, head: head];
SELECT sd.type
FROM
Reject => REJECT;
Retry => RETRY;
Continue, Return, Exit, Loop, GoTo => CONTINUE;
Resume => BBUrpEval.UrpFatal[head, catches, "RESUMEing not yet implemented"];
ENDCASE => ERROR;
}
];
SELECT sd.type
FROM
Reject => NULL;
Retry => NULL;
Continue => NULL;
Resume => NULL;
Return => ERROR Return[sd.fields];
Exit => ERROR Exit[];
Loop => ERROR Loop[];
GoTo => ERROR GoTo[sd.label];
ENDCASE => ERROR;
};
SetupFrame:
PROC [head: EvalHead, argsType, resultsType: Type, frameTV:
TV] = {
nArgs, nResults: NAT;
nArgs ←
SELECT AMTypes.TypeClass[argsType]
FROM
record, structure => AMTypes.NComponents[argsType],
nil => 0,
ENDCASE => ERROR;
nResults ←
SELECT AMTypes.TypeClass[resultsType]
FROM
record, structure => AMTypes.NComponents[resultsType],
nil => 0,
ENDCASE => ERROR;
FOR i:
NAT
IN [1 .. nArgs]
DO
name: ROPE ← AMTypes.IndexToName[argsType, i];
val: TV;
IF name.Length[] = 0 THEN LOOP;
val ← AMTypes.Argument[frameTV, i];
[] ← SymTab.Store[head.specials, name, AMTypes.Copy[val]];
ENDLOOP;
FOR i:
NAT
IN [1 .. nResults]
DO
name: ROPE ← AMTypes.IndexToName[resultsType, i];
val: TV;
IF name.Length[] = 0 THEN LOOP;
val ← AMTypes.IndexToDefaultInitialValue[resultsType, i];
[] ← SymTab.Store[
head.specials,
name,
IF val #
NIL
THEN AMTypes.Copy[val]
ELSE AMTypes.New[AMTypes.IndexToType[resultsType, i]]
];
ENDLOOP;
};
CloseupFrame:
PROC [resultsType: Type, results: Fields, frameTV:
TV, lname:
ROPE, head: EvalHead, parent: Tree, table: SymbolTable] = {
formalResults: Fields ← FieldsFromType[resultsType];
matchedResults: Fields ← SafeMatch[formalResults, results, lname, head, parent, table];
FOR i:
NAT
IN [0 .. formalResults.length)
DO
val, var: TV;
val ← matchedResults[i].value;
var ← AMTypes.Result[frameTV, i+1];
AMTypes.Assign[var, val];
ENDLOOP;
};
FieldsFromType:
PROC [type: Type]
RETURNS [fields: Fields] = {
n: NAT;
someNamed: BOOL ← FALSE;
allNamed: BOOL ← TRUE;
n ←
SELECT AMTypes.TypeClass[type]
FROM
record, structure => AMTypes.NComponents[type],
nil => 0,
ENDCASE => ERROR;
fields ← NEW [FieldsRep[n]];
FOR i:
NAT
IN [0 .. n)
DO
fields[i].name ← AMTypes.IndexToName[type, i+1];
IF fields[i].name.Length[] # 0 THEN someNamed ← TRUE ELSE allNamed ← FALSE;
fields[i].type ← AMTypes.IndexToType[type, i+1];
fields[i].typed ← TRUE;
fields[i].value ← AMTypes.IndexToDefaultInitialValue[type, i+1];
fields[i].valued ← fields[i].value # NIL;
ENDLOOP;
IF (n>0) AND (someNamed # allNamed) THEN ERROR;
fields.named ← someNamed;
};
DigestFields:
PUBLIC
PROC [tree: Tree, eval, mayNIL:
BOOLEAN, head: EvalHead ←
NIL]
RETURNS [fields: Fields] =
BEGIN
Op: TYPE = {Count, Fill};
count, index: NAT ← 0;
op: Op;
someNamed: BOOLEAN ← FALSE;
allNamed: BOOLEAN ← TRUE;
DoIt: PPTree.Scan
--PROC [t: Link]-- =
BEGIN
SELECT PPTreeOps.OpName[t]
FROM
decl => Work[PPTreeOps.NthSon[t, 1], PPTreeOps.NthSon[t, 2], PPTreeOps.NthSon[t, 3]];
item => Work[PPTreeOps.NthSon[t, 1], NIL, PPTreeOps.NthSon[t, 2]];
ENDCASE => Work[NIL, NIL, t];
END;
Work:
PROCEDURE [name, type, value: Tree] =
BEGIN
RealWork: PPTree.Scan
--PROC [t: Link]-- =
BEGIN
name: Tree = t;
SELECT op
FROM
Count => count ← count + 1;
Fill =>
BEGIN
IF name #
NIL
THEN
BEGIN
someNamed ← TRUE;
fields[index].name ← InterpreterOps.TreeToName[name]
END
ELSE
BEGIN
allNamed ← FALSE;
fields[index].name ← NIL;
END;
fields[index].type ←
IF (fields[index].typed ← type #
NIL)
THEN ForceType[EvalExpr[type, head, typeType], head, type]
ELSE nullType;
IF NOT (fields[index].valued ← value # NIL) THEN NULL
ELSE IF NOT eval THEN fields[index].value ← value
ELSE fields[index].value ← EvalExpr[value, head, fields[index].type];
index ← index + 1;
END;
ENDCASE => ERROR;
END;
IF name = NIL THEN RealWork[NIL]
ELSE PPTreeOps.ScanList[name, RealWork];
END;
IF mayNIL AND (tree = NIL) THEN RETURN [NIL];
op ← Count; PPTreeOps.ScanList[tree, DoIt];
fields ← NEW [FieldsRep[count]];
op ← Fill; PPTreeOps.ScanList[tree, DoIt];
IF (someNamed # allNamed) AND count > 0 THEN ERROR;
fields.named ← someNamed;
END;
EvalReturn:
PUBLIC
PROC [rn: Node, head: EvalHead] = {
fields: Fields;
fields ← DigestFields[rn.son[1], TRUE, TRUE, head];
ERROR Return[fields];
};
EvalResume:
PUBLIC
PROC [rn: Node, head: EvalHead] = {
fields: Fields;
fields ← DigestFields[rn.son[1], TRUE, TRUE, head];
ERROR Resume[fields];
};
EvalProcedure:
PUBLIC
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
BEGIN
args: Tree;
actualFields, matchedArgs, ans: Fields ← NIL;
l: Lambda ← NARROW[data];
subHead: EvalHead;
IF PPTreeOps.OpName[tree] # apply THEN ERROR;
args ← PPTreeOps.NthSon[tree, 2];
actualFields ← DigestFields[args, TRUE, FALSE, head];
matchedArgs ← SafeMatch[l.args, actualFields, l.name.Cat[".Args"], head, tree, NIL];
subHead ← NestHead[head, l.symbols];
Bind[subHead.specials, matchedArgs];
Bind[subHead.specials, l.rets];
[] ← InterpNoProps[l.body, subHead !
Return => {ans ← fields; CONTINUE};
DecideSignal, Resume, Exit, Loop, GoTo => {BBUrpEval.UrpFatal[head, tree, "Can't EXIT, LOOP, GOTO, REJECT, RESUME, RETRY, or CONTINUE out of a procedure body"]; CONTINUE}];
SELECT l.rets.length
FROM
0 => {
IF ans # NIL AND ans.length # 0 THEN BBUrpEval.UrpFatal[head, tree, Rope.Cat["Values returned to ", l.name, ", who wasn't expecting them"]];
return ← empty;
};
1 => {
matchedRets: Fields ← SafeMatch[l.rets, ans, l.name.Cat[".Results"], subHead, tree, subHead.specials];
return ← matchedRets[0].value;
SELECT ans.length FROM
0 => {
IF l.rets.named THEN
BEGIN
found: BOOLEAN;
[found, return] ← subHead.specials.Fetch[l.rets[0].name];
IF NOT found THEN
BEGIN
BBUrpEval.UrpFatal[head, tree, Rope.Cat["Return value ", l.rets[0].name, " undefined"]];
return ← empty;
END;
END
ELSE BEGIN
BBUrpEval.UrpFatal[head, tree, "default return of anonymous value"];
return ← empty;
END;
};
1 => {
return ← ans[0].value;
};
ENDCASE => BBUrpEval.UrpFatal[head, tree, "Too many values returned"];
IF return # empty AND l.rets[0].typed THEN
BEGIN
need: BOOL ← TRUE;
WHILE need DO
need ← FALSE;
return ← AMTypes.Coerce[return, l.rets[0].type !AMTypes.Error => {need ← TRUE; CONTINUE}];
IF need THEN return ← BBUrpEval.UrpWrongType[head: head, parent: tree, value: return, target: l.rets[0].type, msg: Rope.Cat["on return from ", l.name]];
ENDLOOP;
END;
};
ENDCASE => ERROR;
END;
SafeMatch:
PROC [formals, actuals: Fields, lname:
ROPE, head: EvalHead, parent: Tree, table: SymbolTable]
RETURNS [bound: Fields] =
BEGIN
bound ← Match[formals, actuals, lname, table !
MatchWarning => {BBUrpEval.UrpFatal[head, parent, IO.PutFR[fmt, v1, v2, v3, v4]]; CONTINUE};
MatchError => {BBUrpEval.UrpFatal[head: head, parent: parent, msg: IO.PutFR[format, v1, v2, v3, v4]]; CONTINUE}];
END;
MatchWarning: SIGNAL [fmt: ROPE, v1, v2, v3, v4: IO.Value ← [null[]]] = CODE;
MatchError: ERROR [format: ROPE, v1, v2, v3, v4: IO.Value ← [null[]]] = CODE;
MissType: TYPE = {elide, omit};
Match:
PROC [formals, actuals: Fields, lname:
ROPE, table: SymbolTable]
RETURNS [bound: Fields] =
BEGIN
Miss:
PROC [i:
NAT, how: MissType] = {
IF formals[i].valued
THEN {bound[i].valued ← TRUE; bound[i].value ← formals[i].value; RETURN}
ELSE
IF formals[i].typed
THEN {
div: TV ← AMTypes.DefaultInitialValue[formals[i].type];
IF div #
NIL
THEN {bound[i].valued ← TRUE; bound[i].value ← div; RETURN};
}
ELSE ERROR --formals must have types, right?--;
SELECT how
FROM
elide => {v:
TV ← AMTypes.New[formals[i].type];
bound[i].valued ← TRUE; bound[i].value ← v; RETURN};
omit => ERROR MatchError["%g omitted", IO.rope[Describe[i]]];
ENDCASE;
};
SetValue:
PROC [j, i:
NAT] =
BEGIN
bound[j].valued ← TRUE;
IF NOT bound[j].typed THEN bound[j].value ← actuals[i].value
ELSE bound[j].value ← AMTypes.Coerce[
tv: actuals[i].value,
targetType: bound[j].type !
AMTypes.Error => {msgs:
IO.
STREAM ←
IO.
ROS[];
msgs.PutF["Type mismatch at %g: expecting a ", IO.rope[Describe[j]]];
PrintTV.PrintType[bound[j].type, msgs];
msgs.PutRope[", got "];
PrintTV.Print[actuals[i].value, msgs];
ERROR MatchError[IO.RopeFromROS[msgs]]}];
END;
Describe:
PROC [i:
NAT]
RETURNS [
ROPE] =
{
RETURN[
IF bound.named
THEN IO.PutFR["%g.%g", IO.rope[lname], IO.rope[bound[i].name]]
ELSE IO.PutFR["%g'th %g", IO.card[i], IO.rope[lname]]]};
bound ← UnvalueFields[formals];
IF actuals =
NIL
THEN {
IF table = NIL THEN ERROR;
IF bound.length = 0 THEN RETURN;
IF NOT bound.named THEN MatchError["Default return or resume of unnamed fields from %g", IO.rope[lname]];
FOR i:
NAT
IN [0 .. bound.length)
DO
found: BOOL;
val: TV;
[found, val] ← table.Fetch[bound[i].name];
IF NOT found THEN ERROR --should have been initialized, right?--;
bound[i].valued ← TRUE;
bound[i].value ← val;
ENDLOOP;
RETURN;
};
IF actuals.named
THEN
BEGIN
IF NOT bound.named THEN ERROR MatchError["No keywords to match against"];
FOR i:
NAT
IN [0 .. actuals.length)
DO
j: NAT ← FindName[bound, actuals[i].name];
IF j >= bound.length
THEN
BEGIN
SIGNAL MatchWarning["%g is not a valid key for %g", IO.rope[actuals[i].name], IO.rope[lname]];
LOOP;
END;
IF bound[j].valued THEN SIGNAL MatchWarning["%g was bound multiple times", IO.rope[Describe[j]]];
IF actuals[i].valued THEN SetValue[j, i] ELSE Miss[j, elide];
ENDLOOP;
END
ELSE
BEGIN
IF actuals.length > formals.length
THEN
SIGNAL MatchWarning["%g extra fields for %g ignored", IO.int[actuals.length - formals.length], IO.rope[lname]];
FOR i:
NAT
IN [0 ..
MIN[formals.length, actuals.length])
DO
IF actuals[i].valued THEN SetValue[i, i] ELSE Miss[i, elide];
ENDLOOP;
END;
FOR i:
NAT
IN [0 .. bound.length)
DO
IF NOT bound[i].valued THEN Miss[i, omit];
ENDLOOP;
END;
FindName:
PROC [fields: Fields, name:
ROPE]
RETURNS [index:
NAT] =
BEGIN
FOR index ← 0, index + 1
WHILE index < fields.length
DO
IF name.Equal[fields[index].name] THEN RETURN;
ENDLOOP;
END;
UnvalueFields:
PROC [from: Fields]
RETURNS [to: Fields] =
BEGIN
to ← NEW [FieldsRep[from.length]];
to.named ← from.named;
FOR i: NAT IN [0 .. to.length) DO to[i] ← from[i]; to[i].valued ← FALSE ENDLOOP;
END;
Bind:
PROC [st: SymbolTable, fields: Fields] =
BEGIN
FOR i:
NAT
IN [0 .. fields.length)
DO
IF fields[i].name = NIL THEN LOOP;
IF fields[i].valued
THEN
BEGIN
[] ← SymTab.Store[st, fields[i].name, AMTypes.Copy[fields[i].value]];
END
ELSE
IF fields[i].typed
THEN
BEGIN
[] ← SymTab.Store[st, fields[i].name, AMTypes.New[fields[i].type]];
END;
ENDLOOP;
END;
Start:
PROC = {
emptyFields.named ← FALSE;
};
Start[];
END.