1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
[@@@ocaml.text "/*"]
(** Copyright 2021-2026, Kakadu and Yackovlev Nickolay *)
(** SPDX-License-Identifier: LGPL-3.0-or-later *)
[@@@ocaml.text "/*"]
open Ast
type prim =
| Print_int
| Fix
type value =
| VInt of int
| VClosure of closure
| VPrim of prim
| VUnit
and closure =
{ param : name
; body : expr
; env : env
}
and env = (name * value) list
type error =
| Unknown_variable of name
| Not_a_function of value
| Div_by_zero
| Type_error of string
| Out_of_fuel
type 'a eval_result = ('a, error) result
let ok x = Ok x
let error e = Error e
let ( let* ) (m : 'a eval_result) (f : 'a -> 'b eval_result) : 'b eval_result =
match m with
| Ok v -> f v
| Error e -> Error e
;;
type fuel = int
let tick (fuel : fuel) : (unit * fuel, error) result =
if fuel <= 0 then error Out_of_fuel else ok ((), fuel - 1)
;;
let lookup (env : env) (x : name) : value option = List.assoc_opt x env
let string_of_value = function
| VInt n -> string_of_int n
| VUnit -> "()"
| VClosure _ -> "<fun>"
| VPrim Print_int -> "<prim print_int>"
| VPrim Fix -> "<prim fix>"
;;
let string_of_error : error -> string = function
| Unknown_variable x -> "Unknown variable: " ^ x
| Not_a_function v -> "Not a function: " ^ string_of_value v
| Div_by_zero -> "Division by zero"
| Type_error msg -> "Type error: " ^ msg
| Out_of_fuel -> "Out of fuel"
;;
let rec apply (fuel : fuel) (f : value) (arg : value) : (value * fuel, error) result =
match f with
| VClosure { param; body; env } ->
let env' = (param, arg) :: env in
eval env' fuel body
| VPrim Print_int ->
(match arg with
| VInt n ->
print_endline (string_of_int n);
ok (VUnit, fuel)
| v -> error (Type_error ("print_int expects int, got " ^ string_of_value v)))
| VPrim Fix ->
(match arg with
| VClosure { param = self; body; env } ->
(match body with
| Abs (arg, inner_body) ->
let rec rec_closure =
VClosure { param = arg; body = inner_body; env = (self, rec_closure) :: env }
in
ok (rec_closure, fuel)
| _ -> error (Type_error "fix expects a function that returns a function"))
| v -> error (Type_error ("fix expects a function, got " ^ string_of_value v)))
| v -> error (Not_a_function v)
and eval (env : env) (fuel : fuel) (e : expr) : (value * fuel, error) result =
let* (), fuel = tick fuel in
match e with
| Var x ->
(match lookup env x with
| Some v -> ok (v, fuel)
| None -> error (Unknown_variable x))
| Int n -> ok (VInt n, fuel)
| Abs (x, body) -> ok (VClosure { param = x; body; env }, fuel)
| App (e1, e2) ->
let* f, fuel1 = eval env fuel e1 in
let* arg, fuel2 = eval env fuel1 e2 in
apply fuel2 f arg
| Let (x, e1, e2) ->
let* v1, fuel1 = eval env fuel e1 in
let env' = (x, v1) :: env in
eval env' fuel1 e2
| Let_rec (f, rhs, body) ->
(match rhs with
| Abs (x, fun_body) ->
let rec closure = VClosure { param = x; body = fun_body; env = env' }
and env' = (f, closure) :: env in
eval env' fuel body
| _ -> error (Type_error "let rec expects a function on the right-hand side"))
| If (cond, e_then, e_else) ->
let* v_cond, fuel1 = eval env fuel cond in
(match v_cond with
| VInt n -> if n <> 0 then eval env fuel1 e_then else eval env fuel1 e_else
| _ -> error (Type_error "if condition must be an int"))
| Unop (op, e1) ->
let* v1, fuel1 = eval env fuel e1 in
(match v1 with
| VInt n ->
let res =
match op with
| Neg -> -n
in
ok (VInt res, fuel1)
| _ -> error (Type_error "integer operand expected in unary operation"))
| Binop (op, e1, e2) ->
let* v1, fuel1 = eval env fuel e1 in
let* v2, fuel2 = eval env fuel1 e2 in
(match v1, v2 with
| VInt n1, VInt n2 ->
let* n =
match op with
| Add -> ok (n1 + n2)
| Sub -> ok (n1 - n2)
| Mul -> ok (n1 * n2)
| Div -> if n2 = 0 then error Div_by_zero else ok (n1 / n2)
in
ok (VInt n, fuel2)
| _ -> error (Type_error "integer operands expected in arithmetic"))
| Cmp (op, e1, e2) ->
let* v1, fuel1 = eval env fuel e1 in
let* v2, fuel2 = eval env fuel1 e2 in
(match v1, v2 with
| VInt n1, VInt n2 ->
let b =
match op with
| Eq -> n1 = n2
| Neq -> n1 <> n2
| Lt -> n1 < n2
| Le -> n1 <= n2
| Gt -> n1 > n2
| Ge -> n1 >= n2
in
ok (VInt (if b then 1 else 0), fuel2)
| _ -> error (Type_error "comparison expects integer operands"))
;;
let initial_env : env = [ "print_int", VPrim Print_int; "fix", VPrim Fix ]