StatementCommands.Mesa
Last Edited by: Spreitzer, January 7, 1985 10:52:20 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, SymTabImpl, WorldVM;
StatementCommands:
CEDAR
PROGRAM
IMPORTS AMBridge, AMModel, AMTypes, BackStop, BBUrpEval, CBinary, Commander, CommandExtras, CommandTool, EvalQuote, InterpreterOps, InterpreterPrivate, IO, List, PPP1, PPTreeOps, PrincOpsUtils, ProcessProps, Real, Rope, StatementInterpreter, StatementInterpreterPrivate, SymTab, SymTabImpl, WorldVM
EXPORTS StatementInterpreter, StatementInterpreterPrivate, SymTab
SHARES SymTabImpl =
BEGIN OPEN StatementInterpreter, StatementInterpreterPrivate;
SymbolTable: TYPE = REF SymTabRep;
SymTabRep: PUBLIC TYPE = SymTabImpl.SymTabRep;
empty: PUBLIC TV ← AMTypes.GetEmptyTV[];
typeType: PUBLIC Type;
Exit: PUBLIC ERROR = CODE;
Loop: PUBLIC ERROR = CODE;
Return: PUBLIC ERROR [fields: Fields] = CODE;
Resume: PUBLIC ERROR [fields: Fields] = CODE;
GoTo: PUBLIC ERROR [label: ROPE] = CODE;
DecideSignal: PUBLIC ERROR [decision: BasicSignalDecisionType] = CODE;
NarrowToSymbolTable:
PUBLIC
PROC [ra:
REF
ANY]
RETURNS [st: SymbolTable] = {
st ← NARROW[ra];
};
StatementCommand:
PROC [cmd: Commander.Handle]
RETURNS [result:
REF ←
NIL, msg:
ROPE ←
NIL]
--Commander.CommandProc-- = {
blockAsRope: ROPE ← Rope.Cat["{", cmd.commandLine];
len: INT ← blockAsRope.Length[];
errorRope: ROPE;
head: InterpreterOps.EvalHead = NARROW[List.Assoc[$EvalHead, ProcessProps.GetPropList[]]];
context: AMModel.Context;
symTab: SymbolTable;
IF len < 1 THEN RETURN;
IF blockAsRope.Fetch[len-1] = '\n THEN blockAsRope ← blockAsRope.Substr[len: len - 1];
IF head =
NIL
THEN TRUSTED {context ← AMModel.RootContext[WorldVM.LocalWorld[]]}
ELSE {
context ← head.context;
IF context =
NIL
THEN TRUSTED {context ← AMModel.RootContext[InterpreterOps.WorldFromHead[head]]};
};
TRUSTED {symTab ← NarrowToSymbolTable[List.Assoc[$SymTab, cmd.propertyList]]};
IF symTab =
NIL
THEN {
symTab ← SymTab.Create[];
[] ← List.PutAssoc[key: $SymTab, val: symTab, aList: cmd.propertyList];
};
errorRope ← InterpretStatement[blockAsRope, context, symTab];
IF errorRope # NIL THEN cmd.out.PutRope[Rope.Cat["Error: ", errorRope, "\n"]];
};
InterpretStatement:
PUBLIC
PROC [blockAsRope:
ROPE, context: Context ←
NIL, symTab: SymbolTable ←
NIL, abort: InterpreterOps.AbortClosure ← Interpreter.nilAbortClosure]
RETURNS [errorRope:
ROPE] = {
Inner:
PROC = {
bodyTree: Tree ← ParseBlock[blockAsRope, errorStream];
Interp[
asTree: bodyTree,
head: InterpreterOps.NewEvalHead[
context: context,
specials: symTab,
helpFatalClosure: [myHelpFatal, errorStream],
abortClosure: abort],
nest: FALSE
!FatalInterpreterError => {errorStream.PutRope[msg]; CONTINUE}];
};
errorStream: IO.STREAM ← IO.ROS[];
IF context = NIL THEN TRUSTED {context ← AMModel.RootContext[WorldVM.LocalWorld[]]};
IF symTab = NIL THEN symTab ← SymTab.Create[];
errorStream.PutRope[BackStop.Call[Inner]];
errorRope ← IO.RopeFromROS[errorStream];
};
FatalInterpreterError: ERROR[msg: ROPE] = CODE;
myHelpFatal:
PROC [data:
REF, head: EvalHead, parent: Tree, msg:
ROPE]
--InterpreterOps.HelpFatal-- =
TRUSTED {
ERROR FatalInterpreterError[msg];
};
First:
PROC [nn: PPTree.NodeName, in: Tree]
RETURNS [out: Tree] = {
IF in = NIL THEN RETURN [NIL];
WITH in
SELECT
FROM
n: Node => {
IF n.name = nn THEN RETURN [n];
FOR i:
NAT
IN [1 .. n.sonLimit)
DO
out ← First[nn, n.son[i]];
IF out # NIL THEN RETURN;
ENDLOOP};
ENDCASE;
out ← NIL};
Interp:
PUBLIC
PROC [asTree: Tree, head: EvalHead, nest:
BOOL ←
TRUE] = {
Inner: PROC = {InterpNoProps[NARROW[asTree], head, nest]};
ProcessProps.AddPropList[List.PutAssoc[$EvalHead, head, NIL], Inner];
};
InterpNoProps:
PUBLIC
PROC [tree: Tree, head: EvalHead, nest:
BOOL ←
TRUE] = {
IF tree #
NIL
THEN
WITH tree
SELECT
FROM
node: Node => {
SELECT node.name
FROM
list =>
FOR i:
NAT
IN[1 .. node.sonLimit)
DO
InterpNoProps[node.son[i], head];
ENDLOOP;
assignx, assign, extractx, extract => [] ← EvalExpr[node, head];
apply => TryApplyCatch[node, head];
body => EvalBody[node, head, nest];
block => EvalBlock[node, head, nest];
if => EvalIf[node, head];
do => EvalDo[node, head];
label => EvalLabelled[node, head];
return => EvalReturn[node, head];
resume => EvalResume[node, head];
exit => ERROR Exit;
loop => ERROR Loop;
goto => {name: PPLeaves.HTIndex ←
NARROW[node.son[1]];
ERROR GoTo[name.name]};
reject => ERROR DecideSignal[Reject];
retry => ERROR DecideSignal[Retry];
continue => ERROR DecideSignal[Continue];
null => NULL;
enable => {
EvalInner: PROC = {InterpNoProps[NARROW[node.son[2]], head]};
Enable[NARROW[node.son[1]], head, EvalInner];
};
syserror => {
SIGNAL BackStop.SuspendBackStop[];
ERROR;
don't bother: SIGNAL BackStop.ResumeBackStop[]
}
ENDCASE => GOTO NYI;
EXITS
NYI => BBUrpEval.UrpFatal[head, node, Rope.Cat["Not Implemented: ", nodeNames[node.name]]];
};
ENDCASE => [] ← EvalExpr[tree, head];
};
EvalExpr:
PUBLIC
PROC [tree: Tree, head: EvalHead, target: Type ← nullType]
RETURNS [tv:
TV] =
{tv ← InterpreterPrivate.EvalNoProps[tree, head, target]};
TryApplyCatch:
PROC [node: Node, head: EvalHead] = {
IF node.sonLimit = 4
THEN {
third: Tree ← node.son[3];
WITH third
SELECT
FROM
n: Node =>
IF n.name = catch
THEN {
DoCall: PROC = {[] ← EvalExpr[node, head]};
Enable[catches: n, head: head, inner: DoCall];
RETURN};
ENDCASE;
};
[] ← EvalExpr[node, head];
};
EvalIf:
PROC [node: Node, head: EvalHead] = {
cond: Tree = node.son[1];
thenClause: Node = NARROW[node.son[2]];
elseClause: Node = NARROW[node.son[3]];
ans: BOOL ← ForceBoolean[EvalExpr[cond, head, underBOOL], head, cond];
InterpNoProps[IF ans THEN thenClause ELSE elseClause, head];
};
EvalLabelled:
PROC [node: Node, head: EvalHead] = {
stmt: Tree ← node.son[1];
exits: Node ← NARROW[node.son[2]];
InterpNoProps[stmt, head !GoTo => IF MatchingLabel[label, exits, head] THEN CONTINUE];
};
MatchingLabel:
PROC [label:
ROPE, exits: Node, head: EvalHead]
RETURNS [match:
BOOL] = {
SELECT exits.name
FROM
item => {name: PPLeaves.HTIndex ←
NARROW[exits.son[1]];
IF match ← label.Equal[name.name]
THEN InterpNoProps[exits.son[2], head]};
list => {
FOR i:
NAT
IN [1 .. exits.sonLimit)
DO
IF MatchingLabel[label, NARROW[exits.son[i]], head] THEN RETURN [TRUE];
ENDLOOP;
match ← FALSE};
ENDCASE => ERROR};
EvalDo:
PROC [node: Node, head: EvalHead] = {
for: Node ← NARROW[node.son[1]];
test: Tree ← node.son[2];
opens: Tree ← node.son[3];
body: Node ← NARROW[node.son[4]];
exits: Node ← NARROW[node.son[5]];
finishedExit: Node ← NARROW[node.son[6]];
LoopWork:
PROC [
Initial, Delta:
PROC
RETURNS [
INT],
Test:
PROC
RETURNS [
BOOL]] = {
FOR i:
INT ← Initial[], Delta[]
WHILE Test[]
DO
InterpNoProps[body, head !
Exit => EXIT;
Loop => CONTINUE;
GoTo => IF MatchingLabel[label, exits, head] THEN EXIT;
];
REPEAT
FINISHED => InterpNoProps[finishedExit, head];
ENDLOOP};
IF for =
NIL
THEN {
Dull: PROC RETURNS [i: INT] = {i ← 1};
Vanilla: PROC RETURNS [b: BOOL] = {b ← test = NIL OR ForceBoolean[EvalExpr[test, head, underBOOL], head, test]};
LoopWork[Dull, Dull, Vanilla]}
ELSE
SELECT for.name
FROM
forseq => {
cv: PPLeaves.HTIndex;
ctl: Tree = for.son[1];
initial: Tree = for.son[2];
delta: Tree = for.son[3];
InitialFor:
PROC
RETURNS [i:
INT] = {
EvalAssign[cv, initial, head];
i ← 0};
DeltaFor:
PROC
RETURNS [i:
INT] = {
EvalAssign[cv, delta, head];
i ← 1};
TestFor:
PROC
RETURNS [b:
BOOL] = {
b ← test = NIL OR ForceBoolean[EvalExpr[test, head, underBOOL], head, test]};
WITH ctl
SELECT
FROM
hti: PPLeaves.HTIndex => cv ← hti;
n: Node => {
IF n.name # decl
THEN
ERROR;
head ← NestHead[head];
AddDecls[head, n];
cv ← NARROW[n.son[1]]};
ENDCASE => ERROR;
LoopWork[InitialFor, DeltaFor, TestFor];
};
upthru, downthru => {
ctl: Tree = for.son[1];
range: Tree = for.son[2];
unknown: Tree = for.son[3];
ctv, cur: TV;
rangeType: Type;
int: Interval;
inRange: BOOL;
InitialUp:
PROC
RETURNS [i:
INT] = {
[cur, inRange] ← IntFirst[int, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
DeltaUp:
PROC
RETURNS [i:
INT] = {
[cur, inRange] ← IntNext[int, ctv, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
TestRange:
PROC
RETURNS [b:
BOOL] = {
b ← inRange AND (test = NIL OR ForceBoolean[EvalExpr[test, head, underBOOL], head, test])};
InitialDown:
PROC
RETURNS [i:
INT] = {
[cur, inRange] ← IntLast[int, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
DeltaDown:
PROC
RETURNS [i:
INT] = {
[cur, inRange] ← IntPrev[int, ctv, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
IF unknown # NIL THEN ERROR;
IF ctl =
NIL
THEN {
int ← EvalInterval[range, head, nullType];
ctv ← AMTypes.Copy[int.low]}
ELSE
WITH ctl
SELECT
FROM
hti: PPLeaves.HTIndex => {
ctv ← EvalExpr[hti, head];
rangeType ← AMTypes.TVType[ctv];
int ← EvalInterval[range, head, rangeType]};
n: Node => {name: Tree ← n.son[1];
type: Tree ← n.son[2];
IF n.name # decl THEN ERROR;
head ← NestHead[head];
AddDecls[head, n];
ctv ← EvalExpr[name, head];
rangeType ← AMTypes.TVType[ctv];
int ← EvalInterval[range, head, rangeType]};
ENDCASE => ERROR;
SELECT for.name
FROM
upthru => LoopWork[InitialUp, DeltaUp, TestRange];
downthru => LoopWork[InitialDown, DeltaDown, TestRange];
ENDCASE => ERROR;
};
ENDCASE => ERROR;
};
EvalInterval:
PROC [tree: Tree, head: EvalHead, target: Type]
RETURNS [int: Interval] =
BEGIN
node: Node ← IF ISTYPE[tree, Node] THEN NARROW[tree] ELSE NIL;
intC: BOOL ← TRUE;
int ← NEW [IntervalRep ← []];
IF node = NIL THEN intC ← FALSE
ELSE
SELECT node.name
FROM
intOO => int.lowClosed ← int.highClosed ← FALSE;
intOC => int.lowClosed ← NOT (int.highClosed ← TRUE);
intCO => int.lowClosed ← NOT (int.highClosed ← FALSE);
intCC => int.lowClosed ← int.highClosed ← TRUE;
ENDCASE => intC ← FALSE;
IF intC
THEN {
lowTree: Tree ← node.son[1];
highTree: Tree ← node.son[2];
int.low ← EvalExpr[lowTree, head, target];
int.high ← EvalExpr[highTree, head, target];
}
ELSE {
type: Type ← ForceType[EvalExpr[tree, head, typeType], head, tree];
int.low ← AMTypes.First[type];
int.high ← AMTypes.Last[type];
int.lowClosed ← int.highClosed ← TRUE;
};
END;
IntFirst:
PROC [int: Interval, head: EvalHead, parent: Tree]
RETURNS [first:
TV, inRange:
BOOL] =
BEGIN
rtv: TV;
first ← int.low;
IF NOT int.lowClosed THEN first ← AMTypes.Next[first];
IF first = NIL THEN RETURN [NIL, FALSE];
rtv ← EvalBinop[first, int.high, IF int.highClosed THEN relLE ELSE relL, head, underBOOL, parent];
inRange ←
SELECT rtv
FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;
IntNext:
PROC [int: Interval, cur:
TV, head: EvalHead, parent: Tree]
RETURNS [next:
TV, inRange:
BOOL] =
BEGIN
rtv: TV;
next ← AMTypes.Next[cur];
IF next = NIL THEN RETURN [NIL, FALSE];
rtv ← EvalBinop[next, int.high, IF int.highClosed THEN relLE ELSE relL, head, underBOOL, parent];
inRange ←
SELECT rtv
FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;
IntLast:
PROC [int: Interval, head: EvalHead, parent: Tree]
RETURNS [last:
TV, inRange:
BOOL] =
BEGIN
rtv: TV;
last ← int.high;
IF NOT int.highClosed THEN last ← Prev[last, head, parent];
IF last = NIL THEN RETURN [NIL, FALSE];
rtv ← EvalBinop[last, int.low, IF int.lowClosed THEN relGE ELSE relG, head, underBOOL, parent];
inRange ←
SELECT rtv
FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;
IntPrev:
PROC [int: Interval, cur:
TV, head: EvalHead, parent: Tree]
RETURNS [prev:
TV, inRange:
BOOL] =
BEGIN
rtv: TV;
prev ← Prev[cur, head, parent];
IF prev = NIL THEN RETURN [NIL, FALSE];
rtv ← EvalBinop[prev, int.low, IF int.lowClosed THEN relGE ELSE relG, head, underBOOL, parent];
inRange ←
SELECT rtv
FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;
Prev:
PROC [tv:
TV, head: EvalHead, parent: Tree]
RETURNS [prev:
TV] =
{IF AMTypes.TVEqual[tv, AMTypes.First[AMTypes.TVType[tv]]] THEN RETURN [NIL];
prev ← EvalBinop[tv, one, minus, head, nullType, parent]};
true, false, one: TV ← NIL;
EvalBinop:
PROC [lval, rval:
TV, kind: PPTree.NodeName, head: EvalHead, target: Type, parent: Tree]
RETURNS [rtn:
TV ←
NIL] = {
op: PPTree.NodeName ← kind;
ltype, rtype, ttype, altype, artype: Type;
lclass, rclass, alclass, arclass, targClass: AMTypes.Class;
rtnBit: BOOL;
ttype ← AMTypes.TVType[lval];
ltype ← AMTypes.UnderType[ttype];
lclass ← AMTypes.TypeClass[ltype];
IF target = nullType THEN target ← ttype;
rtype ← AMTypes.UnderType[AMTypes.TVType[rval]];
rclass ← AMTypes.TypeClass[rtype];
targClass ← AMTypes.TypeClass[AMTypes.GroundStar[target]];
SELECT kind
FROM
relE, relN =>
SELECT lclass
FROM
subrange, cardinal, integer, character, longInteger, longCardinal,
real, unspecified =>
-- these values must be arithmetic
op ← minus
ENDCASE => {
eq: BOOL ← AMTypes.TVEqual[lval, rval];
IF kind = relN THEN eq ← NOT eq;
RETURN [IF eq THEN true ELSE false];
};
relL, relGE, relG, relLE => op ← minus
ENDCASE;
At this point the values must be arithmetic.
lval ← ForceArithmetic[lval, head, parent];
altype ← AMTypes.UnderType[AMTypes.TVType[lval]];
alclass ← AMTypes.TypeClass[altype];
rval ← ForceArithmetic[rval, head, parent];
artype ← AMTypes.UnderType[AMTypes.TVType[rval]];
arclass ← AMTypes.TypeClass[artype];
IF alclass = real
OR arclass = real
THEN
TRUSTED {
-- raise conciousness to the real level
lreal: REAL ← AMBridge.TVToReal[lval];
rreal: REAL ← AMBridge.TVToReal[rval];
IF lclass # real THEN lreal ← AMBridge.TVToLI[lval];
IF rclass # real THEN rreal ← AMBridge.TVToLI[rval];
SELECT op
FROM
plus => lreal ← lreal + rreal;
minus => lreal ← lreal - rreal;
times => lreal ← lreal * rreal;
div => lreal ← lreal / rreal;
mod => lreal ← Real.FRem[lreal, rreal];
min => lreal ← MIN[lreal, rreal];
max => lreal ← MAX[lreal, rreal]
ENDCASE => ERROR;
SELECT kind
FROM
relE => rtnBit ← lreal = 0.0;
relN => rtnBit ← lreal # 0.0;
relL => rtnBit ← lreal < 0.0;
relGE => rtnBit ← lreal >= 0.0;
relG => rtnBit ← lreal > 0.0;
relLE => rtnBit ← lreal <= 0.0;
ENDCASE => IF targClass = enumerated THEN BBUrpEval.UrpFatal[head, parent, "can't do REAL arithmatic with enumerated values"] ELSE RETURN [InterpreterPrivate.NewReal[lreal]];
IF rtnBit THEN RETURN [true] ELSE RETURN [false];
};
TRUSTED {
lint: INT ← AMBridge.TVToLI[lval];
rint: INT ← AMBridge.TVToLI[rval];
SELECT op
FROM
plus => lint ← lint + rint;
minus => lint ← lint - rint;
times => lint ← lint * rint;
div => lint ← lint / rint;
mod => lint ← lint MOD rint;
min => lint ← MIN[lint, rint];
max => lint ← MAX[lint, rint]
ENDCASE => ERROR;
SELECT kind
FROM
relE => rtnBit ← lint = 0;
relN => rtnBit ← lint # 0;
relL => rtnBit ← lint < 0;
relGE => rtnBit ← lint >= 0;
relG => rtnBit ← lint > 0;
relLE => rtnBit ← lint <= 0;
ENDCASE =>
IF targClass = enumerated
THEN {new:
TV ← AMTypes.New[target];
AMBridge.SetTVFromLC[new, LOOPHOLE[lint]];
RETURN [new]}
ELSE RETURN [InterpreterPrivate.NewInt[lint]];
IF rtnBit THEN RETURN [true] ELSE RETURN [false];
}
};
ForceArithmetic:
PROC [val:
TV, head: EvalHead, parent: Tree]
RETURNS [rtn:
TV] =
TRUSTED {
ForceArithmetic forces the given value to be arithmetic; the result is a TV with class = real or class = longInteger.
type: Type;
ground: Type;
class: AMTypes.Class;
rtn ← StripSingleComponentRecord[val];
type ← AMTypes.TVType[rtn];
ground ← AMTypes.GroundStar[type];
class ← AMTypes.TypeClass[ground];
SELECT class
FROM
real =>
IF type # ground THEN rtn ← InterpreterPrivate.NewReal[AMBridge.TVToReal[rtn]];
cardinal, character, unspecified =>
rtn ← InterpreterPrivate.NewInt[AMBridge.TVToCardinal[rtn]];
integer =>
rtn ← InterpreterPrivate.NewInt[AMBridge.TVToInteger[rtn]];
longCardinal =>
rtn ← InterpreterPrivate.NewInt[LOOPHOLE[AMBridge.TVToLC[rtn], INT]];
longInteger =>
IF type # ground THEN rtn ← InterpreterPrivate.NewInt[AMBridge.TVToLI[rtn]];
enumerated => rtn ← InterpreterPrivate.NewInt[AMBridge.TVToCardinal[rtn]];
ENDCASE => BBUrpEval.UrpFatal[head, parent, "not a number"];
};
EvalAssign:
PROC [name: PPLeaves.HTIndex, valueT: Tree, head: EvalHead] = {
n: Node ← NEW [PPTree.Node[assTemp.sonLimit]];
n.name ← assTemp.name;
n.attr ← assTemp.attr;
n.info ← assTemp.info;
n.son[1] ← name;
n.son[2] ← valueT;
IF assTemp.sonLimit # 3 THEN ERROR;
[] ← InterpNoProps[n, head]};
assTemp: Node ← NARROW[First[assign, ParseBlock["{x ← 1}", IO.ROS[]]]];
EvalBody:
PROC [node: Node, head: EvalHead, nest:
BOOL] = {
opens: Node ← NARROW[node.son[1]];
decls: Node ← NARROW[node.son[2]];
stmts: Node ← NARROW[node.son[3]];
IF decls #
NIL
THEN {
IF nest THEN head ← NestHead[head];
AddDecls[head, decls]};
InterpNoProps[stmts, head];
};
EvalBlock:
PROC [node: Node, head: EvalHead, nest:
BOOL] = {
decls: Node ← NARROW[node.son[1]];
stmts: Node ← NARROW[node.son[2]];
IF decls #
NIL
THEN {
IF nest THEN head ← NestHead[head];
AddDecls[head, decls]};
InterpNoProps[stmts, head];
};
NestHead:
PUBLIC
PROC [outer: EvalHead, st: SymbolTable ←
NIL]
RETURNS [inner: EvalHead] =
BEGIN
found: BOOL;
sttv, sttv2: TV;
IF st = NIL THEN st ← outer.specials;
inner ← NEW [InterpreterOps.EvalHeadRep ← outer^];
inner.specials ← CopySymbolTable[st];
[found, sttv] ← inner.specials.Fetch["&EvalQuoteSymTab"];
IF found
THEN {
eqst, eqst2: SymbolTable;
TRUSTED {eqst ← NarrowToSymbolTable[AMBridge.RefFromTV[sttv]]};
eqst2 ← CopySymbolTable[eqst];
TRUSTED {sttv2 ← AMBridge.TVForReferent[eqst2]};
[] ← inner.specials.Store["&EvalQuoteSymTab", sttv2]};
END;
CopySymbolTable:
PROC [old: SymbolTable]
RETURNS [new: SymbolTable] =
BEGIN
ToNew:
PROC [key: SymTab.Key, val: SymTab.Val]
RETURNS [quit:
BOOL]
--SymTab.EachPairAction-- =
{[] ← SymTab.Store[new, key, val]; quit ← FALSE};
new ← SymTab.Create[];
[] ← SymTab.Pairs[old, ToNew];
END;
AddDecls:
PROC [head: EvalHead, decls: Node] = {
AddDecl:
PROC [namesT, typeT, valueT: Tree] = {
IF typeT #
NIL
AND valueT #
NIL
AND
ISTYPE[typeT, Node]
AND
ISTYPE[valueT, Node]
THEN {
PerName:
PROC [nameT: Tree] =
{AddProcDecl[NARROW[nameT], typeN, bodyN, head]};
typeN: Node = NARROW[typeT];
bodyN: Node ← NARROW[valueT];
IF typeN.name = procTC
THEN {
PPTreeOps.ScanList[namesT, PerName];
RETURN}};
--otherwise--{
PerName:
PROC [nameT: Tree] = {
name: PPLeaves.HTIndex = NARROW[nameT];
[] ← head.specials.Store[name.name, val];
};
type: Type ← ForceType[EvalExpr[typeT, head, typeType], head, typeT];
val: TV ← AMTypes.New[type];
IF valueT # NIL THEN AMTypes.Assign[val, EvalExpr[valueT, head, type]];
PPTreeOps.ScanList[namesT, PerName];
}
};
AddTypeDecl:
PROC [namesT, typeT: Tree] = {
PerName:
PROC [nameT: Tree] = {
name: PPLeaves.HTIndex = NARROW[nameT];
[] ← head.specials.Store[name.name, val];
};
type: Type ← ForceType[EvalExpr[typeT, head, typeType], head, typeT];
val: TV;
TRUSTED {val ← AMBridge.TVForType[type]};
PPTreeOps.ScanList[namesT, PerName];
};
SELECT decls.name
FROM
decl => AddDecl[decls.son[1], decls.son[2], decls.son[3]];
typedecl => AddTypeDecl[decls.son[1], decls.son[2]];
list =>
FOR i:
NAT
IN [1 .. decls.sonLimit)
DO
AddDecls[head, NARROW[decls.son[i]]];
ENDLOOP;
ENDCASE => ERROR};
AddProcDecl:
PROC [nameT: PPLeaves.HTIndex, procTypeC, body: Node, head: EvalHead] = {
procArgs: Node ← NARROW[procTypeC.son[1]];
procRets: Node ← NARROW[procTypeC.son[2]];
l: Lambda ←
NEW[LambdaRep ← [
name: nameT.name,
args: DigestFields[procArgs, TRUE, FALSE, head],
rets: DigestFields[procRets, TRUE, FALSE, head],
body: body,
symbols: head.specials]];
IF l.name.Length[] < 2 OR l.name.Fetch[0] # '& THEN BBUrpEval.UrpFatal[head, nameT, "Can only fake &-procs"];
IF l.rets.length > 1 THEN BBUrpEval.UrpFatal[head, procTypeC, "Can't handle more than one return"];
EvalQuote.Register[l.name, EvalProcedure, head.specials, l];
};
ParseModule:
PUBLIC
PROC [asRope:
ROPE, errout:
IO.
STREAM]
RETURNS [asTree: Tree] = {
complete: BOOL;
nErrors: CARDINAL;
PPTreeOps.Initialize[];
TRUSTED {[complete, , nErrors] ← PPP1.Parse[
asRope,
LOOPHOLE[PrincOpsUtils.Codebase[LOOPHOLE[CBinary.MesaTab, PrincOps.GlobalFrameHandle]]],
asTree ← IF complete AND nErrors = 0 THEN PPTreeOps.PopTree[] ELSE PPTree.Null;
PPTreeOps.Finalize[];
};
ParseBlock:
PUBLIC
PROC [asRope:
ROPE, errout:
IO.
STREAM]
RETURNS [asTree: Tree] = {
asRope ← Rope.Cat["Block: PROGRAM = ", asRope, "."];
asTree ← ParseModule[asRope: asRope, errout: errout];
asTree ← First[body, asTree];
};
StripSingleComponentRecord:
PROC [tv:
TV, max:
NAT ← 100]
RETURNS [rtn:
TV] =
TRUSTED {
rtn ← tv;
THROUGH [0..max)
DO
under: Type = AMTypes.UnderType[AMTypes.TVType[rtn]];
class: AMTypes.Class ← AMTypes.UnderClass[under];
IF (class # record AND class # structure) OR (AMTypes.NComponents[under] # 1) THEN EXIT;
rtn ← AMTypes.IndexToTV[rtn, 1];
ENDLOOP;
};
underBOOL: Type ← AMTypes.UnderType[CODE[BOOL]];
trueCard: CARDINAL ← LOOPHOLE[TRUE, CARDINAL];
falseCard: CARDINAL ← LOOPHOLE[FALSE, CARDINAL];
ForceBoolean:
PROC [tv:
TV, head: EvalHead, parent: Tree]
RETURNS [
BOOL] =
TRUSTED {
rtn: TV ← tv;
DO
Try to get the right stuff.
rtn ← StripSingleComponentRecord[rtn];
IF AMTypes.UnderType[AMTypes.TVType[rtn]] = underBOOL
THEN {
card: CARDINAL ← AMBridge.TVToCardinal[rtn];
IF card = trueCard THEN RETURN [TRUE];
IF card = falseCard THEN RETURN [FALSE]};
rtn ← BBUrpEval.UrpWrongType[head, parent, rtn, underBOOL, "not boolean"]
ENDLOOP
};
underType: Type ← AMTypes.UnderType[CODE[Type]];
ForceType:
PUBLIC
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
};
AddMissingTypes:
PROC =
TRUSTED {
st: SymTab.Ref ← InterpreterPrivate.GetGlobalSymTab[];
IF NOT st.Fetch["REAL"].found THEN {IF NOT st.Store["REAL", AMBridge.TVForType[CODE[REAL]]] THEN ERROR};
IF NOT st.Fetch["NAT"].found THEN {IF NOT st.Store["NAT", AMBridge.TVForType[CODE[NAT]]] THEN ERROR};
IF NOT st.Fetch["UNWIND"].found THEN {IF NOT st.Store["UNWIND", AMBridge.TVForSignal[UNWIND]] THEN ERROR};
IF NOT st.Fetch["ABORTED"].found THEN {IF NOT st.Store["ABORTED", AMBridge.TVForSignal[ABORTED]] THEN ERROR};
};
nodeNames: ARRAY PPTree.NodeName OF ROPE;
Start:
PROC = {
rnn: REF PPTree.NodeName ← NEW [PPTree.NodeName];
tvnn: TV;
TRUSTED {tvnn ← AMBridge.TVForReferent[rnn]};
FOR nn: PPTree.NodeName
IN PPTree.NodeName
DO
rnn^ ← nn;
nodeNames[nn] ← AMTypes.TVToName[tvnn];
ENDLOOP;
TRUSTED {
typeType ← AMTypes.TVType[AMBridge.TVForType[CODE[BOOL]]];
true ← AMBridge.TVForReferent[NEW[BOOL ← TRUE]];
false ← AMBridge.TVForReferent[NEW[BOOL ← FALSE]];
one ← AMBridge.TVForReferent[NEW[NAT ← 1]];
};
IF AMTypes.TypeClass[typeType] # type THEN ERROR;
Commander.Register["{", StatementCommand, "a statement evaluation command"];
CommandExtras.MakeUninterpreted[ Commander.Lookup[ CommandTool.CurrentWorkingDirectory[].Cat["{"]]];
AddMissingTypes[];
};
Start[];
END.