% $Id: Reducer.oz,v 1.10 2009/01/11 19:50:34 leavens Exp leavens $ % A Reducer that shows execution of Oz statements in the declarative kernel % AUTHOR: Gary T. Leavens \insert 'Configuration.oz' \insert 'MV.oz' declare fun {ReductionsFor StmtAST} %% ENSURES: Result is a lazy list of configurations %% that result from starting with an initial configuration for StmtAST {Reducer 'start'#{InputToConfig StmtAST}} end fun {MakeReductions StmtAST Env Store} %% ENSURES: Result is a lazy list of configurations %% that result from starting with a configuration for StmtAST %% with the given environment and store {Reducer 'start'#{MakeConfig StmtAST Env Store}} end fun lazy {Reducer RuleName#Config} %% ENSURES: Result is a lazy list of RuleName#Config pairs %% starting with the given one. %% (The original RuleName could be 'start' or something similar.) RuleName#Config | if {IsTerminalConfig Config} then nil else {Reducer {Reduce1 Config}} end end fun {Reduce1 Config} %% REQUIRES: Config is not terminal %% ENSURES: Result is a pair RuleName#NewConfiguration %% for a single reduction step starting at Config case Config of config(skipStmt#_|Rest Store) then 'skip' # config(Rest Store) [] config(seqStmt(StmtList)#Env|Rest Store) then 'sequence' # config({Append {Map StmtList fun {$ Stmt} (Stmt#Env) end} Rest} Store) [] config(localStmt(V Body)#Env|Rest Store) then 'local' # local X#Store2 = {AllocStore Store} in config(Body#{ExtendEnv Env V X}|Rest Store2) end [] config(assignStmt(V1 varIdExp(V2))#Env|Rest Store) then 'var-var binding' # local Store2 = {UnifyLocs Store {ApplyEnv Env V1} {ApplyEnv Env V2}} in config(Rest Store2) end [] config(assignStmt(V Exp)#Env|Rest Store) then 'value-creation' # local Store2 = {UnifyLocVal Store {ApplyEnv Env V} {MV Exp Env}} in config(Rest Store2) end [] config(ifStmt(varIdExp(V) S1 S2)#Env|Rest Store) andthen {Determined Store {ApplyEnv Env V}} then case {Read Store {ApplyEnv Env V}} of bool(true) then 'if-true' # config(S1#Env|Rest Store) [] bool(false) then 'if-false' # config(S2#Env|Rest Store) else 'if-error' # msg("Not a Boolean") end [] config(caseStmt(varIdExp(V) Pattern S1 S2)#Env|Rest Store) andthen {Determined Store {ApplyEnv Env V}} then local NoMatchConfig = 'case-else' # config(S2#Env|Rest Store) Loc = {ApplyEnv Env V} recordPat(Atom FieldList) = Pattern Pairs = {FieldListToPairs FieldList} PatternAsRecord = {List.toRecord Atom Pairs} PatternVars = {Map Pairs fun {$ _#varIdExp(V)} V end} in case {Read Store Loc} of record(R) then local FieldNames = {Arity PatternAsRecord} in % (sorts for us :-) if {Label R} == Atom andthen {Arity R} == FieldNames then local Locs = {Record.toList R} in 'case-match' # config(S1#{ExtendEnvList Env PatternVars Locs}|Rest Store) end else NoMatchConfig end end else NoMatchConfig end end [] config(applyStmt(varIdExp(X) ArgExpList)#Env|Rest Store) andthen {All ArgExpList IsVarIdExp} andthen {Determined Store {ApplyEnv Env X}} then local Loc = {ApplyEnv Env X} ActualLocs = {Map ArgExpList fun {$ varIdExp(Y)} {ApplyEnv Env Y} end} in case {Read Store Loc} of closure(Formals Body ProcEnv) then if {Length Formals} \= {Length ArgExpList} then 'application-error' # msg("Application Error") else 'application' # config(Body#{ExtendEnvList ProcEnv Formals ActualLocs}|Rest Store) end [] primitive(OzPrim) then local Store2 = {ApplyPrimitive OzPrim ActualLocs Store} in 'apply-primitive' # config(Rest Store2) end end end else raise noRuleFor(Config) end end end fun {IsVarIdExp E} %% ENSURES: Result is true if E is a variable Id Expression case E of varIdExp(_) then true else false end end fun {FieldListToPairs FieldList} %% ENSURES: Result is a list of pairs representing the fields in FieldList PosFields = {Filter FieldList IsPosField} NamedPairs = {Map {Filter FieldList IsNamedField} fun {$ colonFld(Name Val)} Name#Val end} PosPairs#_ = {FoldL PosFields fun {$ posFld(Val) L#I} (I+1#Val|L)#(I+1) end nil#0} in {Append PosPairs NamedPairs} end fun {IsPosField Field} %% ENSURES: Result is true if Field is a positional field case Field of posFld(...) then true else false end end fun {IsNamedField Field} %% ENSURES: Result is true if Field is a named field case Field of colonFld(...) then true else false end end % Primitives % Representation: % ::= numberPlus fun {ApplyPrimitive OzPrim Locs Store} %% ENSURES: Result is the store that results from applying the %% primitive to the locations given. %% Note that function primitives are really procedures that %% assign to their last argument's location case OzPrim of numberPlus andthen {Length Locs} == 3 then local Loc1|Loc2|Loc3|nil = Locs in if {Determined Store Loc1} andthen {Determined Store Loc2} then local num(Arg1Val) = {Read Store Loc1} num(Arg2Val) = {Read Store Loc2} in {UnifyLocVal Store Loc3 num(Arg1Val + Arg2Val)} end else raise needArguments(numberPlus) end end end [] showInfo andthen {Length Locs} == 1 then local Loc1|nil = Locs in if {Determined Store Loc1} then {System.showInfo {StringForValue {Read Store Loc1}}} else % undetermined {System.showInfo "_"} end Store end else raise badPrimitiveApplication(OzPrim) end end end fun {StdEnvStore} %% ENSURES: Result is a standard environment containing the primtives EnvInit = {InitEnv} StoreInit = {EmptyStore} LocNumberPlus#Store0 = {AllocStore StoreInit} Store0_2 = {UnifyLocVal Store0 LocNumberPlus primitive(numberPlus)} LocShowInfo#Store1 = {AllocStore Store0_2} Store1_2 = {UnifyLocVal Store1 LocShowInfo primitive(showInfo)} StdEnv = {ExtendEnvList EnvInit ["Number.+" "System.showInfo"] [LocNumberPlus LocShowInfo]} in StdEnv#Store1_2 end fun {MakeStdReductions StmtAST} %% ENSURES: Result is a lazy list of configurations %% that result from starting with a configuration for StmtAST %% with a standard environment and store StdEnv#StdStore = {StdEnvStore} in {Reducer 'start'#{MakeConfig StmtAST StdEnv StdStore}} end