@ -85,16 +85,20 @@ type ( 'f_in
type ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , ' list_constraint ) templ_matcher
=
{ on_objc_cpp :
' context -> ' f_in -> objc_cpp
' context
-> ' f_in
-> objc_cpp
-> ( ' f_out * ' captured_types capt * Typ . template_arg list ) option
; on_templated_name :
' context -> ' f_in -> templated_name
' context
-> ' f_in
-> templated_name
-> ( ' f_out * ' captured_types capt * Typ . template_arg list ) option
; get_markers : ' markers_in -> ' markers_out }
type ( ' context , ' f_in , ' f_out , ' captured_types , ' emptyness ) path_extra =
| PathEmpty : ( ' context , ' f , ' f , unit , empty ) path_extra
| PathNonEmpty :
| 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
@ -120,8 +124,8 @@ let empty : ('context, 'f, 'f, unit, 'markers, 'markers, empty) path_matcher =
{ on_templated_name ; path_extra = PathEmpty ; get_markers }
let name_cons
: ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ ) path_matcher
let name_cons :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ ) path_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher =
fun m name ->
@ -136,7 +140,7 @@ let name_cons
| _ ->
None
in
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
if String . equal name objc_cpp . method_name then
on_templated_name context f ( templated_name_of_class_name objc_cpp . class_name )
else None
@ -144,8 +148,8 @@ let name_cons
{ on_objc_cpp ; on_qual_name ; get_markers }
let name_cons_f
: ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ ) path_matcher
let name_cons_f :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ ) path_matcher
-> ( ' context -> string -> bool )
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher =
fun m f_name ->
@ -157,7 +161,7 @@ let name_cons_f
| _ ->
None
in
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
if f_name context objc_cpp . method_name then
on_templated_name context f ( templated_name_of_class_name objc_cpp . class_name )
else None
@ -165,32 +169,26 @@ let name_cons_f
{ on_objc_cpp ; on_qual_name ; get_markers }
let all_names_cons
: ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , non_empty ) path_matcher
-> ( ' context
, ' f_in
, ' f_out
, ' captured_tpes
, ' markers_in
, ' markers_out
, non_empty )
path_matcher =
let all_names_cons :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , non_empty ) path_matcher
-> ( ' context , ' f_in , ' f_out , ' captured_tpes , ' markers_in , ' markers_out , non_empty ) path_matcher
=
fun m ->
let { on_templated_name ; get_markers ; 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 ->
some
| None ->
| None -> (
let qual_name , _ template_args = templated_name in
match QualifiedCppName . extract_last qual_name with
| None ->
None
| Some ( _ last , rest ) ->
on_templated_name_rec context f ( rest , [] )
on_templated_name_rec context f ( rest , [] ) )
in
let on_templated_name = on_templated_name_rec in
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
match on_objc_cpp context f objc_cpp with
| Some _ as some ->
some
@ -200,8 +198,8 @@ let all_names_cons
{ on_templated_name ; get_markers ; path_extra = PathNonEmpty { on_objc_cpp } }
let templ_begin
: ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
let templ_begin :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
-> ( ' context
, ' f_in
, ' f_out
@ -219,7 +217,7 @@ let templ_begin
| Some ( f , captured_types ) ->
Some ( f , captured_types , template_args )
in
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
let on_objc_cpp context f ( objc_cpp : Typ . Procname . ObjC_Cpp . t ) =
match on_objc_cpp context f objc_cpp with
| None ->
None
@ -230,8 +228,8 @@ let templ_begin
{ on_objc_cpp ; on_templated_name ; get_markers }
let templ_cons
: ( ' context
let templ_cons :
( ' context
, ' f_in
, ' f_interm
, ' captured_types_in
@ -247,14 +245,8 @@ let templ_cons
, ' markers_interm
, ' lc )
template_arg
-> ( ' context
, ' f_in
, ' f_out
, ' captured_types_out
, ' markers_in
, ' markers_out
, ' lc )
templ_matcher =
-> ( ' context , ' f_in , ' f_out , ' captured_types_out , ' markers_in , ' markers_out , ' lc ) 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
@ -268,8 +260,8 @@ let templ_cons
{ on_objc_cpp ; on_templated_name ; get_markers }
let templ_end
: ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ ) templ_matcher
let templ_end :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ ) templ_matcher
-> ( ' context
, ' f_in
, ' f_out
@ -381,7 +373,8 @@ module type Common = sig
val ( > :: ) :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out , _ ) templ_matcher
-> string -> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
(* * Ends template arguments and starts a name *)
val ( & + .. . > :: ) :
@ -392,17 +385,20 @@ module type Common = sig
, ' markers_in
, ' markers_out
, accept_more )
templ_matcher -> string
templ_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
(* * Ends template arguments with eats-ALL and starts a name *)
val ( & :: ) :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher -> string
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
(* * Separates names ( accepts ALL template arguments on the left one ) *)
val ( < > :: ) :
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher -> string
( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
-> string
-> ( ' context , ' f_in , ' f_out , ' captured_types , ' markers_in , ' markers_out ) name_matcher
(* * Separates names ( accepts NO template arguments on the left one ) *)
end
@ -413,15 +409,15 @@ module Common = struct
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 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 }
(* * Eats a type *)
let any_typ
: (' f , ' f , ' captured_types , ' captured_types , ' markers , ' markers , accept_more ) template_arg =
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
in
@ -429,8 +425,8 @@ module Common = struct
(* * Captures a type than can be back-referenced *)
let capt_typ
: ' marker
let capt_typ :
' marker
-> ( ' marker mtyp -> ' f
, ' f
, ' captured_types
@ -453,8 +449,8 @@ module Common = struct
(* * Captures an int *)
let capt_int
: ( Int64 . t -> ' f
let capt_int :
( Int64 . t -> ' f
, ' f
, ' captured_types
, ' captured_types
@ -469,8 +465,8 @@ module Common = struct
(* * Captures all template args *)
let capt_all
: ( Typ . template_arg list -> ' f
let capt_all :
( Typ . template_arg list -> ' f
, ' f
, ' captured_types
, ' captured_types
@ -580,8 +576,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 ) func_args_end =
on_args : ( ' context , ' f_in , ' f_out , ' captured_types ) on_args -> ' context -> FuncArg . t list
-> ' f_in * ' captured_types -> ( ' context , ' f_out ) pre_result
on_args : ( ' context , ' f_in , ' f_out , ' captured_types ) on_args
-> ' context
-> FuncArg . t list
-> ' f_in * ' captured_types
-> ( ' context , ' f_out ) pre_result
type ( ' context , ' f_in , ' f_out ) all_args_matcher =
{ on_objc_cpp : ' context -> ' f_in -> objc_cpp -> FuncArg . t list -> ( ' context , ' f_out ) pre_result
@ -590,19 +589,19 @@ module Call = struct
type ( ' context , ' f ) dispatcher = ' context -> Typ . Procname . t -> FuncArg . t list -> ' f option
let args_begin
: ( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , non_empty ) path_matcher
let args_begin :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , non_empty ) path_matcher
-> ( ' context , ' f_in , ' f_out , ' f_out , ' captured_types , ' markers ) args_matcher =
let on_args _ context _ capt 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_c context f ( c : c ) =
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
in
let on_java context f ( java : java ) =
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 =
@ -612,8 +611,8 @@ module Call = struct
{ on_proc ; on_args ; markers }
let args_cons
: ( ' context , ' f_in , ' f_proc_out , ' f_interm , ' captured_types , ' markers ) args_matcher
let args_cons :
( ' context , ' f_in , ' f_proc_out , ' f_interm , ' captured_types , ' markers ) args_matcher
-> ( ' context , ' f_interm , ' f_out , ' captured_types , ' markers ) func_arg
-> ( ' context , ' f_in , ' f_proc_out , ' f_out , ' captured_types , ' markers ) args_matcher =
fun m func_arg ->
@ -626,8 +625,8 @@ module Call = struct
{ on_proc ; on_args ; markers }
let args_end
: ( ' context , ' f_in , ' f_proc_out , ' f_out , ' captured_types , ' markers ) args_matcher
let args_end :
( ' context , ' f_in , ' f_proc_out , ' f_out , ' captured_types , ' markers ) args_matcher
-> ( ' context , ' f_proc_out , ' f_out , ' captured_types ) func_args_end
-> ( ' context , ' f_in , ' f_out ) all_args_matcher =
fun m func_args_end ->
@ -644,10 +643,10 @@ module Call = struct
{ on_c ; on_java ; on_objc_cpp }
let make_matcher
: (' context , ' f_in , ' f_out ) all_args_matcher -> ' f_in -> ( ' context , ' f_out ) matcher =
let make_matcher :
(' context , ' f_in , ' f_out ) all_args_matcher -> ' f_in -> ( ' context , ' f_out ) matcher =
fun m f ->
let {on_c ; on_java ; on_objc_cpp } : ( _ , _ , _ ) all_args_matcher = m in
let ( {on_c ; on_java ; on_objc_cpp } : ( _ , _ , _ ) all_args_matcher ) = m in
let on_objc_cpp context objc_cpp args =
match on_objc_cpp context f objc_cpp args with
| DoesNotMatch ->
@ -682,14 +681,14 @@ module Call = struct
let make_dispatcher : ( ' context , ' f ) matcher list -> ( ' context , ' f ) dispatcher =
fun matchers ->
let on_objc_cpp context objc_cpp args =
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) ->
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) ->
matcher . on_objc_cpp context objc_cpp args )
in
let on_c context c args =
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) -> matcher . on_c context c args )
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) -> matcher . on_c context c args )
in
let on_java context java args =
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) -> matcher . on_java context java args )
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) -> matcher . on_java context java args )
in
fun context procname args ->
match procname with
@ -713,8 +712,10 @@ module Call = struct
{ match_arg ; marker_static_checker = no_marker_checker }
let mk_match_typ_nth
: ( ' markers -> ' marker ) -> ( ' captured_types -> ' marker mtyp ) -> ' marker
let mk_match_typ_nth :
( ' markers -> ' marker )
-> ( ' captured_types -> ' marker mtyp )
-> ' marker
-> ( ' context , ' captured_types , ' markers ) one_arg_matcher =
fun get_m get_c marker ->
let marker_static_checker markers = Polymorphic_compare . ( = ) marker ( get_m markers ) in
@ -729,25 +730,26 @@ module Call = struct
(* * Matches second captured type *)
let match_typ2 : ' marker -> ( ' context , _ * ( ' marker mtyp * _ ) , _ * ( ' marker * _ ) ) one_arg_matcher =
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
: ' mark er
-> ( ' context , _ * ( _ * ( ' marker mtyp * _ ) ) , _ * ( _ * ( ' marker * _ ) ) ) one_arg_matcher =
let match_typ3 :
' marker -> ( ' context , _ * ( _ * ( ' marker mtyp * _ ) ) , _ * ( _ * ( ' marker * _ ) ) ) one_arg_match er
=
let pos3 ( _ , ( _ , ( x , _ ) ) ) = x in
fun marker -> mk_match_typ_nth pos3 pos3 marker
(* * Matches the type matched by the given path_matcher *)
let match_typ
: ( ' context , _ , _ , unit , unit , unit , non_empty ) path_matcher
let match_typ :
( ' context , _ , _ , unit , unit , unit , non_empty ) path_matcher
-> ( ' context , _ , _ ) one_arg_matcher =
fun m ->
let {on_templated_name } : ( _ , _ , _ , unit , unit , unit , non_empty ) path_matcher = m in
let ( {on_templated_name } : ( _ , _ , _ , unit , unit , unit , non_empty ) path_matcher ) = m in
let rec match_typ context typ =
match typ with
| { Typ . desc = Tstruct name } ->
@ -762,6 +764,7 @@ module Call = struct
(* Function argument capture *)
(* * Do not capture this argument *)
let no_capture : ( _ , _ , ' f , ' f ) arg_capture =
let get_captured_value _ arg = () in
@ -802,8 +805,8 @@ module Call = struct
{ on_empty ; wrapper }
let make_arg
: ( ' arg_in , ' arg_out , ' f_in , ' f_out ) arg_preparer
let make_arg :
( ' arg_in , ' arg_out , ' f_in , ' f_out ) arg_preparer
-> ( ' context , ' arg_in , ' arg_out , ' f_in , ' f_out , _ , _ ) one_arg
-> ( ' context , ' f_in , ' f_out , _ , _ ) func_arg =
fun arg_preparer one_arg ->
@ -856,6 +859,7 @@ module Call = struct
(* Function args end *)
(* * Matches if there is no function arguments left *)
let no_args_left : ( ' context , _ , _ , _ ) func_args_end =
let match_empty_args = function Some ( f , [] ) -> Matches f | _ -> DoesNotMatch in
@ -868,8 +872,8 @@ module Call = struct
(* * If [func_args_end1] does not match, use [func_args_end2] *)
let alternative_args_end
: ( ' context , ' f_in , ' f_out , ' captured_types ) func_args_end
let alternative_args_end :
( ' context , ' f_in , ' f_out , ' captured_types ) func_args_end
-> ( ' context , ' f_in , ' f_out , ' captured_types ) func_args_end
-> ( ' context , ' f_in , ' f_out , ' captured_types ) func_args_end =
fun func_args_end1 func_args_end2 ~ on_args context args f_capt ->
@ -952,19 +956,23 @@ module type NameCommon = sig
include Common
val ( > - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , _ ) templ_matcher -> ' f_in
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers , _ ) templ_matcher
-> ' f_in
-> ( ' context , ' f_out ) matcher
val ( < > - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers ) name_matcher -> ' f_in
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers ) name_matcher
-> ' f_in
-> ( ' context , ' f_out ) matcher
val ( & - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers ) name_matcher -> ' f_in
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers ) name_matcher
-> ' f_in
-> ( ' context , ' f_out ) matcher
val ( & :: . * - -> ) :
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers ) name_matcher -> ' f_in
( ' context , ' f_in , ' f_out , ' captured_types , unit , ' markers ) name_matcher
-> ' f_in
-> ( ' context , ' f_out ) matcher
(* * After a name, accepts ALL template arguments, accepts ALL path tails ( names, templates ) ,
accepts ALL function arguments , binds the function * )
@ -977,12 +985,13 @@ module NameCommon = struct
{ on_templated_name : ' context -> templated_name -> ' f option
; on_objc_cpp : ' context -> objc_cpp -> ' f option }
let make_matcher
: ( ' context , ' f_in , ' f_out , _ , _ , _ , non_empty ) path_matcher -> ' f_in
let make_matcher :
( ' context , ' f_in , ' f_out , _ , _ , _ , non_empty ) path_matcher
-> ' f_in
-> ( ' context , ' f_out ) matcher =
fun m f ->
let {on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } }
: ( ' context , ' f_in , ' f_out , _ , _ , _ , non_empty ) path_matcher =
let ( {on_templated_name ; path_extra = PathNonEmpty { on_objc_cpp } }
: ( ' context , ' f_in , ' f_out , _ , _ , _ , non_empty ) path_matcher ) =
m
in
let on_templated_name context templated_name =
@ -1011,17 +1020,17 @@ module ProcName = struct
let make_dispatcher : ( ' context , ' f ) matcher list -> ( ' context , ' f ) dispatcher =
fun matchers ->
let on_objc_cpp context objc_cpp =
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) -> matcher . on_objc_cpp context objc_cpp )
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) -> matcher . on_objc_cpp context objc_cpp )
in
let on_templated_name context templated_name =
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) ->
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) ->
matcher . on_templated_name context templated_name )
in
let on_java context ( java : Typ . Procname . Java . t ) =
let on_java context ( java : Typ . Procname . Java . t ) =
let templated_name = templated_name_of_java java in
on_templated_name context templated_name
in
let on_c context ( c : c ) =
let on_c context ( c : c ) =
let template_args = template_args_of_template_spec_info c . template_args in
let templated_name = ( c . name , template_args ) in
on_templated_name context templated_name
@ -1046,6 +1055,6 @@ module TypName = struct
let make_dispatcher : ( ' context , ' f ) matcher list -> ( ' context , ' f ) dispatcher =
fun matchers context typname ->
let templated_name = templated_name_of_class_name typname in
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) ->
List . find_map matchers ~ f : ( fun ( matcher : _ matcher ) ->
matcher . on_templated_name context templated_name )
end