@ -31,10 +31,6 @@ type qual_name = QualifiedCppName.t
type templated_name = qual_name * Typ . template_arg list
type ' marker mtyp = typ
type ' captured_types capt = unit -> ' captured_types
(* Typ helpers *)
let template_args_of_template_spec_info = function
@ -65,89 +61,51 @@ let templated_name_of_java java =
(* Intermediate matcher types *)
type ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher =
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> ( ' f_out * ' captured_types capt ) option
; on_qual_name : ' context -> ' f_in -> qual_name -> ( ' f_out * ' captured_types capt ) option
; get_markers : ' markers_in -> ' markers_out }
type ( ' f_in
, ' f_out
, ' captured_types_in
, ' captured_types_out
, ' markers_in
, ' markers_out
, ' list_constraint )
template_arg =
{ eat_template_arg :
' f_in * ' captured_types_in capt * Typ . template_arg list
-> ( ' f_out * ' captured_types_out capt * Typ . template_arg list ) option
; add_marker : ' markers_in -> ' markers_out }
type ( ' context
, ' f_in
, ' f_out
, ' captured_types
, ' markers_in
, ' markers_out
, ' list_constraint
, ' value )
templ_matcher =
{ on_objc_cpp :
' context
-> ' f_in
-> objc_cpp
-> ( ' f_out * ' captured_types capt * Typ . template_arg list ) option
type ( ' context , ' f_in , ' f_out , ' value ) name_matcher =
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> ' f_out option
; on_qual_name : ' context -> ' f_in -> qual_name -> ' f_out option }
type ( ' f_in , ' f_out , ' list_constraint ) template_arg =
{ eat_template_arg : ' f_in * Typ . template_arg list -> ( ' f_out * Typ . template_arg list ) option }
type ( ' context , ' f_in , ' f_out , ' list_constraint , ' value ) templ_matcher =
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> ( ' f_out * Typ . template_arg list ) option
; on_templated_name :
' context
-> ' f_in
-> templated_name
-> ( ' f_out * ' captured_types capt * Typ . template_arg list ) option
; get_markers : ' markers_in -> ' markers_out }
' context -> ' f_in -> templated_name -> ( ' f_out * Typ . template_arg list ) option }
type ( ' context , ' f_in , ' f_out , ' captured_types, ' emptyness) path_extra =
| PathEmpty : ( ' context , ' f , ' f , unit , empty ) path_extra
type ( ' context , ' f_in , ' f_out , ' emptyness ) path_extra =
| PathEmpty : ( ' context , ' f , ' f , empty ) path_extra
| PathNonEmpty :
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> ( ' f_out * ' captured_types capt ) option }
-> ( ' context , ' f_in , ' f_out , ' captured_types , non_empty ) path_extra
type ( ' context
, ' f_in
, ' f_out
, ' captured_types
, ' markers_in
, ' markers_out
, ' emptyness
, ' value )
path_matcher =
{ on_templated_name : ' context -> ' f_in -> templated_name -> ( ' f_out * ' captured_types capt ) option
; path_extra : ( ' context , ' f_in , ' f_out , ' captured_types , ' emptyness ) path_extra
; get_markers : ' markers_in -> ' markers_out }
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> ' f_out option }
-> ( ' context , ' f_in , ' f_out , non_empty ) path_extra
type ( ' context , ' f_in , ' f_out , ' emptyness , ' value ) path_matcher =
{ on_templated_name : ' context -> ' f_in -> templated_name -> ' f_out option
; path_extra : ( ' context , ' f_in , ' f_out , ' emptyness ) path_extra }
type typ_matcher = typ -> bool
(* Combinators *)
let empty : ( ' context , ' f , ' f , unit , ' markers , ' markers , empty , ' value ) path_matcher =
let get_markers m = m in
let get_capture () = () in
let empty : ( ' context , ' f , ' f , empty , ' value ) path_matcher =
let on_templated_name _ context f ( qual_name , template_args ) =
match ( QualifiedCppName . extract_last qual_name , template_args ) with
| None , [] ->
Some ( f , get_capture )
Some f
| None , _ ->
assert false
| Some _ , _ ->
None
in
{ on_templated_name ; path_extra = PathEmpty ; get_markers }
{ on_templated_name ; path_extra = PathEmpty }
let name_cons :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ , ' value ) path_matcher
( ' context , ' f_in , ' f_out , _ , ' value ) path_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher =
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher =
fun m name ->
let { on_templated_name ; get_markers } = m in
let { on_templated_name } = m in
let match_fuzzy_name =
let fuzzy_name_regexp = name | > Str . quote | > Printf . sprintf " ^%s \\ (<.+> \\ )?$ " | > Str . regexp in
fun s -> Str . string_match fuzzy_name_regexp s 0
@ -164,15 +122,15 @@ let name_cons :
on_templated_name context f ( templated_name_of_class_name objc_cpp . class_name )
else None
in
{ on_objc_cpp ; on_qual_name ; get_markers }
{ on_objc_cpp ; on_qual_name }
let name_cons_f :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ , ' value ) path_matcher
( ' context , ' f_in , ' f_out , _ , ' value ) path_matcher
-> ( ' context -> string -> bool )
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher =
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher =
fun m f_name ->
let { on_templated_name ; get_markers } = m in
let { on_templated_name } = m in
let on_qual_name context f qual_name =
match QualifiedCppName . extract_last qual_name with
| Some ( last , rest ) when f_name context last ->
@ -185,30 +143,14 @@ let name_cons_f :
on_templated_name context f ( templated_name_of_class_name objc_cpp . class_name )
else None
in
{ on_objc_cpp ; on_qual_name ; get_markers }
{ on_objc_cpp ; on_qual_name }
let all_names_cons :
( ' context
, ' f_in
, ' f_out
, ' captured_types
, ' markers_in
, ' markers_out
, non_empty
, ' value )
path_matcher
-> ( ' context
, ' f_in
, ' f_out
, ' captured_tpes
, ' markers_in
, ' markers_out
, non_empty
, ' value )
path_matcher =
( ' context , ' f_in , ' f_out , non_empty , ' value ) path_matcher
-> ( ' context , ' f_in , ' f_out , non_empty , ' value ) path_matcher =
fun m ->
let { on_templated_name ; get_markers; path_extra= PathNonEmpty { on_objc_cpp } } = m in
let { on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } } = m in
let rec on_templated_name_rec context f templated_name =
match on_templated_name context f templated_name with
| Some _ as some ->
@ -229,103 +171,59 @@ let all_names_cons :
| None ->
on_templated_name context f ( templated_name_of_class_name objc_cpp . class_name )
in
{ on_templated_name ; get_markers; path_extra= PathNonEmpty { on_objc_cpp } }
{ on_templated_name ; path_extra= PathNonEmpty { on_objc_cpp } }
let templ_begin :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
-> ( ' context
, ' f_in
, ' f_out
, ' captured_types
, ' markers_in
, ' markers_out
, accept_more
, ' value )
templ_matcher =
( ' context , ' f_in , ' f_out , ' value ) name_matcher
-> ( ' context , ' f_in , ' f_out , accept_more , ' value ) templ_matcher =
fun m ->
let { on_objc_cpp ; on_qual_name ; get_markers } = m in
let { on_objc_cpp ; on_qual_name } = m in
let on_templated_name context f ( qual_name , template_args ) =
match on_qual_name context f qual_name with
| None ->
None
| Some ( f , captured_types ) ->
Some ( f , captured_types , template_args )
match on_qual_name context f qual_name with None -> None | Some f -> Some ( f , template_args )
in
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
match on_objc_cpp context f objc_cpp with
| None ->
None
| Some ( f , captured_types ) ->
| Some f ->
let template_args = template_args_of_template_spec_info objc_cpp . template_args in
Some ( f , captured_types, template_args)
Some ( f , template_args)
in
{ on_objc_cpp ; on_templated_name ; get_markers }
{ on_objc_cpp ; on_templated_name }
let templ_cons :
( ' context
, ' f_in
, ' f_interm
, ' captured_types_in
, ' markers_interm
, ' markers_out
, accept_more
, ' value )
templ_matcher
-> ( ' f_interm
, ' f_out
, ' captured_types_in
, ' captured_types_out
, ' markers_in
, ' markers_interm
, ' lc )
template_arg
-> ( ' context
, ' f_in
, ' f_out
, ' captured_types_out
, ' markers_in
, ' markers_out
, ' lc
, ' value )
templ_matcher =
( ' context , ' f_in , ' f_interm , accept_more , ' value ) templ_matcher
-> ( ' f_interm , ' f_out , ' lc ) template_arg
-> ( ' context , ' f_in , ' f_out , ' lc , ' value ) templ_matcher =
fun m template_arg ->
let { on_objc_cpp ; on_templated_name ; get_markers } = m in
let { eat_template_arg ; add_marker } = template_arg in
let get_markers m = get_markers ( add_marker m ) in
let { on_objc_cpp ; on_templated_name } = m in
let { eat_template_arg } = template_arg in
let on_templated_name context f templated_name =
on_templated_name context f templated_name | > Option . bind ~ f : eat_template_arg
in
let on_objc_cpp context f objc_cpp =
on_objc_cpp context f objc_cpp | > Option . bind ~ f : eat_template_arg
in
{ on_objc_cpp ; on_templated_name ; get_markers }
{ on_objc_cpp ; on_templated_name }
let templ_end :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ , ' value ) templ_matcher
-> ( ' context
, ' f_in
, ' f_out
, ' captured_types
, ' markers_in
, ' markers_out
, non_empty
, ' value )
path_matcher =
let match_empty_templ_args ( f , captured_types , template_args ) =
match template_args with [] -> Some ( f , captured_types ) | _ -> None
( ' context , ' f_in , ' f_out , _ , ' value ) templ_matcher
-> ( ' context , ' f_in , ' f_out , non_empty , ' value ) path_matcher =
let match_empty_templ_args ( f , template_args ) =
match template_args with [] -> Some f | _ -> None
in
fun m ->
let { on_objc_cpp ; on_templated_name ; get_markers } = m in
let { on_objc_cpp ; on_templated_name } = m in
let on_templated_name context f templated_name =
on_templated_name context f templated_name | > Option . bind ~ f : match_empty_templ_args
in
let on_objc_cpp context f objc_cpp =
on_objc_cpp context f objc_cpp | > Option . bind ~ f : match_empty_templ_args
in
{ on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } ; get_markers }
{ on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } }
module type Common = sig
@ -337,227 +235,108 @@ module type Common = sig
(* Template arguments *)
val any_typ :
( ' f , ' f , ' captured_types , ' captured_types , ' markers , ' markers , accept_more ) template_arg
val any_typ : ( ' f , ' f , accept_more ) template_arg
(* * Eats a type *)
val capt_typ :
' marker
-> ( ' marker mtyp -> ' f
, ' f
, ' captured_types
, ' marker mtyp * ' captured_types
, ' markers
, ' marker * ' markers
, accept_more )
template_arg
(* * Captures a type than can be back-referenced *)
val capt_int :
( Int64 . t -> ' f
, ' f
, ' captured_types
, ' captured_types
, ' markers
, ' markers
, accept_more )
template_arg
val capt_typ : ( Typ . t -> ' f , ' f , accept_more ) template_arg
(* * Captures a type *)
val capt_int : ( Int64 . t -> ' f , ' f , accept_more ) template_arg
(* * Captures an int *)
val capt_all :
( Typ . template_arg list -> ' f
, ' f
, ' captured_types
, ' captured_types
, ' markers
, ' markers
, end_of_list )
template_arg
val capt_all : ( Typ . template_arg list -> ' f , ' f , end_of_list ) template_arg
(* * Captures all template args *)
val ( ~ - ) : string -> ( ' context , ' f , ' f , unit , ' markers , ' markers , ' value ) name_matcher
val ( ~ - ) : string -> ( ' context , ' f , ' f , ' value ) name_matcher
(* * Starts a path with a name *)
val ( ~ + ) :
( ' context -> string -> bool )
-> ( ' context , ' f , ' f , unit , ' markers , ' markers , ' value ) name_matcher
val ( ~ + ) : ( ' context -> string -> bool ) -> ( ' context , ' f , ' f , ' value ) name_matcher
(* * Starts a path with a matching name that satisfies the given function *)
val ( & + ) :
( ' context
, ' f_in
, ' f_interm
, ' captured_types_in
, ' markers_interm
, ' markers_out
, accept_more
, ' value )
templ_matcher
-> ( ' f_interm
, ' f_out
, ' captured_types_in
, ' captured_types_out
, ' markers_in
, ' markers_interm
, ' lc )
template_arg
-> ( ' context
, ' f_in
, ' f_out
, ' captured_types_out
, ' markers_in
, ' markers_out
, ' lc
, ' value )
templ_matcher
( ' context , ' f_in , ' f_interm , accept_more , ' value ) templ_matcher
-> ( ' f_interm , ' f_out , ' lc ) template_arg
-> ( ' context , ' f_in , ' f_out , ' lc , ' value ) templ_matcher
(* * Separate template arguments *)
val ( < ) :
( ' context
, ' f_in
, ' f_interm
, ' captured_types_in
, ' markers_interm
, ' markers_out
, ' value )
name_matcher
-> ( ' f_interm
, ' f_out
, ' captured_types_in
, ' captured_types_out
, ' markers_in
, ' markers_interm
, ' lc )
template_arg
-> ( ' context
, ' f_in
, ' f_out
, ' captured_types_out
, ' markers_in
, ' markers_out
, ' lc
, ' value )
templ_matcher
( ' context , ' f_in , ' f_interm , ' value ) name_matcher
-> ( ' f_interm , ' f_out , ' lc ) template_arg
-> ( ' context , ' f_in , ' f_out , ' lc , ' value ) templ_matcher
(* * Starts template arguments after a name *)
val ( > :: ) :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ , ' value ) templ_matcher
( ' context , ' f_in , ' f_out , _ , ' value ) templ_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher
(* * Ends template arguments and starts a name *)
val ( > :: + ) :
( ' a, ' b , ' c , ' d , ' e , ' f , ' g , ' h ) templ_matcher
-> ( ' a -> string -> bool )
-> ( ' a, ' b , ' c , ' d , ' e , ' f , ' h ) name_matcher
( ' context , ' f_in , ' f_out , ' lc , ' value ) templ_matcher
-> ( ' context -> string -> bool )
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher
val ( & + .. . > :: ) :
( ' context
, ' f_in
, ' f_out
, ' captured_types
, ' markers_in
, ' markers_out
, accept_more
, ' value )
templ_matcher
( ' context , ' f_in , ' f_out , accept_more , ' value ) templ_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher
(* * Ends template arguments with eats-ALL and starts a name *)
val ( & :: ) :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
( ' context , ' f_in , ' f_out , ' value ) name_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher
(* * Separates names ( accepts ALL template arguments on the left one ) *)
val ( & :: + ) :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
( ' context , ' f_in , ' f_out , ' value ) name_matcher
-> ( ' context -> string -> bool )
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher
val ( < > :: ) :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
( ' context , ' f_in , ' f_out , ' value ) name_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' value ) name_matcher
-> ( ' context , ' f_in , ' f_out , ' value ) name_matcher
(* * Separates names ( accepts NO template arguments on the left one ) *)
end
module Common = struct
(* Template arguments *)
let add_no_marker capture_markers = capture_markers
(* * Eats all template args *)
let any_template_args :
( ' f , ' f , ' captured_types , ' captured_types , ' markers , ' markers , end_of_list ) template_arg =
let eat_template_arg ( f , captured_types , _ ) = Some ( f , captured_types , [] ) in
{ eat_template_arg ; add_marker = add_no_marker }
let any_template_args : ( ' f , ' f , end_of_list ) template_arg =
let eat_template_arg ( f , _ ) = Some ( f , [] ) in
{ eat_template_arg }
(* * Eats a type *)
let any_typ :
( ' f , ' f , ' captured_types , ' captured_types , ' markers , ' markers , accept_more ) template_arg =
let eat_template_arg ( f , captured_types , template_args ) =
match template_args with Typ . TType _ :: rest -> Some ( f , captured_types , rest ) | _ -> None
let any_typ : ( ' f , ' f , accept_more ) template_arg =
let eat_template_arg ( f , template_args ) =
match template_args with Typ . TType _ :: rest -> Some ( f , rest ) | _ -> None
in
{ eat_template_arg ; add_marker = add_no_marker }
(* * Captures a type than can be back-referenced *)
let capt_typ :
' marker
-> ( ' marker mtyp -> ' f
, ' f
, ' captured_types
, ' marker mtyp * ' captured_types
, ' markers
, ' marker * ' markers
, accept_more )
template_arg =
fun marker ->
let eat_template_arg ( f , captured_types , template_args ) =
match template_args with
| Typ . TType ty :: rest ->
let captured_types () = ( ty , captured_types () ) in
Some ( f ty , captured_types , rest )
| _ ->
None
{ eat_template_arg }
(* * Captures a type *)
let capt_typ : ( Typ . t -> ' f , ' f , accept_more ) template_arg =
let eat_template_arg ( f , template_args ) =
match template_args with Typ . TType ty :: rest -> Some ( f ty , rest ) | _ -> None
in
let add_marker capture_markers = ( marker , capture_markers ) in
{ eat_template_arg ; add_marker }
{ eat_template_arg }
(* * Captures an int *)
let capt_int :
( Int64 . t -> ' f
, ' f
, ' captured_types
, ' captured_types
, ' markers
, ' markers
, accept_more )
template_arg =
let eat_template_arg ( f , captured_types , template_args ) =
match template_args with Typ . TInt i :: rest -> Some ( f i , captured_types , rest ) | _ -> None
let capt_int : ( Int64 . t -> ' f , ' f , accept_more ) template_arg =
let eat_template_arg ( f , template_args ) =
match template_args with Typ . TInt i :: rest -> Some ( f i , rest ) | _ -> None
in
{ eat_template_arg ; add_marker = add_no_marker }
{ eat_template_arg }
(* * Captures all template args *)
let capt_all :
( Typ . template_arg list -> ' f
, ' f
, ' captured_types
, ' captured_types
, ' markers
, ' markers
, end_of_list )
template_arg =
let eat_template_arg ( f , captured_types , template_args ) =
Some ( f template_args , captured_types , [] )
in
{ eat_template_arg ; add_marker = add_no_marker }
let capt_all : ( Typ . template_arg list -> ' f , ' f , end_of_list ) template_arg =
let eat_template_arg ( f , template_args ) = Some ( f template_args , [] ) in
{ eat_template_arg }
let ( < ! ) name_matcher () = templ_begin name_matcher
@ -616,40 +395,33 @@ module Call = struct
Logging . ( die InternalError ) " Expected Lvar, got %a:%a " Exp . pp e ( Typ . pp Pp . text ) typ
end
type ( ' context , ' f_in , ' f_out , ' captured_types ) proc_matcher =
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> ( ' f_out * ' captured_types ) option
; on_c : ' context -> ' f_in -> c -> ( ' f_out * ' captured_types ) option
; on_java : ' context -> ' f_in -> java -> ( ' f_out * ' captured_types ) option }
type ( ' context , ' f_in , ' f_out ) proc_matcher =
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> ' f_out option
; on_c : ' context -> ' f_in -> c -> ' f_out option
; on_java : ' context -> ' f_in -> java -> ' f_out option }
type ( ' context , ' f_in , ' f_out , ' captured_types , ' value ) on_args =
' context
-> ' captured_types
-> ' f_in * ' value FuncArg . t list
-> ( ' f_out * ' value FuncArg . t list ) option
type ( ' context , ' f_in , ' f_out , ' value ) on_args =
' context -> ' f_in * ' value FuncArg . t list -> ( ' f_out * ' value FuncArg . t list ) option
type ( ' context , ' f_in , ' f_proc_out , ' f_out , ' captured_types , ' markers , ' value ) args_matcher =
{ on_proc : ( ' context , ' f_in , ' f_proc_out , ' captured_types ) proc_matcher
; on_args : ( ' context , ' f_proc_out , ' f_out , ' captured_types , ' value ) on_args
; markers : ' markers }
type ( ' context , ' f_in , ' f_proc_out , ' f_out , ' value ) args_matcher =
{ on_proc : ( ' context , ' f_in , ' f_proc_out ) proc_matcher
; on_args : ( ' context , ' f_proc_out , ' f_out , ' value ) on_args }
type ( ' context , ' captured_types , ' markers , ' value ) one_arg_matcher =
{ match_arg : ' context -> ' captured_types -> ' value FuncArg . t -> bool
; marker_static_checker : ' markers -> bool }
type ( ' context , ' value ) one_arg_matcher = { match_arg : ' context -> ' value FuncArg . t -> bool }
type ( ' arg_in , ' arg_out , ' f_in , ' f_out , ' value ) arg_capture =
{ get_captured_value : ' value FuncArg . t -> ' arg_in ; do_capture : ' f_in -> ' arg_out -> ' f_out }
type ( ' context , ' arg_in , ' arg_out , ' f_in , ' f_out , ' captured_types , ' markers , ' value ) one_arg =
{ one_arg_matcher : ( ' context , ' captured_types , ' markers , ' value ) one_arg_matcher
type ( ' context , ' arg_in , ' arg_out , ' f_in , ' f_out , ' value ) one_arg =
{ one_arg_matcher : ( ' context , ' value ) one_arg_matcher
; capture : ( ' arg_in , ' arg_out , ' f_in , ' f_out , ' value ) arg_capture }
type ( ' arg_in , ' arg_out , ' f_in , ' f_out , ' value ) arg_preparer =
{ on_empty : ( ' f_in -> ' arg_out -> ' f_out ) -> ' f_in -> ( ' f_out * ' value FuncArg . t list ) option
; wrapper : ' arg_in -> ' arg_out }
type ( ' context , ' f_in , ' f_out , ' captured_types , ' markers , ' value ) func_arg =
{ eat_func_arg : ( ' context , ' f_in , ' f_out , ' captured_types , ' value ) on_args
; marker_static_checker : ' markers -> bool }
type ( ' context , ' f_in , ' f_out , ' value ) func_arg =
{ eat_func_arg : ( ' context , ' f_in , ' f_out , ' value ) on_args }
type ( ' context , ' f , ' value ) matcher =
{ on_objc_cpp : ' context -> objc_cpp -> ' value FuncArg . t list -> ' f option
@ -665,11 +437,11 @@ module Call = struct
let pre_map_opt opt ~ f = match opt with None -> DoesNotMatch | Some x -> Matches ( f x )
type ( ' context , ' f_in , ' f_out , ' captured_types , ' value ) func_args_end =
on_args : ( ' context , ' f_in , ' f_out , ' captured_types , ' value ) on_args
type ( ' context , ' f_in , ' f_out , ' value ) func_args_end =
on_args : ( ' context , ' f_in , ' f_out , ' value ) on_args
-> ' context
-> ' value FuncArg . t list
-> ' f_in * ' captured_types
-> ' f_in
-> ( ' context , ' f_out , ' value ) pre_result
type ( ' context , ' f_in , ' f_out , ' value ) all_args_matcher =
@ -688,44 +460,37 @@ module Call = struct
' context -> Typ . Procname . t -> ' value FuncArg . t list -> ' f option
let args_begin :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , non_empty , ' value ) path_matcher
-> ( ' context , ' f_in , ' f_out , ' f_out , ' captured_types , ' markers , ' value ) args_matcher =
let on_args _ context _ capt f_args = Some f_args in
( ' context , ' f_in , ' f_out , non_empty , ' value ) path_matcher
-> ( ' context , ' f_in , ' f_out , ' f_out , ' value ) args_matcher =
let on_args _ context f_args = Some f_args in
fun m ->
let { on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } ; get_markers } = m in
let markers = get_markers () in
let get_captures ( f , captured_types ) = ( f , captured_types () ) in
let { on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } } = m in
let on_c context f ( c : c ) =
let template_args = template_args_of_template_spec_info c . template_args in
on_templated_name context f ( c . name , template_args ) | > Option . map ~ f : get_captures
on_templated_name context f ( c . name , template_args )
in
let on_java context f ( java : java ) =
on_templated_name context f ( templated_name_of_java java ) | > Option . map ~ f : get_captures
in
let on_objc_cpp context f objc_cpp =
on_objc_cpp context f objc_cpp | > Option . map ~ f : get_captures
on_templated_name context f ( templated_name_of_java java )
in
let on_proc : ( _ , _ , _ , _ ) proc_matcher = { on_objc_cpp ; on_c ; on_java } in
{ on_proc ; on_args ; markers }
let on_objc_cpp context f objc_cpp = on_objc_cpp context f objc_cpp in
let on_proc : _ proc_matcher = { on_objc_cpp ; on_c ; on_java } in
{ on_proc ; on_args }
let args_cons :
( ' context , ' f_in , ' f_proc_out , ' f_interm , ' captured_types , ' markers , ' value ) args_matcher
-> ( ' context , ' f_interm , ' f_out , ' captured_types , ' markers , ' value ) func_arg
-> ( ' context , ' f_in , ' f_proc_out , ' f_out , ' captured_types , ' markers , ' value ) args_matcher =
( ' context , ' f_in , ' f_proc_out , ' f_interm , ' value ) args_matcher
-> ( ' context , ' f_interm , ' f_out , ' value ) func_arg
-> ( ' context , ' f_in , ' f_proc_out , ' f_out , ' value ) args_matcher =
fun m func_arg ->
let { on_proc ; on_args ; markers } = m in
let { marker_static_checker ; eat_func_arg } = func_arg in
assert ( marker_static_checker markers ) ;
let on_args context capt f_args =
on_args context capt f_args | > Option . bind ~ f : ( eat_func_arg context capt )
in
{ on_proc ; on_args ; markers }
let { on_proc ; on_args } = m in
let { eat_func_arg } = func_arg in
let on_args context f_args = on_args context f_args | > Option . bind ~ f : ( eat_func_arg context ) in
{ on_proc ; on_args }
let args_end :
( ' context , ' f_in , ' f_proc_out , ' f_out , ' captured_types , ' markers , ' value ) args_matcher
-> ( ' context , ' f_proc_out , ' f_out , ' captured_types , ' value ) func_args_end
( ' context , ' f_in , ' f_proc_out , ' f_out , ' value ) args_matcher
-> ( ' context , ' f_proc_out , ' f_out , ' value ) func_args_end
-> ( ' context , ' f_in , ' f_out , ' value ) all_args_matcher =
fun m func_args_end ->
let { on_proc = { on_c ; on_java ; on_objc_cpp } ; on_args } = m in
@ -816,52 +581,17 @@ module Call = struct
(* Function args *)
let no_marker_checker _ markers = true
(* * Matches any arg *)
let match_any_arg : ( _ , _ , _ , _ ) one_arg_matcher =
let match_arg _ context _ capt _ arg = true in
{ match_arg ; marker_static_checker = no_marker_checker }
let mk_match_typ_nth :
( ' markers -> ' marker )
-> ( ' captured_types -> ' marker mtyp )
-> ' marker
-> ( ' context , ' captured_types , ' markers , ' value ) one_arg_matcher =
fun get_m get_c marker ->
let marker_static_checker markers = Poly . equal marker ( get_m markers ) in
let match_arg _ context capt arg = Typ . equal ( FuncArg . typ arg ) ( get_c capt ) in
{ match_arg ; marker_static_checker }
(* * Matches first captured type *)
let match_typ1 : ' marker -> ( ' context , ' marker mtyp * _ , ' marker * _ , _ ) one_arg_matcher =
let pos1 ( x , _ ) = x in
fun marker -> mk_match_typ_nth pos1 pos1 marker
(* * Matches second captured type *)
let match_typ2 :
' marker -> ( ' context , _ * ( ' marker mtyp * _ ) , _ * ( ' marker * _ ) , _ ) one_arg_matcher =
let pos2 ( _ , ( x , _ ) ) = x in
fun marker -> mk_match_typ_nth pos2 pos2 marker
(* * Matches third captured type *)
let match_typ3 :
' marker
-> ( ' context , _ * ( _ * ( ' marker mtyp * _ ) ) , _ * ( _ * ( ' marker * _ ) ) , ' value ) one_arg_matcher =
let pos3 ( _ , ( _ , ( x , _ ) ) ) = x in
fun marker -> mk_match_typ_nth pos3 pos3 marker
let match_any_arg : _ one_arg_matcher =
let match_arg _ context _ arg = true in
{ match_arg }
(* * Matches the type matched by the given path_matcher *)
let match_typ :
( ' context , _ , _ , unit , unit , unit , non_empty , ' value ) path_matcher
-> ( ' context , _ , _ , _ ) one_arg_matcher =
( ' context , _ , _ , non_empty , ' value ) path_matcher -> ( ' context , ' value ) one_arg_matcher =
fun m ->
let ( { on_templated_name } : ( _ , _ , _ , unit , unit , unit , non_empty , ' value ) path_matcher ) = m in
let ( { on_templated_name } : ( _ , _ , _ , non_empty , ' value ) path_matcher ) = m in
let rec match_typ context typ =
match typ with
| { Typ . desc = Tstruct name } ->
@ -871,15 +601,15 @@ module Call = struct
| _ ->
false
in
let match_arg context _ capt arg = match_typ context ( FuncArg . typ arg ) in
{ match_arg ; marker_static_checker = no_marker_checker }
let match_arg context arg = match_typ context ( FuncArg . typ arg ) in
{ match_arg }
(* * Matches the type matched by the given typ_matcher *)
let match_prim_typ : typ_matcher -> _ one_arg_matcher =
fun on_typ ->
let match_arg _ context _ capt arg = on_typ ( FuncArg . typ arg ) in
{ match_arg ; marker_static_checker = no_marker_checker }
let match_arg _ context arg = on_typ ( FuncArg . typ arg ) in
{ match_arg }
(* Function argument capture *)
@ -933,43 +663,43 @@ module Call = struct
let make_arg :
( ' arg_in , ' arg_out , ' f_in , ' f_out , ' value ) arg_preparer
-> ( ' context , ' arg_in , ' arg_out , ' f_in , ' f_out , _ , _ , ' value ) one_arg
-> ( ' context , ' f_in , ' f_out , _ , _ , ' value ) func_arg =
-> ( ' context , ' arg_in , ' arg_out , ' f_in , ' f_out , ' value ) one_arg
-> ( ' context , ' f_in , ' f_out , ' value ) func_arg =
fun arg_preparer one_arg ->
let { on_empty ; wrapper } = arg_preparer in
let { one_arg_matcher ; capture } = one_arg in
let { match_arg ; marker_static_checker } = one_arg_matcher in
let { match_arg } = one_arg_matcher in
let { get_captured_value ; do_capture } = capture in
let eat_func_arg context capt ( f , args ) =
let eat_func_arg context ( f , args ) =
match args with
| [] ->
on_empty do_capture f
| arg :: rest when match_arg context capt arg ->
| arg :: rest when match_arg context arg ->
Some ( arg | > get_captured_value | > wrapper | > do_capture f , rest )
| _ ->
None
in
{ eat_func_arg ; marker_static_checker }
{ eat_func_arg }
let any_arg : ( ' context , unit , _ , ' f , ' f , _ , _ , _ ) one_arg =
let any_arg : ( ' context , unit , _ , ' f , ' f , ' value ) one_arg =
{ one_arg_matcher = match_any_arg ; capture = no_capture }
let capt_arg :
(' context , ' value FuncArg . t , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , _ , _ , ' value ) one_arg =
let capt_arg : ( ' context , ' value FuncArg . t , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , ' value ) one_arg
=
{ one_arg_matcher = match_any_arg ; capture = capture_arg }
let capt_value : ( ' context , ' value , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , _ , _ , ' value ) one_arg =
let capt_value : ( ' context , ' value , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , ' value ) one_arg =
{ one_arg_matcher = match_any_arg ; capture = capture_arg_val }
let capt_exp : ( ' context , Exp . t , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , _ , _ , _ ) one_arg =
let capt_exp : ( ' context , Exp . t , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , ' value ) one_arg =
{ one_arg_matcher = match_any_arg ; capture = capture_arg_exp }
let capt_var_exn : ( ' context , Ident . t , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , _ , _ , _ ) one_arg =
let capt_var_exn : ( ' context , Ident . t , ' wrapped_arg , ' wrapped_arg -> ' f , ' f , ' value ) one_arg =
{ one_arg_matcher = match_any_arg ; capture = capture_arg_var_exn }
@ -992,36 +722,24 @@ module Call = struct
{ one_arg_matcher = one_arg_matcher_of_prim_typ typ ; capture = capture_arg_exp }
let typ1 : ' marker -> ( ' context , unit , _ , ' f , ' f , _ , _ , _ ) one_arg =
fun m -> { one_arg_matcher = match_typ1 m ; capture = no_capture }
let typ2 : ' marker -> ( ' context , unit , _ , ' f , ' f , _ , _ , _ ) one_arg =
fun m -> { one_arg_matcher = match_typ2 m ; capture = no_capture }
let typ3 : ' marker -> ( ' context , unit , _ , ' f , ' f , _ , _ , _ ) one_arg =
fun m -> { one_arg_matcher = match_typ3 m ; capture = no_capture }
(* Function args end *)
(* * Matches if there is no function arguments left *)
let no_args_left : ( ' context , _ , _ , _ , _ ) func_args_end =
let no_args_left : ( ' context , _ , _ , ' value ) func_args_end =
let match_empty_args = function Some ( f , [] ) -> Matches f | _ -> DoesNotMatch in
fun ~ on_args context args ( f , capt ) -> on_args contex t cap t ( f , args ) | > match_empty_args
fun ~ on_args context args f -> on_args context ( f , args ) | > match_empty_args
(* * Matches any function arguments *)
let any_func_args : ( ' context , _ , _ , _ , _ ) func_args_end =
fun ~ on_args context args ( f , capt ) -> on_args contex t cap t ( f , args ) | > pre_map_opt ~ f : fst
let any_func_args : ( ' context , _ , _ , ' value ) func_args_end =
fun ~ on_args context args f -> on_args context ( f , args ) | > pre_map_opt ~ f : fst
(* * If [func_args_end1] does not match, use [func_args_end2] *)
let alternative_args_end :
( ' context , ' f_in , ' f_out , ' captured_types , ' value ) func_args_end
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' value ) func_args_end
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' value ) func_args_end =
( ' context , ' f_in , ' f_out , ' value ) func_args_end
-> ( ' context , ' f_in , ' f_out , ' value ) func_args_end
-> ( ' context , ' f_in , ' f_out , ' value ) func_args_end =
fun func_args_end1 func_args_end2 ~ on_args context args f_capt ->
match func_args_end1 ~ on_args context args f_capt with
| DoesNotMatch ->
@ -1031,14 +749,14 @@ module Call = struct
(* * Retries matching with another matcher *)
let args_end_retry : _ matcher -> ( ' context , _ , _ , _ , _ ) func_args_end =
let args_end_retry : _ matcher -> ( ' context , _ , _ , ' value ) func_args_end =
fun m ~ on_args : _ _ context _ args _ f_capt -> RetryWith m
(* * Retries matching with another matcher if the function does not have the
exact number / types of args * )
let exact_args_or_retry :
(' context , ' f , ' value ) matcher -> ( ' context , _ , _ , _ , ' value ) func_args_end =
let exact_args_or_retry : ( ' context , ' f , ' value ) matcher -> ( ' context , _ , _ , ' value ) func_args_end
=
fun m -> alternative_args_end no_args_left ( args_end_retry m )
@ -1103,24 +821,18 @@ module type NameCommon = sig
include Common
val ( > - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , _ , ' value ) templ_matcher
( ' context , ' f_in , ' f_out , _ , ' value ) templ_matcher
-> ' f_in
-> ( ' context , ' f_out , ' value ) matcher
val ( < > - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , ' value ) name_matcher
-> ' f_in
-> ( ' context , ' f_out , ' value ) matcher
( ' context , ' f_in , ' f_out , ' value ) name_matcher -> ' f_in -> ( ' context , ' f_out , ' value ) matcher
val ( & - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , ' value ) name_matcher
-> ' f_in
-> ( ' context , ' f_out , ' value ) matcher
( ' context , ' f_in , ' f_out , ' value ) name_matcher -> ' f_in -> ( ' context , ' f_out , ' value ) matcher
val ( & :: . * - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , ' value ) name_matcher
-> ' f_in
-> ( ' context , ' f_out , ' value ) matcher
( ' context , ' f_in , ' f_out , ' value ) name_matcher -> ' f_in -> ( ' context , ' f_out , ' value ) matcher
(* * After a name, accepts ALL template arguments, accepts ALL path tails ( names, templates ) ,
accepts ALL function arguments , binds the function * )
end
@ -1133,18 +845,16 @@ module NameCommon = struct
; on_objc_cpp : ' context -> objc_cpp -> ' f option }
let make_matcher :
( ' context , ' f_in , ' f_out , _ , _ , _ , non_empty , ' value ) path_matcher
( ' context , ' f_in , ' f_out , non_empty , ' value ) path_matcher
-> ' f_in
-> ( ' context , ' f_out , ' value ) matcher =
fun m f ->
let ( { on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } }
: ( ' context , ' f_in , ' f_out , _ , _ , _ , non_empty , ' value ) path_matcher ) =
: ( ' context , ' f_in , ' f_out , non_empty , ' value ) path_matcher ) =
m
in
let on_templated_name context templated_name =
templated_name | > on_templated_name context f | > Option . map ~ f : fst
in
let on_objc_cpp context objc_cpp = objc_cpp | > on_objc_cpp context f | > Option . map ~ f : fst in
let on_templated_name context templated_name = templated_name | > on_templated_name context f in
let on_objc_cpp context objc_cpp = objc_cpp | > on_objc_cpp context f in
{ on_templated_name ; on_objc_cpp }