<> <> <> DIRECTORY Rope USING [ROPE], IO USING [STREAM], ProcessExtras USING [CheckForAbort], RussellICode USING [ICExp, ICPrimConst, ICCharConst, ICStringConst, ICIntConst, ICId, ICBinding, ICMkTuple, ICMkRecTuple, ICConcat, ICSelect, ICApply, ICCond, ICGuardedExp, ICLoop, ICSeq, ICLambda, ICOpen, ICProduct, ICUnion, ICFunc, ICProc, ICRef, ErrMsgProc, ParseRussellExpression], RussellRuntime USING [RTError, RTValue, RTTuple, ConsRTNode, MkTuple, ConcatTuple, SelectFromTuple, QueryTuple, RTCodeBody, RTClosure, MkClosure, ApplyClosure, RTLocation, PrependProc, New, Assign, ValueOf], RussellInterp; RussellEvalImpl: CEDAR PROGRAM IMPORTS ProcessExtras, RussellRuntime, RussellICode EXPORTS RussellInterp = 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 <> <> 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]>> < ref[T].loc ]>> = BEGIN RETURN[ New[] ] END ; -- GenericNewBody GenericValOfBody: PRIVATE RTCodeBody <<[ env: RTTuple, arg: RTValue, ip: REF ANY ] RETURNS[RTValue]>> < T ]>> = BEGIN RETURN[ ValueOf[arg] ] END ; -- GenericValOfBody GenericAssignBody: PRIVATE RTCodeBody <<[ env: RTTuple, arg: RTValue, ip: REF ANY ] RETURNS[RTValue]>> < 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]>> < {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 <> 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 .