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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
(** Copyright 2026, Dmitrii Kuznetsov *)
(** SPDX-License-Identifier: LGPL-3.0-or-later *)
open Format
open Ast
let pp_list : 'a. (formatter -> 'a -> unit) -> string -> formatter -> 'a list -> unit =
fun pp sep fmt lst ->
let rec aux fmt = function
| [] -> ()
| [ x ] -> pp fmt x
| x :: xs -> fprintf fmt "%a%s%a" pp x sep aux xs
in
aux fmt lst
;;
let pp_option : 'a. (formatter -> 'a -> unit) -> formatter -> 'a option -> unit =
fun pp fmt -> function
| None -> ()
| Some x -> pp fmt x
;;
let pp_ident fmt (Id s) = fprintf fmt "%s" s
let pp_base_type fmt = function
| TypeInt -> fprintf fmt "int"
| TypeChar -> fprintf fmt "char"
| TypeBool -> fprintf fmt "bool"
| TypeString -> fprintf fmt "string"
;;
let pp_type fmt = function
| TypeBase bt -> pp_base_type fmt bt
| TypeVoid -> fprintf fmt "void"
;;
let pp_var_type fmt (TypeVar t) = pp_type fmt t
let pp_modifier fmt = function
| MPublic -> fprintf fmt "public"
| MStatic -> fprintf fmt "static"
| MAsync -> fprintf fmt "async"
;;
let pp_var_decl fmt (Var (vt, id)) = fprintf fmt "%a %a" pp_var_type vt pp_ident id
let pp_bin_op fmt = function
| OpAdd -> fprintf fmt "+"
| OpSub -> fprintf fmt "-"
| OpMul -> fprintf fmt "*"
| OpDiv -> fprintf fmt "/"
| OpMod -> fprintf fmt "%%"
| OpEqual -> fprintf fmt "=="
| OpNonEqual -> fprintf fmt "!="
| OpLess -> fprintf fmt "<"
| OpMore -> fprintf fmt ">"
| OpLessEqual -> fprintf fmt "<="
| OpMoreEqual -> fprintf fmt ">="
| OpAnd -> fprintf fmt "&&"
| OpOr -> fprintf fmt "||"
| OpAssign -> fprintf fmt "="
;;
let pp_un_op fmt = function
| OpNot -> fprintf fmt "!"
| OpNeg -> fprintf fmt "-"
;;
let pp_val_type fmt = function
| ValInt n -> fprintf fmt "%d" n
| ValChar c -> fprintf fmt "'%c'" c
| ValNull -> fprintf fmt "null"
| ValBool b -> fprintf fmt "%b" b
| ValString s -> fprintf fmt {|%S|} s
;;
let rec pp_expr fmt = function
| EValue v -> pp_val_type fmt v
| EBinOp (OpAssign, EId id, e) -> fprintf fmt "%a = %a" pp_ident id pp_expr e
| EBinOp (op, e1, e2) -> fprintf fmt "(%a %a %a)" pp_expr e1 pp_bin_op op pp_expr e2
| EUnOp (op, e) ->
(match e with
| EValue _ | EId _ -> fprintf fmt "%a%a" pp_un_op op pp_expr e
| _ -> fprintf fmt "(%a%a)" pp_un_op op pp_expr e)
| EId id -> pp_ident fmt id
| EArrayAccess (e1, e2) -> fprintf fmt "%a[%a]" pp_expr e1 pp_expr e2
| EFuncCall (e, Args args) -> fprintf fmt "%a(%a)" pp_expr e (pp_list pp_expr ", ") args
| EAwait e -> fprintf fmt "await %a" pp_expr e
;;
let rec pp_stmt fmt = function
| SFor (init, cond, incr, body) ->
let pp_init fmt = function
| None -> fprintf fmt ""
| Some stmt ->
(match stmt with
| SDecl (vd, e) ->
fprintf
fmt
"%a%a"
pp_var_decl
vd
(fun fmt -> function
| None -> ()
| Some expr -> fprintf fmt " = %a" pp_expr expr)
e
| SExpr e -> pp_expr fmt e
| _ -> pp_stmt fmt stmt)
in
fprintf
fmt
"@[<v 4>for (%a%a%a) {@ %a@]@ }"
pp_init
init
(fun fmt -> function
| None -> fprintf fmt ";"
| Some e -> fprintf fmt "; %a" pp_expr e)
cond
(fun fmt -> function
| None -> fprintf fmt ";"
| Some e -> fprintf fmt "; %a" pp_expr e)
incr
pp_stmt
body
| SIf (cond, then_branch, else_branch) ->
(match else_branch with
| None -> fprintf fmt "@[<v 4>if (%a) {@ %a@]@ }" pp_expr cond pp_stmt then_branch
| Some else_stmt ->
fprintf
fmt
"@[<v 4>if (%a) {@ %a@]@ }@ @[<v 4>else {@ %a@]@ }@ "
pp_expr
cond
pp_stmt
then_branch
pp_stmt
else_stmt)
| SWhile (cond, body) ->
fprintf fmt "@[<v 4>while (%a) {@ %a@]@ }" pp_expr cond pp_stmt body
| SReturn e ->
fprintf
fmt
"return%a;"
(fun fmt -> function
| None -> ()
| Some expr -> fprintf fmt " %a" pp_expr expr)
e
| SBlock stmts -> pp_sblock fmt stmts
| SBreak -> fprintf fmt "break;"
| SContinue -> fprintf fmt "continue;"
| SExpr e -> fprintf fmt "%a;" pp_expr e
| SDecl (vd, e) ->
fprintf
fmt
"%a%a;"
pp_var_decl
vd
(fun fmt -> function
| None -> ()
| Some expr -> fprintf fmt " = %a" pp_expr expr)
e
and pp_sblock fmt = function
| [] -> fprintf fmt ""
| stmts -> fprintf fmt "@[<v>%a@]" (pp_list pp_stmt " ") stmts
;;
let pp_field fmt = function
| VarField (mods, t, id, e) ->
fprintf
fmt
"%a %a %a%a;"
(pp_list pp_modifier " ")
mods
pp_var_type
t
pp_ident
id
(fun fmt -> function
| None -> ()
| Some expr ->
let init_expr =
match expr with
| EBinOp (OpAssign, _, e) -> e
| _ -> expr
in
fprintf fmt " = %a" pp_expr init_expr)
e
| Method (mods, t, id, Params params, body) ->
fprintf
fmt
"@[<v 2>%a %a %a(%a)@ @[<v 4>{@ %a@]@ @[<v 2>}@]@ "
(pp_list pp_modifier " ")
mods
pp_type
t
pp_ident
id
(pp_list pp_var_decl ", ")
params
pp_stmt
body
;;
let pp_c_sharp_class fmt (Class (mods, id, fields)) =
fprintf
fmt
"@[<v>%a class %a@ @[<v 4>{@ %a@]@ @[<v>}@]"
(pp_list pp_modifier " ")
mods
pp_ident
id
(pp_list pp_field " ")
fields
;;
let pp_prog fmt (Program cls) = pp_c_sharp_class fmt cls