[ocamlformat] upgrade ocamlformat to 0.9

Reviewed By: jeremydubreil

Differential Revision: D14668400

fbshipit-source-id: 9d22da9a8
master
Josh Berdine 6 years ago committed by Facebook Github Bot
parent 757460ade7
commit 4acad5ca90

@ -1,4 +1,4 @@
profile = ocamlformat
let-binding-spacing = sparse
break-cases = nested
margin = 100
version = 0.8
version = 0.9

@ -1 +1 @@
e2cf2fd21fdc2f79840ddf994403a0c2469b6bfd
9006560863e9323b8ee3e4d78fd0e799fe10259c

@ -803,7 +803,7 @@ endif
# This is a magical version number that doesn't reinstall the world when added on top of what we
# have in opam.locked. To upgrade this version number, manually try to install several utop versions
# until you find one that doesn't recompile the world. TODO(t20828442): get rid of magic
OPAM_DEV_DEPS = ocamlformat.0.8 ocp-indent merlin utop.2.2.0 webbrowser
OPAM_DEV_DEPS = ocamlformat.$$(grep version .ocamlformat | cut -d ' ' -f 3) ocp-indent merlin utop.2.2.0 webbrowser
ifneq ($(EMACS),no)
OPAM_DEV_DEPS += tuareg

@ -101,8 +101,8 @@ type err_data =
; linters_def_file: string option
; doc_url: string option
; access: string option
; extras: Jsonbug_t.extra option
(* NOTE: Please consider adding new fields as part of extras *) }
; extras: Jsonbug_t.extra option (* NOTE: Please consider adding new fields as part of extras *)
}
let compare_err_data err_data1 err_data2 = Location.compare err_data1.loc err_data2.loc

@ -251,7 +251,7 @@ end)
let hashqueue_of_sequence ?init s =
let q = match init with None -> HashQueue.create () | Some q0 -> q0 in
Sequence.iter s ~f:(fun id ->
let _ : [`Key_already_present | `Ok] = HashQueue.enqueue q id () in
let (_ : [`Key_already_present | `Ok]) = HashQueue.enqueue q id () in
() ) ;
q

@ -12,7 +12,8 @@ open! IStd
let errLogMap = ref Typ.Procname.Map.empty
let get_errlog procname =
try Typ.Procname.Map.find procname !errLogMap with Caml.Not_found ->
try Typ.Procname.Map.find procname !errLogMap
with Caml.Not_found ->
let errlog = Errlog.empty () in
errLogMap := Typ.Procname.Map.add procname errlog !errLogMap ;
errlog

@ -105,9 +105,7 @@ let get_value_line_tag tags =
let value = snd (List.find_exn ~f:(fun (tag, _) -> String.equal tag Tags.value) tags) in
let line = snd (List.find_exn ~f:(fun (tag, _) -> String.equal tag Tags.line) tags) in
Some [value; line]
with
| Not_found_s _ | Caml.Not_found ->
None
with Not_found_s _ | Caml.Not_found -> None
(** extract from desc a value on which to apply polymorphic hash and equality *)
@ -630,7 +628,8 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc
match bucket_opt with Some bucket when Config.show_buckets -> bucket | _ -> ""
in
{ no_desc with
descriptions= (bucket_str :: xxx_allocated_to) @ by_call_to @ is_not_rxxx_after; tags= !tags }
descriptions= (bucket_str :: xxx_allocated_to) @ by_call_to @ is_not_rxxx_after
; tags= !tags }
(** kind of precondition not met *)

@ -447,7 +447,7 @@ let compute_distance_to_exit_node pdesc =
(** check or indicate if we have performed preanalysis on the CFG *)
let did_preanalysis pdesc = pdesc.attributes.did_preanalysis
let signal_did_preanalysis pdesc = (pdesc.attributes).did_preanalysis <- true
let signal_did_preanalysis pdesc = pdesc.attributes.did_preanalysis <- true
let get_attributes pdesc = pdesc.attributes
@ -546,7 +546,7 @@ let set_start_node pdesc node = pdesc.start_node <- node
(** Append the locals to the list of local variables *)
let append_locals pdesc new_locals =
(pdesc.attributes).locals <- pdesc.attributes.locals @ new_locals
pdesc.attributes.locals <- pdesc.attributes.locals @ new_locals
let set_succs_exn_only (node : Node.t) exn = node.exn <- exn
@ -622,7 +622,7 @@ let get_wto pdesc =
wto
| None ->
let wto = WTO.make pdesc in
let _ : int =
let (_ : int) =
WeakTopologicalOrder.Partition.fold_nodes wto ~init:0 ~f:(fun idx node ->
node.Node.wto_index <- idx ;
idx + 1 )

