///Projects/StatementFunctions/StatementFunctions.Mesa
Last Edited by: Spreitzer, August 5, 1984 10:39:37 pm PDT
DIRECTORY AMBridge, AMTypes, Commander, EvalQuote, InterpreterOps, IO, List, PPTree, PPTreeOps, PrintTV, ProcessProps, Rope, SafeStorage, SymTab;
StatementFunctions:
CEDAR
PROGRAM
IMPORTS AMBridge, AMTypes, EvalQuote, InterpreterOps, IO, List, PPTreeOps, PrintTV, ProcessProps, Rope, SafeStorage, SymTab =
BEGIN
ROPE: TYPE = Rope.ROPE;
TV: TYPE = AMTypes.TV;
Type: TYPE = AMTypes.Type;
SymbolTable: TYPE = SymTab.Ref;
EvalHead: TYPE = InterpreterOps.EvalHead;
Tree: TYPE = InterpreterOps.Tree;
nullType: Type = AMTypes.nullType;
GetStream:
PROC
RETURNS [
IO.
STREAM] = {
WITH List.Assoc[$CommanderHandle, ProcessProps.GetPropList[]]
SELECT
FROM
cmd: Commander.Handle => RETURN [cmd.out];
ENDCASE => RETURN [NIL];
};
empty: TV ← AMTypes.GetEmptyTV[];
Fields: TYPE = REF FieldsRep;
FieldsRep:
TYPE =
RECORD [
named: BOOLEAN,
fields: SEQUENCE length: CARDINAL OF Field];
Field:
TYPE =
RECORD [
name: ROPE ← NIL,
type: AMTypes.Type ← nullType,
typed, valued: BOOLEAN ← FALSE,
value: REF ANY ← NIL];
typeType: Type;
typeAsTV: TV;
typeAsType: REF Type;
MyTreeToType:
PROC [tree: Tree, head: EvalHead]
RETURNS [type: Type] =
BEGIN
asTV: TV;
itsType: Type;
asTV ← InterpreterOps.Eval[tree, head];
IF SafeStorage.EquivalentTypes[typeType, AMTypes.TVType[asTV]]
THEN
BEGIN
AMTypes.Assign[typeAsTV, asTV];
RETURN[typeAsType^];
END;
itsType ← AMTypes.TVType[asTV];
SELECT AMTypes.TypeClass[AMTypes.UnderType[itsType]]
FROM
type => RETURN[AMTypes.TVToType[asTV]];
ENDCASE =>
BEGIN
head.helpFatalClosure.proc[data: head.helpFatalClosure.data, head: head, parent: tree, msg: "Not a TYPE"];
END;
END;
Mush:
PROC [tv:
TV]
RETURNS [mushy:
TV] =
BEGIN
type: Type;
tag: TV ← NIL;
IF AMTypes.TVStatus[tv] = mutable THEN RETURN[tv];
mushy ← AMTypes.Copy[tv];
type ← AMTypes.TVType[tv];
SELECT AMTypes.TypeClass[AMTypes.UnderType[type]] FROM
union => tag ← AMTypes.Tag[tv];
ENDCASE;
mushy ← AMType.New[type: type, status: mutable, tag: tag];
Assign[lhs: mushy, rhs: tv];
END;
DigestFields:
PROC [tree: Tree, eval:
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;
IF (fields[index].typed ← type # NIL) THEN fields[index].type ← MyTreeToType[type, head];
IF NOT (fields[index].valued ← value # NIL) THEN NULL
ELSE IF NOT eval THEN fields[index].value ← value
ELSE fields[index].value ← InterpreterOps.Eval[value, head];
index ← index + 1;
END;
ENDCASE => ERROR;
END;
IF name = NIL THEN RealWork[NIL]
ELSE PPTreeOps.ScanList[name, RealWork];
END;
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;
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;
CopyFields:
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] ENDLOOP;
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;
Match:
PROC [formals, actuals: Fields, lname:
ROPE]
RETURNS [bound: Fields] =
BEGIN
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's %g'th arg", IO.rope[lname], IO.card[i]]]};
bound ← CopyFields[formals];
IF bound.length < 1 THEN RETURN;
IF actuals.named
THEN
BEGIN
bindCount: NAT ← 0;
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", IO.rope[actuals[i].name]];
LOOP;
END;
IF actuals[i].valued
THEN
BEGIN
SetValue[j, i];
bindCount ← bindCount + 1;
END;
ENDLOOP;
IF bindCount > bound.length
THEN
SIGNAL MatchWarning["Some keys were bound to multiple times"];
END
ELSE
BEGIN
IF actuals.length > formals.length
THEN
SIGNAL MatchWarning["%g extra arguments ignored", IO.int[actuals.length - formals.length]];
FOR i:
NAT
IN [0 ..
MIN[formals.length, actuals.length])
DO
IF actuals[i].valued THEN SetValue[i, i];
ENDLOOP;
END;
FOR i:
NAT
IN [0 .. bound.length)
DO
IF
NOT bound[i].valued
THEN
BEGIN
IF bound.named
THEN ERROR MatchError["%g unbound", IO.rope[Describe[i]]]
ELSE ERROR MatchError["%g unbound", IO.rope[Describe[i]]];
END;
ENDLOOP;
END;
SafeMatch:
PROC [formals, actuals: Fields, lname:
ROPE, head: EvalHead, parent: Tree]
RETURNS [bound: Fields] =
BEGIN
bound ← Match[formals, actuals, lname !
MatchWarning => {GetStream[].PutF[Rope.Cat["Warning: ", fmt, "\n"], v1, v2, v3, v4]; RESUME};
MatchError => {head.helpFatalClosure.proc[data: head.helpFatalClosure.data, head: head, parent: parent, msg: IO.PutFR[format, v1, v2, v3, v4]]; CONTINUE}];
END;
defineFields: Fields ← NEW[FieldsRep[3]];
EvalDefine:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
BEGIN
myArgs, name, type, procArgs, procRets, expr: Tree;
myFields: Fields;
l: Lambda ← NEW[LambdaRep ← []];
IF PPTreeOps.OpName[tree] # apply THEN ERROR;
myArgs ← PPTreeOps.NthSon[tree, 2];
myFields ← SafeMatch[defineFields, DigestFields[myArgs, FALSE], "define", head, tree];
name ← myFields[0].value;
type ← myFields[1].value;
expr ← myFields[2].value;
IF PPTreeOps.OpName[name] # none
THEN
BEGIN
GetStream[].PutF["Define.name should be an ID, not %g\n", IO.refAny[name]];
RETURN[empty];
END;
IF PPTreeOps.OpName[type] # typecode
THEN
BEGIN
GetStream[].PutF["Define.type should be CODE[a PROCEDURE TYPE-constructor], not %g\n", IO.refAny[type]];
RETURN[empty];
END;
type ← PPTreeOps.NthSon[type, 1];
IF PPTreeOps.OpName[type] # procTC
THEN
BEGIN
GetStream[].PutF["Define.type should be CODE[a PROCEDURE TYPE-constructor], not %g\n", IO.refAny[type]];
RETURN[empty];
END;
procArgs ← PPTreeOps.NthSon[type, 1];
procRets ← PPTreeOps.NthSon[type, 2];
l.name ← InterpreterOps.TreeToName[name];
l.args ← DigestFields[procArgs, TRUE, head];
l.rets ← DigestFields[procRets, TRUE, head];
IF l.rets.length > 1
THEN
BEGIN
GetStream[].PutF["Can't handle %g return values, only 0 or 1.\n", IO.card[l.rets.length]];
RETURN[empty];
END;
l.expr ← expr;
l.symbols ← head.specials;
EvalQuote.Register[l.name, EvalProcedure, head.specials, l];
return ← empty;
END;
Lambda: TYPE = REF LambdaRep;
LambdaRep:
TYPE =
RECORD [
name: ROPE ← NIL,
args, rets: Fields ← NIL,
expr: Tree ← NIL,
symbols: SymbolTable ← NIL];
NestHead:
PROC [outer: EvalHead]
RETURNS [inner: EvalHead] =
BEGIN
found: BOOL;
sttv, sttv2: TV;
inner ← NEW [InterpreterOps.EvalHeadRep ← outer^];
inner.specials ← CopySymbolTable[outer.specials];
[found, sttv] ← inner.specials.Fetch["&EvalQuoteSymTab"];
IF found
THEN {
eqst, eqst2: SymbolTable;
TRUSTED {eqst ← LOOPHOLE[AMBridge.RefFromTV[sttv]]};
eqst2 ← CopySymbolTable[eqst];
TRUSTED {sttv2 ← AMBridge.TVForReferent[eqst2]};
[] ← inner.specials.Store["&EvalQuoteSymTab", sttv2]};
END;
EvalProcedure:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
BEGIN
args: Tree;
actualFields, match, 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, head];
match ← SafeMatch[l.args, actualFields, l.name, head, tree];
subHead ← NestHead[head];
Bind[subHead.specials, match];
Bind[subHead.specials, l.rets];
[] ← InterpreterOps.Eval[l.expr, subHead !
Return => {ans ← fields; CONTINUE}];
IF ans = NIL THEN ans ← emptyFields;
IF l.rets.length = 0
THEN
BEGIN
IF ans.length # 0 THEN GetStream[].PutF["Warning: values returned to %g, who wasn't expecting them\n", IO.rope[l.name]];
return ← empty;
END
ELSE
BEGIN
IF ans.length = 0
THEN
BEGIN
IF l.rets.named
THEN
BEGIN
found: BOOLEAN;
[found, return] ← subHead.specials.Fetch[l.rets[0].name];
IF
NOT found
THEN
BEGIN
GetStream[].PutF["Error: return value %g undefined\n", IO.rope[l.rets[0].name]];
return ← empty;
END;
END
ELSE
BEGIN
GetStream[].PutF["Error: default return of anonymous value\n"];
return ← empty;
END;
END
ELSE
BEGIN
return ← ans[0].value;
END;
IF return # empty
AND l.rets[0].typed
THEN
BEGIN
return ← AMTypes.Coerce[return, l.rets[0].type !AMTypes.Error =>
BEGIN
s: IO.STREAM ← GetStream[];
s.PutF["Type mismatch on return from %g: expected ", IO.rope[l.name]];
PrintTV.PrintType[l.rets[0].type, s];
s.PutRope[", got "];
PrintTV.Print[return, s];
s.PutChar['\n];
END];
END;
END;
END;
OldBind:
PROC [st: SymbolTable, fields: Fields, createShadows:
BOOLEAN]
RETURNS [shadows: Fields] =
BEGIN
IF createShadows THEN shadows ← CopyFields[fields];
FOR i:
NAT
IN [0 .. fields.length)
DO
IF fields[i].name = NIL THEN LOOP;
IF fields[i].valued
THEN
BEGIN
IF createShadows THEN [shadows[i].valued, shadows[i].value] ← st.Fetch[fields[i].name];
[] ← st.Store[fields[i].name, fields[i].value];
END
ELSE IF createShadows THEN shadows[i].valued ← FALSE;
ENDLOOP;
END;
CopySymbolTable:
PROC [old: SymbolTable]
RETURNS [new: SymbolTable] =
BEGIN
ToNew: SymTab.EachPairAction
--PROC [key: Key, val: Val] RETURNS [quit: BOOL]-- =
{[] ← new.Store[key, val]; quit ← FALSE};
new ← SymTab.Create[];
[] ← old.Pairs[ToNew];
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
[] ← st.Store[fields[i].name, AMTypes.Copy[fields[i].value]];
END
ELSE
IF fields[i].typed
THEN
BEGIN
[] ← st.Store[fields[i].name, AMTypes.New[fields[i].type]];
END;
ENDLOOP;
END;
Return: SIGNAL [fields: Fields] = CODE;
emptyFields: Fields ← NEW[FieldsRep[0]];
EvalReturn:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
BEGIN
args: Tree;
fields: Fields;
IF PPTreeOps.OpName[tree] # apply THEN ERROR;
args ← PPTreeOps.NthSon[tree, 2];
fields ← DigestFields[args, TRUE, head];
SIGNAL Return[fields];
return ← empty;
END;
EvalLetProgN:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
BEGIN
first: BOOLEAN ← TRUE;
DoIt: PPTree.Scan
--PROC [t: Link]-- =
BEGIN
IF first
THEN
BEGIN
first ← FALSE;
IF PPTreeOps.OpName[t] = typecode
THEN
BEGIN
rc: Tree ← PPTreeOps.NthSon[t, 1];
IF PPTreeOps.OpName[rc] = recordTC
THEN
BEGIN
fields: Fields ← DigestFields[PPTreeOps.NthSon[rc, 1], TRUE, head];
head ← NestHead[head];
Bind[head.specials, fields];
RETURN;
END;
END;
END;
return ← InterpreterOps.Eval[t, head];
END;
return ← empty;
PPTreeOps.ScanList[PPTreeOps.NthSon[tree, 2], DoIt];
END;
cforFields: Fields ← NEW[FieldsRep[4]];
Exit: ERROR [value: TV ← NIL] = CODE;
Loop: ERROR [value: TV ← NIL] = CODE;
EvalCFor:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
BEGIN
special: BOOLEAN ← FALSE;
rawArgFields: Fields ← DigestFields[PPTreeOps.NthSon[tree, 2], FALSE];
argFields: Fields ← SafeMatch[cforFields, rawArgFields, "cfor", head, tree];
init, test, step, body: Tree;
init ← argFields[0].value;
test ← argFields[1].value;
step ← argFields[2].value;
body ← argFields[3].value;
return ← empty;
IF PPTreeOps.OpName[init] = typecode
THEN
BEGIN
rc: Tree ← PPTreeOps.NthSon[init, 1];
IF PPTreeOps.OpName[rc] = recordTC
THEN
BEGIN
fields: Fields ← DigestFields[PPTreeOps.NthSon[rc, 1], TRUE, head];
head ← NestHead[head];
Bind[head.specials, fields];
special ← TRUE;
END;
END;
IF NOT special THEN [] ← InterpreterOps.Eval[init, head];
DO
testTV: TV ← InterpreterOps.Eval[test, head];
card: LONG CARDINAL;
TRUSTED {card ← AMBridge.TVToLC[testTV]};
IF card = 0 THEN EXIT;
return ← InterpreterOps.Eval[body, head !Exit => {return ← value; EXIT}; Loop => {return ← value; CONTINUE}];
[] ← InterpreterOps.Eval[step, head];
ENDLOOP;
END;
EvalExit:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
{ERROR Exit[EvalLetProgN[head: head, tree: tree]]};
EvalLoop:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
{ERROR Loop[EvalLetProgN[head: head, tree: tree]]};
EvalAbort:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
{ERROR ABORTED};
EvalPrint:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
--EvalQuote.EvalQuoteProc-- =
BEGIN
PrintIt: PPTree.Scan
--PROC [t: Link]-- =
BEGIN
tv: TV ← InterpreterOps.Eval[t, head];
IF first THEN first ← FALSE ELSE out.PutRope[", "];
PrintTV.Print[tv, out];
END;
out: IO.STREAM ← GetStream[];
first: BOOLEAN ← TRUE;
return ← empty;
PPTreeOps.ScanList[PPTreeOps.NthSon[tree, 2], PrintIt];
IF NOT first THEN out.PutChar['\n];
END;
Setup:
PROC =
BEGIN
TRUSTED {typeAsTV ← AMBridge.TVForReferent[typeAsType ← NEW[Type]]};
typeType ← AMTypes.TVType[typeAsTV];
defineFields.named ← TRUE;
defineFields[0] ← ["name", nullType, FALSE, FALSE, NIL];
defineFields[1] ← ["type", nullType, FALSE, FALSE, NIL];
defineFields[2] ← ["expr", nullType, FALSE, FALSE, NIL];
cforFields.named ← TRUE;
cforFields[0] ← ["init", nullType, FALSE, FALSE, NIL];
cforFields[1] ← ["test", nullType, FALSE, FALSE, NIL];
cforFields[2] ← ["step", nullType, FALSE, FALSE, NIL];
cforFields[3] ← ["body", nullType, FALSE, FALSE, NIL];
EvalQuote.Register["&define", EvalDefine, NIL];
EvalQuote.Register["&return", EvalReturn, NIL];
EvalQuote.Register["&block", EvalLetProgN, NIL];
EvalQuote.Register["&cfor", EvalCFor, NIL];
EvalQuote.Register["&exit", EvalExit, NIL];
EvalQuote.Register["&loop", EvalLoop, NIL];
EvalQuote.Register["&print", EvalPrint, NIL];
EvalQuote.Register["&abort", EvalAbort, NIL];
END;
Setup[];
END.
&define[name: id, type: CODE[procTC], expr: expr]
Defines a procedure. Procedure's name is the id. Procedure takes arguments and returns results as given by the type argument. Mesa semantics for args and returns, except that there can be no more than 1 return value. The body of the procedure consists of executing the expression. The &define itself returns nothing.
&return[expr]
Causes the value of the expression to be returned from the procedure body this is executed in. Woe if not executed in a procedure body.
&block[expr1, expr2, ... exprN]
Evaluates the expressions in order, and returns the value of the last one. Returns nothing if N = 0.
&block[CODE[recordTC], expr1, expr2, ... exprN]
Introduces a nested scope. The fields of the record type declaration are the local variables, and they are initialized, if initial values are given. Then the following expressions are executed in that scope, and the value of the &block is the value of the last of them, or no value, if N=0.
&cfor[init: expr, test: booleanExpr, step: expr, body: expr]
A C-style for loop. Evaluates init, then repeatedly:
Evaluates test. If false, done with looping.
Otherwise executes body, then step.
The value returned from the &cfor is the value of the last execution of the body (unless an &exit was performed). If the init was CODE[recordTC], a nested scope is introduced, as in &block. The scope covers the test, step, and body.
&loop[expr1, expr2, ... exprN]
&loop[CODE[recordTC], expr1, expr2, ... exprN]
Causes the smallest enclosing &cfor to abort executing its body, and proceed to its step. &loop must be executed from the body of a &cfor. The value of the last expression is taken to be value the aborted body execution; if no expressions, no body value. If the first expression is preceded by a CODE[recordTC], a nested scope is introduced, as in &block. The scope covers the expressions after the CODE[recordTC].
&exit[expr1, expr2, ... exprN]
&exit[CODE[recordTC], expr1, expr2, ... exprN]
Causes the smallest enclosing &cfor to stop looping. The value returned from that &cfor will be the value of the last expression, or no value if no expressions. If the first expression is preceded by a CODE[recordTC], a nested scope is introduced, as in &block.
&print[expr1, expr2, ... exprN]
Evaluates the expresions in order, and prints their values, separated by commas, and terminated with a newline.
&abort[]
Raises the ERROR ABORTED.