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
[@@@ocaml.text "/*"]
(** Copyright 2026, Dmitry Arzhaev *)
(** SPDX-License-Identifier: LGPL-3.0-or-later *)
[@@@ocaml.text "/*"]
type const =
| IConst of int
| FConst of float
| BConst of bool
type binop =
| Add
| Sub
| Mul
| Div
| Eq
| Neq
| Leq
| Geq
| Lt
| Gt
| And
| Or
| AddF
| SubF
| MulF
| DivF
type reclabel =
| Recursive
| Nonrecursive
type expr =
| EConst of const
| EVar of string
| EBinOp of binop * expr * expr
| ELet of reclabel * letbind * expr
| EIf of expr * expr * expr
| EFun of expr * expr
| EApp of expr * expr
and letbind = Bind of expr * expr
type toplevel =
| TopLet of reclabel * letbind
| TopExpr of expr
let pp_const fmt = function
| IConst i -> Format.fprintf fmt "%d" i
| FConst f -> Format.fprintf fmt "%g" f
| BConst b -> Format.fprintf fmt "%b" b
;;
(* pp_binop *)
let pp_binop fmt = function
| Add -> Format.fprintf fmt "+"
| Sub -> Format.fprintf fmt "-"
| Mul -> Format.fprintf fmt "*"
| Div -> Format.fprintf fmt "/"
| AddF -> Format.fprintf fmt "+."
| SubF -> Format.fprintf fmt "-."
| MulF -> Format.fprintf fmt "*."
| DivF -> Format.fprintf fmt "/."
| Eq -> Format.fprintf fmt "="
| Neq -> Format.fprintf fmt "<>"
| Leq -> Format.fprintf fmt "<="
| Geq -> Format.fprintf fmt ">="
| Lt -> Format.fprintf fmt "<"
| Gt -> Format.fprintf fmt ">"
| And -> Format.fprintf fmt "&&"
| Or -> Format.fprintf fmt "||"
;;
let pp_reclabel fmt = function
| Recursive -> Format.fprintf fmt "rec "
| Nonrecursive -> ()
;;
let rec pp_expr fmt = function
| EConst c -> pp_const fmt c
| EVar v -> Format.fprintf fmt "%s" v
| EBinOp (op, l, r) ->
Format.fprintf fmt "@[(%a %a %a)@]" pp_expr l pp_binop op pp_expr r
| EIf (c, t, e) ->
Format.fprintf fmt "@[if %a then@ %a@ else@ %a@]" pp_expr c pp_expr t pp_expr e
| EFun (EVar x, body) -> Format.fprintf fmt "@[fun %s -> %a@]" x pp_expr body
| EApp (f, arg) -> Format.fprintf fmt "@[(%a %a)@]" pp_expr f pp_expr arg
| ELet (label, Bind (EVar x, e1), e2) ->
Format.fprintf
fmt
"@[let %a%s = %a in@ %a@]"
pp_reclabel
label
x
pp_expr
e1
pp_expr
e2
| _ -> Format.fprintf fmt "<unsupported>"
;;
let pp_letbind fmt = function
| Bind (EVar x, e) -> Format.fprintf fmt "%s = %a" x pp_expr e
| _ -> Format.fprintf fmt "<unsupported let binding>"
;;
let pp_toplevel fmt = function
| TopExpr e -> Format.fprintf fmt "%a" pp_expr e
| TopLet (label, bind) ->
Format.fprintf fmt "let %a%a" pp_reclabel label pp_letbind bind
;;