[infer] Remove marker from procname dispatcher

Summary: This diff removes `'markers` and `'captured_types` from the procname dispatcher. They are for checking an integrity when a type is captured from template parameters then it is used to match in parameters. However, we have not used that feature, so which simply complicates the types in the dispatcher without any gain at the moment.

Reviewed By: jvillard

Differential Revision: D18706254

fbshipit-source-id: f493778d7
master
Sungkeun Cho 5 years ago committed by Facebook Github Bot
parent 3d181bd831
commit b15395ad60

@ -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 context capt (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 context capt (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}

@ -12,40 +12,13 @@ type accept_more
and end_of_list
(* Markers are a fool-proofing mechanism to avoid mistaking captured types.
Template argument types can be captured with [capt_typ] to be referenced later
by their position [typ1], [typ2], [typ3], ...
To avoid mixing them, give a different name to each captured type, using whatever
type/value you want and reuse it when referencing the captured type, e.g.
[capt_typ `T &+ capt_typ `A], then use [typ1 `T], [typ2 `A].
If you get them wrong, you will get a typing error at compile-time or an
assertion failure at matcher-building time.
*)
(* Intermediate matcher types *)
type 'marker mtyp = Typ.t
type ('context, 'f_in, 'f_out, 'value) name_matcher
(* Intermediate matcher types *)
type ('f_in, 'f_out_in_out, 'list_constraint) template_arg
type ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'value) name_matcher
type ( 'f_in
, 'f_out
, 'captured_types_in
, 'captured_types_out
, 'markers_in
, 'markers_out
, 'list_constraint )
template_arg
type ( 'context
, 'f_in
, 'f_out
, 'captured_types
, 'markers_in
, 'markers_out
, 'list_constraint
, 'value )
templ_matcher
type ('context, 'f_in, 'f_out, 'list_constraint, 'value) templ_matcher
(* A matcher is a rule associating a function [f] to a [C/C++ function/method]:
- [C/C++ function/method] --> [f]
@ -72,151 +45,70 @@ 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
(** Separates names that satisfies the given function (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
-> 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
@ -224,24 +116,19 @@ 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
@ -269,153 +156,124 @@ module Call : sig
-> ('context, 'f, 'value) dispatcher
(** Merges two dispatchers into a dispatcher *)
type ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers, 'value) args_matcher
type ('context, 'f_in, 'f_proc_out, 'f_out, 'value) args_matcher
type ('context, 'arg_in, 'arg_out, 'f_in, 'f_out, 'captured_types, 'markers, 'value) one_arg
type ('context, 'arg_in, 'arg_out, 'f_in, 'f_out, 'value) one_arg
(* Function args *)
val any_arg : ('context, unit, _, 'f, 'f, _, _, _) one_arg
val any_arg : ('context, unit, _, 'f, 'f, 'value) one_arg
(** Eats one arg *)
val capt_arg :
('context, 'value FuncArg.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _, 'value) one_arg
val capt_arg : ('context, 'value FuncArg.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, 'value) one_arg
(** Captures one arg *)
val capt_value : ('context, 'value, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _, 'value) one_arg
val capt_value : ('context, 'value, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, 'value) one_arg
(** Captures the value of one arg at current state *)
val capt_exp : ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _, _) one_arg
val capt_exp : ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, 'value) one_arg
(** Captures one arg expression *)
val any_arg_of_typ :
('context, unit, _, unit, unit, unit, 'value) name_matcher
-> ('context, unit, _, 'f, 'f, _, _, 'value) one_arg
('context, unit, _, 'value) name_matcher -> ('context, unit, _, 'f, 'f, 'value) one_arg
(** Eats one arg of the given type *)
val capt_arg_of_typ :
('context, unit, _, unit, unit, unit, 'value) name_matcher
-> ('context, 'value FuncArg.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _, 'value) one_arg
('context, unit, _, 'value) name_matcher
-> ('context, 'value FuncArg.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, 'value) one_arg
(** Captures one arg of the given type *)
val capt_exp_of_typ :
('context, unit, _, unit, unit, unit, 'value) name_matcher
-> ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _, _) one_arg
('context, unit, _, 'value) name_matcher
-> ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, 'value) one_arg
(** Captures one arg expression of the given type *)
val any_arg_of_prim_typ : Typ.t -> ('context, unit, _, 'f, 'f, _, _, _) one_arg
val any_arg_of_prim_typ : Typ.t -> ('context, unit, _, 'f, 'f, 'value) one_arg
(** Eats one arg of the given primitive type *)
val capt_exp_of_prim_typ :
Typ.t -> ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _, _) one_arg
Typ.t -> ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, 'value) one_arg
(** Captures one arg expression of the given primitive type *)
val capt_var_exn : ('context, Ident.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _, _) one_arg
val capt_var_exn : ('context, Ident.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, 'value) one_arg
(** Captures one arg Var. Fails with an internal error if the expression is not a Var *)
val typ1 : 'marker -> ('context, unit, _, 'f, 'f, 'marker mtyp * _, 'marker * _, _) one_arg
(** Matches first captured type *)
val typ2 :
'marker -> ('context, unit, _, 'f, 'f, _ * ('marker mtyp * _), _ * ('marker * _), _) one_arg
(** Matches second captured type *)
val typ3 :
'marker
-> ('context, unit, _, 'f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _)), _) one_arg
(** Matches third captured type *)
val ( $+ ) :
('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers, 'value) args_matcher
-> ('context, 'arg, 'arg, 'f_interm, 'f_out, 'captured_types, 'markers, 'value) one_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, 'arg, 'arg, 'f_interm, 'f_out, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'value) args_matcher
(** Separate function arguments *)
val ( $+? ) :
('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers, 'value) args_matcher
-> ('context, 'arg, 'arg option, 'f_interm, 'f_out, 'captured_types, 'markers, 'value) one_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, 'arg, 'arg option, 'f_interm, 'f_out, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'value) args_matcher
(** Add an optional argument *)
val ( >$ ) :
('context, 'f_in, 'f_proc_out, 'ct, unit, 'cm, _, 'value) templ_matcher
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'ct, 'cm, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'ct, 'cm, 'value) args_matcher
('context, 'f_in, 'f_proc_out, 'ct, 'value) templ_matcher
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'value) args_matcher
(** Ends template arguments and starts function arguments *)
val ( $--> ) :
('context, 'f_in, _, 'f_out, 'captured_types, 'markers, 'value) args_matcher
-> 'f_in
-> ('context, 'f_out, 'value) matcher
('context, 'f_in, _, 'f_out, 'value) args_matcher -> 'f_in -> ('context, 'f_out, 'value) matcher
(** Ends function arguments, binds the function *)
val ( $ ) :
('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers, 'value) name_matcher
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'captured_types, 'markers, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers, 'value) args_matcher
('context, 'f_in, 'f_proc_out, 'value) name_matcher
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'value) args_matcher
(** Ends a name with accept-ALL template arguments and starts function arguments *)
val ( <>$ ) :
('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers, 'value) name_matcher
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'captured_types, 'markers, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers, 'value) args_matcher
('context, 'f_in, 'f_proc_out, 'value) name_matcher
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'value) one_arg
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'value) args_matcher
(** Ends a name with accept-NO template arguments and starts function arguments *)
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
(** Ends template arguments, accepts ALL function arguments, binds the function *)
val ( $+...$--> ) :
('context, 'f_in, _, 'f_out, 'captured_types, 'markers, 'value) args_matcher
-> 'f_in
-> ('context, 'f_out, 'value) matcher
('context, 'f_in, _, 'f_out, 'value) args_matcher -> 'f_in -> ('context, 'f_out, 'value) matcher
(** Ends function arguments with eats-ALL and binds the function *)
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
(** Ends template arguments, accepts NO function arguments, binds the function *)
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 NO function arguments, binds the function *)
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 NO template arguments, accepts NO function arguments, binds the function *)
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 function arguments, binds the function *)
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 NO template arguments, accepts ALL function arguments, binds the function *)
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 *)
val ( $!--> ) :
('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers, 'value) args_matcher
('context, 'f_in, 'f_proc_out, 'f_out, 'value) args_matcher
-> 'f_in
-> ('context, 'f_out, 'value) matcher
(** Ends function arguments, accepts NO more function arguments.
If the args do not match, raise an internal error.
*)
If the args do not match, raise an internal error. *)
end
[@@warning "-32"]

@ -1259,29 +1259,18 @@ module Call = struct
; std_array2 >:: "at" $ capt_arg $+ capt_arg $!--> StdArray.at
; std_array2 >:: "operator[]" $ capt_arg $+ capt_arg $!--> StdArray.at
; -"std" &:: "array" &::.*--> no_model
; -"std" &:: "basic_string"
< capt_typ `T
&+...>:: "basic_string" $ capt_arg
; -"std" &:: "basic_string" < capt_typ &+...>:: "basic_string" $ capt_arg
$+ capt_exp_of_typ (-"std" &:: "basic_string")
$--> StdBasicString.copy_constructor
; -"std" &:: "basic_string"
< capt_typ `T
&+...>:: "basic_string" $ capt_arg $+ capt_exp_of_prim_typ char_ptr
$--> StdBasicString.constructor_from_char_ptr_without_len
; -"std" &:: "basic_string"
< capt_typ `T
&+...>:: "basic_string" $ capt_arg $+ capt_exp_of_prim_typ char_ptr
; -"std" &:: "basic_string" < capt_typ &+...>:: "basic_string" $ capt_arg
$+ capt_exp_of_prim_typ char_ptr $--> StdBasicString.constructor_from_char_ptr_without_len
; -"std" &:: "basic_string" < capt_typ &+...>:: "basic_string" $ capt_arg
$+ capt_exp_of_prim_typ char_ptr
$+ capt_exp_of_prim_typ (Typ.mk (Typ.Tint Typ.size_t))
$--> StdBasicString.constructor_from_char_ptr_with_len
; -"std" &:: "basic_string"
< capt_typ `T
&+...>:: "empty" $ capt_arg $--> StdBasicString.empty
; -"std" &:: "basic_string"
< capt_typ `T
&+...>:: "length" $ capt_arg $--> StdBasicString.length
; -"std" &:: "basic_string"
< capt_typ `T
&+...>:: "size" $ capt_arg $--> StdBasicString.length
; -"std" &:: "basic_string" < capt_typ &+...>:: "empty" $ capt_arg $--> StdBasicString.empty
; -"std" &:: "basic_string" < capt_typ &+...>:: "length" $ capt_arg $--> StdBasicString.length
; -"std" &:: "basic_string" < capt_typ &+...>:: "size" $ capt_arg $--> StdBasicString.length
; -"std" &:: "basic_string" &:: "compare" &--> by_value Dom.Val.Itv.top
; +PatternMatch.implements_lang "String"
&:: "equals"
@ -1314,35 +1303,26 @@ module Call = struct
$+ any_arg_of_typ (-"std" &:: "basic_string")
$--> by_value Dom.Val.Itv.unknown_bool
; -"std" &:: "basic_string" &::.*--> no_model
; -"std" &:: "vector"
< capt_typ `T
&+ any_typ >:: "vector"
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "vector"
$ capt_arg_of_typ (-"std" &:: "vector")
$--> StdVector.constructor_empty
; -"std" &:: "vector"
< capt_typ `T
&+ any_typ >:: "vector"
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "vector"
$ capt_arg_of_typ (-"std" &:: "vector")
$+ capt_exp_of_prim_typ (Typ.mk (Typ.Tint Typ.size_t))
$+? any_arg $--> StdVector.constructor_size
; -"std" &:: "vector"
< capt_typ `T
&+ any_typ >:: "vector"
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "vector"
$ capt_arg_of_typ (-"std" &:: "vector")
$+ capt_exp_of_typ (-"std" &:: "vector")
$+? any_arg $--> StdVector.constructor_copy
; -"std" &:: "vector"
< capt_typ `T
&+ any_typ >:: "operator[]"
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "operator[]"
$ capt_arg_of_typ (-"std" &:: "vector")
$+ capt_exp $--> StdVector.at
; -"std" &:: "vector" < capt_typ `T &+ any_typ >:: "empty" $ capt_arg $--> StdVector.empty
; -"std" &:: "vector" < capt_typ `T &+ any_typ >:: "data" $ capt_arg $--> StdVector.data
; -"std" &:: "vector"
< capt_typ `T
&+ any_typ >:: "push_back" $ capt_arg $+ capt_exp $--> StdVector.push_back
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "empty" $ capt_arg $--> StdVector.empty
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "data" $ capt_arg $--> StdVector.data
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "push_back" $ capt_arg $+ capt_exp
$--> StdVector.push_back
; -"std" &:: "vector" < any_typ &+ any_typ >:: "reserve" $ any_arg $+ any_arg $--> no_model
; -"std" &:: "vector" < capt_typ `T &+ any_typ >:: "size" $ capt_arg $--> StdVector.size
; -"std" &:: "vector" < capt_typ &+ any_typ >:: "size" $ capt_arg $--> StdVector.size
; +PatternMatch.implements_collection
&:: "<init>" <>$ capt_var_exn
$+ capt_exp_of_typ (+PatternMatch.implements_collection)

@ -33,7 +33,7 @@ end
let dispatch : (Tenv.t, typ_model, unit) ProcnameDispatcher.TypName.dispatcher =
let open ProcnameDispatcher.TypName in
make_dispatcher
[ -"std" &:: "array" < capt_typ `T &+ capt_int >--> std_array
[ -"std" &:: "array" < capt_typ &+ capt_int >--> std_array
; -"std" &:: "vector" < any_typ &+ any_typ >--> std_vector
; +PatternMatch.implements_collection &::.*--> Java.collection
; +PatternMatch.implements_iterator &::.*--> Java.collection

Loading…
Cancel
Save