@ -146,7 +146,7 @@ module T = {
[ @@ deriving compare ]
[ @@ deriving compare ]
and template_spec_info =
and template_spec_info =
| NoTemplate
| NoTemplate
| Template ( QualifiedCppName . t , list ( option t ) )
| Template ( list ( option t ) )
[ @@ deriving compare ] ;
[ @@ deriving compare ] ;
let equal_desc = [ % compare . equal : desc ] ;
let equal_desc = [ % compare . equal : desc ] ;
let equal_quals = [ % compare . equal : type_quals ] ;
let equal_quals = [ % compare . equal : type_quals ] ;
@ -183,26 +183,107 @@ let mk ::default=? ::quals=? desc :t => {
mk_aux :: ? default :: ? quals desc
mk_aux :: ? default :: ? quals desc
} ;
} ;
let escape pe = >
if ( Pp . equal_print_kind pe . Pp . kind Pp . HTML ) {
Escape . escape_xml
} else {
ident
} ;
/* * Pretty print a type with all the details, using the C syntax. */
let rec pp_full pe f typ = > {
let pp_quals f { quals } = > {
if ( is_const quals ) {
F . fprintf f " const "
} ;
if ( is_restrict quals ) {
F . fprintf f " __restrict "
} ;
if ( is_volatile quals ) {
F . fprintf f " volatile "
}
} ;
let pp_desc f { desc } = >
switch desc {
| Tstruct tname = > F . fprintf f " %a " ( pp_name_c_syntax pe ) tname
| Tint ik = > F . fprintf f " %s " ( ikind_to_string ik )
| Tfloat fk = > F . fprintf f " %s " ( fkind_to_string fk )
| Tvoid = > F . fprintf f " void "
| Tfun false = > F . fprintf f " _fn_ "
| Tfun true = > F . fprintf f " _fn_noreturn_ "
| Tptr ( { desc : Tarray _ | Tfun _ } as typ ) pk = >
F . fprintf f " %a(%s) " ( pp_full pe ) typ ( ptr_kind_string pk | > escape pe )
| Tptr typ pk = > F . fprintf f " %a%s " ( pp_full pe ) typ ( ptr_kind_string pk | > escape pe )
| Tarray typ static_len = >
let pp_array_static_len fmt = > (
fun
| Some static_len = > IntLit . pp fmt static_len
| None = > F . fprintf fmt " _ "
) ;
F . fprintf f " %a[%a] " ( pp_full pe ) typ pp_array_static_len static_len
} ;
F . fprintf f " %a%a " pp_desc typ pp_quals typ
}
and pp_name_c_syntax pe f = >
fun
| CStruct name
| CUnion name
| ObjcClass name
| ObjcProtocol name = > F . fprintf f " %a " QualifiedCppName . pp name
| CppClass name template_spec = >
F . fprintf f " %a%a " QualifiedCppName . pp name ( pp_template_spec_info pe ) template_spec
| JavaClass name = > F . fprintf f " %a " Mangled . pp name
and pp_template_spec_info pe f = >
fun
| NoTemplate = > ()
| Template args = > {
let pp_arg_opt f = > (
fun
| Some typ = > F . fprintf f " %a " ( pp_full pe ) typ
| None = > F . fprintf f " _ "
) ;
F . fprintf f " %s%a%s " ( escape pe " < " ) ( Pp . comma_seq pp_arg_opt ) args ( escape pe " > " )
} ;
/* * Pretty print a type. Do nothing by default. */
let pp pe f te = >
if Config . print_types {
pp_full pe f te
} else {
()
} ;
let to_string typ = > {
let pp fmt = > pp_full Pp . text fmt typ ;
F . asprintf " %t " pp
} ;
module Name = {
module Name = {
type t = name [ @@ deriving compare ] ;
type t = name [ @@ deriving compare ] ;
let equal = [ % compare . equal : t ] ;
let equal = [ % compare . equal : t ] ;
let name =
fun
| CStruct name
| CUnion name
| CppClass name _
| ObjcClass name
| ObjcProtocol name = > QualifiedCppName . to_qual_string name
| JavaClass name = > Mangled . to_string name ;
let qual_name =
let qual_name =
fun
fun
| CStruct name
| CStruct name
| CUnion name
| CUnion name
| CppClass name _
| ObjcClass name
| ObjcClass name
| ObjcProtocol name = > name
| ObjcProtocol name = > name
| CppClass name templ_args = > {
let template_suffix = F . asprintf " %a " ( pp_template_spec_info Pp . text ) templ_args ;
QualifiedCppName . append_template_args_to_last name args :: template_suffix
}
| JavaClass _ = > QualifiedCppName . empty ;
| JavaClass _ = > QualifiedCppName . empty ;
let to_string tname = > {
let name n = >
switch n {
| CStruct _
| CUnion _
| CppClass _ _
| ObjcClass _
| ObjcProtocol _ = > qual_name n | > QualifiedCppName . to_qual_string
| JavaClass name = > Mangled . to_string name
} ;
let pp fmt tname = > {
let prefix =
let prefix =
fun
fun
| CStruct _ = > " struct "
| CStruct _ = > " struct "
@ -211,9 +292,9 @@ module Name = {
| JavaClass _
| JavaClass _
| ObjcClass _ = > " class "
| ObjcClass _ = > " class "
| ObjcProtocol _ = > " protocol " ;
| ObjcProtocol _ = > " protocol " ;
prefix tname ^ " " ^ name tname
F . fprintf fmt " %s %a " ( prefix tname ) ( pp_name_c_syntax Pp . text ) tname
} ;
} ;
let pp f typename = > F . fprintf f " %s " ( to_string typename ) ;
let to_string = F . asprintf " %a " pp ;
let is_class =
let is_class =
fun
fun
| CppClass _ _
| CppClass _ _
@ -283,61 +364,6 @@ module Map = Caml.Map.Make T;
module Tbl = Hashtbl . Make T ;
module Tbl = Hashtbl . Make T ;
/* * Pretty print a type with all the details, using the C syntax. */
let rec pp_full pe f typ = > {
let pp_quals f { quals } = > {
if ( is_const quals ) {
F . fprintf f " const "
} ;
if ( is_restrict quals ) {
F . fprintf f " __restrict "
} ;
if ( is_volatile quals ) {
F . fprintf f " volatile "
}
} ;
let pp_desc f { desc } = >
switch desc {
| Tstruct tname = >
if ( Pp . equal_print_kind pe . Pp . kind Pp . HTML ) {
F . fprintf f " %s " ( Name . name tname | > Escape . escape_xml )
} else {
F . fprintf f " %s " ( Name . name tname )
}
| Tint ik = > F . fprintf f " %s " ( ikind_to_string ik )
| Tfloat fk = > F . fprintf f " %s " ( fkind_to_string fk )
| Tvoid = > F . fprintf f " void "
| Tfun false = > F . fprintf f " _fn_ "
| Tfun true = > F . fprintf f " _fn_noreturn_ "
| Tptr ( { desc : Tarray _ | Tfun _ } as typ ) pk = >
F . fprintf f " %a(%s) " ( pp_full pe ) typ ( ptr_kind_string pk )
| Tptr typ pk = > F . fprintf f " %a%s " ( pp_full pe ) typ ( ptr_kind_string pk )
| Tarray typ static_len = >
let pp_array_static_len fmt = > (
fun
| Some static_len = > IntLit . pp fmt static_len
| None = > F . fprintf fmt " _ "
) ;
F . fprintf f " %a[%a] " ( pp_full pe ) typ pp_array_static_len static_len
} ;
F . fprintf f " %a%a " pp_desc typ pp_quals typ
} ;
/* * Pretty print a type. Do nothing by default. */
let pp pe f te = >
if Config . print_types {
pp_full pe f te
} else {
()
} ;
let to_string typ = > {
let pp fmt = > pp_full Pp . text fmt typ ;
F . asprintf " %t " pp
} ;
/* * dump a type with all the details. */
/* * dump a type with all the details. */
let d_full ( t : t ) = > L . add_print_action ( L . PTtyp_full , Obj . repr t ) ;
let d_full ( t : t ) = > L . add_print_action ( L . PTtyp_full , Obj . repr t ) ;
@ -1016,8 +1042,7 @@ module Struct = {
statics : fields , /* * static fields */
statics : fields , /* * static fields */
supers : list Name . t , /* * superclasses */
supers : list Name . t , /* * superclasses */
methods : list Procname . t , /* * methods defined */
methods : list Procname . t , /* * methods defined */
annots : Annot . Item . t , /* * annotations */
annots : Annot . Item . t /* * annotations */
specialization : template_spec_info /* * template specialization */
} ;
} ;
type lookup = Name . t = > option t ;
type lookup = Name . t = > option t ;
let pp pe name f { fields , supers , methods , annots } = >
let pp pe name f { fields , supers , methods , annots } = >
@ -1044,23 +1069,8 @@ module Struct = {
} else {
} else {
F . fprintf f " %a " Name . pp name
F . fprintf f " %a " Name . pp name
} ;
} ;
let internal_mk_struct
let internal_mk_struct :: default = ? :: fields = ? :: statics = ? :: methods = ? :: supers = ? :: annots = ? () = > {
:: default = ?
let default_ = { fields : [] , statics : [] , methods : [] , supers : [] , annots : Annot . Item . empty } ;
:: fields = ?
:: statics = ?
:: methods = ?
:: supers = ?
:: annots = ?
:: specialization = ?
() = > {
let default_ = {
fields : [] ,
statics : [] ,
methods : [] ,
supers : [] ,
annots : Annot . Item . empty ,
specialization : NoTemplate
} ;
let mk_struct_
let mk_struct_
:: default = default_
:: default = default_
:: fields = default . fields
:: fields = default . fields
@ -1068,16 +1078,14 @@ module Struct = {
:: methods = default . methods
:: methods = default . methods
:: supers = default . supers
:: supers = default . supers
:: annots = default . annots
:: annots = default . annots
:: specialization = default . specialization
() = > {
() = > {
fields ,
fields ,
statics ,
statics ,
methods ,
methods ,
supers ,
supers ,
annots ,
annots
specialization
} ;
} ;
mk_struct_ :: ? default :: ? fields :: ? statics :: ? methods :: ? supers :: ? annots :: ? specialization ()
mk_struct_ :: ? default :: ? fields :: ? statics :: ? methods :: ? supers :: ? annots ()
} ;
} ;
/* * the element typ of the final extensible array in the given typ, if any */
/* * the element typ of the final extensible array in the given typ, if any */