///Projects/StatementFunctions/EQT.Mesa
Last Edited by: Spreitzer, April 16, 1985 11:55:22 am PST
DIRECTORY AMBridge, AMTypes, BBUrpEval, Commander, CommandExtras, CommandTool, EvalQuote, InterpreterOps, IO, List, PPTree, PPTreeOps, PrintTV, ProcessProps, Rope, StatementInterpreter, StructuredStreams, SymTab;
EQT:
CEDAR
PROGRAM
IMPORTS AMBridge, AMTypes, BBUrpEval, Commander, CommandExtras, CommandTool, EvalQuote, InterpreterOps, IO, List, PPTreeOps, PrintTV, ProcessProps, Rope, StatementInterpreter, StructuredStreams =
BEGIN
ROPE: TYPE = Rope.ROPE;
Type: TYPE = AMTypes.Type;
TV: TYPE = AMTypes.TV;
SymbolTable: TYPE = SymTab.Ref;
Tree: TYPE = InterpreterOps.Tree;
EvalHead: TYPE = InterpreterOps.EvalHead;
nullType: Type = AMTypes.nullType;
empty: TV ← AMTypes.GetEmptyTV[];
ShowModuleParseTree:
PROC [cmd: Commander.Handle]
RETURNS [result:
REF ←
NIL, msg:
ROPE ←
NIL]
--Commander.CommandProc-- = {
blockAsRope: ROPE ← cmd.commandLine;
len: INT ← blockAsRope.Length[];
errorStream: IO.STREAM ← IO.ROS[];
body: Tree;
IF len < 1 THEN RETURN;
IF blockAsRope.Fetch[len-1] = '\n THEN blockAsRope ← blockAsRope.Substr[len: len - 1];
body ← StatementInterpreter.ParseModule[blockAsRope, errorStream];
msg ← IO.RopeFromROS[errorStream];
IF msg.Length[] > 0
THEN result ← $Failure
ELSE {
out: IO.STREAM ← StructuredStreams.Create[cmd.out];
PrettyPrintTree[out, body, 57];
out.PutRope["\n"];
out.Close[];
};
};
ShowBlockParseTree:
PROC [cmd: Commander.Handle]
RETURNS [result:
REF ←
NIL, msg:
ROPE ←
NIL]
--Commander.CommandProc-- = {
blockAsRope: ROPE ← Rope.Cat["{", cmd.commandLine];
len: INT ← blockAsRope.Length[];
errorStream: IO.STREAM ← IO.ROS[];
body: Tree;
IF len < 1 THEN RETURN;
IF blockAsRope.Fetch[len-1] = '\n THEN blockAsRope ← blockAsRope.Substr[len: len - 1];
body ← StatementInterpreter.ParseBlock[blockAsRope, errorStream];
msg ← IO.RopeFromROS[errorStream];
IF msg.Length[] > 0
THEN result ← $Failure
ELSE {
out: IO.STREAM ← StructuredStreams.Create[cmd.out];
PrettyPrintTree[out, body, 57];
out.PutRope["\n"];
out.Close[];
};
};
GetStream:
PROC
RETURNS [
IO.
STREAM] = {
WITH List.Assoc[$CommanderHandle, ProcessProps.GetPropList[]]
SELECT
FROM
cmd: Commander.Handle => RETURN [cmd.out];
ENDCASE => RETURN [NIL];
};
Cons:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
last: Tree ← NIL;
tail: TV;
listType, consType, carType: Type;
tailIndex: NAT;
FOR tailIndex ← 1, tailIndex+1
DO
t: Tree ← InterpreterOps.GetArg[tree, tailIndex];
IF t = NIL THEN EXIT;
last ← t;
ENDLOOP;
tailIndex ← tailIndex - 1;
tail ← InterpreterOps.Eval[tree: last, head: head, target: target];
listType ← AMTypes.TVType[tail];
IF AMTypes.UnderClass[listType] # list THEN ERROR;
consType ← AMTypes.Range[listType];
IF AMTypes.TypeClass[consType] # structure THEN ERROR;
carType ← AMTypes.IndexToType[consType, 1];
FOR i:
NAT
DECREASING
IN [1 .. tailIndex)
DO
elTree: Tree ← InterpreterOps.GetArg[tree, i];
elt: TV ← InterpreterOps.Eval[tree: elTree, head: head, target: carType];
cons: TV ← AMTypes.New[consType];
car: TV ← AMTypes.IndexToTV[cons, 1];
cdr: TV ← AMTypes.IndexToTV[cons, 2];
tailRef: REF ANY;
AMTypes.Assign[car, elt];
AMTypes.Assign[cdr, tail];
TRUSTED {
tailRef ← AMBridge.RefFromTV[cons];
tail ← AMBridge.TVForReferent[NEW [REF ANY ← tailRef]]};
tail ← AMTypes.Coerce[tail, listType];
ENDLOOP;
return ← tail;
END;
MakeExplicitlyTypedList:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
typeTree: Tree ← InterpreterOps.GetArg[tree, 1];
listType: Type ← ForceType[InterpreterOps.Eval[typeTree, head, typeType], head, typeTree];
consType, carType: Type;
nilIndex: NAT;
tail: TV;
IF AMTypes.UnderClass[listType] # list THEN ERROR;
consType ← AMTypes.Range[listType];
carType ← AMTypes.IndexToType[consType, 1];
tail ← AMTypes.New[listType];
AMTypes.Assign[tail, nil];
FOR nilIndex ← 2, nilIndex + 1
DO
t: Tree ← InterpreterOps.GetArg[tree, nilIndex];
IF t = NIL THEN EXIT;
ENDLOOP;
FOR i:
NAT
DECREASING
IN (1 .. nilIndex)
DO
elTree: Tree ← InterpreterOps.GetArg[tree, i];
elt: TV ← InterpreterOps.Eval[tree: elTree, head: head, target: carType];
cons: TV ← AMTypes.New[consType];
car: TV ← AMTypes.IndexToTV[cons, 1];
cdr: TV ← AMTypes.IndexToTV[cons, 2];
tailRef: REF ANY;
AMTypes.Assign[car, elt];
AMTypes.Assign[cdr, tail];
TRUSTED {
tailRef ← AMBridge.RefFromTV[cons];
tail ← AMBridge.TVForReferent[NEW [REF ANY ← tailRef]]};
tail ← AMTypes.Coerce[tail, listType];
ENDLOOP;
return ← tail;
END;
loraType: Type ← AMTypes.UnderType[CODE[LIST OF REF ANY]];
MakeImplicitlyTypedList:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
listType: Type ← IF target # nullType THEN target ELSE loraType;
consType, carType: Type;
nilIndex: NAT;
tail: TV;
IF AMTypes.UnderClass[listType] # list THEN ERROR;
consType ← AMTypes.Range[listType];
carType ← AMTypes.IndexToType[consType, 1];
tail ← AMTypes.New[listType];
AMTypes.Assign[tail, nil];
FOR nilIndex ← 1, nilIndex + 1
DO
t: Tree ← InterpreterOps.GetArg[tree, nilIndex];
IF t = NIL THEN EXIT;
ENDLOOP;
FOR i:
NAT
DECREASING
IN (0 .. nilIndex)
DO
elTree: Tree ← InterpreterOps.GetArg[tree, i];
elt: TV ← InterpreterOps.Eval[tree: elTree, head: head, target: carType];
cons: TV ← AMTypes.New[consType];
car: TV ← AMTypes.IndexToTV[cons, 1];
cdr: TV ← AMTypes.IndexToTV[cons, 2];
tailRef: REF ANY;
AMTypes.Assign[car, elt];
AMTypes.Assign[cdr, tail];
TRUSTED {
tailRef ← AMBridge.RefFromTV[cons];
tail ← AMBridge.TVForReferent[NEW [REF ANY ← tailRef]]};
tail ← AMTypes.Coerce[tail, listType];
ENDLOOP;
return ← tail;
END;
typeType: Type;
underType: Type ← AMTypes.UnderType[CODE[Type]];
nil: TV;
ForceType:
PROC [tv:
TV, head: EvalHead, parent: Tree]
RETURNS [Type] =
TRUSTED {
rtn: TV ← tv;
DO
Try to get the right stuff.
ut: Type = AMTypes.UnderType[AMTypes.TVType[rtn]];
IF ut = underType THEN RETURN [AMTypes.TVToType[rtn]];
IF AMTypes.TypeClass[ut] = type THEN RETURN [AMTypes.TVToType[rtn]];
rtn ← BBUrpEval.UrpWrongType[head, parent, rtn, underType, "not Type"]
ENDLOOP
};
Print:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
out: IO.STREAM ← GetStream[];
args: Tree ← PPTreeOps.NthSon[tree, 2];
IF out # NIL THEN out ← StructuredStreams.Create[out];
IF args #
NIL
AND
ISTYPE[args,
REF PPTree.Node]
AND
NARROW[args,
REF PPTree.Node].name = list
THEN {
FOR i:
NAT
IN [1 .. PPTreeOps.NSons[args]]
DO
son: Tree ← PPTreeOps.NthSon[args, i];
return ← InterpreterOps.Eval[tree: son, head: head, target: target];
PrintTV.Print[return, out];
ENDLOOP}
ELSE {
return ← InterpreterOps.Eval[tree: args, head: head, target: target];
PrintTV.Print[return, out]};
IF out = NIL THEN RETURN;
out.PutChar['\n];
out.Close[];
END;
Reflection: TYPE = RECORD [head: EvalHead, tree: Tree, target: Type];
Reflect:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
TRUSTED {return ← AMBridge.TVForReferent[NEW[Reflection ← latest ← [head, tree, target]]]};
END;
Up:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
args: Tree ← PPTreeOps.NthSon[tree, 2];
arg: TV ← InterpreterOps.Eval[tree: args, head: head];
TRUSTED {return ← AMBridge.TVForReferent[NEW [TV ← arg]]};
END;
downBitch: TV;
Down:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
args: Tree ← PPTreeOps.NthSon[tree, 2];
arg: TV ← InterpreterOps.Eval[tree: args, head: head];
SELECT AMTypes.TypeClass[AMTypes.UnderType[AMTypes.TVType[arg]]]
FROM
ref => {
ra: REF ANY;
TRUSTED {ra ← AMBridge.TVToRef[arg]};
WITH ra
SELECT
FROM
tv: TV => RETURN [tv];
ENDCASE;
};
ENDCASE;
return ← downBitch;
END;
EnType:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
args: Tree ← PPTreeOps.NthSon[tree, 2];
arg: TV ← InterpreterOps.Eval[tree: args, head: head, target: typeType];
type: Type ← ForceType[arg, head, tree];
TRUSTED {return ← AMBridge.TVForType[type]};
END;
latest: Reflection;
Snarf:
PROC [head: EvalHead, tree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [return:
TV]
-- EvalQuote.EvalQuoteProc -- =
BEGIN
latest ← [head, tree, target];
return ← empty;
END;
PrettyPrintTree:
PROC [to:
IO.
STREAM, t: Tree, margin:
NAT ← 69] = {
realTo: IO.STREAM;
IF to = NIL THEN to ← GetStream[];
realTo ← StructuredStreams.Create[to, margin];
PrintWork[realTo, t];
realTo.Close[];
};
PrintWork:
PROC [to:
IO.
STREAM, t: Tree] = {
WITH t
SELECT
FROM
n:
REF PPTree.Node => {
to.PutRope[nodeNames[n.name]];
IF n.attr #
ALL[
FALSE]
THEN
FOR a: PPTree.AttrId
IN PPTree.AttrId
DO
to.PutChar[IF n.attr[a] THEN 'T ELSE 'F];
ENDLOOP;
IF n.info # 0 THEN to.PutF["%g", IO.card[n.info]];
to.PutRope["["];
StructuredStreams.Begin[to];
FOR i:
NAT
IN [1 .. n.sonLimit)
DO
StructuredStreams.Bp[to, FALSE, 0];
PrintWork[to, n.son[i]];
IF i+1 < n.sonLimit THEN to.PutRope[", "];
ENDLOOP;
to.PutRope["]"];
StructuredStreams.End[to];
};
ra: REF ANY => to.Put[IO.refAny[ra]];
ENDCASE => ERROR;
};
nodeNames: ARRAY PPTree.NodeName OF ROPE;
Start:
PROC = {
rnn: REF PPTree.NodeName ← NEW [PPTree.NodeName];
tvnn: TV;
TRUSTED {
typeType ← AMTypes.TVType[AMBridge.TVForType[CODE[BOOL]]];
nil ← AMBridge.TVForReferent[NEW [REF ANY ← NIL]];
tvnn ← AMBridge.TVForReferent[rnn];
downBitch ← AMBridge.TVForReferent[NEW [ROPE ← "Not a TypedVariable"]];
};
FOR nn: PPTree.NodeName
IN PPTree.NodeName
DO
rnn^ ← nn;
nodeNames[nn] ← AMTypes.TVToName[tvnn];
ENDLOOP;
EvalQuote.Register["&reflect", Reflect, NIL];
EvalQuote.Register["&up", Up, NIL];
EvalQuote.Register["&down", Down, NIL];
EvalQuote.Register["&type", EnType, NIL];
EvalQuote.Register["&snarf", Snarf, NIL];
EvalQuote.Register["&print", Print, NIL];
EvalQuote.Register["&cons", Cons, NIL];
EvalQuote.Register["&tlist", MakeExplicitlyTypedList, NIL];
EvalQuote.Register["&list", MakeImplicitlyTypedList, NIL];
Commander.Register["d{", ShowBlockParseTree, "PrettyPrints statement parse tree"];
CommandExtras.MakeUninterpreted[ Commander.Lookup[ CommandTool.CurrentWorkingDirectory[].Cat["d{"]]];
Commander.Register["dm", ShowModuleParseTree, "PrettyPrints module parse tree"];
CommandExtras.MakeUninterpreted[ Commander.Lookup[ CommandTool.CurrentWorkingDirectory[].Cat["dm"]]];
};
Start[];
END.