=
BEGIN
OPEN
RussellICode, RussellRuntime
;
RussellParse:
PUBLIC PROCEDURE [source:
IO.
STREAM, errMsgProc: ErrMsgProc]
RETURNS [ICExp]
=
BEGIN
RETURN[ ParseRussellExpression[source~source, errMsgProc~errMsgProc] ]
END ; -- RussellParse
stepsBetweenAbortChecks: PRIVATE INT ~ 50;
RussellEval:
PUBLIC PROCEDURE [ env: RTTuple, ip: ICExp ]
RETURNS[RTValue]
=
BEGIN
stepCount: INT ← stepsBetweenAbortChecks;
REval:
PROCEDURE [env: RTTuple, ip: ICExp]
RETURNS [RTValue]
=
BEGIN
ipLocal: ICExp ← ip;
DO
IF ipLocal = NIL THEN RETURN[ NIL ];
stepCount ← stepCount - 1;
IF stepCount <= 0
THEN
BEGIN
ProcessExtras.CheckForAbort[];
stepCount ← stepsBetweenAbortChecks
END ;
WITH ipLocal
SELECT
FROM
c: ICPrimConst =>
BEGIN
SELECT c.which
FROM
$type =>
RETURN[ MkPrimType[]] ;
$safetype =>
RETURN[ MkPrimSafetype[]] ;
ENDCASE =>
ERROR RTError[ec~$badICode] ;
END ;
c: ICCharConst =>
RETURN[ NEW[ CHAR ← c.which ]] ;
s: ICStringConst =>
RETURN[ NEW[ Rope.ROPE ← s.which ] ] ;
i: ICIntConst =>
RETURN[ NEW[ INT ← i.which ]] ;
id: ICId =>
RETURN[ SelectFromTuple[ tuple~env, name~id.name ]];
b: ICBinding =>
BEGIN
temp: RTTuple ← MkTuple[name~b.name, value~REval[env,b.value]];
IF b.next =
NIL
THEN RETURN[ temp ]
ELSE RETURN[ ConcatTuple[ temp, REval[env,b.next] ]]
END ;
mk: ICMkTuple =>
BEGIN
ipLocal ← mk.bindings;
LOOP
END ;
mkrec: ICMkRecTuple =>
BEGIN
newEnv: REF ConsRTNode;
answer: RTTuple;
newEnv ← NEW[ ConsRTNode ← [leftPart~NIL, rightPart~env] ];
answer ← REval[ newEnv, mkrec.bindings];
newEnv.leftPart ← (
IF mkrec.localName =
NIL
THEN answer
ELSE MkTuple[ name~mkrec.localName, value~answer] );
RETURN[answer]
END ;
c: ICConcat =>
RETURN[ConcatTuple[ REval[env,c.leftPart], REval[env,c.rightPart]]];
s: ICSelect =>
RETURN[SelectFromTuple[ REval[env,s.tuple], s.name ]];
a: ICApply =>
RETURN[ ApplyClosure[ closure~REval[env,a.proc], arg~REval[env,a.arg] ]];
c: ICCond =>
BEGIN
p: ICGuardedExp;
FOR p ← c.thenClauses, p.next
WHILE p #
NIL
DO
IF QueryTuple[ tuple~REval[env,p.tuple], name~p.name ]
THEN RETURN[ REval[env,p.result] ] ;
REPEAT
FINISHED => RETURN[ REval[env,c.elseExp] ] ;
ENDLOOP;
END ;
d: ICLoop =>
BEGIN
p: ICGuardedExp;
DO
FOR p ← d.loopClauses, p.next
WHILE p #
NIL
DO
IF QueryTuple[ tuple~REval[env,p.tuple], name~p.name ]
THEN {
[] ← REval[env,p.result];
GOTO trueGuardFound } ;
REPEAT
trueGuardFound => NULL ;
FINISHED => RETURN[ NIL ] ;
ENDLOOP
ENDLOOP
END ;
s: ICSeq =>
BEGIN
[] ← REval[env,s.leftPart];
ipLocal ← s.rightPart;
LOOP
END ;
lambda: ICLambda =>
BEGIN
IF lambda.param =
NIL
THEN ERROR RTError[$badICode] ;
RETURN[ MkClosure[ ep~env, ip~lambda, cb~RussellApplyBody ]]
END ;
open: ICOpen =>
BEGIN
newEnv: RTTuple ← ConcatTuple[ REval[env,open.tuple], env];
RETURN[ REval[ newEnv, open.body ]]
END ;
product: ICProduct =>
RETURN[ MkProductType[env~env, product~product ]] ;
union: ICUnion =>
RETURN[ MkUnionType[env~env, union~union]] ;
func: ICFunc =>
RETURN[ MkFuncType[env~env, func~func]] ;
proc: ICProc =>
RETURN[ MkProcType[env~env, proc~proc]] ;
ref: ICRef =>
RETURN[ MkRefType[env~env, ref~ref] ] ;
ENDCASE =>
ERROR RTError[ec~$badICode] ;
ENDLOOP
END ; -- REval
RETURN[ REval[env~env, ip~ip] ]
END ; -- RussellEval
RussellApplyBody:
PRIVATE RTCodeBody
[ env: RTTuple, arg: RTValue, ip: REF ANY ] RETURNS[RTValue]
=
BEGIN
WITH ip
SELECT
FROM
lambda: ICLambda =>
BEGIN
newEnv: RTTuple;
newName: ATOM;
IF lambda.param =
NIL
THEN ERROR RTError[$badICode];
newName ← lambda.param.name;
IF newName #
NIL
THEN
BEGIN
newEnv ← ConcatTuple[
MkTuple[name~newName, value~NARROW[arg]],
env ]
END
ELSE
BEGIN
newEnv ← ConcatTuple[ arg, env ]
END ;
RETURN[ RussellEval[ newEnv, NARROW[lambda.body] ]]
END ;
ENDCASE =>
ERROR RTError[$badICode] ;
END ; -- RussellApplyBody
Type Constructors
The following procedures build type values. Since types have so little computational significance, it is safe to have most of them return NIL. The only case for which this is not true is ref[t], because ref[] really produces an algebra rather than a type.
MkPrimType:
PRIVATE PROCEDURE []
RETURNS [RTValue]
=
BEGIN
RETURN[ NIL ]
END ; -- MkPrimType
MkPrimSafetype:
PRIVATE PROCEDURE []
RETURNS [RTValue]
=
BEGIN
RETURN[ NIL ]
END ; -- MkPrimSafetype
MkProductType:
PRIVATE PROCEDURE [env: RTTuple, product: ICProduct]
RETURNS [RTValue]
=
BEGIN
RETURN[ NIL ]
END ; -- MkProductType
MkUnionType:
PRIVATE PROCEDURE [env: RTTuple, union: ICUnion]
RETURNS [RTValue]
=
BEGIN
RETURN[ NIL ]
END ; -- MkUnionType
MkFuncType:
PRIVATE PROCEDURE [env: RTTuple, func: ICFunc]
RETURNS [RTValue]
=
BEGIN
RETURN[ NIL ]
END ; -- MkFuncType
MkProcType:
PRIVATE PROCEDURE [env: RTTuple, proc: ICProc]
RETURNS [RTValue]
=
BEGIN
RETURN[ NIL ]
END ; -- MkProcType
genericRefCluster: RTTuple; -- Initialized below.
genericLocType: RTValue ← NIL;
GenericNewBody:
PRIVATE RTCodeBody
[ env: RTTuple, arg: RTValue, ip: REF ANY ] RETURNS[RTValue]
Russell type: func[ [] -> ref[T].loc ]
=
BEGIN
RETURN[ New[] ]
END ; -- GenericNewBody
GenericValOfBody:
PRIVATE RTCodeBody
[ env: RTTuple, arg: RTValue, ip: REF ANY ] RETURNS[RTValue]
Russell type: func[ ref[T].loc -> T ]
=
BEGIN
RETURN[ ValueOf[arg] ]
END ; -- GenericValOfBody
GenericAssignBody:
PRIVATE RTCodeBody
[ env: RTTuple, arg: RTValue, ip: REF ANY ] RETURNS[RTValue]
Russell type: func[ [lhs:ref[T].loc,rhs:T] -> T ]
=
BEGIN
lhs: RTValue ← SelectFromTuple[tuple~arg, name~$lhs];
rhs: RTValue ← SelectFromTuple[tuple~arg, name~$rhs];
RETURN[ Assign[location~lhs, value~rhs] ]
END ; -- GenericAssignBody
GenericAliasBody:
PRIVATE RTCodeBody
[ env: RTTuple, arg: RTValue, ip: REF ANY ] RETURNS[RTValue]
Russell type: func[ [a:ref[T].loc,b:ref[T].loc] -> {t:[]} ]
=
BEGIN
lhs: RTValue ← SelectFromTuple[tuple~arg, name~$lhs];
rhs: RTValue ← SelectFromTuple[tuple~arg, name~$rhs];
RETURN[ IF lhs = rhs THEN MkTuple[name~$t, value~NIL] ELSE NIL ]
END ; -- GenericAliasBody
MkRefType:
PRIVATE PROCEDURE [env: RTTuple, ref: ICRef]
RETURNS [RTValue]
=
BEGIN
RETURN[ genericRefCluster ]
END ; -- MkRefType
Create generic ref cluster (returned by MkRefType above).
genericRefCluster ← MkTuple[name~$loc, value~genericLocType];
genericRefCluster ← PrependProc[tuple~genericRefCluster, name~$alias, body~GenericAliasBody];
genericRefCluster ← PrependProc[tuple~genericRefCluster, name~$new, body~GenericNewBody];
genericRefCluster ← PrependProc[tuple~genericRefCluster, name~$assign, body~GenericAssignBody];
genericRefCluster ← PrependProc[tuple~genericRefCluster, name~$valOf, body~GenericValOfBody];
END .