@ -76,14 +76,21 @@ type ( 'f_in
, 'captured_types_out
, 'markers_in
, 'markers_out
, 'list_constraint ) template_arg =
, '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) templ_matcher
=
type ( 'context
, 'f_in
, 'f_out
, 'captured_types
, 'markers_in
, 'markers_out
, 'list_constraint )
templ_matcher =
{ on_objc_cpp:
'context
-> 'f_in

@ -33,9 +33,17 @@ type ( 'f_in
, 'captured_types_out
, 'markers_in
, 'markers_out
, 'list_constraint ) template_arg
, 'list_constraint )
template_arg
type ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'list_constraint) templ_matcher
type ( 'context
, 'f_in
, 'f_out
, 'captured_types
, 'markers_in
, 'markers_out
, 'list_constraint )
templ_matcher
(* A matcher is a rule associating a function [f] to a [C/C++ function/method]:
- [C/C++ function/method] --> [f]

@ -1408,7 +1408,8 @@ let hpred_compact_ sh hpred =
let hpred_compact sh hpred =
try HpredInstHash.find sh.hpredh hpred with Caml.Not_found ->
try HpredInstHash.find sh.hpredh hpred
with Caml.Not_found ->
let hpred' = hpred_compact_ sh hpred in
HpredInstHash.add sh.hpredh hpred' hpred' ;
hpred'

@ -23,7 +23,8 @@ let convert_cfg ~callee_pdesc ~resolved_pdesc ~f_instr_list =
[]
| node :: other_node ->
let converted_node =
try Procdesc.NodeMap.find node !node_map with Caml.Not_found ->
try Procdesc.NodeMap.find node !node_map
with Caml.Not_found ->
let new_node = convert_node node
and successors = Procdesc.Node.get_succs node
and exn_nodes = Procdesc.Node.get_exn node in
@ -67,8 +68,8 @@ let with_formals_types_proc callee_pdesc resolved_pdesc substitutions =
, {Typ.desc= Tptr ({desc= Tstruct origin_typename}, Pk_pointer)}
, loc ) ->
let specialized_typname =
try Mangled.Map.find (Pvar.get_name origin_pvar) substitutions with Caml.Not_found ->
origin_typename
try Mangled.Map.find (Pvar.get_name origin_pvar) substitutions
with Caml.Not_found -> origin_typename
in
subst_map := Ident.Map.add id specialized_typname !subst_map ;
Some (Sil.Load (id, convert_exp origin_exp, mk_ptr_typ specialized_typname, loc))

@ -84,7 +84,8 @@ end)
let check_subtype =
let subtMap = ref SubtypesMap.empty in
fun tenv c1 c2 ->
( try SubtypesMap.find (c1, c2) !subtMap with Caml.Not_found ->
( try SubtypesMap.find (c1, c2) !subtMap
with Caml.Not_found ->
let is_subt = check_subclass_tenv tenv c1 c2 in
subtMap := SubtypesMap.add (c1, c2) is_subt !subtMap ;
is_subt

@ -45,7 +45,8 @@ let mk_struct tenv ?default ?fields ?statics ?methods ?exported_objc_methods ?su
(** Look up a name in the global type environment. *)
let lookup tenv name : Typ.Struct.t option =
try Some (TypenameHash.find tenv name) with Caml.Not_found -> (
try Some (TypenameHash.find tenv name)
with Caml.Not_found -> (
(* ToDo: remove the following additional lookups once C/C++ interop is resolved *)
match (name : Typ.Name.t) with
| CStruct m -> (

@ -567,7 +567,7 @@ struct
None
| Some s ->
let s' = S.remove v s in
if S.is_empty s' then None else Some s')
if S.is_empty s' then None else Some s' )
m
end

@ -499,8 +499,8 @@ module Stats = struct
let process_loc loc stats =
try Hashtbl.find stats.files loc.Location.file with Caml.Not_found ->
Hashtbl.add stats.files loc.Location.file ()
try Hashtbl.find stats.files loc.Location.file
with Caml.Not_found -> Hashtbl.add stats.files loc.Location.file ()
let loc_trace_to_string_list linereader indent_num ltr =

@ -190,8 +190,8 @@ let load_summary_to_spec_table =
let get proc_name =
try Some (Typ.Procname.Hash.find cache proc_name) with Caml.Not_found ->
load_summary_to_spec_table proc_name
try Some (Typ.Procname.Hash.find cache proc_name)
with Caml.Not_found -> load_summary_to_spec_table proc_name
(** Check if the procedure is from a library:

@ -47,7 +47,7 @@ module Runner = struct
ProcessPool.create ~jobs ~f
~child_prelude:
((* hack: run post-fork bookkeeping stuff by passing a dummy function to [fork_protect] *)
fork_protect ~f:(fun () -> () ))
fork_protect ~f:(fun () -> ()))
in
ResultsDatabase.new_database_connection () ;
PerfEvent.(log (fun logger -> log_end_event logger ())) ;

@ -112,7 +112,8 @@ let strip_special_chars b =
let replace st c c' =
if Bytes.contains st c then (
let idx = String.index_exn (Bytes.to_string st) c in
try Bytes.set st idx c' ; st with Invalid_argument _ ->
try Bytes.set st idx c' ; st
with Invalid_argument _ ->
L.internal_error "@\n@\nstrip_special_chars: Invalid argument!@\n@." ;
assert false )
else st

@ -41,7 +41,8 @@ type t =
; file_map: file_data SourceFile.Hash.t (** map from source files to file data *) }
let get_file_data exe_env pname =
try Some (Typ.Procname.Hash.find exe_env.proc_map pname) with Caml.Not_found ->
try Some (Typ.Procname.Hash.find exe_env.proc_map pname)
with Caml.Not_found ->
let source_file_opt =
match Attributes.load pname with
| None ->

@ -73,7 +73,8 @@ module FileContainsStringMatcher = struct
let source_map = ref SourceFile.Map.empty in
let regexp = Str.regexp (String.concat ~sep:"\\|" s_patterns) in
fun source_file ->
try SourceFile.Map.find source_file !source_map with Caml.Not_found -> (
try SourceFile.Map.find source_file !source_map
with Caml.Not_found -> (
try
let file_in = In_channel.create (SourceFile.to_abs_path source_file) in
let pattern_found = file_contains regexp file_in in
@ -102,9 +103,8 @@ module FileOrProcMatcher = struct
List.fold
~f:(fun map pattern ->
let previous =
try String.Map.find_exn map pattern.class_name with
| Not_found_s _ | Caml.Not_found ->
[]
try String.Map.find_exn map pattern.class_name
with Not_found_s _ | Caml.Not_found -> []
in
String.Map.set ~key:pattern.class_name ~data:(pattern :: previous) map )
~init:String.Map.empty m_patterns
@ -118,9 +118,7 @@ module FileOrProcMatcher = struct
~f:(fun p ->
match p.method_name with None -> true | Some m -> String.equal m method_name )
class_patterns
with
| Not_found_s _ | Caml.Not_found ->
false
with Not_found_s _ | Caml.Not_found -> false
in
fun _ proc_name ->
match proc_name with Typ.Procname.Java pname_java -> do_java pname_java | _ -> false

@ -248,7 +248,8 @@ let analyze_proc_desc ~caller_pdesc callee_pdesc =
if is_active callee_pname then None
else
let cache = Lazy.force cached_results in
try Typ.Procname.Hash.find cache callee_pname with Caml.Not_found ->
try Typ.Procname.Hash.find cache callee_pname
with Caml.Not_found ->
let summary_option, update_memcached =
match memcache_get callee_pname with
| Some summ_opt ->
@ -279,7 +280,8 @@ let analyze_proc_name ?caller_pdesc callee_pname =
if is_active callee_pname then None
else
let cache = Lazy.force cached_results in
try Typ.Procname.Hash.find cache callee_pname with Caml.Not_found ->
try Typ.Procname.Hash.find cache callee_pname
with Caml.Not_found ->
let summary_option, update_memcached =
match memcache_get callee_pname with
| Some summ_opt ->

@ -43,7 +43,8 @@ module LineReader = struct
let file_data (hash : t) fname =
try Some (Hashtbl.find hash fname) with Caml.Not_found -> (
try Some (Hashtbl.find hash fname)
with Caml.Not_found -> (
try
let lines_arr = read_file (SourceFile.to_abs_path fname) in
Hashtbl.add hash fname lines_arr ; Some lines_arr

@ -281,7 +281,8 @@ let mk ?(deprecated = []) ?(parse_mode = InferCommand) ?(in_help = []) ~long ?sh
let variable = ref default in
let closure = mk_setter variable in
let setter str =
try closure str with exc ->
try closure str
with exc ->
raise (Arg.Bad (F.sprintf "bad value %s for flag %s (%s)" str long (Exn.to_string exc)))
in
let spec = mk_spec setter in
@ -1000,8 +1001,8 @@ let wrap_line indent_string wrap_length line0 =
let word_length =
let len = String.length word in
if String.is_prefix ~prefix:"$(b," word || String.is_prefix ~prefix:"$(i," word then
len - 4 (* length of formatting tag prefix *)
- 1 (* APPROXIMATION: closing parenthesis that will come after the word, or maybe later *)
len - 4 (* length of formatting tag prefix *) - 1
(* APPROXIMATION: closing parenthesis that will come after the word, or maybe later *)
else len
in
let new_length = line_length + String.length word_sep_str + word_length in
@ -1045,8 +1046,7 @@ let show_manual ?internal_section format default_doc command_opt =
blocks, so we do a bit of formatting by hand *)
let indent_string = " " in
let width =
77 (* Cmdliner.Manpage width limit it seems *)
- 7
77 (* Cmdliner.Manpage width limit it seems *) - 7
(* base indentation of documentation strings *)
in
`I (Format.asprintf "$(b,%s)%a%a" (dashdash long) pp_short short pp_meta meta, doc_first_line)

@ -108,19 +108,19 @@ let string_of_build_system build_system =
let build_system_of_exe_name name =
try List.Assoc.find_exn ~equal:String.equal (List.Assoc.inverse build_system_exe_assoc) name with
| Not_found_s _ | Caml.Not_found ->
L.(die UserError)
"Unsupported build command '%s'.@\n\
If this is an alias for another build system that infer supports, you can use@\n\
`--force-integration <command>` where <command> is one of the following supported build \
systems:@\n\
@[<v2> %a@]"
name
(Pp.seq ~print_env:Pp.text_break ~sep:"" F.pp_print_string)
( List.map ~f:fst build_system_exe_assoc
|> List.map ~f:string_of_build_system
|> List.dedup_and_sort ~compare:String.compare )
try List.Assoc.find_exn ~equal:String.equal (List.Assoc.inverse build_system_exe_assoc) name
with Not_found_s _ | Caml.Not_found ->
L.(die UserError)
"Unsupported build command '%s'.@\n\
If this is an alias for another build system that infer supports, you can use@\n\
`--force-integration <command>` where <command> is one of the following supported build \
systems:@\n\
@[<v2> %a@]"
name
(Pp.seq ~print_env:Pp.text_break ~sep:"" F.pp_print_string)
( List.map ~f:fst build_system_exe_assoc
|> List.map ~f:string_of_build_system
|> List.dedup_and_sort ~compare:String.compare )
(** Constant configuration values *)
@ -682,7 +682,7 @@ and ( annotation_reachability
and starvation = mk_checker ~long:"starvation" ~default:false "starvation analysis"
and uninit = mk_checker ~long:"uninit" "checker for use of uninitialized values" ~default:true in
let mk_only (var, long, doc, _) =
let _ : bool ref =
let (_ : bool ref) =
CLOpt.mk_bool_group ~long:(long ^ "-only")
~in_help:InferCommand.[(Analyze, manual_generic)]
~f:(fun b ->
@ -691,8 +691,7 @@ and ( annotation_reachability
b )
( if String.equal doc "" then ""
else Printf.sprintf "Enable $(b,--%s) and disable all other checkers" long )
[] (* do all the work in ~f *)
[]
[] (* do all the work in ~f *) []
(* do all the work in ~f *)
in
()
@ -714,8 +713,7 @@ and ( annotation_reachability
var := if b then default || !var else (not default) && !var )
!all_checkers ;
b )
[] (* do all the work in ~f *)
[]
[] (* do all the work in ~f *) []
(* do all the work in ~f *)
in
( annotation_reachability
@ -1099,7 +1097,7 @@ and ( bo_debug
; write_html
; write_dotty ]
[filtering; only_cheap_debug]
and _ : int option ref =
and (_ : int option ref) =
CLOpt.mk_int_opt ~long:"debug-level" ~in_help:all_generic_manuals ~meta:"level"
~f:(fun level -> set_debug_level level ; level)
{|Debug level (sets $(b,--bo-debug) $(i,level), $(b,--debug-level-analysis) $(i,level), $(b,--debug-level-capture) $(i,level), $(b,--debug-level-linters) $(i,level)):
@ -1196,7 +1194,7 @@ and differential_filter_set =
and () =
let mk b ?deprecated ~long ?default doc =
let _ : string list ref =
let (_ : string list ref) =
CLOpt.mk_string_list ?deprecated ~long
~f:(fun issue_id ->
let issue = IssueType.from_string issue_id in
@ -2074,7 +2072,7 @@ and specs_library =
CLOpt.mk_path_list ~deprecated:["lib"] ~long:"specs-library" ~short:'L' ~meta:"dir|jar"
"Search for .spec files in given directory or jar file"
in
let _ : string ref =
let (_ : string ref) =
(* Given a filename with a list of paths, convert it into a list of string iff they are
absolute *)
let read_specs_dir_list_file fname =

@ -13,7 +13,8 @@ let late_callback = ref (fun () -> ())
let register callback_ref ~f ~description =
let f_no_exn () =
try f () with exn ->
try f ()
with exn ->
F.eprintf "%a: Error while running epilogue \"%s\":@ %a.@ Powering through...@." Pid.pp
(Unix.getpid ()) description Exn.pp exn
in

@ -152,7 +152,8 @@ module Make (V : Value) : Server with module Value = V = struct
let set_ =
let buffer = ref (Bytes.create 1024) in
let rec try_to_buffer value =
try Marshal.to_buffer !buffer 0 (Bytes.length !buffer) value [] with Failure _ ->
try Marshal.to_buffer !buffer 0 (Bytes.length !buffer) value []
with Failure _ ->
(* double buffer length *)
buffer := Bytes.create (2 * Bytes.length !buffer) ;
try_to_buffer value

@ -48,9 +48,8 @@ let write multilinks ~dir =
let lookup ~dir =
try Some (String.Table.find_exn multilink_files_cache dir) with
| Not_found_s _ | Caml.Not_found ->
read ~dir
try Some (String.Table.find_exn multilink_files_cache dir)
with Not_found_s _ | Caml.Not_found -> read ~dir
let resolve fname =
@ -63,6 +62,5 @@ let resolve fname =
| None ->
fname
| Some links -> (
try DB.filename_from_string (String.Table.find_exn links base) with
| Not_found_s _ | Caml.Not_found ->
fname )
try DB.filename_from_string (String.Table.find_exn links base)
with Not_found_s _ | Caml.Not_found -> fname )

@ -124,7 +124,8 @@ let killall pool ~slot status =
Array.iter pool.slots ~f:(fun {pid} ->
match Signal.send Signal.term (`Pid pid) with `Ok | `No_such_process -> () ) ;
Array.iter pool.slots ~f:(fun {pid} ->
try Unix.wait (`Pid pid) |> ignore with Unix.Unix_error (ECHILD, _, _) ->
try Unix.wait (`Pid pid) |> ignore
with Unix.Unix_error (ECHILD, _, _) ->
(* some children may have died already, it's fine *) () ) ;
L.die InternalError "Subprocess %d: %s" slot status
@ -197,7 +198,8 @@ let rec child_loop ~slot send_to_parent receive_from_parent ~f =
| GoHome ->
()
| Do stuff ->
( try f stuff with e ->
( try f stuff
with e ->
IExn.reraise_if e ~f:(fun () ->
if Config.keep_going then (
L.internal_error "Error in subprocess %d: %a@." slot Exn.pp e ;

@ -59,8 +59,8 @@ let create_db () =
(* Can't use WAL with custom VFS *)
() ) ;
SqliteUtils.db_close db ;
try Sys.rename temp_db database_fullpath with Sys_error _ ->
(* lost the race, doesn't matter *) ()
try Sys.rename temp_db database_fullpath
with Sys_error _ -> (* lost the race, doesn't matter *) ()
let new_db_callbacks = ref []
@ -78,7 +78,8 @@ let register_statement =
let stmt_ref = ref None in
let new_statement db =
let stmt =
try Sqlite3.prepare db stmt0 with Sqlite3.Error error ->
try Sqlite3.prepare db stmt0
with Sqlite3.Error error ->
L.die InternalError "Could not prepare the following statement:@\n%s@\nReason: %s" stmt0
error
in

@ -139,11 +139,11 @@ let is_under_project_root = function
let exists_cache = String.Table.create ~size:256 ()
let path_exists abs_path =
try String.Table.find_exn exists_cache abs_path with
| Not_found_s _ | Caml.Not_found ->
let result = Sys.file_exists abs_path = `Yes in
String.Table.set exists_cache ~key:abs_path ~data:result ;
result
try String.Table.find_exn exists_cache abs_path
with Not_found_s _ | Caml.Not_found ->
let result = Sys.file_exists abs_path = `Yes in
String.Table.set exists_cache ~key:abs_path ~data:result ;
result
let of_header ?(warn_on_error = true) header_file =

@ -27,8 +27,8 @@ let exec db ~log ~stmt =
PerfEvent.log_begin_event logger ~name:"sql exec" ~arguments:[("stmt", `String log)] () ) ;
let rc = Sqlite3.exec db stmt in
PerfEvent.(log (fun logger -> log_end_event logger ())) ;
try check_result_code ~fatal:true db ~log rc with Error err ->
error ~fatal:true "exec: %s (%s)" err (Sqlite3.errmsg db)
try check_result_code ~fatal:true db ~log rc
with Error err -> error ~fatal:true "exec: %s (%s)" err (Sqlite3.errmsg db)
let finalize db ~log stmt =

@ -36,7 +36,8 @@ let try_finally ~f ~finally =
| finally_exn
when (* do not swallow Analysis_failure_exe thrown from finally *)
match finally_exn with Analysis_failure_exe _ -> false | _ -> true
-> () )
->
() )
let pp_failure_kind fmt = function

@ -163,7 +163,8 @@ let read_json_file path =
let do_finally_swallow_timeout ~f ~finally =
let res =
try f () with exc ->
try f ()
with exc ->
IExn.reraise_after exc ~f:(fun () ->
try finally () |> ignore with _ -> (* swallow in favor of the original exception *) () )
in
@ -252,7 +253,8 @@ let create_dir dir =
if (Unix.stat dir).Unix.st_kind <> Unix.S_DIR then
L.(die ExternalError) "file '%s' already exists and is not a directory" dir
with Unix.Unix_error _ -> (
try Unix.mkdir dir ~perm:0o700 with Unix.Unix_error _ ->
try Unix.mkdir dir ~perm:0o700
with Unix.Unix_error _ ->
let created_concurrently =
(* check if another process created it meanwhile *)
try Polymorphic_compare.( = ) (Unix.stat dir).Unix.st_kind Unix.S_DIR

@ -80,7 +80,7 @@ let get tenv prop exp category =
| Sil.Apred (att, _) | Anpred (att, _) ->
PredSymb.equal_category (PredSymb.to_category att) category
| _ ->
false)
false )
atts
@ -300,7 +300,7 @@ let deallocate_stack_vars tenv (p : 'a Prop.t) pvars =
fresh_address_vars := (v, freshv) :: !fresh_address_vars ;
(Exp.Lvar v, Exp.Var freshv)
| _ ->
assert false)
assert false )
sigma_stack
in
let pi1 = List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in

@ -39,8 +39,8 @@ let check_register_populated () =
(** get the symbolic execution handler associated to the builtin function name *)
let get name : t option =
try Some (Typ.Procname.Hash.find builtin_functions name) with Caml.Not_found ->
check_register_populated () ; None
try Some (Typ.Procname.Hash.find builtin_functions name)
with Caml.Not_found -> check_register_populated () ; None
(** register a builtin [Typ.Procname.t] and symbolic execution handler *)

@ -221,7 +221,7 @@ let execute___get_type_of {Builtin.pdesc; tenv; prop_; path; ret_id_typ; args} :
let hpred_opt =
List.find_map
~f:(function
| Sil.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None)
| Sil.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None )
prop.Prop.sigma
in
match hpred_opt with

@ -526,6 +526,7 @@ module Rename : sig
val get_unify_eqs : unit -> (Exp.t * Exp.t) list
val to_subst_emb : side -> Sil.subst
(*
val get : Exp.t -> Exp.t -> Exp.t option
val pp : printenv -> Format.formatter -> (Exp.t * Exp.t * Exp.t) list -> unit
@ -687,8 +688,8 @@ end = struct
in
List.iter ~f:handle_triple !tbl ;
let rep x =
try H.find rep_cache (get x) with Caml.Not_found ->
L.die L.InternalError "Dom.Rename.get_unify_eqs broken"
try H.find rep_cache (get x)
with Caml.Not_found -> L.die L.InternalError "Dom.Rename.get_unify_eqs broken"
in
rep
in

@ -242,8 +242,9 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
in
let do_empty_hpats iter_cur _ =
let sub_new, vars_leftover =
match Prop.prop_iter_current tenv iter_cur with _, (sub_new, vars_leftover) ->
(sub_new, vars_leftover)
match Prop.prop_iter_current tenv iter_cur with
| _, (sub_new, vars_leftover) ->
(sub_new, vars_leftover)
in
let sub_res = sub_extend_with_ren sub_new vars_leftover in
let p_leftover = Prop.prop_iter_remove_curr_then_to_prop tenv iter_cur in
@ -256,8 +257,9 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
in
let do_nonempty_hpats iter_cur _ =
let sub_new, vars_leftover =
match Prop.prop_iter_current tenv iter_cur with _, (sub_new, vars_leftover) ->
(sub_new, vars_leftover)
match Prop.prop_iter_current tenv iter_cur with
| _, (sub_new, vars_leftover) ->
(sub_new, vars_leftover)
in
let hpat_next, hpats_rest =
match hpats with [] -> assert false | hpat_next :: hpats_rest -> (hpat_next, hpats_rest)

@ -385,7 +385,8 @@ end = struct
let delayed_num = ref 0 in
let delayed = ref PathMap.empty in
let add_path p =
try ignore (PathMap.find p !delayed) with Caml.Not_found ->
try ignore (PathMap.find p !delayed)
with Caml.Not_found ->
incr delayed_num ;
delayed := PathMap.add p !delayed_num !delayed
in

@ -971,8 +971,8 @@ module Normalize = struct
else
match (e1, e2) with
| Const (Cint n), Const (Cint m) -> (
try Exp.int (IntLit.shift_left n m) with IntLit.OversizedShift ->
BinOp (Shiftlt, eval e1, eval e2) )
try Exp.int (IntLit.shift_left n m)
with IntLit.OversizedShift -> BinOp (Shiftlt, eval e1, eval e2) )
| _, Const (Cint m) when IntLit.iszero m ->
eval e1
| _, Const (Cint m) when IntLit.isone m ->
@ -986,8 +986,8 @@ module Normalize = struct
else
match (e1, e2) with
| Const (Cint n), Const (Cint m) -> (
try Exp.int (IntLit.shift_right n m) with IntLit.OversizedShift ->
BinOp (Shiftrt, eval e1, eval e2) )
try Exp.int (IntLit.shift_right n m)
with IntLit.OversizedShift -> BinOp (Shiftrt, eval e1, eval e2) )
| _, Const (Cint m) when IntLit.iszero m ->
eval e1
| Const (Cint m), _ when IntLit.iszero m ->
@ -2411,7 +2411,10 @@ let prop_iter_next iter =
| hpred' :: new' ->
Some
{ iter with
pit_old= iter.pit_curr :: iter.pit_old; pit_curr= hpred'; pit_state= (); pit_new= new' }
pit_old= iter.pit_curr :: iter.pit_old
; pit_curr= hpred'
; pit_state= ()
; pit_new= new' }
(** Insert before the current element of the iterator. *)

@ -105,7 +105,7 @@ let remove_abduced_retvars tenv p =
| Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) ->
exp_contains lhs || exp_contains rhs
| Sil.Apred (_, es) | Sil.Anpred (_, es) ->
List.exists ~f:exp_contains es)
List.exists ~f:exp_contains es )
pi
in
(Sil.HpredSet.elements reach_hpreds, reach_pi)

@ -14,7 +14,8 @@ module L = Logging
module F = Format
let decrease_indent_when_exception thunk =
try thunk () with exn when SymOp.exn_not_failure exn ->
try thunk ()
with exn when SymOp.exn_not_failure exn ->
IExn.reraise_after exn ~f:(fun () -> L.d_decrease_indent ())
@ -489,7 +490,7 @@ end = struct
(* [e <= n' <= n |- e <= n] *)
List.exists
~f:(function
| e', Exp.Const (Const.Cint n') -> Exp.equal e e' && IntLit.leq n' n | _, _ -> false)
| e', Exp.Const (Const.Cint n') -> Exp.equal e e' && IntLit.leq n' n | _, _ -> false )
leqs
| Exp.Const (Const.Cint n), e ->
(* [ n-1 <= n' < e |- n <= e] *)
@ -498,7 +499,7 @@ end = struct
| Exp.Const (Const.Cint n'), e' ->
Exp.equal e e' && IntLit.leq (n -- IntLit.one) n'
| _, _ ->
false)
false )
lts
| _ ->
Exp.equal e1 e2
@ -514,7 +515,7 @@ end = struct
(* [n <= n' < e |- n < e] *)
List.exists
~f:(function
| Exp.Const (Const.Cint n'), e' -> Exp.equal e e' && IntLit.leq n n' | _, _ -> false)
| Exp.Const (Const.Cint n'), e' -> Exp.equal e e' && IntLit.leq n n' | _, _ -> false )
lts
| e, Exp.Const (Const.Cint n) ->
(* [e <= n' <= n-1 |- e < n] *)
@ -523,7 +524,7 @@ end = struct
| e', Exp.Const (Const.Cint n') ->
Exp.equal e e' && IntLit.leq n' (n -- IntLit.one)
| _, _ ->
false)
false )
leqs
| _ ->
false
@ -1459,8 +1460,8 @@ let array_len_imply tenv calc_missing subs len1 len2 indices2 =
| _, Exp.BinOp (Binop.PlusA _, Exp.Var _, _)
| _, Exp.BinOp (Binop.PlusA _, _, Exp.Var _)
| Exp.BinOp (Binop.Mult _, _, _), _ -> (
try exp_imply tenv calc_missing subs len1 len2 with IMPL_EXC (s, subs', x) ->
raise (IMPL_EXC ("array len:" ^ s, subs', x)) )
try exp_imply tenv calc_missing subs len1 len2
with IMPL_EXC (s, subs', x) -> raise (IMPL_EXC ("array len:" ^ s, subs', x)) )
| _ ->
ProverState.add_bounds_check (ProverState.BClen_imply (len1, len2, indices2)) ;
subs
@ -2175,10 +2176,11 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
let subs' = exp_list_imply tenv calc_missing subs (f2 :: elist2) (f2 :: elist2) in
let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in
let hpred1 =
match Prop.prop_iter_current tenv iter1' with hpred1, b ->
if b then ProverState.add_missing_pi (Sil.Aneq (e2_, f2_)) ;
(* for PE |- NE *)
hpred1
match Prop.prop_iter_current tenv iter1' with
| hpred1, b ->
if b then ProverState.add_missing_pi (Sil.Aneq (e2_, f2_)) ;
(* for PE |- NE *)
hpred1
in
match hpred1 with
| Sil.Hlseg _ ->

@ -616,7 +616,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
| Sil.Hlseg (_, _, e1, _, _) ->
Exp.equal e e1
| Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) ->
Exp.equal e e_iF || Exp.equal e e_iB)
Exp.equal e e_iF || Exp.equal e e_iB )
footprint_sigma
in
let atoms_sigma_list =
@ -829,7 +829,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
when Exp.equal lhs_exp matching_exp ->
get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds
| _ ->
None)
None )
sigma
| _ ->
None )
@ -954,7 +954,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
false )
flds
| _ ->
false)
false )
prop.Prop.sigma
in
Procdesc.get_access pdesc <> PredSymb.Private
@ -1502,9 +1502,8 @@ let attr_has_annot is_annotation tenv prop exp =
| _ ->
None
in
try List.find_map ~f:attr_has_annot (Attribute.get_for_exp tenv prop exp) with
| Not_found_s _ | Caml.Not_found ->
None
try List.find_map ~f:attr_has_annot (Attribute.get_for_exp tenv prop exp)
with Not_found_s _ | Caml.Not_found -> None
let is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp (fld, strexp) =

@ -21,7 +21,7 @@ type failure_stats =
mutable node_ok: int
; (* number of node successes (i.e. no instruction failures) *)
mutable first_failure: (Location.t * Procdesc.Node.t * int * Errlog.loc_trace * exn) option
(* exception at the first failure *) }
(* exception at the first failure *) }
module NodeHash = Procdesc.NodeHash
@ -67,7 +67,8 @@ let reset_diverging_states_node () = !gs.diverging_states_node <- Paths.PathSet.
let reset () = gs := initial ()
let get_failure_stats node =
try NodeHash.find !gs.failure_map node with Caml.Not_found ->
try NodeHash.find !gs.failure_map node
with Caml.Not_found ->
let fs = {instr_fail= 0; instr_ok= 0; node_fail= 0; node_ok= 0; first_failure= None} in
NodeHash.add !gs.failure_map node fs ;
fs

@ -1484,8 +1484,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_ : Prop.normal Prop.t)
let eprop = Prop.expose prop_ in
match
List.partition_tf
~f:(function
| Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false)
~f:(function Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false)
eprop.Prop.sigma
with
| [Sil.Hpointsto (e, se, typ)], sigma' ->
@ -1525,7 +1524,8 @@ and instrs ?(mask_errors = false) exe_env tenv pdesc instrs ppl =
L.d_str "Executing Generated Instruction " ;
Sil.d_instr instr ;
L.d_ln () ;
try sym_exec exe_env tenv pdesc instr p path with exn ->
try sym_exec exe_env tenv pdesc instr p path
with exn ->
IExn.reraise_if exn ~f:(fun () -> (not mask_errors) || not (SymOp.exn_not_failure exn)) ;
let error = Exceptions.recognize_exception exn in
let loc =
@ -1587,7 +1587,7 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call
| Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual ->
Sil.Hpointsto (lhs, abduced_strexp, typ_exp)
| hpred ->
hpred)
hpred )
prop'.Prop.sigma
in
Prop.normalize tenv (Prop.set prop' ~sigma:filtered_sigma)
@ -1596,8 +1596,7 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call
let prop' =
let filtered_sigma =
List.filter
~f:(function
| Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true)
~f:(function Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true)
prop.Prop.sigma
in
Prop.normalize tenv (Prop.set prop ~sigma:filtered_sigma)

@ -56,7 +56,7 @@ let resolve_method_with_block_args_and_analyze ~caller_pdesc pname act_params =
when Procdesc.is_defined pdesc
&& Int.equal (List.length (Procdesc.get_formals pdesc)) (List.length act_params)
(* only specialize defined methods, and when formals and actuals have the same length *)
-> (
-> (
(* a list with the same length of the actual params of the function,
containing either a Closure or None. *)
let block_args =

@ -117,8 +117,7 @@ let log_call_trace ~caller_name ~callee_name ?callee_attributes ?reason ?dynamic
(***************)
let get_specs_from_payload summary =
Option.map summary.Summary.payloads.biabduction ~f:(fun BiabductionSummary.({preposts}) ->
preposts )
Option.map summary.Summary.payloads.biabduction ~f:(fun BiabductionSummary.{preposts} -> preposts)
|> BiabductionSummary.get_specs_from_preposts
@ -650,7 +649,8 @@ let sigma_star_fld tenv (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Si
| _ ->
star sg1 sigma2' )
in
try star sigma1 sigma2 with exn when SymOp.exn_not_failure exn ->
try star sigma1 sigma2
with exn when SymOp.exn_not_failure exn ->
L.d_str "cannot star " ;
Prop.d_sigma sigma1 ;
L.d_str " and " ;
@ -691,7 +691,8 @@ let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Exp.t * Exp.t) list) :
| _ ->
star sg1 typings2' )
in
try star sigma1 typings2 with exn when SymOp.exn_not_failure exn ->
try star sigma1 typings2
with exn when SymOp.exn_not_failure exn ->
L.d_str "cannot star " ;
Prop.d_sigma sigma1 ;
L.d_str " and " ;
@ -1021,7 +1022,7 @@ let mk_posts tenv prop callee_pname posts =
| Sil.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname ->
Prover.check_disequal tenv prop exp Exp.zero
| _ ->
false)
false )
(Attribute.get_all prop)
in
if last_call_ret_non_null then
@ -1031,7 +1032,7 @@ let mk_posts tenv prop callee_pname posts =
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar ->
Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero
| _ ->
false)
false )
prop.Prop.sigma
in
List.filter ~f:(fun (prop, _) -> not (returns_null prop)) posts
@ -1115,7 +1116,8 @@ let add_missing_field_to_tenv ~missing_sigma exe_env caller_tenv callee_pname hp
(* if the callee is a model, then we don't have a tenv for it *)
if (not callee_attributes.ProcAttributes.is_model) && add_fields then
let callee_tenv_opt =
try Some (Exe_env.get_tenv exe_env callee_pname) with _ ->
try Some (Exe_env.get_tenv exe_env callee_pname)
with _ ->
let source_file = callee_attributes.ProcAttributes.loc.Location.file in
Tenv.load source_file
in
@ -1378,7 +1380,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
let exn = get_check_exn tenv check callee_pname loc __POS__ in
raise exn
| _ ->
false)
false )
invalid_res
then call_desc (Some Localise.Pnm_bounds)
else call_desc None

@ -131,7 +131,8 @@ let path_set_create_worklist proc_cfg =
let htable_retrieve (htable : (Procdesc.Node.id, Paths.PathSet.t) Hashtbl.t)
(key : Procdesc.Node.id) : Paths.PathSet.t =
try Hashtbl.find htable key with Caml.Not_found ->
try Hashtbl.find htable key
with Caml.Not_found ->
Hashtbl.replace htable key Paths.PathSet.empty ;
Paths.PathSet.empty
@ -605,8 +606,8 @@ let extract_specs tenv pdesc pathset : Prop.normal BiabductionSummary.spec list
let pre_post_map =
let add map (pre, post, visited) =
let current_posts, current_visited =
try Pmap.find pre map with Caml.Not_found ->
(Paths.PathSet.empty, BiabductionSummary.Visitedset.empty)
try Pmap.find pre map
with Caml.Not_found -> (Paths.PathSet.empty, BiabductionSummary.Visitedset.empty)
in
let new_posts =
match post with
@ -1258,7 +1259,8 @@ let analyze_procedure {Callbacks.summary; proc_desc; tenv; exe_env} : Summary.t
(* make sure models have been registered *)
BuiltinDefn.init () ;
if not (List.is_empty Config.topl_properties) then Topl.init () ;
try analyze_procedure_aux summary exe_env tenv proc_desc with exn ->
try analyze_procedure_aux summary exe_env tenv proc_desc
with exn ->
IExn.reraise_if exn ~f:(fun () -> not (Exceptions.handle_exception exn)) ;
Reporting.log_error_using_state summary exn ;
summary

@ -418,9 +418,10 @@ let report_errors : Tenv.t -> checks -> Summary.t -> unit =
let get_checks_summary : BufferOverrunAnalysis.local_decls -> checks -> checks_summary =
fun locals
Checks.({ cond_set
; unused_branches= _ (* intra-procedural *)
; unreachable_statements= _ (* intra-procedural *) }) ->
Checks.
{ cond_set
; unused_branches= _ (* intra-procedural *)
; unreachable_statements= _ (* intra-procedural *) } ->
PO.ConditionSet.for_summary ~forget_locs:locals cond_set

@ -798,7 +798,7 @@ module Make (Manager : Manager_S) = struct
Texpr1.Unop (uop, re', typ, round) )
| Texpr1.Binop (bop, re1, re2, typ, round) ->
Option.map2 (symexp_raw_subst subst_map re1) (symexp_raw_subst subst_map re2)
~f:(fun re1' re2' -> Texpr1.Binop (bop, re1', re2', typ, round) )
~f:(fun re1' re2' -> Texpr1.Binop (bop, re1', re2', typ, round))
let symexp_subst subst_map x =

@ -136,7 +136,7 @@ let rec must_alias_cmp : Exp.t -> Mem.t -> bool =
let set_array_stride integer_type_widths typ v =
match typ with
| Typ.({desc= Tptr ({desc= Tint ikind}, Pk_pointer)}) ->
| Typ.{desc= Tptr ({desc= Tint ikind}, Pk_pointer)} ->
let width = Typ.width_of_ikind integer_type_widths ikind in
Val.set_array_stride (Z.of_int (width / 8)) v
| _ ->
@ -379,7 +379,8 @@ type eval_mode = EvalNormal | EvalPOCond | EvalPOReachability
let rec eval_sympath_partial ~mode params p mem =
match p with
| Symb.SymbolPath.Pvar x -> (
try ParamBindings.find x params with Caml.Not_found ->
try ParamBindings.find x params
with Caml.Not_found ->
L.d_printfln_escaped "Symbol %a is not found in parameters." (Pvar.pp Pp.text) x ;
Val.Itv.top )
| Symb.SymbolPath.Callsite {cs} -> (

@ -23,7 +23,7 @@ module Reverse = struct
let add k v rm =
M.update k
(function
| None -> Some (false, VarSet.singleton v) | Some (_, s) -> Some (false, VarSet.add v s))
| None -> Some (false, VarSet.singleton v) | Some (_, s) -> Some (false, VarSet.add v s) )
rm

@ -238,8 +238,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
then
let return_access_path = Domain.LocalAccessPath.make (return_base, []) caller_pname in
let return_calls =
( try Domain.find return_access_path astate with Caml.Not_found -> Domain.CallSet.empty
)
( try Domain.find return_access_path astate
with Caml.Not_found -> Domain.CallSet.empty )
|> Domain.CallSet.add (Domain.MethodCall.make receiver callee_procname)
in
Domain.add return_access_path return_calls astate

@ -138,7 +138,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
let exec_instr astate {ProcData.pdesc} _ (instr : Sil.instr) =
match instr with
| Store (Lvar global, Typ.({desc= Tptr _}), Lvar _, loc)
| Store (Lvar global, Typ.{desc= Tptr _}, Lvar _, loc)
when (Option.equal Typ.Procname.equal)
(Pvar.get_initializer_pname global)
(Some (Procdesc.get_proc_name pdesc)) ->

@ -321,7 +321,8 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct
let base, accesses = AccessPath.Abs.extract ap in
let is_exact = AccessPath.Abs.is_exact ap in
let base_node =
try BaseMap.find base tree with Caml.Not_found ->
try BaseMap.find base tree
with Caml.Not_found ->
(* note: we interpret max_depth <= 0 as max_depth = 1 *)
if Config.max_depth > 1 then empty_normal_leaf else empty_starred_leaf
in

@ -23,8 +23,8 @@ module Domain = struct
astate
| NonBottom _ ->
let sink_map =
try AnnotReachabilityDomain.find annot annot_map with Caml.Not_found ->
AnnotReachabilityDomain.SinkMap.empty
try AnnotReachabilityDomain.find annot annot_map
with Caml.Not_found -> AnnotReachabilityDomain.SinkMap.empty
in
let sink_map' =
if AnnotReachabilityDomain.SinkMap.mem sink sink_map then sink_map
@ -117,8 +117,8 @@ let method_overrides_annot annot tenv pname = method_overrides (method_has_annot
let lookup_annotation_calls ~caller_pdesc annot pname =
match Ondemand.analyze_proc_name ~caller_pdesc pname with
| Some {Summary.payloads= {Payloads.annot_map= Some annot_map}} -> (
try AnnotReachabilityDomain.find annot annot_map with Caml.Not_found ->
AnnotReachabilityDomain.SinkMap.empty )
try AnnotReachabilityDomain.find annot annot_map
with Caml.Not_found -> AnnotReachabilityDomain.SinkMap.empty )
| _ ->
AnnotReachabilityDomain.SinkMap.empty

@ -435,7 +435,7 @@ module ConstraintSolver = struct
let union ~debug equalities e1 e2 =
let _ : bool = log_union ~debug equalities e1 e2 in
let (_ : bool) = log_union ~debug equalities e1 e2 in
()
@ -642,7 +642,7 @@ module ThresholdReports = struct
let config =
List.fold ReportConfig.as_list ~init:none ~f:(fun acc -> function
| k, ReportConfig.({threshold= Some threshold}) ->
| k, ReportConfig.{threshold= Some threshold} ->
CostDomain.CostKindMap.add k (Threshold (BasicCost.of_int_exn threshold)) acc
| _ ->
acc )
@ -766,16 +766,16 @@ module Check = struct
else if BasicCost.is_zero cost then report IssueType.zero_execution_time_call "is zero"
let check_and_report WorstCaseCost.({costs; reports}) proc_desc summary =
let check_and_report WorstCaseCost.{costs; reports} proc_desc summary =
CostDomain.CostKindMap.iter2 ReportConfig.as_map reports
~f:(fun kind ReportConfig.({name; threshold}) -> function
~f:(fun kind ReportConfig.{name; threshold} -> function
| ThresholdReports.Threshold _ ->
()
| ThresholdReports.ReportOn {location; cost} ->
report_threshold summary ~name ~location ~cost ~threshold:(Option.value_exn threshold)
~kind ) ;
CostDomain.CostKindMap.iter2 ReportConfig.as_map costs
~f:(fun _kind ReportConfig.({name; top_and_bottom}) cost ->
~f:(fun _kind ReportConfig.{name; top_and_bottom} cost ->
if top_and_bottom then report_top_and_bottom proc_desc summary ~name ~cost )
end

@ -33,7 +33,7 @@ module CostKindMap = struct
type no_value = |
let iter2 map1 map2 ~f =
let _ : no_value t =
let (_ : no_value t) =
merge
(fun k v1_opt v2_opt ->
(match (v1_opt, v2_opt) with Some v1, Some v2 -> f k v1 v2 | _ -> ()) ;
@ -58,7 +58,7 @@ module VariantCostMap = struct
let increase_by kind cost_to_add record =
update kind
(function
| None -> Some cost_to_add | Some existing -> Some (BasicCost.plus cost_to_add existing))
| None -> Some cost_to_add | Some existing -> Some (BasicCost.plus cost_to_add existing) )
record

@ -26,9 +26,10 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
let exec_instr astate _ _ = function
| Sil.Load (lhs_id, _, _, _) when Ident.is_none lhs_id ->
astate
| Sil.Load (lhs_id, Exp.Lvar rhs_pvar, Typ.({desc= Tptr ({desc= Tfun _}, _)}), _) ->
| Sil.Load (lhs_id, Exp.Lvar rhs_pvar, Typ.{desc= Tptr ({desc= Tfun _}, _)}, _) ->
let fun_ptr =
try Domain.find (Pvar.to_string rhs_pvar) astate with Caml.Not_found -> ProcnameSet.empty
try Domain.find (Pvar.to_string rhs_pvar) astate
with Caml.Not_found -> ProcnameSet.empty
in
Domain.add (Ident.to_string lhs_id) fun_ptr astate
| Sil.Store (Lvar lhs_pvar, _, Exp.Const (Const.Cfun pn), _) ->

@ -65,7 +65,7 @@ let get_hoist_inv_map tenv ~get_callee_purity reaching_defs_invariant_map loop_h
loop_head_to_source_nodes LoopHeadToHoistInstrs.empty
let do_report summary Call.({pname; loc}) ~issue loop_head_loc =
let do_report summary Call.{pname; loc} ~issue loop_head_loc =
let exp_desc =
F.asprintf "The call to %a at %a is loop-invariant" Typ.Procname.pp pname Location.pp loc
in
@ -81,10 +81,10 @@ let model_satisfies ~f tenv pname =
let is_call_expensive integer_type_widths get_callee_cost_summary_and_formals inferbo_invariant_map
Call.({pname; node; params}) =
Call.{pname; node; params} =
(* only report if function call has expensive/symbolic cost *)
match get_callee_cost_summary_and_formals pname with
| Some (CostDomain.({post= cost_record}), callee_formals)
| Some (CostDomain.{post= cost_record}, callee_formals)
when CostDomain.BasicCost.is_symbolic (CostDomain.get_operation_cost cost_record) ->
let last_node = InstrCFG.last_of_underlying_node node in
let instr_node_id = InstrCFG.Node.id last_node in
@ -107,7 +107,7 @@ let is_call_variant_for_hoisting tenv call =
model_satisfies ~f:InvariantModels.is_variant_for_hoisting tenv call.Call.pname
let get_issue_to_report tenv should_report_invariant (Call.({pname}) as call) =
let get_issue_to_report tenv should_report_invariant (Call.{pname} as call) =
if should_report_invariant call then
if model_satisfies ~f:InvariantModels.is_invariant tenv pname then
Some IssueType.loop_invariant_call
@ -138,7 +138,7 @@ let report_errors proc_desc tenv get_callee_purity reaching_defs_invariant_map
loop_head_to_inv_instrs
let checker Callbacks.({tenv; summary; proc_desc; integer_type_widths}) : Summary.t =
let checker Callbacks.{tenv; summary; proc_desc; integer_type_widths} : Summary.t =
let cfg = InstrCFG.from_pdesc proc_desc in
(* computes reaching defs: node -> (var -> node set) *)
let reaching_defs_invariant_map = ReachingDefs.compute_invariant_map proc_desc tenv in

@ -111,7 +111,8 @@ module TransferFunctions (LConfig : LivenessConfig) (CFG : ProcCfg.S) = struct
in
let actuals = List.map actuals ~f:(fun (e, _) -> Exp.ignore_cast e) in
match Exp.ignore_cast call_exp with
| Exp.Const (Cfun (Typ.Procname.ObjC_Cpp _ as pname)) when Typ.Procname.is_constructor pname -> (
| Exp.Const (Cfun (Typ.Procname.ObjC_Cpp _ as pname)) when Typ.Procname.is_constructor pname
-> (
(* first actual passed to a C++ constructor is actually written, not read *)
match actuals with
| Exp.Lvar pvar :: exps ->

@ -134,7 +134,7 @@ let get_loop_head_to_source_nodes cfg =
let get_control_maps loop_head_to_source_nodes_map =
Procdesc.NodeMap.fold
(fun loop_head source_list
(Control.({exit_map; loop_head_to_guard_nodes}), loop_head_to_loop_nodes) ->
(Control.{exit_map; loop_head_to_guard_nodes}, loop_head_to_loop_nodes) ->
L.(debug Analysis Medium)
"Back-edge source list : [%a] --> loop_head: %i \n" (Pp.comma_seq Procdesc.Node.pp)
source_list (nid_int loop_head) ;
@ -154,7 +154,7 @@ let get_control_maps loop_head_to_source_nodes_map =
| Some existing_loop_heads ->
Some (Control.LoopHeads.add loop_head existing_loop_heads)
| None ->
Some (Control.LoopHeads.singleton loop_head))
Some (Control.LoopHeads.singleton loop_head) )
exit_map_acc ))
exit_nodes
in
@ -164,7 +164,7 @@ let get_control_maps loop_head_to_source_nodes_map =
| Some existing_guard_nodes ->
Some (Control.GuardNodes.union existing_guard_nodes guard_prune_nodes)
| None ->
Some guard_prune_nodes)
Some guard_prune_nodes )
loop_head_to_guard_nodes
in
let loop_head_to_loop_nodes' =
@ -173,7 +173,7 @@ let get_control_maps loop_head_to_source_nodes_map =
| Some existing_loop_nodes ->
Some (LoopInvariant.LoopNodes.union existing_loop_nodes loop_nodes)
| None ->
Some loop_nodes)
Some loop_nodes )
loop_head_to_loop_nodes
in
let open Control in

@ -115,7 +115,8 @@ let run_clang_frontend ast_source =
let run_and_validate_clang_frontend ast_source =
try run_clang_frontend ast_source with exc ->
try run_clang_frontend ast_source
with exc ->
IExn.reraise_if exc ~f:(fun () -> not Config.keep_going) ;
L.internal_error "ERROR RUNNING CAPTURE: %a@\n%s@\n" Exn.pp exc (Printexc.get_backtrace ())

@ -102,7 +102,7 @@ let filter_and_replace_unsupported_args ?(replace_options_arg = fun _ s -> s)
aux in_argfiles (false, res_rev, true) tl
| at_argfile :: tl
when String.is_prefix at_argfile ~prefix:"@" && not (String.Set.mem in_argfiles at_argfile)
-> (
-> (
let in_argfiles' = String.Set.add in_argfiles at_argfile in
let argfile = String.slice at_argfile 1 (String.length at_argfile) in
match In_channel.read_lines argfile with
@ -135,9 +135,10 @@ let filter_and_replace_unsupported_args ?(replace_options_arg = fun _ s -> s)
let arg' = replace_options_arg res_rev arg in
aux in_argfiles (false, arg' :: res_rev, changed || not (phys_equal arg arg')) tl
in
match aux String.Set.empty (false, [], false) args with _, res_rev, _ ->
(* return non-reversed list *)
List.rev_append res_rev post_args
match aux String.Set.empty (false, [], false) args with
| _, res_rev, _ ->
(* return non-reversed list *)
List.rev_append res_rev post_args
(* Work around various path or library issues occurring when one tries to substitute Apple's version

@ -14,7 +14,6 @@ include struct
[@@@warning "-60"]
module rec CTransImpl : CModule_type.CTranslation = CTrans.CTrans_funct (CFrontend_declImpl)
and CFrontend_declImpl : CModule_type.CFrontend = CFrontend_decl.CFrontend_decl_funct (CTransImpl)
end

@ -273,9 +273,8 @@ let create_parsed_linters linters_def_file checkers : linter list =
let rec apply_substitution f sub =
let sub_param p =
try snd (List.find_exn sub ~f:(fun (a, _) -> ALVar.equal p a)) with
| Not_found_s _ | Caml.Not_found ->
p
try snd (List.find_exn sub ~f:(fun (a, _) -> ALVar.equal p a))
with Not_found_s _ | Caml.Not_found -> p
in
let sub_list_param ps = List.map ps ~f:sub_param in
let open CTL in
@ -423,10 +422,11 @@ let build_paths_map paths =
let paths_map =
List.fold
~f:(fun map' data ->
match data with path_name, paths ->
if ALVar.VarMap.mem path_name map' then
L.(die ExternalError) "Path '%s' has more than one definition." path_name
else ALVar.VarMap.add path_name paths map' )
match data with
| path_name, paths ->
if ALVar.VarMap.mem path_name map' then
L.(die ExternalError) "Path '%s' has more than one definition." path_name
else ALVar.VarMap.add path_name paths map' )
~init:init_map paths
in
paths_map

@ -297,7 +297,9 @@ let create_external_procdesc trans_unit_ctx cfg proc_name clang_method_kind type
in
let proc_attributes =
{ (ProcAttributes.default trans_unit_ctx.CFrontend_config.source_file proc_name) with
ProcAttributes.formals; clang_method_kind; ret_type }
ProcAttributes.formals
; clang_method_kind
; ret_type }
in
ignore (Cfg.create_proc_desc cfg proc_attributes)

@ -427,21 +427,22 @@ module Debug = struct
if Stack.is_empty t.eval_stack then
raise (Empty_stack "Unbalanced number of eval_begin/eval_end invocations") ;
let evaluated_tree, eval_node, ast_node_to_display =
match Stack.pop_exn t.eval_stack
with Tree (({id= _; content} as eval_node), children), ast_node_to_display ->
let content' =
{content with eval_result= eval_result_of_bool result_bool; witness= result}
in
let eval_node' = {eval_node with content= content'} in
(Tree (eval_node', children), eval_node', ast_node_to_display)
match Stack.pop_exn t.eval_stack with
| Tree (({id= _; content} as eval_node), children), ast_node_to_display ->
let content' =
{content with eval_result= eval_result_of_bool result_bool; witness= result}
in
let eval_node' = {eval_node with content= content'} in
(Tree (eval_node', children), eval_node', ast_node_to_display)
in
let t' = explain t ~eval_node ~ast_node_to_display in
let forest' =
if Stack.is_empty t'.eval_stack then evaluated_tree :: t'.forest
else
let parent =
match Stack.pop_exn t'.eval_stack with Tree (node, children), ntd ->
(Tree (node, evaluated_tree :: children), ntd)
match Stack.pop_exn t'.eval_stack with
| Tree (node, children), ntd ->
(Tree (node, evaluated_tree :: children), ntd)
in
Stack.push t'.eval_stack parent ; t'.forest
in
@ -1217,7 +1218,7 @@ and eval_EF phi an lcxt trans =
if Option.is_some witness_opt then witness_opt
else
List.fold_left (Ctl_parser_types.get_direct_successor_nodes an) ~init:witness_opt
~f:(fun acc node -> choose_witness_opt (eval_EF phi node lcxt trans) acc )
~f:(fun acc node -> choose_witness_opt (eval_EF phi node lcxt trans) acc)
(* an, lcxt |= EX phi <=> exists an' in Successors(st): an', lcxt |= phi

@ -29,6 +29,7 @@ type transitions =
| PointerToDecl (** stmt to decl *)
| Protocol (** decl to decl *)
[@@deriving compare]
(* In formulas below prefix
"E" means "exists a path"
"A" means "for all path" *)

@ -579,7 +579,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s
in
let instrs = pre_trans_result.control.instrs @ deref_instrs in
{ pre_trans_result with
control= {pre_trans_result.control with instrs}; return= (exp, field_typ) }
control= {pre_trans_result.control with instrs}
; return= (exp, field_typ) }
type decl_ref_context = MemberOrIvar of trans_result | DeclRefExpr
@ -1121,7 +1122,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s
let sil_method = Exp.Const (Const.Cfun callee_pname) in
let call_flags =
{ CallFlags.default with
cf_virtual= is_cpp_call_virtual; cf_injected_destructor= is_injected_destructor }
cf_virtual= is_cpp_call_virtual
; cf_injected_destructor= is_injected_destructor }
in
let res_trans_call =
create_call_instr trans_state_pri function_type sil_method actual_params sil_loc
@ -1466,7 +1468,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s
qual_type.Clang_ast_t.qt_type_ptr ~is_injected_destructor:true
~is_inner_destructor:false
| _ ->
assert false)
assert false )
vars_to_destroy
with Caml.Not_found ->
L.(debug Capture Verbose) "@\n Variables that go out of scope are not found...@\n@." ;
@ -1571,10 +1573,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s
(cond_trans ~if_kind:Sil.Ik_bexp ~negate_cond:false)
in
(* Note: by contruction prune nodes are leafs_nodes_cond *)
let _ : trans_result =
let (_ : trans_result) =
do_branch true exp1 var_typ res_trans_cond.control.leaf_nodes join_node pvar
in
let _ : trans_result =
let (_ : trans_result) =
do_branch false exp2 var_typ res_trans_cond.control.leaf_nodes join_node pvar
in
let id = Ident.create_fresh Ident.knormal in
@ -1789,7 +1791,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s
do_branch false stmt2 res_trans_cond.control.leaf_nodes ;
mk_trans_result (mk_fresh_void_exp_typ ())
{ empty_control with
root_nodes= res_trans_decl.control.root_nodes; leaf_nodes= [join_node] }
root_nodes= res_trans_decl.control.root_nodes
; leaf_nodes= [join_node] }
| _ ->
assert false
@ -3224,7 +3227,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s
(Pp.to_string ~f:Clang_ast_proj.get_stmt_kind_string)
instr pp_pointer instr ;
let trans_result =
try instruction_aux trans_state instr with e ->
try instruction_aux trans_state instr
with e ->
IExn.reraise_after e ~f:(fun () ->
let should_log_error = not !logged_error in
if should_log_error then (
@ -3680,7 +3684,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s
exec_trans_instrs_rev trans_state (List.rev trans_stmt_fun_list)
in
( { rev_control with
instrs= List.rev rev_control.instrs; initd_exps= List.rev rev_control.initd_exps }
instrs= List.rev rev_control.instrs
; initd_exps= List.rev rev_control.initd_exps }
, List.rev rev_returns )

@ -90,7 +90,8 @@ end
module GotoLabel = struct
let find_goto_label context label sil_loc =
try Hashtbl.find context.CContext.label_map label with Caml.Not_found ->
try Hashtbl.find context.CContext.label_map label
with Caml.Not_found ->
let node_name = Format.sprintf "GotoLabel_%s" label in
let new_node =
Procdesc.create_node context.CContext.procdesc sil_loc (Procdesc.Node.Skip_node node_name)
@ -104,7 +105,7 @@ type continuation =
{ break: Procdesc.Node.t list
; continue: Procdesc.Node.t list
; return_temp: bool
(* true if temps should not be removed in the node but returned to ancestors *) }
(* true if temps should not be removed in the node but returned to ancestors *) }
let is_return_temp continuation =
match continuation with Some cont -> cont.return_temp | _ -> false

@ -47,8 +47,8 @@ let add_formula_to_valuation k s =
let get_node_valuation k =
try NodesValuationHashtbl.find k !global_nodes_valuation with Caml.Not_found ->
CTLFormulaSet.empty
try NodesValuationHashtbl.find k !global_nodes_valuation
with Caml.Not_found -> CTLFormulaSet.empty
let is_decl_allowed lcxt decl =
@ -305,7 +305,8 @@ let report_issue an lcxt linter (*npo_condition*) =
let check_linter_map linter_map_contex phi =
try ClosureHashtbl.find phi linter_map_contex with Caml.Not_found ->
try ClosureHashtbl.find phi linter_map_contex
with Caml.Not_found ->
Logging.die InternalError "@\n ERROR: linter_map must have an entry for each formula"
@ -329,7 +330,8 @@ let build_valuation parsed_linters an lcxt linter_map_context =
build_transition_set npo_condition ; *)
let normalized_condition = normalize linter.condition in
let is_state_only, cl =
try ClosureHashtbl.find normalized_condition !closure_map with Caml.Not_found ->
try ClosureHashtbl.find normalized_condition !closure_map
with Caml.Not_found ->
let cl' = formula_closure normalized_condition in
let is_state_only = is_state_only_formula normalized_condition in
(*print_closure cl' ; *)

@ -82,9 +82,11 @@ end = struct
; unlock= ["release"] }
in
[ { def with
classname= "apache::thrift::concurrency::Monitor"; trylock= "timedlock" :: def.trylock }
classname= "apache::thrift::concurrency::Monitor"
; trylock= "timedlock" :: def.trylock }
; { def with
classname= "apache::thrift::concurrency::Mutex"; trylock= "timedlock" :: def.trylock }
classname= "apache::thrift::concurrency::Mutex"
; trylock= "timedlock" :: def.trylock }
; {rwm with classname= "apache::thrift::concurrency::NoStarveReadWriteMutex"}
; {rwm with classname= "apache::thrift::concurrency::ReadWriteMutex"}
; {shd with classname= "boost::shared_mutex"}

@ -596,8 +596,8 @@ let analyze_procedure {Callbacks.proc_desc; tenv; summary} =
in
let return_ownership = OwnershipDomain.get_owned return_var_ap ownership in
let return_attributes =
try AttributeMapDomain.find return_var_ap attribute_map with Caml.Not_found ->
AttributeSetDomain.empty
try AttributeMapDomain.find return_var_ap attribute_map
with Caml.Not_found -> AttributeSetDomain.empty
in
let post = {threads; locks; accesses; return_ownership; return_attributes} in
Payload.update_summary post summary
@ -1140,7 +1140,8 @@ let report_unsafe_accesses classname (aggregated_access_map : ReportMap.t) =
(* reset the reported reads and writes for each memory location *)
let reported_acc =
{ reported_acc with
reported_writes= Typ.Procname.Set.empty; reported_reads= Typ.Procname.Set.empty }
reported_writes= Typ.Procname.Set.empty
; reported_reads= Typ.Procname.Set.empty }
in
report_guardedby_violations_on_location grouped_accesses reported_acc
|> report_accesses_on_location grouped_accesses

@ -474,7 +474,7 @@ module AttributeMapDomain = struct
| Some attrs ->
Some (AttributeSetDomain.add attribute attrs)
| None ->
Some (AttributeSetDomain.singleton attribute))
Some (AttributeSetDomain.singleton attribute) )
t
@ -482,8 +482,8 @@ module AttributeMapDomain = struct
let open HilExp in
match e with
| HilExp.AccessExpression access_expr -> (
try find (AccessExpression.to_access_path access_expr) attribute_map with Caml.Not_found ->
AttributeSetDomain.empty )
try find (AccessExpression.to_access_path access_expr) attribute_map
with Caml.Not_found -> AttributeSetDomain.empty )
| Constant _ ->
AttributeSetDomain.singleton Attribute.Functional
| Exception expr (* treat exceptions as transparent wrt attributes *) | Cast (_, expr) ->

@ -37,7 +37,8 @@ let is_java_container_write =
@ make_android_support_template "SparseArrayCompat" array_methods
@ [ {default with classname= "android.util.SparseArray"; methods= array_methods}
; { default with
classname= "java.util.List"; methods= ["add"; "addAll"; "clear"; "remove"; "set"] }
classname= "java.util.List"
; methods= ["add"; "addAll"; "clear"; "remove"; "set"] }
; {default with classname= "java.util.Map"; methods= ["clear"; "put"; "putAll"; "remove"]} ]
|> of_records

@ -95,8 +95,9 @@ let standard_matchers =
let high_sev =
[ {default with classname= "java.lang.Thread"; methods= ["sleep"]}
; { default with
classname= "java.lang.Object"; methods= ["wait"]; actuals_pred= empty_or_excessive_timeout
}
classname= "java.lang.Object"
; methods= ["wait"]
; actuals_pred= empty_or_excessive_timeout }
; { default with
classname= "java.util.concurrent.CountDownLatch"
; methods= ["await"]
@ -141,9 +142,12 @@ let strict_mode_matcher =
let dont_search_superclasses = {default with search_superclasses= false} in
let matcher_records =
[ { dont_search_superclasses with
classname= "dalvik.system.BlockGuard$Policy"; methods= ["on"]; method_prefix= true }
classname= "dalvik.system.BlockGuard$Policy"
; methods= ["on"]
; method_prefix= true }
; { dont_search_superclasses with
classname= "java.lang.System"; methods= ["gc"; "runFinalization"] }
classname= "java.lang.System"
; methods= ["gc"; "runFinalization"] }
; {dont_search_superclasses with classname= "java.lang.Runtime"; methods= ["gc"]}
; {dont_search_superclasses with classname= "java.net.Socket"; methods= ["connect"]}
(* all public constructors of Socket with two or more arguments call connect *)

@ -200,7 +200,8 @@ let inline_argument_files buck_args =
(* Arguments that start with @ could mean something different than an arguments file in buck. *)
else
let expanded_args =
try Utils.with_file_in file_name ~f:In_channel.input_lines with exn ->
try Utils.with_file_in file_name ~f:In_channel.input_lines
with exn ->
Logging.die UserError "Could not read from file '%s': %a@." file_name Exn.pp exn
in
expanded_args

@ -286,7 +286,7 @@ let capture ~changed_files = function
(* swallow infer.py argument parsing error *)
Config.print_usage_exit ()
| status ->
command_error_handling ~always_die:true ~prog:infer_py ~args status)
command_error_handling ~always_die:true ~prog:infer_py ~args status )
() ;
PerfStats.get_reporter PerfStats.TotalFrontend ()
| XcodeXcpretty (prog, args) ->

@ -133,7 +133,8 @@ let add_infer_profile mvn_pom infer_pom =
in
protect ~f:with_ic ~finally:(fun () -> In_channel.close ic)
in
try Utils.with_file_out infer_pom ~f:with_oc with Xmlm.Error ((line, col), error) ->
try Utils.with_file_out infer_pom ~f:with_oc
with Xmlm.Error ((line, col), error) ->
L.die ExternalError "%s:%d:%d: ERROR: %s" mvn_pom line col (Xmlm.error_message error)

@ -21,7 +21,7 @@ let is_singleton ~fold t = match singleton_or_more ~fold t with Singleton _ -> t
let mem_nth ~fold t index =
With_return.with_return (fun {return} ->
let _ : int =
let (_ : int) =
fold t ~init:index ~f:(fun index _ -> if index <= 0 then return true else index - 1)
in
false )
@ -50,7 +50,7 @@ let rev_filter_map_to_list ~fold t ~f =
let iter_consecutive ~fold t ~f =
let _ : _ option =
let (_ : _ option) =
fold t ~init:None ~f:(fun prev_opt curr ->
(match prev_opt with Some prev -> f prev curr | None -> ()) ;
Some curr )

@ -61,8 +61,10 @@ let text_break = {text with break_lines= true}
(** Default html print environment *)
let html color =
{ text with
kind= HTML; cmap_norm= colormap_from_color color; cmap_foot= colormap_from_color color; color
}
kind= HTML
; cmap_norm= colormap_from_color color
; cmap_foot= colormap_from_color color
; color }
(** Extend the normal colormap for the given object with the given color *)

@ -101,10 +101,9 @@ let add_source_file path map =
(* Two or more source file with the same base name have been found *)
let current_package = read_package_declaration current_source_file in
Duplicate ((current_package, current_source_file) :: previous_source_files)
with
| Not_found_s _ | Caml.Not_found ->
(* Most common case: there is no conflict with the base name of the source file *)
Singleton current_source_file
with Not_found_s _ | Caml.Not_found ->
(* Most common case: there is no conflict with the base name of the source file *)
Singleton current_source_file
in
String.Map.set ~key:basename ~data:entry map
@ -141,7 +140,8 @@ let load_from_verbose_output javac_verbose_out =
let path =
if Version.is_jdk11 then Str.matched_group 1 line
else
try Str.matched_group 5 line with Caml.Not_found ->
try Str.matched_group 5 line
with Caml.Not_found ->
(* either matched group 5 is found, or matched group 2 is found, see doc for [class_filename_re] above *)
Config.javac_classes_out ^/ Str.matched_group 2 line
in
@ -274,7 +274,8 @@ let iter_missing_callees program ~f =
let cleanup program = Javalib.close_class_path program.classpath.channel
let lookup_node cn program =
try Some (JBasics.ClassMap.find cn (get_classmap program)) with Caml.Not_found -> (
try Some (JBasics.ClassMap.find cn (get_classmap program))
with Caml.Not_found -> (
try
let jclass = javalib_get_class (get_classpath_channel program) cn in
add_class cn jclass program ; Some jclass

@ -68,8 +68,9 @@ let set_pvar context var typ = fst (get_or_set_pvar_type context var typ)
let reset_pvar_type context =
let var_map = context.var_map in
let aux var item =
match item with pvar, otyp, _ ->
set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map)
match item with
| pvar, otyp, _ ->
set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map)
in
JBir.VarMap.iter aux var_map

@ -258,7 +258,7 @@ let get_bytecode cm =
| JCode.OpInvoke (`Dynamic _, ms) ->
JCode.OpInvoke (`Static JBasics.java_lang_object, ms)
| opcode ->
opcode)
opcode )
bytecode.JCode.c_code
in
{bytecode with JCode.c_code}
@ -306,7 +306,12 @@ let create_callee_attributes tenv program cn ms procname =
let translation_unit = SourceFile.invalid __FILE__ in
Some
{ (ProcAttributes.default translation_unit procname) with
ProcAttributes.access; exceptions; method_annotation; formals; ret_type; is_abstract }
ProcAttributes.access
; exceptions
; method_annotation
; formals
; ret_type
; is_abstract }
with Caml.Not_found -> None
in
Option.bind ~f (JClasspath.lookup_node cn program)
@ -738,8 +743,9 @@ let method_invocation (context : JContext.t) loc pc var_opt cn ms sil_obj_opt ex
let get_array_length context pc expr_list content_type =
let get_expr_instr expr other_instrs =
let instrs, sil_len_expr, _ = expression context pc expr in
match other_instrs with other_instrs, other_exprs ->
(instrs @ other_instrs, sil_len_expr :: other_exprs)
match other_instrs with
| other_instrs, other_exprs ->
(instrs @ other_instrs, sil_len_expr :: other_exprs)
in
let instrs, sil_len_exprs = List.fold_right ~f:get_expr_instr expr_list ~init:([], []) in
let get_array_type_len sil_len_expr (content_type, _) =

@ -47,7 +47,8 @@ let translate_exceptions (context : JContext.t) exit_nodes get_body_nodes handle
[instr_get_ret_val; instr_deactivate_exn; instr_unwrap_ret_val]
in
let create_entry_block handler_list =
try ignore (Hashtbl.find catch_block_table handler_list) with Caml.Not_found ->
try ignore (Hashtbl.find catch_block_table handler_list)
with Caml.Not_found ->
let collect succ_nodes rethrow_exception handler =
let catch_nodes = get_body_nodes handler.JBir.e_handler in
let loc =

@ -296,7 +296,7 @@ let add_model_fields program classpath_fields cn =
let rec get_method_procname program tenv cn ms method_kind =
let _ : Typ.Struct.t = get_class_struct_typ program tenv cn in
let (_ : Typ.Struct.t) = get_class_struct_typ program tenv cn in
let return_type_name, method_name, args_type_name = method_signature_names ms in
let class_name = Typ.Name.Java.from_string (JBasics.cn_name cn) in
let proc_name_java =

@ -25,7 +25,7 @@ let get proc_attributes : t =
let method_annotation = proc_attributes.ProcAttributes.method_annotation in
let formals = proc_attributes.ProcAttributes.formals in
let ret_type = proc_attributes.ProcAttributes.ret_type in
let Annot.Method.({return; params}) = method_annotation in
let Annot.Method.{return; params} = method_annotation in
let natl =
let rec extract ial parl =
match (ial, parl) with

@ -104,7 +104,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
let pname = Procdesc.get_proc_name pdesc in
let annotation = Localise.nullable_annotation_name pname in
let call_site =
try CallSites.min_elt call_sites with Caml.Not_found ->
try CallSites.min_elt call_sites
with Caml.Not_found ->
L.(die InternalError)
"Expecting a least one element in the set of call sites when analyzing %a"
Typ.Procname.pp pname
@ -205,7 +206,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
let rec longest_nullable_prefix ap ((nullable_aps, _) as astate) =
try Some (ap, NullableAP.find ap nullable_aps) with Caml.Not_found -> (
try Some (ap, NullableAP.find ap nullable_aps)
with Caml.Not_found -> (
match ap with
| _, [] ->
None

@ -246,7 +246,7 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu
let pvar =
Pvar.mk (Mangled.from_string (Typ.Fieldname.to_string fn)) pname
in
filter_range_opt (TypeState.lookup_pvar pvar typestate))
filter_range_opt (TypeState.lookup_pvar pvar typestate) )
list
in
let may_be_assigned_in_final_typestate =

@ -516,7 +516,8 @@ let typecheck_instr tenv calls_this checks (node : Procdesc.Node.t) idenv curr_p
let ret_type = Typ.Procname.Java.get_return_typ callee_pname_java in
let proc_attributes =
{ (ProcAttributes.default (SourceFile.invalid __FILE__) callee_pname) with
ProcAttributes.formals; ret_type }
ProcAttributes.formals
; ret_type }
in
proc_attributes
in

@ -72,11 +72,13 @@ let map_join m1 m2 =
if only_keep_intersection then tjoined := M.add exp2 range1 !tjoined
| Some range' ->
tjoined := M.add exp2 range' !tjoined
with Caml.Not_found -> if not only_keep_intersection then tjoined := M.add exp2 range2 !tjoined
with Caml.Not_found ->
if not only_keep_intersection then tjoined := M.add exp2 range2 !tjoined
in
let missing_rhs exp1 range1 =
(* handle elements missing in the rhs *)
try ignore (M.find exp1 m2) with Caml.Not_found ->
try ignore (M.find exp1 m2)
with Caml.Not_found ->
let t1, ta1, locs1 = range1 in
let range1' =
let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in

@ -136,7 +136,7 @@ module SourceKind = struct
in
res
| _ ->
false)
false )
tenv pname
in
(* taint all formals except for [this] *)

@ -240,8 +240,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct
let matching_sink, _ = List.find_exn ~f:snd matching_sinks in
expand_sink matching_sink (Sink.indexes matching_sink)
(matching_sink :: report_acc, seen_acc')
with
| Not_found_s _ | Caml.Not_found -> (
with Not_found_s _ | Caml.Not_found -> (
(* didn't find a sink whose indexes match; this can happen when taint flows in via a
global. pick any sink whose kind matches *)
match matching_sinks with

@ -404,6 +404,6 @@ let () =
let to_check = List.rev !to_check in
let exit_code = ref 0 in
List.iter to_check ~f:(fun file ->
try check_copyright file with CopyrightEvent event ->
if not !keep_going then exit_code := exit_code_of_event event ) ;
try check_copyright file
with CopyrightEvent event -> if not !keep_going then exit_code := exit_code_of_event event ) ;
exit !exit_code

@ -15,13 +15,14 @@ let properties = ref []
let parse topl_file =
let f ch =
let lexbuf = Lexing.from_channel ch in
try ToplParser.properties (ToplLexer.token ()) lexbuf with ToplParser.Error ->
let Lexing.({pos_lnum; pos_bol; pos_cnum; _}) = Lexing.lexeme_start_p lexbuf in
try ToplParser.properties (ToplLexer.token ()) lexbuf
with ToplParser.Error ->
let Lexing.{pos_lnum; pos_bol; pos_cnum; _} = Lexing.lexeme_start_p lexbuf in
let col = pos_cnum - pos_bol + 1 in
L.(die UserError) "@[%s:%d:%d: topl parse error@]@\n@?" topl_file pos_lnum col
in
try In_channel.with_file topl_file ~f with Sys_error msg ->
L.(die UserError) "@[topl:%s: %s@]@\n@?" topl_file msg
try In_channel.with_file topl_file ~f
with Sys_error msg -> L.(die UserError) "@[topl:%s: %s@]@\n@?" topl_file msg
let init () =

@ -67,9 +67,7 @@ module MockProcCfg = struct
~f:(fun (_, succs) -> List.exists ~f:(fun node -> equal_id (Node.id node) node_id) succs)
t
|> List.map ~f:fst |> List.fold ~init ~f
with
| Not_found_s _ | Caml.Not_found ->
init
with Not_found_s _ | Caml.Not_found -> init
let fold_nodes t ~init ~f = List.map ~f:fst t |> List.fold ~init ~f

@ -29,22 +29,16 @@ let trace_conv =
(parse, print)
type t =
{ compile_only: bool
[@aka ["c"]]
{ compile_only: bool [@aka ["c"]]
(** Do not analyze: terminate after translating input LLVM to LLAIR. *)
; input: string
[@pos 0] [@docv "input.bc"]
; input: string [@pos 0] [@docv "input.bc"]
(** LLVM bitcode file to analyze, in either binary $(b,.bc) or
textual $(b,.ll) form. *)
; output: string option
[@aka ["o"]] [@docv "output.llair"]
; output: string option [@aka ["o"]] [@docv "output.llair"]
(** Dump $(i,input.bc) translated to LLAIR in human-readable form to
$(i,output.llair), or $(b,-) for $(b,stdout). *)
; trace: Trace.config
[@aka ["t"]]
[@docv "spec"]
[@conv trace_conv]
[@default Trace.none]
[@aka ["t"]] [@docv "spec"] [@conv trace_conv] [@default Trace.none]
(** Enable debug tracing according to $(i,spec), which is a sequence
of module and function names separated by $(b,+) or $(b,-). For
example, $(b,Control-Control.exec_inst) enables all tracing in

@ -302,7 +302,7 @@ let exec_term : Llair.t -> Stack.t -> Domain.t -> Llair.block -> Work.x =
( match
Domain.assume state
(Vector.fold tbl ~init:(Exp.bool true)
~f:(fun b (case, _) -> Exp.and_ (Exp.dq key case) b ))
~f:(fun b (case, _) -> Exp.and_ (Exp.dq key case) b))
with
| Some state -> exec_jump stk state block els
| None -> Work.skip )

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save