Source file printer.ml
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
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
module Make (Node : Clang__ast.NodeS) = struct
module Ast = Clang__ast.Custom (Node)
let string_of_builtin_type (ty : Clang__ast.builtin_type) =
match ty with
| Void -> "void"
| Bool -> "bool"
| Char_S
| SChar -> "char"
| UChar -> "unsigned char"
| Float -> "float"
| Int -> "int"
| UInt -> "unsigned int"
| Long -> "long"
| ULong -> "unsigned long"
| LongLong -> "long long"
| Short -> "short"
| UShort -> "unsigned short"
| Double -> "double"
| _ ->
Printf.sprintf "<unknown builtin type:%s>"
(Clang__bindings.get_type_kind_spelling ty)
let maybe_parentheses in_prec out_prec fmt k =
if in_prec >= out_prec then
Format.fprintf fmt "(@[%t@])" k
else
k fmt
let pp_print_option pp_print_value fmt opt =
match opt with
| None -> ()
| Some value -> pp_print_value fmt value
let c_escape_char fmt c =
match c with
| '"' | '\'' | '\\' -> Format.fprintf fmt "\\%c" c
| '\x07' -> Format.pp_print_string fmt "\\a"
| '\x08' -> Format.pp_print_string fmt "\\b"
| '\x09' -> Format.pp_print_string fmt "\\t"
| '\x0A' -> Format.pp_print_string fmt "\\n"
| '\x0B' -> Format.pp_print_string fmt "\\v"
| '\x0C' -> Format.pp_print_string fmt "\\f"
| '\x0D' -> Format.pp_print_string fmt "\\r"
| '\x00' .. '\x20' -> Format.fprintf fmt "\\x%02X" (int_of_char c)
| _ -> Format.pp_print_char fmt c
type associativity =
| Left_to_right
| Right_to_left
type unary_position =
| Prefix
| Postfix
let prec_of_unary_operator (kind : Clang__ast.unary_operator_kind) =
match kind with
| PostInc | PostDec -> 1, Postfix
| PreInc | PreDec -> 1, Prefix
| AddrOf
| Deref
| Plus | Minus
| Not | LNot -> 2, Prefix
| _ -> invalid_arg "prec_of_unary_operator"
let prec_of_binary_operator (kind : Clang__ast.binary_operator_kind) =
match kind with
| Mul | Div | Rem -> 3, Left_to_right
| Add | Sub -> 4, Left_to_right
| Shl | Shr -> 5, Left_to_right
| LT | GT | LE | GE -> 6, Left_to_right
| EQ | NE -> 7, Left_to_right
| And -> 8, Left_to_right
| Xor -> 9, Left_to_right
| Or -> 10, Left_to_right
| LAnd -> 11, Left_to_right
| LOr -> 12, Left_to_right
| Assign
| MulAssign
| DivAssign
| RemAssign
| AddAssign
| SubAssign
| ShlAssign
| ShrAssign
| AndAssign
| XorAssign
| OrAssign -> 14, Right_to_left
| Comma -> 15, Left_to_right
| _ -> invalid_arg "prec_of_binary_operator"
let pp_comma fmt () =
Format.fprintf fmt ",@ "
let pp_typedef pp_sub fmt name =
Format.fprintf fmt "@[typedef@ %t@ %s@]" pp_sub name
let rec decl fmt (d : Ast.decl) =
match Node.force d.desc with
| Function { linkage; function_type; name; body; _ } ->
Format.fprintf fmt "@[<v>%a%a%a@]"
pp_linkage linkage
pp_function_type (function_type, name)
pp_function_body body
| Var var_decl ->
Format.fprintf fmt "@[%a@]" pp_var_decl var_decl
| EnumDecl { name; constants; _ } ->
let pp_constant fmt (constant : Ast.enum_constant) =
let desc = Node.force constant.desc in
Format.pp_print_string fmt desc.constant_name;
desc.constant_init |> Option.iter (fun init ->
Format.fprintf fmt "@ =@ %a" expr init) in
Format.fprintf fmt "@[<v>@[enum@ %s@ {@]@,%a}@]" name
(Format.pp_print_list ~pp_sep:pp_comma pp_constant) constants
| RecordDecl { keyword; name; fields; _ } ->
Format.fprintf fmt "@[<v>@[%s@ %s@ {@]@,%a}@]"
(Clang__bindings.ext_elaborated_type_get_keyword_spelling keyword)
name
decls
fields
| Field { name; qual_type = ty; bitwidth; _ } ->
Format.fprintf fmt "@[%a%t@]"
(typed_value (fun fmt -> Format.pp_print_string fmt name)) ty
(fun fmt ->
match bitwidth with
| None -> ()
| Some bitwidth -> Format.fprintf fmt "@ :@ %a" expr bitwidth)
| AccessSpecifier specifier ->
Format.fprintf fmt "%s:" (Clang__utils.string_of_cxx_access_specifier specifier)
| Constructor { class_name; parameters; initializer_list; body; explicit; defaulted; deleted; _ } ->
Format.fprintf fmt "%t%s(%a)%t%t%a"
(fun fmt ->
if explicit then Format.fprintf fmt "explicit@ ")
class_name
pp_parameters parameters
(fun fmt ->
match initializer_list with
| [] -> ()
| _ ->
Format.fprintf fmt "@ :@ ";
Format.pp_print_list ~pp_sep:pp_comma
(fun fmt ({ kind; init } : Ast.constructor_initializer) ->
let name fmt =
match kind with
| Base { qual_type; _ } | Delegating qual_type ->
begin
match Node.force qual_type.desc with
| Record name -> pp_ident_ref fmt name
| _ -> assert false
end
| Member { field; _ } ->
Format.pp_print_string fmt (Node.force field.desc) in
Format.fprintf fmt "%t(%a)" name expr init)
fmt initializer_list)
(fun fmt ->
if defaulted then
Format.fprintf fmt "@ =@ default";
if deleted then
Format.fprintf fmt "@ =@ delete")
pp_function_body body
| Directive (Include { program_context; filename }) ->
let pp_arg fmt =
if program_context then
Format.fprintf fmt "\"%s\"" filename
else
Format.fprintf fmt "<%s>" filename in
Format.fprintf fmt "@\n#include %t@\n" pp_arg
| Directive (Ifdef var) ->
Format.fprintf fmt "@\n#ifdef %s@\n" var
| Directive (Ifndef var) ->
Format.fprintf fmt "@\n#ifndef %s@\n" var
| Directive Endif ->
Format.fprintf fmt "@\n#endif@\n"
| LinkageSpec { language; decls = list } ->
Format.fprintf fmt "@[extern@ \"%s\"@ {@ @[%a@]@ }@]"
(Clang__utils.extern_of_language language)
decls list
| TypedefDecl { name; underlying_type } ->
pp_typedef (fun fmt -> pp_qual_type fmt underlying_type) fmt name
| _ ->
Format.fprintf fmt {|@[\<not implemented decl: %a>@]|}
(Refl.pp [%refl: Ast.decl] []) d
and pp_var_decl fmt (var_decl : Ast.var_decl_desc) =
match var_decl with { linkage; var_type = ty; var_name; var_init; _ } ->
Format.fprintf fmt "@[%a%a%a@]"
pp_linkage linkage
(typed_value (fun fmt -> Format.pp_print_string fmt var_name)) ty
pp_variable_init var_init
and pp_variable_init fmt init =
match init with
| None -> ()
| Some value ->
Format.fprintf fmt "@ =@ %a" expr value
and expr fmt e =
expr_prec 15 fmt e
and expr_prec prec fmt (e : Ast.expr) =
match Node.force e.desc with
| IntegerLiteral i ->
Clang__ast_utils.pp_print_integer_literal fmt i
| FloatingLiteral f ->
Clang__ast_utils.pp_print_floating_literal fmt f
| CharacterLiteral { kind; value } ->
begin
match kind with
| Ascii -> Format.fprintf fmt "'%a'" c_escape_char (char_of_int value)
| _ -> failwith "Not implemented character kind"
end
| StringLiteral { bytes; _ } ->
Format.pp_print_string fmt "\"";
String.iter (c_escape_char fmt) bytes;
Format.pp_print_string fmt "\""
| BoolLiteral b ->
Format.pp_print_bool fmt b
| ArraySubscript { base; index } ->
maybe_parentheses 1 prec fmt (fun fmt ->
Format.fprintf fmt "@[%a[@[%a@]]@]" (expr_prec 1) base (expr_prec 15)
index)
| Call { callee; args } ->
begin match Node.force callee.desc, args with
| DeclRef { name = OperatorName kind; _ }, [lhs; rhs] ->
let kind = Clang__utils.binary_of_overloaded_operator_kind kind in
let desc : Ast.expr_desc = BinaryOperator { lhs; kind; rhs } in
expr_prec prec fmt { e with desc = Node.from_val desc}
| _ ->
maybe_parentheses 1 prec fmt (fun fmt ->
Format.fprintf fmt "@[%a(@[%a@])@]" (expr_prec 1) callee
(Format.pp_print_list ~pp_sep:pp_comma
(expr_prec 15)) args)
end
| UnaryOperator { kind; operand } ->
let op_prec, position = prec_of_unary_operator kind in
begin match position with
| Prefix ->
maybe_parentheses op_prec prec fmt (fun fmt ->
Format.fprintf fmt "@[%s@ %a@]"
(Clang__bindings.ext_unary_operator_get_opcode_spelling kind)
(expr_prec op_prec) operand)
| Postfix ->
maybe_parentheses op_prec prec fmt (fun fmt ->
Format.fprintf fmt "@[%a@ %s@]" (expr_prec op_prec)
operand (Clang__bindings.ext_unary_operator_get_opcode_spelling kind))
end
| BinaryOperator { lhs; kind; rhs } ->
let op_prec, associativity = prec_of_binary_operator kind in
let left_prec, right_prec =
match associativity with
| Left_to_right -> op_prec - 1, op_prec
| Right_to_left -> op_prec, op_prec - 1 in
maybe_parentheses op_prec prec fmt (fun fmt ->
Format.fprintf fmt "@[%a@ %s@ %a@]" (expr_prec left_prec) lhs
(Clang__bindings.ext_binary_operator_get_opcode_spelling kind)
(expr_prec right_prec) rhs)
| DeclRef ident_ref ->
pp_ident_ref fmt ident_ref
| Member { base = None; field = FieldName field; _ } ->
pp_ident_ref fmt (Node.force field.desc)
| Member { base = Some base; arrow; field } ->
let arrow_str =
if arrow then "->"
else "." in
let pp_field fmt (field : Ast.field) =
match field with
| FieldName name -> pp_ident_ref fmt (Node.force name.desc)
| _ -> invalid_arg "print_field" in
Format.fprintf fmt "@[%a%s%a@]" expr base arrow_str
pp_field field
| Cast { kind = CStyle; qual_type = ty; operand } ->
maybe_parentheses 2 prec fmt (fun fmt ->
Format.fprintf fmt "@[(%a)@ %a@]" pp_qual_type ty (expr_prec 4) operand)
| New { qual_type = ty; init; _ } ->
let format_init fmt (init : Ast.expr option) =
match init with
| None -> ()
| Some init ->
match Node.force init.desc with
| Construct { args; _ } ->
Format.fprintf fmt "@[(%a)@]"
(Format.pp_print_list ~pp_sep:pp_comma expr) args
| _ ->
failwith
(Format.asprintf "Unexpected constructor argument %a"
(Refl.pp [%refl: Ast.expr] []) e) in
Format.fprintf fmt "new@ %a%a" pp_qual_type ty format_init init
| Delete { argument; _ } ->
Format.fprintf fmt "delete@ %a" expr argument
| ConditionalOperator { cond; then_branch; else_branch } ->
begin match then_branch with
| Some then_branch ->
Format.fprintf fmt "%a ? %a : %a" expr cond expr then_branch expr
else_branch
| None ->
Format.fprintf fmt "%a ?: %a" expr cond expr else_branch
end
| _ ->
Format.fprintf fmt "<not implemented expr: %a>"
(Refl.pp [%refl: Ast.expr] []) e
and pp_condition_variable fmt
((condition_variable : Ast.var_decl option), cond) =
match condition_variable with
| Some condition_variable ->
pp_var_decl fmt (Node.force condition_variable.desc)
| None -> expr fmt cond
and stmt fmt (s : Ast.stmt) =
match Node.force s.desc with
| Null -> Format.pp_print_string fmt ";"
| Break -> Format.pp_print_string fmt "break;"
| Case { lhs; rhs; body } ->
let pp_rhs fmt =
match rhs with
| None -> ()
| Some rhs -> Format.fprintf fmt " .. %a" expr rhs in
Format.fprintf fmt "@[case@ %a%t:@]@ %a" expr lhs pp_rhs stmt body
| Default body ->
Format.fprintf fmt "default:@ %a" stmt body
| Switch { condition_variable; cond; body; _ } ->
Format.fprintf fmt "@[switch@ (@[%a@])@ %a@]"
pp_condition_variable (condition_variable, cond) stmt body
| Compound list ->
Format.fprintf fmt "@[{@[<v>%a@]}@]" (Format.pp_print_list stmt) list
| If { condition_variable; cond; then_branch; else_branch; _ } ->
Format.fprintf fmt "@[if@ (@[%a@])@ %a%a@]"
pp_condition_variable (condition_variable, cond) stmt then_branch
pp_else_branch else_branch
| While { cond; body; _ } ->
Format.fprintf fmt "@[while@ (@[%a@])@ %a@]"
expr cond stmt body
| For { init; condition_variable; cond; inc; body } ->
Format.fprintf fmt "@[for@ (@[%t@];@ @[%t@];@ @[%t@])@ %a@]"
(fun fmt -> init |> Option.iter @@ stmt_without_semicolon fmt)
(fun fmt -> cond |> Option.iter @@ fun cond ->
pp_condition_variable fmt (condition_variable, cond))
(fun fmt -> inc |> Option.iter @@ stmt_without_semicolon fmt)
stmt body
| ForRange { var = { desc; _}; range; body } ->
let { var_name; var_type; _ } : Ast.var_decl_desc = Node.force desc in
Format.fprintf fmt "@[for@ (@[%a@ :@ %a@])@ %a@]"
(typed_value (fun fmt -> Format.pp_print_string fmt var_name))
var_type expr range stmt body
| Return None ->
Format.fprintf fmt "@[return;@]"
| Return (Some value) ->
Format.fprintf fmt "@[return@ %a;@]" expr value
| Decl d ->
decls fmt d
| Expr e ->
Format.fprintf fmt "@[%a;@]" expr e
| _ ->
Format.fprintf fmt "<not implemented stmt: %a>"
(Refl.pp [%refl: Ast.stmt] []) s
and stmt_without_semicolon fmt (s : Ast.stmt) =
match Node.force s.desc with
| Decl [{ desc; _ }] ->
begin match Node.force desc with
| Var var_decl ->
pp_var_decl fmt var_decl
| _ ->
Format.fprintf fmt "<not implemented stmt_without_semicolon: %a>"
(Refl.pp [%refl: Ast.stmt] []) s
end
| Expr e ->
expr fmt e
| _ ->
Format.fprintf fmt "<not implemented stmt_without_semicolon: %a>"
(Refl.pp [%refl: Ast.stmt] []) s
and pp_else_branch fmt else_branch =
match else_branch with
| None -> ()
| Some else_branch ->
Format.fprintf fmt "@[else@ %a@]" stmt else_branch
and pp_linkage fmt linkage =
match linkage with
| Internal -> Format.fprintf fmt "static@ "
| External
| NoLinkage -> ()
| _ ->
failwith (Format.asprintf "Not implemented linkage: %a"
(Refl.pp [%refl: Clang__bindings.cxlinkagekind] []) linkage)
and pp_parameters fmt parameters =
let all_parameters = List.map Option.some parameters.non_variadic in
let all_parameters =
if parameters.variadic then all_parameters @ [None] else all_parameters in
let pp_parameter fmt (parameter : Ast.parameter option) =
match parameter with
| None -> Format.pp_print_string fmt "..."
| Some { desc; _ } ->
let { name; qual_type = ty; _ } : Ast.parameter_desc =
Node.force desc in
typed_value (fun fmt -> Format.pp_print_string fmt name) fmt ty in
Format.pp_print_list
~pp_sep:pp_comma
pp_parameter fmt all_parameters
and pp_function_type fmt (function_type, name) =
typed_value
(fun fmt -> Format.fprintf fmt "@[%a(@]@,@[%a)@]" pp_declaration_name name
(pp_print_option pp_parameters) function_type.parameters)
fmt function_type.result
and pp_function_body fmt body =
match body with
| None -> Format.pp_print_string fmt ";"
| Some body -> Format.fprintf fmt "@ %a" stmt body
and pp_ident_ref fmt ident_ref =
let pp_nested_name_specifier_component
(component : Ast.nested_name_specifier_component) =
match component with
| Global -> Format.pp_print_string fmt "::"
| NestedIdentifier s -> Format.fprintf fmt "%s::" s
| NamespaceName name
| NamespaceAliasName name ->
Format.fprintf fmt "%s::" name
| TypeSpec ty
| TypeSpecWithTemplate ty ->
Format.fprintf fmt "%a::" pp_qual_type ty in
Option.iter (List.iter pp_nested_name_specifier_component)
ident_ref.nested_name_specifier;
pp_declaration_name fmt ident_ref.name;
if ident_ref.template_arguments <> [] then
Format.fprintf fmt "<%a>"
(Format.pp_print_list ~pp_sep:pp_comma pp_template_argument)
ident_ref.template_arguments
and pp_template_argument fmt (argument : Ast.template_argument) =
match argument with
| Type ty -> pp_qual_type fmt ty
| ExprTemplateArgument e -> expr fmt e
| _ ->
Format.fprintf fmt "@[<not implemented template argument: %a>@]"
(Refl.pp [%refl: Ast.template_argument] []) argument
and pp_declaration_name fmt (name : Ast.declaration_name) =
match name with
| IdentifierName s
| LiteralOperatorName s -> Format.pp_print_string fmt s
| ConstructorName ty
| ConversionFunctionName ty -> pp_qual_type fmt ty
| DestructorName ty -> Format.fprintf fmt "~%a" pp_qual_type ty
| OperatorName op ->
Format.fprintf fmt "operator%s"
(Clang__bindings.ext_overloaded_operator_get_spelling op)
| _ -> failwith "Not implemented pp_ident_ref.declaration_name"
and typed_value fmt_value fmt t =
let fmt_value =
if t.const then
(fun fmt -> Format.fprintf fmt "@[const %t@]" fmt_value)
else
fmt_value in
match Node.force t.desc with
| Pointer t ->
typed_value (fun fmt -> Format.fprintf fmt "@[*%t@]" fmt_value) fmt t
| LValueReference t ->
typed_value (fun fmt -> Format.fprintf fmt "@[&%t@]" fmt_value) fmt t
| RValueReference t ->
typed_value (fun fmt -> Format.fprintf fmt "@[&&%t@]" fmt_value) fmt t
| BuiltinType ty ->
Format.fprintf fmt "@[%s@ %t@]" (string_of_builtin_type ty) fmt_value
| ConstantArray { element; size_as_expr = Some size_as_expr; _ } ->
typed_value
(fun fmt ->
Format.fprintf fmt "@[%t[%a]@]" fmt_value expr size_as_expr)
fmt element
| ConstantArray { element; size_as_expr = None; size } ->
typed_value
(fun fmt -> Format.fprintf fmt "@[%t[%d]@]" fmt_value size) fmt
element
| Elaborated { keyword; named_type; _ } ->
Format.fprintf fmt "@[%s@ %a@]"
(Clang__bindings.ext_elaborated_type_get_keyword_spelling keyword)
(typed_value fmt_value) named_type
| Record ident
| Enum ident
| Typedef ident ->
Format.fprintf fmt "@[%a@ %t@]" pp_ident_ref ident fmt_value
| Auto ->
Format.fprintf fmt "@[auto@ %t@]" fmt_value
| FunctionType { result; parameters; _ } ->
typed_value (fun fmt -> Format.fprintf fmt "@[(%t)(%t)@]"
fmt_value (fun fmt -> parameters |> Option.iter @@ pp_parameters fmt))
fmt result
| _ ->
Format.fprintf fmt {|@[\<not implemented qual type: %a>@]|}
(Refl.pp [%refl: Ast.qual_type] []) t
and pp_qual_type fmt t =
typed_value (fun _fmt -> ()) fmt t
and decls fmt list =
let rec aux fmt (list : Ast.decl list) =
match list with
| [] -> ()
| hd :: tl ->
let default_case () =
Format.fprintf fmt "@[%a;@]@ " decl hd;
aux fmt tl in
match Node.force hd.desc, tl with
| (EnumDecl _ | RecordDecl { keyword = Struct; _ }) as desc,
(hd' :: tl) ->
begin match Node.force hd'.desc with
| TypedefDecl { name = typedef_name; underlying_type } ->
begin match Node.force underlying_type.desc with
| Elaborated { keyword; named_type; _ } ->
begin match desc, keyword, Node.force named_type.desc with
| EnumDecl { name = enum_name; _ },
Enum,
Enum { name = IdentifierName ref_name; _ }
when enum_name = ref_name ->
Format.fprintf fmt "@[%a;@]@ "
(pp_typedef (fun fmt -> decl fmt hd)) typedef_name;
Format.pp_print_space fmt ();
aux fmt tl
| RecordDecl { name = struct_name; _ },
Struct,
Record { name = IdentifierName ref_name; _ }
when struct_name = ref_name ->
Format.fprintf fmt "@[%a;@]@ "
(pp_typedef (fun fmt -> decl fmt hd)) typedef_name;
aux fmt tl
| _ -> default_case ()
end
| _ -> default_case ()
end
| _ -> default_case ()
end
| _ -> default_case () in
Format.fprintf fmt "@[<v>%a@]" aux list
let translation_unit fmt (tu : Ast.translation_unit) =
decls fmt (Node.force tu.desc).items
let qual_type = pp_qual_type
end