Skip to content

Commit db26f00

Browse files
ivgivg
authored
reimplements C types printing functions (#1503)
They now use a proper C syntax instead of custom pseudo-syntax.
1 parent 9335834 commit db26f00

File tree

3 files changed

+121
-48
lines changed

3 files changed

+121
-48
lines changed

‎lib/bap_c/bap_c_type.ml‎

Lines changed: 117 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -262,3 +262,120 @@ let function_ ?(attrs=[]) ?(variadic=false) ?(return=`Void) args : t =
262262
}
263263

264264
let is_function : t -> Bool.t = function `Function _ -> true | _ -> false
265+
266+
267+
let pp_comma ppf () = Format.fprintf ppf ", "
268+
269+
let pp_attr ppf = function
270+
| {Attr.name; args=[]} -> Format.fprintf ppf "%s" name
271+
| {Attr.name; args} ->
272+
Format.fprintf ppf "%s(%a)" name
273+
(Format.pp_print_list ~pp_sep:pp_comma
274+
Format.pp_print_string) args
275+
276+
let pp_attr_list ppf xs =
277+
Format.pp_print_list ~pp_sep:pp_comma pp_attr ppf xs
278+
279+
let pp_attrs ppf = function
280+
| [] -> ()
281+
| attrs ->
282+
Format.fprintf ppf " __attribute__((%a)) "
283+
pp_attr_list attrs
284+
285+
let pp_qualifier name ppf = function
286+
| false -> ()
287+
| true -> Format.fprintf ppf " %s " name
288+
289+
let pp_cv ppf {Qualifier.const;volatile} =
290+
Format.fprintf ppf "%a%a"
291+
(pp_qualifier "const") const
292+
(pp_qualifier "volatile") volatile
293+
294+
let pp_cvr ppf {Qualifier.const;volatile;restrict} =
295+
Format.fprintf ppf "%a%a%a"
296+
(pp_qualifier "const") const
297+
(pp_qualifier "volatile") volatile
298+
(pp_qualifier "restrict") restrict
299+
300+
let pp_size ppf = function
301+
| None -> ()
302+
| Some size -> Format.fprintf ppf "%d" size
303+
304+
let pp_enum_value ppf = function
305+
| None -> Format.fprintf ppf ","
306+
| Some v -> Format.fprintf ppf "= %Ld," v
307+
308+
let pp_enum_field ppf (name,value) =
309+
Format.fprintf ppf "@,%s%a," name pp_enum_value value
310+
311+
let rec pp_enum_fields ppf =
312+
List.iter ~f:(pp_enum_field ppf)
313+
314+
let string_of_basic t = match (t : basic) with
315+
| `schar -> "signed char"
316+
| `cdouble -> "double complex"
317+
| `long_double -> "long double"
318+
| `cfloat -> "float complex"
319+
| `float -> "float"
320+
| `clong_double -> "long double complex"
321+
| `ulong_long -> "unsigned long long"
322+
| `uint -> "unsigned"
323+
| `slong -> "signed long"
324+
| `bool -> "_Bool"
325+
| `double -> "double"
326+
| `slong_long -> "signed long long"
327+
| `sshort -> "signed short"
328+
| `ushort -> "unsigned short"
329+
| `char -> "char"
330+
| `sint -> "signed"
331+
| `ulong -> "unsigned long"
332+
| `uchar -> "unsigned char"
333+
| `enum fields ->
334+
Format.asprintf "@[<v>@[<v4>enum {%a@]@,}@;" pp_enum_fields fields
335+
336+
let pp_variadic ppf = function
337+
| true -> Format.fprintf ppf ", ..."
338+
| false -> ()
339+
340+
let pp_basic ppf t =
341+
Format.pp_print_string ppf (string_of_basic t)
342+
343+
let rec pp ppf t = match (t : t) with
344+
| `Void ->
345+
Format.fprintf ppf "void"
346+
| `Array { qualifier; t={ element; size }; attrs } ->
347+
Format.fprintf ppf "@[<h>%a%a%a[%a]@]"
348+
pp_attrs attrs pp_cvr qualifier pp_incomplete element pp_size size
349+
|`Basic { qualifier; t; attrs } ->
350+
Format.fprintf ppf "@[<h>%a%a%a@]"
351+
pp_attrs attrs pp_cv qualifier pp_basic t
352+
| `Function { t=proto; attrs } ->
353+
Format.fprintf ppf "@[<h>%a%a;@]"
354+
pp_proto proto pp_attrs attrs
355+
| `Pointer { qualifier; t; attrs } ->
356+
Format.fprintf ppf "@[<h>%a%a%a*@]"
357+
pp_attrs attrs pp_incomplete t pp_cvr qualifier
358+
| `Union { t={name;fields}; attrs }
359+
| `Structure { t={name;fields}; attrs } as t ->
360+
let kind = if is_structure t then "struct" else "union" in
361+
Format.fprintf ppf "@[<v>@[<v4>%s %s {@,%a@]@,}@]%a;"
362+
kind name pp_fields fields pp_attrs attrs
363+
and pp_proto ppf { return; args; variadic } =
364+
Format.fprintf ppf "%a (*)(%a%a)"
365+
pp_incomplete return pp_args args pp_variadic variadic
366+
and pp_args ppf = function
367+
| [] -> Format.fprintf ppf "void"
368+
| args ->
369+
Format.pp_print_list ~pp_sep:pp_comma pp_arg ppf args
370+
and pp_arg ppf (name,t) =
371+
Format.fprintf ppf "%a %s" pp_incomplete t name
372+
and pp_fields ppf fields =
373+
Format.pp_print_list pp_field ppf fields
374+
and pp_field ppf (name,t) =
375+
Format.fprintf ppf "%a %s;" pp_incomplete t name
376+
and pp_incomplete ppf t = match (t : t) with
377+
| `Union { t={name} }
378+
| `Structure { t={name} } as t ->
379+
let kind = if is_structure t then "struct" else "union" in
380+
Format.fprintf ppf "%s %s" kind name
381+
| t -> pp ppf t

‎lib/bap_c/bap_c_type.mli‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -231,3 +231,6 @@ val function_ : ?attrs:attr list -> ?variadic:Bool.t -> ?return:t ->
231231
(string * t) list -> t
232232

233233
val is_function : t -> Bool.t
234+
235+
val pp : Format.formatter -> t -> unit
236+
val pp_proto : Format.formatter -> proto -> unit

‎lib/bap_c/bap_c_type_printer.ml‎

Lines changed: 1 addition & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -1,48 +1 @@
1-
open Core_kernel[@@warning "-D"]
2-
open Format
3-
open Bap_c_type
4-
5-
let pr ppf x = fprintf ppf x
6-
7-
let pp_spec ppq ppt ppf {Spec.qualifier; t; attrs} =
8-
pr ppf "%a%a" ppq qualifier ppt t
9-
10-
let pp_flag c ppf x = pr ppf "%s" (if x then c else "")
11-
let pp_c,pp_v,pp_r = pp_flag "c", pp_flag "v", pp_flag "r"
12-
let pp_cvr ppf {Qualifier.const=c;restrict=r;volatile=v} =
13-
pr ppf "%a%a%a" pp_c c pp_v v pp_r r
14-
let pp_cv ppf {Qualifier.const=c;volatile=v} =
15-
pr ppf "%a%a" pp_c c pp_v v
16-
17-
let pp_basic ppf t = Sexp.pp ppf (sexp_of_basic t)
18-
19-
let pp_size ppf t = Option.iter t ~f:(Int.pp ppf)
20-
21-
let pp_or ppf () = pr ppf "@ | @ "
22-
let pp_to ppf () = pr ppf "@ ->@ "
23-
let pp_sc ppf () = pr ppf ";@ "
24-
let pp_sp ppf () = pr ppf "@,"
25-
26-
let pp_list pp_sep field = pp_print_list ~pp_sep field
27-
28-
let rec pp ppf : t -> unit = function
29-
| `Void -> pr ppf "void"
30-
| `Basic spec -> pp_spec pp_cv pp_basic ppf spec
31-
| `Pointer {Spec.t; qualifier} -> pr ppf "%a %aptr" pp t pp_cvr qualifier
32-
| `Array {Spec.t={Array.element=et; size};qualifier} ->
33-
pr ppf "%a %aptr[%a]" pp et pp_cvr qualifier pp_size size
34-
| `Structure {Spec.t={Compound.fields; name}} ->
35-
pr ppf "@[<2>%s.{%a}@]" name (pp_list pp_sc pp_field) fields
36-
| `Union {Spec.t={Compound.fields; name}} ->
37-
pr ppf "@[<2>%s.{%a}@]" name (pp_list pp_or pp_field) fields
38-
| `Function {Spec.t} -> pp_proto ppf t
39-
and pp_field ppf = function
40-
| (name,t) -> pr ppf "%s:%a" name pp t
41-
and pp_arg ppf = function
42-
| "",t -> pr ppf "%a" pp t
43-
| n,t -> pr ppf "%s:%a" n pp t
44-
and pp_proto ppf {Proto.return; args} =
45-
pr ppf "%a@ ->@ %a" pp_args args pp return
46-
and pp_args ppf = function
47-
| [] -> pp ppf `Void
48-
| args -> (pp_list pp_to pp_arg ppf) args
1+
let pp = Bap_c_type.pp and pp_proto = Bap_c_type.pp_proto

0 commit comments

Comments
 (0)