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
[@@@ocaml.text "/*"]
(** Copyright 2021-2026, Kakadu and contributors *)
(** SPDX-License-Identifier: LGPL-3.0-or-later *)
[@@@ocaml.text "/*"]
open Base
open Base.Result.Monad_infix
type error =
| UnknownVariable of string
| DivisionByZero
| TypeMismatch
| StepLimitExceeded
(** Values in our interpreter *)
type value =
| VInt of int
| VClosure of string * string Ast.t * environment
| VBuiltin of string * (value -> (value, error) Result.t)
| VUnit
and environment = (string * value) list
(** Lookup variable in environment *)
let lookup env name =
match List.Assoc.find ~equal:String.equal env name with
| Some v -> Ok v
| None -> Error (UnknownVariable name)
;;
(** Evaluate binary operation *)
let eval_binop op v1 v2 =
match op, v1, v2 with
| Ast.Add, VInt a, VInt b -> Ok (VInt (a + b))
| Ast.Sub, VInt a, VInt b -> Ok (VInt (a - b))
| Ast.Mul, VInt a, VInt b -> Ok (VInt (a * b))
| Ast.Div, VInt _, VInt 0 -> Error DivisionByZero
| Ast.Div, VInt a, VInt b -> Ok (VInt (a / b))
| Ast.Mod, VInt _, VInt 0 -> Error DivisionByZero
| Ast.Mod, VInt a, VInt b -> Ok (VInt (a % b))
| Ast.Eq, VInt a, VInt b -> Ok (VInt (if a = b then 1 else 0))
| Ast.Neq, VInt a, VInt b -> Ok (VInt (if a <> b then 1 else 0))
| Ast.Lt, VInt a, VInt b -> Ok (VInt (if a < b then 1 else 0))
| Ast.Gt, VInt a, VInt b -> Ok (VInt (if a > b then 1 else 0))
| Ast.Leq, VInt a, VInt b -> Ok (VInt (if a <= b then 1 else 0))
| Ast.Geq, VInt a, VInt b -> Ok (VInt (if a >= b then 1 else 0))
| _ -> Error TypeMismatch
;;
(** Main evaluation function with step counter *)
let rec eval steps_remaining env expr =
if steps_remaining <= 0
then Error StepLimitExceeded
else (
let steps = steps_remaining - 1 in
match expr with
| Ast.Int n -> Ok (VInt n)
| Ast.Var name -> lookup env name
| Ast.Abs (param, body) -> Ok (VClosure (param, body, env))
| Ast.BinOp (op, l, r) ->
eval steps env l >>= fun vl -> eval steps env r >>= fun vr -> eval_binop op vl vr
| Ast.If (cond, then_branch, else_branch_opt) ->
eval steps env cond
>>= (function
| VInt 0 ->
(match else_branch_opt with
| Some else_branch -> eval steps env else_branch
| None -> Ok (VInt 0))
| VInt _ -> eval steps env then_branch
| _ -> Error TypeMismatch)
| Ast.Let (is_rec, name, binding, body) ->
if is_rec
then (
match binding with
| Ast.Abs (param, func_body) ->
(* Recursive environment: function references itself *)
let rec new_env = (name, VClosure (param, func_body, new_env)) :: env in
eval steps new_env body
| _ ->
eval steps env binding
>>= fun value ->
let new_env = (name, value) :: env in
eval steps new_env body)
else
eval steps env binding
>>= fun value ->
let new_env = (name, value) :: env in
eval steps new_env body
| Ast.App (f, arg) ->
eval steps env f
>>= (function
| VClosure (param, body, closure_env) ->
eval steps env arg
>>= fun varg ->
let new_env = (param, varg) :: closure_env in
eval steps new_env body
| VBuiltin (_, builtin_fn) -> eval steps env arg >>= builtin_fn
| _ -> Error TypeMismatch))
;;
(** Create initial environment with built-in functions *)
let initial_env () =
let print_builtin =
VBuiltin
( "print"
, fun v ->
(match v with
| VInt n -> Stdio.printf "%d\n%!" n
| VClosure _ -> Stdio.printf "<fun>\n%!"
| VBuiltin (name, _) -> Stdio.printf "<builtin:%s>\n%!" name
| VUnit -> Stdio.printf "()\n%!");
Ok VUnit )
in
let rec fix_apply f =
VBuiltin
( "fix_partial"
, fun x ->
match f with
| VClosure _ | VBuiltin _ ->
let fix_f = fix_apply f in
apply f fix_f >>= fun partial -> apply partial x
| _ -> Error TypeMismatch )
and apply fn arg =
match fn with
| VClosure (param, body, closure_env) ->
let new_env = (param, arg) :: closure_env in
eval 10000 new_env body
| VBuiltin (_, builtin_fn) -> builtin_fn arg
| _ -> Error TypeMismatch
in
let fix_builtin =
VBuiltin
( "fix"
, fun f ->
match f with
| VClosure _ | VBuiltin _ -> Ok (fix_apply f)
| _ -> Error TypeMismatch )
in
[ "print", print_builtin; "fix", fix_builtin ]
;;
(** Public function to evaluate an AST expression *)
let eval_expr ?(max_steps = 10000) ast = eval max_steps (initial_env ()) ast