git @ Cat's Eye Technologies Robin / 5486f34
Convert evaluator from continuation-passing-style to ordinary-style. Chris Pressey 4 years ago
6 changed file(s) with 184 addition(s) and 183 deletion(s). Raw diff Collapse all Expand all
+100
-85
src/Language/Robin/Builtins.hs less more
1818 -- Helper functions
1919 --
2020
21 evalAll env [] acc cc =
22 cc $ List $ reverse acc
23 evalAll env (head:tail) acc cc =
24 eval env head (\value ->
25 evalAll env tail (value:acc) cc)
26
27 -- formals actuals origActuals env continuation
28 evalArgs :: [Expr] -> [Expr] -> [Expr] -> Env -> (Env -> Expr) -> Expr
29 evalArgs [] [] _ _ cc =
30 cc empty
31 evalArgs ((Symbol formal):formals) (actual:actuals) origActuals env cc =
32 eval env actual (\value ->
33 evalArgs formals actuals origActuals env (\nenv ->
34 cc $ insert formal value nenv))
35 evalArgs _ _ origActuals env cc =
21 evalAll env [] acc =
22 List $ reverse acc
23 evalAll env (head:tail) acc =
24 let
25 value = (eval env head)
26 in
27 evalAll env tail (value:acc)
28
29 -- formals actuals origActuals env
30 evalArgs :: [Expr] -> [Expr] -> [Expr] -> Env -> Expr
31 evalArgs [] [] _ _ =
32 empty
33 evalArgs ((Symbol formal):formals) (actual:actuals) origActuals env =
34 let
35 value = eval env actual
36 nenv = evalArgs formals actuals origActuals env
37 in
38 insert formal value nenv
39 evalArgs _ _ origActuals env =
3640 errMsg "illegal-arguments" $ List origActuals
3741
3842
39 evalTwoNumbers :: (Int32 -> Int32 -> (Expr -> Expr) -> Expr) -> Evaluable
40 evalTwoNumbers fn env (List [xexpr, yexpr]) cc =
41 eval env xexpr (\x ->
42 assertNumber env x (\(Number xv) ->
43 eval env yexpr (\y ->
44 assertNumber env y (\(Number yv) ->
45 (fn xv yv cc)))))
46 evalTwoNumbers fn env other cc = errMsg "illegal-arguments" other
43 evalTwoNumbers :: (Int32 -> Int32 -> Expr) -> Evaluable
44 evalTwoNumbers fn env (List [xexpr, yexpr]) =
45 case (eval env xexpr, eval env yexpr) of
46 (Number xv, Number yv) -> fn xv yv
47 (other, Number yv) -> errMsg "expected-number" other
48 (_, other) -> errMsg "expected-number" other
49 evalTwoNumbers fn env other = errMsg "illegal-arguments" other
4750
4851 --
4952 -- `Small`
5457 --
5558
5659 literal :: Evaluable
57 literal env (List (expr:_)) cc =
58 cc expr
59 literal env other cc = errMsg "illegal-arguments" other
60 literal env (List (expr:_)) = expr
61 literal env other = errMsg "illegal-arguments" other
6062
6163 list :: Evaluable
62 list env (List exprs) cc =
63 evalAll env exprs [] cc
64 list env (List exprs) =
65 evalAll env exprs []
6466
6567 env_ :: Evaluable
66 env_ env (List _) cc =
67 cc $ env
68 env_ env (List _) = env
6869
6970 choose :: Evaluable
70 choose env (List [(List [(Symbol "else"), branch])]) cc =
71 eval env branch cc
72 choose env (List ((List [test, branch]):rest)) cc =
73 eval env test (\x ->
74 case x of
75 Boolean True ->
76 eval env branch cc
77 Boolean False ->
78 choose env (List rest) cc)
79 choose env other cc = errMsg "illegal-arguments" other
71 choose env (List [(List [(Symbol "else"), branch])]) =
72 eval env branch
73 choose env (List ((List [test, branch]):rest)) =
74 case eval env test of
75 Boolean True ->
76 eval env branch
77 Boolean False ->
78 choose env (List rest)
79 choose env other = errMsg "illegal-arguments" other
8080
8181 bind :: Evaluable
82 bind env (List [(Symbol name), expr, body]) cc =
83 eval env expr (\value ->
84 eval (insert name value env) body cc)
85 bind env other cc = errMsg "illegal-arguments" other
82 bind env (List [(Symbol name), expr, body]) =
83 let
84 value = eval env expr
85 env' = insert name value env
86 in
87 eval env' body
88 bind env other = errMsg "illegal-arguments" other
8689
8790 let_ :: Evaluable
88 let_ env (List ((List bindings):body:_)) cc =
89 bindAll bindings env (\env' ->
90 eval env' body cc)
91 where
92 bindAll [] env cc =
93 cc env
94 bindAll (List ((Symbol name):sexpr:_):rest) env cc =
95 eval env sexpr (\value ->
96 bindAll rest (insert name value env) cc)
97 bindAll (other:rest) env cc =
98 errMsg "illegal-binding" other
99 let_ env other cc = errMsg "illegal-arguments" other
91 let_ env (List ((List bindings):body:_)) =
92 let
93 env' = bindAll bindings env
94 in
95 eval env' body
96 where
97 bindAll [] env = env
98 bindAll (List ((Symbol name):expr:_):rest) env =
99 let
100 value = eval env expr
101 env' = insert name value env
102 in
103 bindAll rest env'
104 bindAll (other:rest) env =
105 errMsg "illegal-binding" other
106 let_ env other = errMsg "illegal-arguments" other
100107
101108 bindArgs :: Evaluable
102 bindArgs env (List [(List formals), givenArgs, givenEnvExpr, body]) cc =
103 eval env givenArgs (\(List actuals) ->
104 eval env givenEnvExpr (\outerEnvExpr ->
105 evalArgs formals actuals actuals outerEnvExpr (\argEnv ->
106 eval (mergeEnvs argEnv env) body cc)))
107 bindArgs env other cc = errMsg "illegal-arguments" other
109 bindArgs env (List [(List formals), givenArgs, givenEnvExpr, body]) =
110 let
111 List actuals = eval env givenArgs
112 outerEnvExpr = eval env givenEnvExpr
113 argEnv = evalArgs formals actuals actuals outerEnvExpr
114 in
115 eval (mergeEnvs argEnv env) body
116 bindArgs env other = errMsg "illegal-arguments" other
108117
109118 fun :: Evaluable
110 fun closedEnv (List [(List formals), body]) cc =
111 cc $ Operator "<lambda>" fun
112 where
113 fun env (List actuals) cc =
114 evalArgs formals actuals actuals env (\argEnv ->
115 eval (mergeEnvs argEnv closedEnv) body cc)
116 fun env other cc = errMsg "illegal-arguments" other
119 fun closedEnv (List [(List formals), body]) =
120 let
121 fun env (List actuals) =
122 let
123 argEnv = evalArgs formals actuals actuals env
124 env' = mergeEnvs argEnv closedEnv
125 in
126 eval env' body
127 in
128 Operator "<lambda>" fun
129 fun env other = errMsg "illegal-arguments" other
117130
118131 --
119132 -- `Arith`
124137 --
125138
126139 gtP :: Evaluable
127 gtP = evalTwoNumbers (\x y cc -> cc $ Boolean (x > y))
140 gtP = evalTwoNumbers (\x y -> Boolean (x > y))
128141
129142 gteP :: Evaluable
130 gteP = evalTwoNumbers (\x y cc -> cc $ Boolean (x >= y))
143 gteP = evalTwoNumbers (\x y -> Boolean (x >= y))
131144
132145 ltP :: Evaluable
133 ltP = evalTwoNumbers (\x y cc -> cc $ Boolean (x < y))
146 ltP = evalTwoNumbers (\x y -> Boolean (x < y))
134147
135148 lteP :: Evaluable
136 lteP = evalTwoNumbers (\x y cc -> cc $ Boolean (x <= y))
137
138 robinAbs :: Evaluable
139 robinAbs env (List [expr]) cc =
140 eval env expr (\x -> assertNumber env x (\(Number xv) -> cc (Number $ abs xv)))
141 robinAbs env other cc = errMsg "illegal-arguments" other
149 lteP = evalTwoNumbers (\x y -> Boolean (x <= y))
150
151 abs_ :: Evaluable
152 abs_ env (List [expr]) =
153 case eval env expr of
154 Number xv -> Number $ abs xv
155 other -> errMsg "expected-number" other
156 abs_ env other = errMsg "illegal-arguments" other
142157
143158 add :: Evaluable
144 add = evalTwoNumbers (\x y cc -> cc $ Number (x + y))
159 add = evalTwoNumbers (\x y -> Number (x + y))
145160
146161 multiply :: Evaluable
147 multiply = evalTwoNumbers (\x y cc -> cc $ Number (x * y))
162 multiply = evalTwoNumbers (\x y -> Number (x * y))
148163
149164 divide :: Evaluable
150 divide = evalTwoNumbers (\x y cc -> case y of
165 divide = evalTwoNumbers (\x y -> case y of
151166 0 -> errMsg "division-by-zero" $ Number x
152 _ -> cc $ Number (x `div` y))
167 _ -> Number (x `div` y))
153168
154169 remainder :: Evaluable
155 remainder = evalTwoNumbers (\x y cc -> case y of
170 remainder = evalTwoNumbers (\x y -> case y of
156171 0 -> errMsg "division-by-zero" $ Number x
157 _ -> cc $ Number (abs (x `mod` y)))
172 _ -> Number (abs (x `mod` y)))
158173
159174 --
160175 -- Mapping of names to our functions, providing an evaluation environment.
177192 ("lt?", ltP),
178193 ("lte?", lteP),
179194
180 ("abs", robinAbs),
195 ("abs", abs_),
181196 ("add", add),
182197 ("multiply", multiply),
183198 ("divide", divide),
+14
-21
src/Language/Robin/Eval.hs less more
55 --
66 -- This evaluator is written in continuation-passing style.
77 --
8 -- Every evaluation function has this signature:
8 -- The evaluation function has this signature:
99 --
10 -- Env -> Expr -> (Expr -> Expr) -> Expr
10 -- Env -> Expr -> Expr
1111 --
1212 -- (This is actually the `Evaluable` type from `Robin.Expr`.)
1313 --
1515 -- (and modifiable, during `eval`) by the Robin program.
1616 --
1717 -- The second argument is the expression to be evaluated.
18 --
19 -- The third argument is the continuation. Once the expression has been
20 -- evaluated, the continuation will be applied with the result of the
21 -- evaluation.
2218 --
2319
2420 eval :: Evaluable
2824 -- value. Then continue the current continuation with that value.
2925 --
3026
31 eval env sym@(Symbol s) cc =
27 eval env sym@(Symbol s) =
3228 case find s env of
3329 Just value ->
34 cc value
30 value
3531 Nothing ->
3632 errMsg "unbound-identifier" sym
3733
4137 -- operator. We then apply the operator, passing it the tail of the list.
4238 --
4339
44 eval env (List (applierExpr:actuals)) cc =
45 eval env applierExpr (\applier ->
46 case applier of
47 Operator _ fun ->
48 fun env (List actuals) cc
49 other ->
50 errMsg "inapplicable-object" other)
40 eval env (List (applierExpr:actuals)) =
41 case eval env applierExpr of
42 Operator _ op ->
43 op env (List actuals)
44 other ->
45 errMsg "inapplicable-object" other
5146
5247 --
53 -- Everything else just evaluates to itself. Continue the current
54 -- continuation with that value.
48 -- Everything else just evaluates to itself.
5549 --
5650
57 eval env e cc =
58 cc e
51 eval env e = e
5952
6053 --
6154 -- Helper functions
6659
6760 makeMacro :: Expr -> Expr -> Expr -> Evaluable
6861 makeMacro defineTimeEnv formals body =
69 \callTimeEnv actuals cc ->
62 \callTimeEnv actuals ->
7063 let
7164 env = makeMacroEnv callTimeEnv actuals defineTimeEnv formals
7265 in
73 eval env body cc
66 eval env body
7467
7568 makeMacroEnv callTimeEnv actuals defineTimeEnv argList =
7669 let
+2
-2
src/Language/Robin/Expr.hs less more
88 -- (perhaps unsurprisingly?) to be the type of the evaluator function.
99 --
1010
11 type Evaluable = Expr -> Expr -> (Expr -> Expr) -> Expr
12 -- env args continuation result
11 type Evaluable = Expr -> Expr -> Expr
12 -- env args result
1313
1414 --
1515 -- Basic expressions in Robin. These may be evaluated, or they may be
+61
-68
src/Language/Robin/Intrinsics.hs less more
44 import Language.Robin.Eval
55
66
7 head :: Evaluable
8 head env (List [expr]) cc =
9 eval env expr (\x ->
10 assertList env x (\val ->
11 case val of
12 List (a:_) -> cc a
13 other -> errMsg "expected-list" other))
14 head env other cc = errMsg "illegal-arguments" other
7 head_ :: Evaluable
8 head_ env (List [expr]) =
9 case eval env expr of
10 List (a:_) -> a
11 other -> errMsg "expected-list" other
12 head_ env other = errMsg "illegal-arguments" other
1513
16 tail :: Evaluable
17 tail env (List [expr]) cc =
18 eval env expr (\x ->
19 assertList env x (\val ->
20 case val of
21 List (_:b) -> cc (List b)
22 other -> errMsg "expected-list" other))
23 tail env other cc = errMsg "illegal-arguments" other
14 tail_ :: Evaluable
15 tail_ env (List [expr]) =
16 case eval env expr of
17 List (_:b) -> (List b)
18 other -> errMsg "expected-list" other
19 tail_ env other = errMsg "illegal-arguments" other
2420
2521 prepend :: Evaluable
26 prepend env (List [e1, e2]) cc =
27 eval env e1 (\x1 -> eval env e2 (\val ->
28 case val of
29 List x2 -> cc $ List (x1:x2)
30 other -> errMsg "expected-list" other))
31 prepend env other cc = errMsg "illegal-arguments" other
22 prepend env (List [e1, e2]) =
23 case (eval env e1, eval env e2) of
24 (x1, List x2) -> List (x1:x2)
25 (_, other) -> errMsg "expected-list" other
26 prepend env other = errMsg "illegal-arguments" other
3227
3328 equalP :: Evaluable
34 equalP env (List [e1, e2]) cc =
35 eval env e1 (\x1 -> eval env e2 (\x2 -> cc $ Boolean (x1 == x2)))
36 equalP env other cc = errMsg "illegal-arguments" other
29 equalP env (List [e1, e2]) =
30 let (x1, x2) = (eval env e1, eval env e2) in Boolean (x1 == x2)
31 equalP env other = errMsg "illegal-arguments" other
3732
38 predP pred env (List [expr]) cc =
39 eval env expr (\x -> cc $ Boolean $ pred x)
40 predP pred env other cc = errMsg "illegal-arguments" other
33 predP pred env (List [expr]) =
34 Boolean $ pred (eval env expr)
35 predP pred env other = errMsg "illegal-arguments" other
4136
4237 symbolP = predP isSymbol
4338 listP = predP isList
4439 operatorP = predP isOperator
4540 numberP = predP isNumber
4641
47 subtract :: Evaluable
48 subtract env (List [xexpr, yexpr]) cc =
49 eval env xexpr (\x ->
50 assertNumber env x (\(Number xv) ->
51 eval env yexpr (\y ->
52 assertNumber env y (\(Number yv) ->
53 cc (Number (xv - yv))))))
54 subtract env other cc = errMsg "illegal-arguments" other
42 subtract_ :: Evaluable
43 subtract_ env (List [xexpr, yexpr]) =
44 case (eval env xexpr, eval env yexpr) of
45 (Number xv, Number yv) -> Number (xv - yv)
46 (other, Number yv) -> errMsg "expected-number" other
47 (_, other) -> errMsg "expected-number" other
48 subtract_ env other = errMsg "illegal-arguments" other
5549
5650 sign :: Evaluable
57 sign env (List [expr]) cc =
51 sign env (List [expr]) =
5852 let
5953 sgn x = if x == 0 then 0 else if x < 0 then -1 else 1
6054 in
61 eval env expr (\x ->
62 assertNumber env x (\(Number xv) ->
63 cc $ Number $ sgn xv))
64 sign env other cc = errMsg "illegal-arguments" other
55 case eval env expr of
56 Number xv -> Number $ sgn xv
57 other -> errMsg "expected-number" other
58 sign env other = errMsg "illegal-arguments" other
6559
6660 if_ :: Evaluable
67 if_ env (List [test, texpr, fexpr]) cc =
68 eval env test (\x ->
69 assertBoolean env x (\(Boolean b) ->
70 if b then eval env texpr cc else eval env fexpr cc))
71 if_ env other cc = errMsg "illegal-arguments" other
61 if_ env (List [test, texpr, fexpr]) =
62 case eval env test of
63 Boolean b -> if b then eval env texpr else eval env fexpr
64 other -> errMsg "expected-boolean" other
65 if_ env other = errMsg "illegal-arguments" other
7266
7367 eval_ :: Evaluable
74 eval_ env (List [envlist, form]) cc =
75 eval env envlist (\newEnvVal ->
76 eval env form (\body ->
77 eval newEnvVal body cc))
78 eval_ env other cc = errMsg "illegal-arguments" other
68 eval_ env (List [envlist, form]) =
69 let
70 newEnvVal = eval env envlist
71 body = eval env form
72 in
73 eval newEnvVal body
74 eval_ env other = errMsg "illegal-arguments" other
7975
8076 macro :: Evaluable
81 macro env (List [args@(List [(Symbol argsS), (Symbol envS)]), body]) cc =
82 cc $ Operator "<operator>" $ makeMacro env args body
83 macro env other cc = errMsg "illegal-arguments" other
77 macro env (List [args@(List [(Symbol argsS), (Symbol envS)]), body]) =
78 Operator "<operator>" $ makeMacro env args body
79 macro env other = errMsg "illegal-arguments" other
8480
8581 abort :: Evaluable
86 abort env (List [expr]) cc =
87 eval env expr (\v -> cc $ Abort v)
88 abort env other cc = errMsg "illegal-arguments" other
82 abort env (List [expr]) =
83 Abort $ eval env expr
84 abort env other = errMsg "illegal-arguments" other
8985
9086 recover :: Evaluable
91 recover env (List [expr, (Symbol okName), okExpr, (Symbol abortName), abortExpr]) cc =
92 eval env expr (\result ->
93 case result of
94 e@(Abort contents) ->
95 eval (insert abortName contents env) abortExpr cc
96 other ->
97 eval (insert okName other env) okExpr cc)
98 recover env other cc = errMsg "illegal-arguments" other
87 recover env (List [expr, (Symbol okName), okExpr, (Symbol abortName), abortExpr]) =
88 case eval env expr of
89 e@(Abort contents) -> eval (insert abortName contents env) abortExpr
90 other -> eval (insert okName other env) okExpr
91 recover env other = errMsg "illegal-arguments" other
9992
10093 robinIntrinsics :: Env
10194 robinIntrinsics = fromList $ map (\(name,bif) -> (name, Operator name bif))
10295 [
103 ("head", Language.Robin.Intrinsics.head),
104 ("tail", Language.Robin.Intrinsics.tail),
96 ("head", head_),
97 ("tail", tail_),
10598 ("prepend", prepend),
10699 ("list?", listP),
107100 ("symbol?", symbolP),
108101 ("operator?",operatorP),
109102 ("number?", numberP),
110103 ("equal?", equalP),
111 ("subtract", Language.Robin.Intrinsics.subtract),
104 ("subtract", subtract_),
112105 ("sign", sign),
113106 ("macro", macro),
114107 ("eval", eval_),
+1
-1
src/Language/Robin/Reactor.hs less more
2727 applyStop (command:commands) =
2828 (command:applyStop commands)
2929 in
30 case eval env (List [body, event, state]) id of
30 case eval env (List [body, event, state]) of
3131 (List (state':commands)) ->
3232 (reactor{ state=state' }, applyStop commands)
3333 expr ->
+6
-6
src/Language/Robin/TopLevel.hs less more
3030 collect [] result = result
3131
3232 collect ((List [Symbol "display", expr]):rest) world@World{ env=env, results=results } =
33 collect rest world{ results=((eval env expr id):results) }
33 collect rest world{ results=((eval env expr):results) }
3434
3535 collect ((List [Symbol "assert", expr]):rest) world@World{ env=env, results=results } =
36 case eval env expr id of
36 case eval env expr of
3737 Abort expr ->
3838 world{ results=((Abort expr):results) }
3939 Boolean False ->
5252 case find s env of
5353 Just _ ->
5454 let
55 result = eval env expr id
55 result = eval env expr
5656 in
5757 collect rest world{ secondaryDefs=(insert s result secondaryDefs) }
5858 Nothing ->
5959 let
60 result = eval env expr id
60 result = eval env expr
6161 in
6262 collect rest world{ env=(insert s result env) }
6363
6464 collect ((List [Symbol "reactor", facExpr, stateExpr, bodyExpr]):rest) world@World{ env=env, reactors=reactors } =
6565 let
66 state = eval env stateExpr id
67 body = eval env bodyExpr id
66 state = eval env stateExpr
67 body = eval env bodyExpr
6868 newReactor = Reactor.Reactor{ Reactor.rid=(fromIntegral $ length reactors), Reactor.env=env, Reactor.state=state, Reactor.body=body }
6969 in
7070 collect rest world{ reactors=(newReactor:reactors) }