From 3534838b73c6bdbe5f4da3051656fc32ba1170a5 Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Mon, 26 Feb 2018 14:43:10 -0800 Subject: [PATCH] [ocamlformat] Upgrade to ocamlformat 0.4 Reviewed By: jvillard Differential Revision: D7079161 fbshipit-source-id: 17b2f0c --- .ocamlformat | 2 +- infer/src/IR/Errlog.ml | 4 +- infer/src/IR/Io_infer.ml | 4 +- infer/src/IR/Localise.ml | 18 +- infer/src/IR/Procdesc.ml | 4 +- infer/src/IR/ProcnameDispatcher.ml | 370 +++--- infer/src/IR/Tenv.ml | 4 +- infer/src/IR/Typ.ml | 11 +- infer/src/absint/AbstractInterpreter.ml | 23 +- infer/src/absint/LowerHil.ml | 4 +- infer/src/backend/DifferentialFilters.ml | 6 +- infer/src/backend/InferPrint.ml | 4 +- infer/src/backend/RetainCycles.ml | 10 +- infer/src/backend/abs.ml | 4 +- infer/src/backend/dom.ml | 4 +- infer/src/backend/dotty.ml | 4 +- infer/src/backend/errdesc.ml | 4 +- infer/src/backend/match.ml | 4 +- infer/src/backend/mergeCapture.ml | 4 +- infer/src/backend/paths.ml | 16 +- infer/src/backend/printer.ml | 4 +- infer/src/backend/prop.ml | 6 +- infer/src/backend/prover.ml | 42 +- infer/src/backend/rearrange.ml | 18 +- infer/src/backend/reporting.ml | 5 +- infer/src/backend/symExec.ml | 4 +- infer/src/backend/tabulation.ml | 26 +- infer/src/base/CommandDoc.ml | 113 +- infer/src/base/CommandLineOption.ml | 8 +- infer/src/base/Config.ml | 231 ++-- infer/src/base/Die.mli | 2 +- infer/src/base/Escape.ml | 4 +- infer/src/base/Logging.ml | 4 +- infer/src/base/ProcessPool.mli | 1 - infer/src/base/ProcessPoolState.mli | 1 + infer/src/base/ResultsDir.ml | 5 +- infer/src/base/RunState.ml | 6 +- infer/src/base/Serialization.ml | 10 +- infer/src/base/SqliteUtils.mli | 2 +- infer/src/base/SymOp.ml | 2 +- infer/src/base/SymOp.mli | 3 +- infer/src/bufferoverrun/arrayBlk.ml | 108 +- .../src/bufferoverrun/bufferOverrunChecker.ml | 701 ++++++------ .../src/bufferoverrun/bufferOverrunDomain.ml | 483 ++++---- .../bufferOverrunProofObligations.ml | 195 ++-- .../bufferoverrun/bufferOverrunSemantics.ml | 769 +++++++------ infer/src/bufferoverrun/bufferOverrunTrace.ml | 34 +- infer/src/bufferoverrun/bufferOverrunUtils.ml | 60 +- infer/src/bufferoverrun/itv.ml | 1016 ++++++++--------- infer/src/checkers/BoundedCallTree.ml | 5 +- infer/src/checkers/NullabilityCheck.ml | 6 +- infer/src/checkers/SimpleChecker.ml | 3 +- infer/src/checkers/accessTree.ml | 1 + infer/src/checkers/immutableChecker.ml | 3 +- infer/src/clang/CTLExceptions.mli | 4 +- infer/src/clang/Capture.ml | 30 +- infer/src/clang/ClangWrapper.ml | 14 +- infer/src/clang/ComponentKit.ml | 6 +- infer/src/clang/cArithmetic_trans.ml | 6 +- infer/src/clang/cAst_utils.ml | 7 +- infer/src/clang/cFrontend_checkers.ml | 4 +- infer/src/clang/cFrontend_errors.ml | 4 +- infer/src/clang/cMethod_trans.ml | 8 +- infer/src/clang/cTrans.ml | 23 +- infer/src/clang/cTrans_utils.ml | 4 +- infer/src/clang/ctl_parser_types.ml | 10 +- infer/src/clang/tableaux.ml | 11 +- infer/src/concurrency/RacerD.ml | 36 +- infer/src/concurrency/RacerDDomain.ml | 17 +- infer/src/eradicate/eradicate.ml | 15 +- infer/src/eradicate/eradicateChecks.ml | 18 +- infer/src/eradicate/modelTables.ml | 95 +- infer/src/eradicate/typeErr.ml | 4 +- infer/src/integration/Buck.ml | 4 +- .../integration/CaptureCompilationDatabase.ml | 3 +- infer/src/integration/Diff.ml | 4 +- infer/src/integration/Driver.ml | 30 +- infer/src/integration/Javac.ml | 7 +- infer/src/java/jClasspath.ml | 3 +- infer/src/quandary/TaintAnalysis.ml | 4 +- infer/src/scripts/checkCopyright.ml | 8 +- infer/src/unit/TaintTests.ml | 5 +- 82 files changed, 2485 insertions(+), 2284 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 306c771ab..a915abd6b 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,3 +1,3 @@ margin 100 sparse true -version 0.3 +version 0.4 diff --git a/infer/src/IR/Errlog.ml b/infer/src/IR/Errlog.ml index ad6152588..0c9e97545 100644 --- a/infer/src/IR/Errlog.ml +++ b/infer/src/IR/Errlog.ml @@ -284,7 +284,7 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_ "@\n%a@\n@?" (Exceptions.pp_err ~node_key loc err_kind error.name error.description error.ml_loc) () ; - if err_kind <> Exceptions.Kerror then + if err_kind <> Exceptions.Kerror then ( let warn_str = let pp fmt = Format.fprintf fmt "%s %a" error.name.IssueType.unique_id Localise.pp_error_desc @@ -301,6 +301,6 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_ | Exceptions.Kinfo | Exceptions.Kadvice | Exceptions.Klike -> L.d_info in - d warn_str ; L.d_ln () + d warn_str ; L.d_ln () ) in if should_print_now then print_now () diff --git a/infer/src/IR/Io_infer.ml b/infer/src/IR/Io_infer.ml index bd5aea49b..4338f6afe 100644 --- a/infer/src/IR/Io_infer.ml +++ b/infer/src/IR/Io_infer.ml @@ -161,8 +161,8 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e let node_text = let pp fmt = Format.fprintf fmt - "%snode%d preds:%a succs:%a exn:%a %s%s" - style_class display_name id (Pp.seq Format.pp_print_int) preds + "%snode%d preds:%a succs:%a exn:%a \ + %s%s" style_class display_name id (Pp.seq Format.pp_print_int) preds (Pp.seq Format.pp_print_int) succs (Pp.seq Format.pp_print_int) exn description (if not isvisited then "\nNOT VISITED" else "") in diff --git a/infer/src/IR/Localise.ml b/infer/src/IR/Localise.ml index 51baa855e..f510c8606 100644 --- a/infer/src/IR/Localise.ml +++ b/infer/src/IR/Localise.ml @@ -261,8 +261,8 @@ let deref_str_nil_argument_in_variadic_method pn total_args arg_number = in let problem_str = Printf.sprintf - "could be %s which results in a call to %s with %d arguments instead of %d (%s indicates that the last argument of this variadic %s has been reached)" - nil_null + "could be %s which results in a call to %s with %d arguments instead of %d (%s indicates \ + that the last argument of this variadic %s has been reached)" nil_null (Typ.Procname.to_simplified_string pn) arg_number (total_args - 1) nil_null function_method in @@ -389,9 +389,11 @@ let desc_unsafe_guarded_by_access accessed_fld guarded_by_str loc = in let msg = Format.asprintf - "The field %a is annotated with %a, but the lock %a is not held during the access to the field %s. Since the current method is non-private, it can be called from outside the current class without synchronization. Consider wrapping the access in a %s block or making the method private." - MF.pp_monospaced accessed_fld_str MF.pp_monospaced annot_str MF.pp_monospaced guarded_by_str - line_info syncronized_str + "The field %a is annotated with %a, but the lock %a is not held during the access to the \ + field %s. Since the current method is non-private, it can be called from outside the \ + current class without synchronization. Consider wrapping the access in a %s block or \ + making the method private." MF.pp_monospaced accessed_fld_str MF.pp_monospaced annot_str + MF.pp_monospaced guarded_by_str line_info syncronized_str in {no_desc with descriptions= [msg]} @@ -403,10 +405,12 @@ let desc_fragment_retains_view fragment_typ fieldname fld_typ pname : error_desc (format_typ fragment_typ) (format_field fieldname) (format_typ fld_typ) (format_method pname) in let consequences = - "If this Fragment is placed on the back stack, a reference to this (probably dead) View will be retained." + "If this Fragment is placed on the back stack, a reference to this (probably dead) View will \ + be retained." in let advice = - "In general, it is a good idea to initialize View's in onCreateView, then nullify them in onDestroyView." + "In general, it is a good idea to initialize View's in onCreateView, then nullify them in \ + onDestroyView." in {no_desc with descriptions= [problem; consequences; advice]} diff --git a/infer/src/IR/Procdesc.ml b/infer/src/IR/Procdesc.ml index a5fd02389..6a64e3590 100644 --- a/infer/src/IR/Procdesc.ml +++ b/infer/src/IR/Procdesc.ml @@ -786,8 +786,8 @@ let specialize_with_block_args callee_pdesc pname_with_block_args block_args = source_file | None -> Logging.die InternalError - "specialize_with_block_args ahould only be called with defined procedures, but we cannot find the captured file of procname %a" - Typ.Procname.pp pname + "specialize_with_block_args ahould only be called with defined procedures, but we \ + cannot find the captured file of procname %a" Typ.Procname.pp pname in let resolved_attributes = { callee_attributes with diff --git a/infer/src/IR/ProcnameDispatcher.ml b/infer/src/IR/ProcnameDispatcher.ml index f6e8f3b8e..0b4081dd6 100644 --- a/infer/src/IR/ProcnameDispatcher.ml +++ b/infer/src/IR/ProcnameDispatcher.ml @@ -172,75 +172,75 @@ let empty : ('f, 'f, unit, 'markers, 'markers, empty) path_matcher = let name_cons : ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) path_matcher -> string -> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher = - fun m name -> - let {on_templated_name; get_markers} = m in - let fuzzy_name_regexp = - name |> Str.quote |> Printf.sprintf "^%s\\(<[a-z0-9]+>\\)?$" |> Str.regexp - in - let on_qual_name f qual_name = - match QualifiedCppName.extract_last qual_name with - | Some (last, rest) when Str.string_match fuzzy_name_regexp last 0 -> - on_templated_name f (rest, []) - | _ -> - None - in - let on_objc_cpp f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = - if String.equal name objc_cpp.method_name then - on_templated_name f (templated_name_of_class_name objc_cpp.class_name) - else None - in - {on_objc_cpp; on_qual_name; get_markers} + fun m name -> + let {on_templated_name; get_markers} = m in + let fuzzy_name_regexp = + name |> Str.quote |> Printf.sprintf "^%s\\(<[a-z0-9]+>\\)?$" |> Str.regexp + in + let on_qual_name f qual_name = + match QualifiedCppName.extract_last qual_name with + | Some (last, rest) when Str.string_match fuzzy_name_regexp last 0 -> + on_templated_name f (rest, []) + | _ -> + None + in + let on_objc_cpp f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = + if String.equal name objc_cpp.method_name then + on_templated_name f (templated_name_of_class_name objc_cpp.class_name) + else None + in + {on_objc_cpp; on_qual_name; get_markers} let all_names_cons : ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, non_empty) path_matcher -> ('f_in, 'f_out, 'captured_tpes, 'markers_in, 'markers_out, non_empty) path_matcher = - fun m -> - let {on_templated_name; get_markers; path_extra= PathNonEmpty {on_objc_cpp}} = m in - let rec on_templated_name_rec f templated_name = - match on_templated_name f templated_name with - | Some _ as some -> - some - | None -> - let qual_name, _template_args = templated_name in - match QualifiedCppName.extract_last qual_name with - | None -> - None - | Some (_last, rest) -> - on_templated_name_rec f (rest, []) - in - let on_templated_name = on_templated_name_rec in - let on_objc_cpp f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = - match on_objc_cpp f objc_cpp with - | Some _ as some -> - some - | None -> - on_templated_name f (templated_name_of_class_name objc_cpp.class_name) - in - {on_templated_name; get_markers; path_extra= PathNonEmpty {on_objc_cpp}} + fun m -> + let {on_templated_name; get_markers; path_extra= PathNonEmpty {on_objc_cpp}} = m in + let rec on_templated_name_rec f templated_name = + match on_templated_name f templated_name with + | Some _ as some -> + some + | None -> + let qual_name, _template_args = templated_name in + match QualifiedCppName.extract_last qual_name with + | None -> + None + | Some (_last, rest) -> + on_templated_name_rec f (rest, []) + in + let on_templated_name = on_templated_name_rec in + let on_objc_cpp f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = + match on_objc_cpp f objc_cpp with + | Some _ as some -> + some + | None -> + on_templated_name f (templated_name_of_class_name objc_cpp.class_name) + in + {on_templated_name; get_markers; path_extra= PathNonEmpty {on_objc_cpp}} let templ_begin : ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, accept_more) templ_matcher = - fun m -> - let {on_objc_cpp; on_qual_name; get_markers} = m in - let on_templated_name f (qual_name, template_args) = - match on_qual_name f qual_name with - | None -> - None - | Some (f, captured_types) -> - Some (f, captured_types, template_args) - in - let on_objc_cpp f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = - match on_objc_cpp f objc_cpp with - | None -> - None - | Some (f, captured_types) -> - let template_args = template_args_of_template_spec_info objc_cpp.template_args in - Some (f, captured_types, template_args) - in - {on_objc_cpp; on_templated_name; get_markers} + fun m -> + let {on_objc_cpp; on_qual_name; get_markers} = m in + let on_templated_name f (qual_name, template_args) = + match on_qual_name f qual_name with + | None -> + None + | Some (f, captured_types) -> + Some (f, captured_types, template_args) + in + let on_objc_cpp f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = + match on_objc_cpp f objc_cpp with + | None -> + None + | Some (f, captured_types) -> + let template_args = template_args_of_template_spec_info objc_cpp.template_args in + Some (f, captured_types, template_args) + in + {on_objc_cpp; on_templated_name; get_markers} let templ_cons @@ -260,15 +260,15 @@ let templ_cons , 'lc ) template_arg -> ('f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher = - fun m template_arg -> - let {on_objc_cpp; on_templated_name; get_markers} = m in - let {eat_template_arg; add_marker} = template_arg in - let get_markers m = get_markers (add_marker m) in - let on_templated_name f templated_name = - on_templated_name f templated_name |> Option.bind ~f:eat_template_arg - in - let on_objc_cpp f objc_cpp = on_objc_cpp f objc_cpp |> Option.bind ~f:eat_template_arg in - {on_objc_cpp; on_templated_name; get_markers} + 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_templated_name f templated_name = + on_templated_name f templated_name |> Option.bind ~f:eat_template_arg + in + let on_objc_cpp f objc_cpp = on_objc_cpp f objc_cpp |> Option.bind ~f:eat_template_arg in + {on_objc_cpp; on_templated_name; get_markers} let templ_end @@ -307,24 +307,24 @@ let args_cons : ('f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher -> ('f_interm, 'f_out, 'captured_types, 'markers) func_arg -> ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) 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 capt f_args = on_args capt f_args |> Option.bind ~f:(eat_func_arg capt) in - {on_proc; on_args; markers} + 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 capt f_args = on_args capt f_args |> Option.bind ~f:(eat_func_arg capt) in + {on_proc; on_args; markers} let args_end : ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher -> ('f_proc_out, 'f_out, 'captured_types) func_args_end -> ('f_in, 'f_out) all_args_matcher = - fun m func_args_end -> - let {on_proc= {on_c; on_objc_cpp}; on_args} = m in - let on_c f c args = on_c f c |> pre_bind_opt ~f:(func_args_end ~on_args args) in - let on_objc_cpp f objc_cpp args = - on_objc_cpp f objc_cpp |> pre_bind_opt ~f:(func_args_end ~on_args args) - in - {on_c; on_objc_cpp} + fun m func_args_end -> + let {on_proc= {on_c; on_objc_cpp}; on_args} = m in + let on_c f c args = on_c f c |> pre_bind_opt ~f:(func_args_end ~on_args args) in + let on_objc_cpp f objc_cpp args = + on_objc_cpp f objc_cpp |> pre_bind_opt ~f:(func_args_end ~on_args args) + in + {on_c; on_objc_cpp} module type Common = sig @@ -460,17 +460,17 @@ module Common = struct , '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 - in - let add_marker capture_markers = (marker, capture_markers) in - {eat_template_arg; add_marker} + 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 + in + let add_marker capture_markers = (marker, capture_markers) in + {eat_template_arg; add_marker} (** Captures an int *) @@ -540,46 +540,46 @@ module Procname = struct include Common let make_matcher : ('f_in, 'f_out) all_args_matcher -> 'f_in -> 'f_out matcher = - fun m f -> - let {on_c; on_objc_cpp} : (_, _) all_args_matcher = m in - let on_objc_cpp objc_cpp args = - match on_objc_cpp f objc_cpp args with - | DoesNotMatch -> - None - | Matches res -> - Some res - | RetryWith {on_objc_cpp} -> - on_objc_cpp objc_cpp args - in - let on_c c args = - match on_c f c args with - | DoesNotMatch -> - None - | Matches res -> - Some res - | RetryWith {on_c} -> - on_c c args - in - {on_objc_cpp; on_c} + fun m f -> + let {on_c; on_objc_cpp} : (_, _) all_args_matcher = m in + let on_objc_cpp objc_cpp args = + match on_objc_cpp f objc_cpp args with + | DoesNotMatch -> + None + | Matches res -> + Some res + | RetryWith {on_objc_cpp} -> + on_objc_cpp objc_cpp args + in + let on_c c args = + match on_c f c args with + | DoesNotMatch -> + None + | Matches res -> + Some res + | RetryWith {on_c} -> + on_c c args + in + {on_objc_cpp; on_c} (** Simple implementation of a dispatcher, could be optimized later *) let make_dispatcher : 'f matcher list -> 'f dispatcher = - fun matchers -> - let on_objc_cpp objc_cpp args = - List.find_map matchers ~f:(fun (matcher: _ matcher) -> matcher.on_objc_cpp objc_cpp args) - in - let on_c c args = - List.find_map matchers ~f:(fun (matcher: _ matcher) -> matcher.on_c c args) - in - fun procname args -> - match procname with - | ObjC_Cpp objc_cpp -> - on_objc_cpp objc_cpp args - | C c -> - on_c c args - | _ -> - None + fun matchers -> + let on_objc_cpp objc_cpp args = + List.find_map matchers ~f:(fun (matcher: _ matcher) -> matcher.on_objc_cpp objc_cpp args) + in + let on_c c args = + List.find_map matchers ~f:(fun (matcher: _ matcher) -> matcher.on_c c args) + in + fun procname args -> + match procname with + | ObjC_Cpp objc_cpp -> + on_objc_cpp objc_cpp args + | C c -> + on_c c args + | _ -> + None (* Function args *) @@ -595,10 +595,10 @@ module Procname = struct let mk_match_typ_nth : ('markers -> 'marker) -> ('captured_types -> 'marker mtyp) -> 'marker -> ('captured_types, 'markers) one_arg_matcher = - fun get_m get_c marker -> - let marker_static_checker markers = Polymorphic_compare.( = ) marker (get_m markers) in - let match_arg capt arg = Typ.equal (FuncArg.typ arg) (get_c capt) in - {match_arg; marker_static_checker} + fun get_m get_c marker -> + let marker_static_checker markers = Polymorphic_compare.( = ) marker (get_m markers) in + let match_arg capt arg = Typ.equal (FuncArg.typ arg) (get_c capt) in + {match_arg; marker_static_checker} (** Matches first captured type *) @@ -622,19 +622,19 @@ module Procname = struct (** Matches the type matched by the given path_matcher *) let match_typ : (_, _, unit, unit, unit, non_empty) path_matcher -> (_, _) one_arg_matcher = - fun m -> - let {on_templated_name} : (_, _, unit, unit, unit, non_empty) path_matcher = m in - let rec match_typ typ = - match typ with - | {Typ.desc= Tstruct name} -> - name |> templated_name_of_class_name |> on_templated_name () |> Option.is_some - | {Typ.desc= Tptr (typ, _ptr_kind)} -> - match_typ typ - | _ -> - false - in - let match_arg _capt arg = match_typ (FuncArg.typ arg) in - {match_arg; marker_static_checker= no_marker_checker} + fun m -> + let {on_templated_name} : (_, _, unit, unit, unit, non_empty) path_matcher = m in + let rec match_typ typ = + match typ with + | {Typ.desc= Tstruct name} -> + name |> templated_name_of_class_name |> on_templated_name () |> Option.is_some + | {Typ.desc= Tptr (typ, _ptr_kind)} -> + match_typ typ + | _ -> + false + in + let match_arg _capt arg = match_typ (FuncArg.typ arg) in + {match_arg; marker_static_checker= no_marker_checker} (* Function argument capture *) @@ -674,21 +674,21 @@ module Procname = struct let make_arg : ('arg_in, 'arg_out, 'f_in, 'f_out) arg_preparer -> ('arg_in, 'arg_out, 'f_in, 'f_out, _, _) one_arg -> ('f_in, 'f_out, _, _) 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 {get_captured_value; do_capture} = capture in - let eat_func_arg capt (f, args) = - match args with - | [] -> - on_empty do_capture f - | arg :: rest when match_arg capt arg -> - Some (arg |> get_captured_value |> wrapper |> do_capture f, rest) - | _ -> - None - in - {eat_func_arg; marker_static_checker} + 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 {get_captured_value; do_capture} = capture in + let eat_func_arg capt (f, args) = + match args with + | [] -> + on_empty do_capture f + | arg :: rest when match_arg capt arg -> + Some (arg |> get_captured_value |> wrapper |> do_capture f, rest) + | _ -> + None + in + {eat_func_arg; marker_static_checker} let any_arg : (unit, _, 'f, 'f, _, _) one_arg = @@ -708,15 +708,15 @@ module Procname = struct let capt_exp_of_typ m = {one_arg_matcher= match_typ (m <...>! ()); capture= capture_arg_exp} let typ1 : 'marker -> (unit, _, 'f, 'f, _, _) one_arg = - fun m -> {one_arg_matcher= match_typ1 m; capture= no_capture} + fun m -> {one_arg_matcher= match_typ1 m; capture= no_capture} let typ2 : 'marker -> (unit, _, 'f, 'f, _, _) one_arg = - fun m -> {one_arg_matcher= match_typ2 m; capture= no_capture} + fun m -> {one_arg_matcher= match_typ2 m; capture= no_capture} let typ3 : 'marker -> (unit, _, 'f, 'f, _, _) one_arg = - fun m -> {one_arg_matcher= match_typ3 m; capture= no_capture} + fun m -> {one_arg_matcher= match_typ3 m; capture= no_capture} (* Function args end *) @@ -728,7 +728,7 @@ module Procname = struct (** Matches any function arguments *) let any_func_args : (_, _, _) func_args_end = - fun ~on_args args (f, capt) -> on_args capt (f, args) |> pre_map_opt ~f:fst + fun ~on_args args (f, capt) -> on_args capt (f, args) |> pre_map_opt ~f:fst (** If [func_args_end1] does not match, use [func_args_end2] *) @@ -736,23 +736,23 @@ module Procname = struct : ('f_in, 'f_out, 'captured_types) func_args_end -> ('f_in, 'f_out, 'captured_types) func_args_end -> ('f_in, 'f_out, 'captured_types) func_args_end = - fun func_args_end1 func_args_end2 ~on_args args f_capt -> - match func_args_end1 ~on_args args f_capt with - | DoesNotMatch -> - func_args_end2 ~on_args args f_capt - | otherwise -> - otherwise + fun func_args_end1 func_args_end2 ~on_args args f_capt -> + match func_args_end1 ~on_args args f_capt with + | DoesNotMatch -> + func_args_end2 ~on_args args f_capt + | otherwise -> + otherwise (** Retries matching with another matcher *) let args_end_retry : _ matcher -> (_, _, _) func_args_end = - fun m ~on_args:_ _args _f_capt -> RetryWith m + fun m ~on_args:_ _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 : 'f matcher -> (_, _, _) func_args_end = - fun m -> alternative_args_end no_args_left (args_end_retry m) + fun m -> alternative_args_end no_args_left (args_end_retry m) let wrong_args_internal_error : _ matcher = @@ -816,22 +816,22 @@ module TypName = struct let make_matcher : ('f_in, 'f_out, _, _, _, non_empty) path_matcher -> 'f_in -> 'f_out typ_matcher = - fun m f -> - let {on_templated_name} : ('f_in, 'f_out, _, _, _, non_empty) path_matcher = m in - let on_templated_name templated_name = - templated_name |> on_templated_name f |> Option.map ~f:fst - in - {on_templated_name} + fun m f -> + let {on_templated_name} : ('f_in, 'f_out, _, _, _, non_empty) path_matcher = m in + let on_templated_name templated_name = + templated_name |> on_templated_name f |> Option.map ~f:fst + in + {on_templated_name} let make_dispatcher : 'f typ_matcher list -> 'f typ_dispatcher = - fun matchers typname -> - match templated_name_of_class_name typname with - | exception DoNotHandleJavaYet -> - None - | templated_name -> - List.find_map matchers ~f:(fun (matcher: _ typ_matcher) -> - matcher.on_templated_name templated_name ) + fun matchers typname -> + match templated_name_of_class_name typname with + | exception DoNotHandleJavaYet -> + None + | templated_name -> + List.find_map matchers ~f:(fun (matcher: _ typ_matcher) -> + matcher.on_templated_name templated_name ) let ( &-->! ) path_matcher f = make_matcher path_matcher f diff --git a/infer/src/IR/Tenv.ml b/infer/src/IR/Tenv.ml index a235fc04a..c4a3f85f6 100644 --- a/infer/src/IR/Tenv.ml +++ b/infer/src/IR/Tenv.ml @@ -96,11 +96,11 @@ let load_global () : t option = let store_to_filename tenv tenv_filename = Serialization.write_to_file tenv_serializer tenv_filename ~data:tenv ; - if Config.debug_mode then + if Config.debug_mode then ( let debug_filename = DB.filename_to_string (DB.filename_add_suffix tenv_filename ".debug") in let out_channel = Out_channel.create debug_filename in let fmt = Format.formatter_of_out_channel out_channel in - Format.fprintf fmt "%a" pp tenv ; Out_channel.close out_channel + Format.fprintf fmt "%a" pp tenv ; Out_channel.close out_channel ) let store source_file tenv = tenv_filename_of_source_file source_file |> store_to_filename tenv diff --git a/infer/src/IR/Typ.ml b/infer/src/IR/Typ.ml index 4cf950ecc..ce05e8f22 100644 --- a/infer/src/IR/Typ.ml +++ b/infer/src/IR/Typ.ml @@ -1248,8 +1248,15 @@ module Struct = struct if Config.debug_mode then (* change false to true to print the details of struct *) F.fprintf f - "%a @\n\tfields: {%a@\n\t}@\n\tsupers: {%a@\n\t}@\n\tmethods: {%a@\n\t}@\n\tannots: {%a@\n\t}" - Name.pp name + "%a @\n\ + \tfields: {%a@\n\ + \t}@\n\ + \tsupers: {%a@\n\ + \t}@\n\ + \tmethods: {%a@\n\ + \t}@\n\ + \tannots: {%a@\n\ + \t}" Name.pp name (Pp.seq (pp_field pe)) fields (Pp.seq (fun f n -> F.fprintf f "@\n\t\t%a" Name.pp n)) diff --git a/infer/src/absint/AbstractInterpreter.ml b/infer/src/absint/AbstractInterpreter.ml index 2556f9d2c..bab75276f 100644 --- a/infer/src/absint/AbstractInterpreter.ml +++ b/infer/src/absint/AbstractInterpreter.ml @@ -78,19 +78,19 @@ struct let instr_ids = match CFG.instr_ids node with [] -> [(Sil.skip_instr, None)] | l -> l in if debug then NodePrinter.start_session (CFG.underlying_node node) ; let astate_post, inv_map_post = List.fold ~f:compute_post ~init:(pre, inv_map) instr_ids in - ( if debug then - let instrs = List.map ~f:fst instr_ids in - L.d_strln - (Format.asprintf "PRE: %a@.INSTRS: %aPOST: %a@." Domain.pp pre - (Sil.pp_instr_list Pp.(html Green)) - instrs Domain.pp astate_post) ; - NodePrinter.finish_session (CFG.underlying_node node) ) ; + if debug then ( + let instrs = List.map ~f:fst instr_ids in + L.d_strln + (Format.asprintf "PRE: %a@.INSTRS: %aPOST: %a@." Domain.pp pre + (Sil.pp_instr_list Pp.(html Green)) + instrs Domain.pp astate_post) ; + NodePrinter.finish_session (CFG.underlying_node node) ) ; let inv_map'' = InvariantMap.add node_id {pre; post= astate_post; visit_count} inv_map_post in (inv_map'', Scheduler.schedule_succs work_queue node) in - if InvariantMap.mem node_id inv_map then + if InvariantMap.mem node_id inv_map then ( let old_state = InvariantMap.find node_id inv_map in let widened_pre = if CFG.is_loop_head pdesc node then @@ -102,9 +102,10 @@ struct let visit_count' = old_state.visit_count + 1 in if visit_count' > Config.max_widens then L.(die InternalError) - "Exceeded max widening threshold %d while analyzing %a. Please check your widening operator or increase the threshold" - Config.max_widens Typ.Procname.pp (Procdesc.get_proc_name pdesc) ; - update_inv_map widened_pre visit_count' + "Exceeded max widening threshold %d while analyzing %a. Please check your widening \ + operator or increase the threshold" Config.max_widens Typ.Procname.pp + (Procdesc.get_proc_name pdesc) ; + update_inv_map widened_pre visit_count' ) else (* first time visiting this node *) let visit_count = 1 in diff --git a/infer/src/absint/LowerHil.ml b/infer/src/absint/LowerHil.ml index fa205d45e..4b5f50b62 100644 --- a/infer/src/absint/LowerHil.ml +++ b/infer/src/absint/LowerHil.ml @@ -30,13 +30,13 @@ struct type extras = TransferFunctions.extras let pp_pre_post pre post hil_instr node = - if Config.write_html then + if Config.write_html then ( let underyling_node = CFG.underlying_node node in NodePrinter.start_session underyling_node ; L.d_strln (Format.asprintf "PRE: %a@.INSTR: %a@.POST: %a@." TransferFunctions.Domain.pp pre HilInstr.pp hil_instr TransferFunctions.Domain.pp post) ; - NodePrinter.finish_session underyling_node + NodePrinter.finish_session underyling_node ) let is_java_unlock pname actuals = diff --git a/infer/src/backend/DifferentialFilters.ml b/infer/src/backend/DifferentialFilters.ml index 014b63669..7844d6da7 100644 --- a/infer/src/backend/DifferentialFilters.ml +++ b/infer/src/backend/DifferentialFilters.ml @@ -47,9 +47,9 @@ module FileRenamings = struct raise (Yojson.Json_error "not a record") with Yojson.Json_error err -> L.(die UserError) - "Error parsing file renamings: %s@\nExpected JSON object of the following form: '%s', but instead got: '%s'" - err "{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"}" - (Yojson.Basic.to_string assoc) + "Error parsing file renamings: %s@\n\ + Expected JSON object of the following form: '%s', but instead got: '%s'" err + "{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"}" (Yojson.Basic.to_string assoc) in match j with | `List json_renamings -> diff --git a/infer/src/backend/InferPrint.ml b/infer/src/backend/InferPrint.ml index 325d8293b..052315f70 100644 --- a/infer/src/backend/InferPrint.ml +++ b/infer/src/backend/InferPrint.ml @@ -226,7 +226,7 @@ module IssuesJson = struct if key.in_footprint && error_filter source_file key.err_desc key.err_name && should_report_source_file && should_report key.err_kind key.err_name key.err_desc err_data.err_class - then + then ( let kind = Exceptions.err_kind_string key.err_kind in let bug_type = key.err_name.IssueType.unique_id in let file = SourceFile.to_string source_file in @@ -278,7 +278,7 @@ module IssuesJson = struct ; access= err_data.access } in if not !is_first_item then pp "," else is_first_item := false ; - pp "%s@?" (Jsonbug_j.string_of_jsonbug bug) + pp "%s@?" (Jsonbug_j.string_of_jsonbug bug) ) (** Write bug report in JSON format *) diff --git a/infer/src/backend/RetainCycles.ml b/infer/src/backend/RetainCycles.ml index 63ec246f9..ff811663e 100644 --- a/infer/src/backend/RetainCycles.ml +++ b/infer/src/backend/RetainCycles.ml @@ -191,11 +191,11 @@ let get_retain_cycles hpred tenv prop_ = let exn_retain_cycle tenv hpred cycle = let retain_cycle = desc_retain_cycle tenv cycle in let cycle_dotty = Format.asprintf "%a" RetainCyclesType.pp_dotty cycle in - ( if Config.debug_mode then - let rc_dotty_dir = Filename.concat Config.results_dir Config.retain_cycle_dotty_dir in - Utils.create_dir rc_dotty_dir ; - let rc_dotty_file = Filename.temp_file ~in_dir:rc_dotty_dir "rc" ".dot" in - RetainCyclesType.write_dotty_to_file rc_dotty_file cycle ) ; + if Config.debug_mode then ( + let rc_dotty_dir = Filename.concat Config.results_dir Config.retain_cycle_dotty_dir in + Utils.create_dir rc_dotty_dir ; + let rc_dotty_file = Filename.temp_file ~in_dir:rc_dotty_dir "rc" ".dot" in + RetainCyclesType.write_dotty_to_file rc_dotty_file cycle ) ; let desc = Localise.desc_retain_cycle retain_cycle (State.get_loc ()) (Some cycle_dotty) in Exceptions.Retain_cycle (hpred, desc, __POS__) diff --git a/infer/src/backend/abs.ml b/infer/src/backend/abs.ml index 01e8301c9..d12efd647 100644 --- a/infer/src/backend/abs.ml +++ b/infer/src/backend/abs.ml @@ -1039,7 +1039,7 @@ let check_junk ?original_prop pname tenv prop = List.rev sigma_done | hpred :: sigma_todo' -> let entries = Sil.hpred_entries hpred in - if should_remove_hpred entries then + if should_remove_hpred entries then ( let part = if fp_part then "footprint" else "normal" in L.d_strln (".... Prop with garbage in " ^ part ^ " part ....") ; L.d_increase_indent 1 ; @@ -1159,7 +1159,7 @@ let check_junk ?original_prop pname tenv prop = leaks_reported := alloc_attribute :: !leaks_reported ) in if not ignore_leak then report_leak () ; - remove_junk_recursive sigma_done sigma_todo' + remove_junk_recursive sigma_done sigma_todo' ) else remove_junk_recursive (hpred :: sigma_done) sigma_todo' in remove_junk_recursive [] sigma diff --git a/infer/src/backend/dom.ml b/infer/src/backend/dom.ml index a2863d919..c16d99473 100644 --- a/infer/src/backend/dom.ml +++ b/infer/src/backend/dom.ml @@ -249,7 +249,7 @@ module CheckJoinPre : InfoLossCheckerSig = struct List.length es >= 1 | Exp.Var _ -> if Int.equal Config.join_cond 0 then List.exists ~f:(Exp.equal Exp.zero) es - else if Dangling.check side e then + else if Dangling.check side e then ( let r = List.exists ~f:(fun e' -> not (Dangling.check side_op e')) es in if r then ( L.d_str ".... Dangling Check (dang e:" ; @@ -258,7 +258,7 @@ module CheckJoinPre : InfoLossCheckerSig = struct Sil.d_exp_list es ; L.d_strln ") ...." ; L.d_ln () ) ; - r + r ) else let r = List.exists ~f:(Dangling.check side_op) es in if r then ( diff --git a/infer/src/backend/dotty.ml b/infer/src/backend/dotty.ml index 69fb84b47..bab48c776 100644 --- a/infer/src/backend/dotty.ml +++ b/infer/src/backend/dotty.ml @@ -112,11 +112,11 @@ let print_stack_info = ref false let strip_special_chars b = let b = Bytes.of_string b in let replace st c c' = - if Bytes.contains st c then + 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 _ -> L.internal_error "@\n@\nstrip_special_chars: Invalid argument!@\n@." ; - assert false + assert false ) else st in let s0 = replace b '(' 'B' in diff --git a/infer/src/backend/errdesc.ml b/infer/src/backend/errdesc.ml index 0cf933e5c..6f48f899d 100644 --- a/infer/src/backend/errdesc.ml +++ b/infer/src/backend/errdesc.ml @@ -1150,11 +1150,11 @@ let explain_dereference_as_caller_expression proc_name tenv ?(use_buckets= false if Pvar.is_global pv then let dexp = exp_lv_dexp tenv node (Exp.Lvar pv) in create_dereference_desc proc_name tenv ~use_buckets dexp deref_str actual_pre loc - else if Pvar.is_callee pv then + else if Pvar.is_callee pv then ( let position = find_formal_param_number pv_name in if verbose then L.d_strln ("parameter number: " ^ string_of_int position) ; explain_nth_function_parameter proc_name tenv use_buckets deref_str actual_pre position - pvar_off + pvar_off ) else if Attribute.has_dangling_uninit tenv spec_pre exp then Localise.desc_uninitialized_dangling_pointer_deref deref_str (Pvar.to_string pv) loc else Localise.no_desc diff --git a/infer/src/backend/match.ml b/infer/src/backend/match.ml index 623e198d7..c507885e6 100644 --- a/infer/src/backend/match.ml +++ b/infer/src/backend/match.ml @@ -153,14 +153,14 @@ and isel_match isel1 sub vars isel2 = | (idx1, se1') :: isel1', (idx2, se2') :: isel2' -> let idx2 = Sil.exp_sub (`Exp sub) idx2 in let sanity_check = not (List.exists ~f:(fun id -> Sil.ident_in_exp id idx2) vars) in - if not sanity_check then + if not sanity_check then ( let pe = Pp.text in L.internal_error "@[.... Sanity Check Failure while Matching Index-Strexps ....@\n" ; L.internal_error "@[<4> IDX1: %a, STREXP1: %a@\n" (Sil.pp_exp_printenv pe) idx1 (Sil.pp_sexp pe) se1' ; L.internal_error "@[<4> IDX2: %a, STREXP2: %a@\n@." (Sil.pp_exp_printenv pe) idx2 (Sil.pp_sexp pe) se2' ; - assert false + assert false ) else if Exp.equal idx1 idx2 then match strexp_match se1' sub vars se2' with | None -> diff --git a/infer/src/backend/mergeCapture.ml b/infer/src/backend/mergeCapture.ml index 4d0e04365..7a9e668af 100644 --- a/infer/src/backend/mergeCapture.ml +++ b/infer/src/backend/mergeCapture.ml @@ -102,10 +102,10 @@ let should_link ~target ~target_results_dir ~stats infer_out_src infer_out_dst = let was_copied () = let captured_src = Filename.concat infer_out_src Config.captured_dir_name in let captured_dst = Filename.concat infer_out_dst Config.captured_dir_name in - if Sys.file_exists captured_src = `Yes && Sys.is_directory captured_src = `Yes then + if Sys.file_exists captured_src = `Yes && Sys.is_directory captured_src = `Yes then ( let captured_files = Array.to_list (Sys.readdir captured_src) in num_captured_files := List.length captured_files ; - List.for_all ~f:(fun file -> check_file (Filename.concat captured_dst file)) captured_files + List.for_all ~f:(fun file -> check_file (Filename.concat captured_dst file)) captured_files ) else true in let was_modified () = String.Set.mem !modified_targets target in diff --git a/infer/src/backend/paths.ml b/infer/src/backend/paths.ml index ce7f759ae..08425e98b 100644 --- a/infer/src/backend/paths.ml +++ b/infer/src/backend/paths.ml @@ -205,10 +205,10 @@ end = struct let nodes_found stats = stats.max_length > 0 in function | Pstart (node, stats) -> - if stats_is_dummy stats then + if stats_is_dummy stats then ( let found = f node in stats.max_length <- (if found then 1 else 0) ; - stats.linear_num <- 1.0 + stats.linear_num <- 1.0 ) | Pnode (node, _, _, path, stats, _) -> if stats_is_dummy stats then ( compute_stats do_calls f path ; @@ -227,7 +227,7 @@ end = struct stats.max_length <- max stats1.max_length stats2.max_length ; stats.linear_num <- stats1.linear_num +. stats2.linear_num ) | Pcall (path1, _, ExecCompleted path2, stats) -> - if stats_is_dummy stats then + if stats_is_dummy stats then ( let stats2 = match do_calls with | true -> @@ -244,12 +244,12 @@ end = struct compute_stats do_calls f' path1 ; get_stats path1 in stats.max_length <- stats1.max_length + stats2.max_length ; - stats.linear_num <- stats1.linear_num + stats.linear_num <- stats1.linear_num ) | Pcall (path, _, ExecSkipped _, stats) -> - if stats_is_dummy stats then + if stats_is_dummy stats then ( let stats1 = compute_stats do_calls f path ; get_stats path in stats.max_length <- stats1.max_length ; - stats.linear_num <- stats1.linear_num + stats.linear_num <- stats1.linear_num ) end (* End of module Invariant *) @@ -441,10 +441,10 @@ end = struct F.fprintf fmt "(%a: %s)" (doit (n - 1)) path reason in let print_delayed () = - if not (PathMap.is_empty !delayed) then + if not (PathMap.is_empty !delayed) then ( let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in F.fprintf fmt "where@\n" ; - PathMap.iter f !delayed + PathMap.iter f !delayed ) in add_delayed path ; doit 0 fmt path ; print_delayed () diff --git a/infer/src/backend/printer.ml b/infer/src/backend/printer.ml index 68ed27256..9d8d27348 100644 --- a/infer/src/backend/printer.ml +++ b/infer/src/backend/printer.ml @@ -358,7 +358,7 @@ let node_finish_session node = (** Write html file for the procedure. The boolean indicates whether to print whole seconds only *) let write_proc_html pdesc = - if Config.write_html then + if Config.write_html then ( let pname = Procdesc.get_proc_name pdesc in let source = (Procdesc.get_loc pdesc).file in let nodes = List.sort ~cmp:Procdesc.Node.compare (Procdesc.get_nodes pdesc) in @@ -386,7 +386,7 @@ let write_proc_html pdesc = () | Some summary -> Specs.pp_summary_html source Black fmt summary ; - Io_infer.Html.close (fd, fmt) + Io_infer.Html.close (fd, fmt) ) (** Creare a hash table mapping line numbers to the set of errors occurring on that line *) diff --git a/infer/src/backend/prop.ml b/infer/src/backend/prop.ml index 808105c1d..82526a241 100644 --- a/infer/src/backend/prop.ml +++ b/infer/src/backend/prop.ml @@ -465,8 +465,9 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst -> ( if List.exists ~f:(fun (n, _) -> Typ.Name.equal n name) path then L.die InternalError - "Ill-founded recursion in [create_strexp_of_type]: a sub-element of struct %a is also of type struct %a: %a:%a" - Typ.Name.pp name Typ.Name.pp name pp_path (List.rev path) Typ.Name.pp name ; + "Ill-founded recursion in [create_strexp_of_type]: a sub-element of struct %a is also \ + of type struct %a: %a:%a" Typ.Name.pp name Typ.Name.pp name pp_path (List.rev path) + Typ.Name.pp name ; match (struct_init_mode, Tenv.lookup tenv name) with | Fld_init, Some {fields} -> (* pass len as an accumulator, so that it is passed to create_strexp_of_type for the last @@ -2284,7 +2285,6 @@ let from_pi pi = set prop_emp ~pi let from_sigma sigma = set prop_emp ~sigma - (** {2 Prop iterators} *) (** Iterator state over sigma. *) diff --git a/infer/src/backend/prover.ml b/infer/src/backend/prover.ml index 97b25d9a6..0b8c87775 100644 --- a/infer/src/backend/prover.ml +++ b/infer/src/backend/prover.ml @@ -876,27 +876,27 @@ let get_smt_key a p = let check_atom tenv prop a0 = let a = Prop.atom_normalize_prop tenv prop a0 in let prop_no_fp = Prop.set prop ~pi_fp:[] ~sigma_fp:[] in - ( if Config.smt_output then - let key = get_smt_key a prop_no_fp in - let key_filename = - let source = (State.get_loc ()).file in - DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) [key ^ ".cns"] - in - let outc = Out_channel.create (DB.filename_to_string key_filename) in - let fmt = F.formatter_of_out_channel outc in - L.d_str ("ID: " ^ key) ; - L.d_ln () ; - L.d_str "CHECK_ATOM_BOUND: " ; - Sil.d_atom a ; - L.d_ln () ; - L.d_str "WHERE:" ; - L.d_ln () ; - Prop.d_prop prop_no_fp ; - L.d_ln () ; - L.d_ln () ; - F.fprintf fmt "ID: %s @\nCHECK_ATOM_BOUND: %a@\nWHERE:@\n%a" key (Sil.pp_atom Pp.text) a - (Prop.pp_prop Pp.text) prop_no_fp ; - Out_channel.close outc ) ; + if Config.smt_output then ( + let key = get_smt_key a prop_no_fp in + let key_filename = + let source = (State.get_loc ()).file in + DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) [key ^ ".cns"] + in + let outc = Out_channel.create (DB.filename_to_string key_filename) in + let fmt = F.formatter_of_out_channel outc in + L.d_str ("ID: " ^ key) ; + L.d_ln () ; + L.d_str "CHECK_ATOM_BOUND: " ; + Sil.d_atom a ; + L.d_ln () ; + L.d_str "WHERE:" ; + L.d_ln () ; + Prop.d_prop prop_no_fp ; + L.d_ln () ; + L.d_ln () ; + F.fprintf fmt "ID: %s @\nCHECK_ATOM_BOUND: %a@\nWHERE:@\n%a" key (Sil.pp_atom Pp.text) a + (Prop.pp_prop Pp.text) prop_no_fp ; + Out_channel.close outc ) ; match a with | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> check_le_normalized tenv prop e1 e2 diff --git a/infer/src/backend/rearrange.ml b/infer/src/backend/rearrange.ml index 991ed3e1e..e754e854d 100644 --- a/infer/src/backend/rearrange.ml +++ b/infer/src/backend/rearrange.ml @@ -181,13 +181,13 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp | Tint _, _ | Tfloat _, _ | Tvoid, _ | Tfun _, _ | Tptr _, _ | TVar _, _ -> fail t off __POS__ in - ( if Config.trace_rearrange then - let _, se, _ = res in - L.d_strln "exiting create_struct_values, returning" ; - Sil.d_sexp se ; - L.d_decrease_indent 1 ; - L.d_ln () ; - L.d_ln () ) ; + if Config.trace_rearrange then ( + let _, se, _ = res in + L.d_strln "exiting create_struct_values, returning" ; + Sil.d_sexp se ; + L.d_decrease_indent 1 ; + L.d_ln () ; + L.d_ln () ) ; res @@ -327,7 +327,7 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp let array_default = Sil.Earray (array_len, array_cont, inst_arr) in let typ_default = Typ.mk_array ~default:typ_array typ_cont ?length:typ_array_len in [([], array_default, typ_default)] - else if !Config.footprint then + else if !Config.footprint then ( let atoms, elem_se, elem_typ = create_struct_values pname tenv orig_prop footprint_part kind max_stamp typ_cont off inst in @@ -337,7 +337,7 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in let array_new = Sil.Earray (array_len, cont_new, inst_arr) in let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in - [(atoms, array_new, typ_new)] + [(atoms, array_new, typ_new)] ) else let res_new = if array_is_full then [] diff --git a/infer/src/backend/reporting.ml b/infer/src/backend/reporting.ml index ccb74a00d..3d45d45ad 100644 --- a/infer/src/backend/reporting.ml +++ b/infer/src/backend/reporting.ml @@ -68,8 +68,9 @@ let log_issue_deprecated ?(store_summary= false) err_kind proc_name ?loc ?node_i Specs.store_summary summary | None -> L.(die InternalError) - "Trying to report error on procedure %a, but cannot because no summary exists for this procedure. Did you mean to log the error on the caller of %a instead?" - Typ.Procname.pp proc_name Typ.Procname.pp proc_name + "Trying to report error on procedure %a, but cannot because no summary exists for this \ + procedure. Did you mean to log the error on the caller of %a instead?" Typ.Procname.pp + proc_name Typ.Procname.pp proc_name let log_error = log_issue_from_summary Exceptions.Kerror diff --git a/infer/src/backend/symExec.ml b/infer/src/backend/symExec.ml index d0e28e45a..f44256e5f 100644 --- a/infer/src/backend/symExec.ml +++ b/infer/src/backend/symExec.ml @@ -791,7 +791,7 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ | _ -> prop in - if is_receiver_null then + if is_receiver_null then ( (* objective-c instance method with a null receiver just return objc_null(res). *) let path = Paths.Path.add_description path path_description in L.d_strln @@ -801,7 +801,7 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ we want to add the attribute OBJC_NULL to it so that we can keep track of how this object became null, so that in a NPE we can separate it into a different error type *) - [(add_objc_null_attribute_or_nullify_result pre, path)] + [(add_objc_null_attribute_or_nullify_result pre, path)] ) else match force_objc_init_return_nil pdesc callee_pname tenv ret_id pre path receiver with | [] -> diff --git a/infer/src/backend/tabulation.ml b/infer/src/backend/tabulation.ml index b8953bb2c..5b449b204 100644 --- a/infer/src/backend/tabulation.ml +++ b/infer/src/backend/tabulation.ml @@ -419,7 +419,7 @@ let check_path_errors_in_post tenv caller_pname post post_path = let check_attr atom = match atom with | Sil.Apred (Adiv0 path_pos, [e]) -> - if Prover.check_zero tenv e then + if Prover.check_zero tenv e then ( let desc = Errdesc.explain_divide_by_zero tenv e (State.get_node ()) (State.get_loc ()) in @@ -431,7 +431,7 @@ let check_path_errors_in_post tenv caller_pname post post_path = in State.set_path new_path path_pos_opt ; let exn = Exceptions.Divide_by_zero (desc, __POS__) in - Reporting.log_warning_deprecated caller_pname exn + Reporting.log_warning_deprecated caller_pname exn ) | _ -> () in @@ -964,13 +964,13 @@ let mk_actual_precondition tenv prop actual_params formal_params = | f :: fpars', a :: apars' -> (f, a) :: comb fpars' apars' | [], _ -> - ( if apars <> [] then - let str = - "more actual pars than formal pars in fun call (" - ^ string_of_int (List.length actual_params) ^ " vs " - ^ string_of_int (List.length formal_params) ^ ")" - in - L.d_warning str ; L.d_ln () ) ; + if apars <> [] then ( + let str = + "more actual pars than formal pars in fun call (" + ^ string_of_int (List.length actual_params) ^ " vs " + ^ string_of_int (List.length formal_params) ^ ")" + in + L.d_warning str ; L.d_ln () ) ; [] | _ :: _, [] -> raise (Exceptions.Wrong_argument_number __POS__) @@ -1234,9 +1234,9 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re let call_desc kind_opt = Localise.desc_precondition_not_met kind_opt callee_pname loc in let res_with_path_idents = if !Config.footprint then - if List.is_empty valid_res_cons_pre_missing then - (* no valid results where actual pre and missing are consistent *) - match deref_errors with + if List.is_empty valid_res_cons_pre_missing then ( + match (* no valid results where actual pre and missing are consistent *) + deref_errors with | error :: _ -> ( (* dereference error detected *) @@ -1304,7 +1304,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re else call_desc None in trace_call CR_not_met ; - raise (Exceptions.Precondition_not_met (desc, __POS__)) + raise (Exceptions.Precondition_not_met (desc, __POS__)) ) else (* combine the valid results, and store diverging states *) let process_valid_res vr = diff --git a/infer/src/base/CommandDoc.ml b/infer/src/base/CommandDoc.ml index 44b8ffabe..a5fca4980 100644 --- a/infer/src/base/CommandDoc.ml +++ b/infer/src/base/CommandDoc.ml @@ -74,8 +74,10 @@ $(b,infer) $(b,capture) $(i,[options]) $(b,--) $(b,ndk-build) $(i,...) $(b,infer) $(b,capture) $(i,[--no-xcpretty]) $(i,[options]) $(b,--) $(b,xcodebuild) $(i,...)|} ~description: [ `P - "Capture the build command or compilation database specified on the command line: infer intercepts calls to the compiler to read source files, translate them into infer's intermediate representation, and store the result of the translation in the results directory." - ] + "Capture the build command or compilation database specified on the command line: infer \ + intercepts calls to the compiler to read source files, translate them into infer's \ + intermediate representation, and store the result of the translation in the results \ + directory." ] ~see_also:InferCommand.([Analyze; Compile; Run]) @@ -85,20 +87,26 @@ let compile = ~synopsis:"$(b,infer) $(b,compile) $(b,--) $(i,[compile command])" ~description: [ `P - "Intercepts compilation commands similarly to $(b,infer-capture), but simply execute these compilation commands and do not perform any translation of the source files. This can be useful to configure build systems or for debugging purposes." - ] + "Intercepts compilation commands similarly to $(b,infer-capture), but simply execute \ + these compilation commands and do not perform any translation of the source files. \ + This can be useful to configure build systems or for debugging purposes." ] ~examples: [ `P - "$(b,cmake)(1) hardcodes the absolute paths to the compiler inside the Makefiles it generates, which defeats the later capture of compilation commands by infer. Thus, to capture a CMake project, one should configure the project from within the infer build environment, for instance:" + "$(b,cmake)(1) hardcodes the absolute paths to the compiler inside the Makefiles it \ + generates, which defeats the later capture of compilation commands by infer. Thus, to \ + capture a CMake project, one should configure the project from within the infer build \ + environment, for instance:" ; `Pre {| mkdir build && cd build infer compile -- cmake .. infer capture -- make|} ; `P - "The same solution can be used for projects whose \"./configure\" script hardcodes the paths to the compilers, for instance:" + "The same solution can be used for projects whose \"./configure\" script hardcodes the \ + paths to the compilers, for instance:" ; `Pre {| infer compile -- ./configure infer capture -- make|} ; `P - "Another solution for CMake projects is to use CMake's compilation databases, for instance:" + "Another solution for CMake projects is to use CMake's compilation databases, for \ + instance:" ; `Pre {| mkdir build && cd build cmake -DCMAKE_EXPORT_COMPILE_COMMANDS=1 .. @@ -121,8 +129,8 @@ let explore = ~synopsis:{|$(b,infer) $(b,explore) $(i,[options])|} ~description: [ `P - "Show the list of bugs on the console and explore symbolic program traces emitted by infer to explain a report. Can also generate an HTML report from a JSON report." - ] + "Show the list of bugs on the console and explore symbolic program traces emitted by \ + infer to explain a report. Can also generate an HTML report from a JSON report." ] ~see_also:InferCommand.([Report; Run]) @@ -141,45 +149,64 @@ $(b,infer) $(i,[options]) $(b,--) $(b,compile command) $(b,infer) $(i,[options])|} ~description: [ `P - "Infer is a static analyzer. Given a collection of source files written in Java or in languages of the C family, and a command to build them, infer produces a list of potential issues." + "Infer is a static analyzer. Given a collection of source files written in Java or in \ + languages of the C family, and a command to build them, infer produces a list of \ + potential issues." ; `P - "Infer consists of a collection of tools referenced in the $(i,SEE ALSO) section of this manual. See their respective manuals for more information." + "Infer consists of a collection of tools referenced in the $(i,SEE ALSO) section of \ + this manual. See their respective manuals for more information." ; `P - "When run without a subcommand, and if a compilation command is specified via the $(b,--) option or one of the $(b,--clang-compilation-database[-escaped]) options, then $(b,infer) behaves as $(b,infer-run)(1). Otherwise, $(b,infer) behaves as $(b,infer-analyze)(1)." - ] + "When run without a subcommand, and if a compilation command is specified via the \ + $(b,--) option or one of the $(b,--clang-compilation-database[-escaped]) options, then \ + $(b,infer) behaves as $(b,infer-run)(1). Otherwise, $(b,infer) behaves as \ + $(b,infer-analyze)(1)." ] ~options: (`Prepend [ `P "Every infer command accepts the arguments from all the other infer commands." ; `P (Printf.sprintf - "Options are read from the $(b,%s) file, then from the $(b,%s) environment variable, then from the command line. Options in $(b,%s) take precedence over options in $(b,%s), and options passed on the command line take precedence over options in $(b,%s). See the $(i,%s) and $(i,%s) sections of this manual for more information." - inferconfig_file CLOpt.args_env_var CLOpt.args_env_var inferconfig_file - CLOpt.args_env_var Cmdliner.Manpage.s_environment Cmdliner.Manpage.s_files) + "Options are read from the $(b,%s) file, then from the $(b,%s) environment \ + variable, then from the command line. Options in $(b,%s) take precedence over \ + options in $(b,%s), and options passed on the command line take precedence over \ + options in $(b,%s). See the $(i,%s) and $(i,%s) sections of this manual for more \ + information." inferconfig_file CLOpt.args_env_var CLOpt.args_env_var + inferconfig_file CLOpt.args_env_var Cmdliner.Manpage.s_environment + Cmdliner.Manpage.s_files) ; `P - "Options can be specified inside an argument file $(i,file) by passing $(b,@)$(i,file) as argument. The format is one option per line, and enclosing single ' and double \" quotes are ignored." + "Options can be specified inside an argument file $(i,file) by passing \ + $(b,@)$(i,file) as argument. The format is one option per line, and enclosing single \ + ' and double \" quotes are ignored." ; `P - "Options without a default value (e.g., $(b,--linter)) and options with list-like values (e.g., $(b,--Xbuck)) all have a corresponding $(b,--option-reset) flag that resets their values to nothing or the empty list, respectively. For instance, $(b,--Xbuck-reset) will cancel any previous $(b,--Xbuck) option passed to infer." + "Options without a default value (e.g., $(b,--linter)) and options with list-like \ + values (e.g., $(b,--Xbuck)) all have a corresponding $(b,--option-reset) flag that \ + resets their values to nothing or the empty list, respectively. For instance, \ + $(b,--Xbuck-reset) will cancel any previous $(b,--Xbuck) option passed to infer." ; `P - "See the manuals of individual infer commands for details about their supported options. The following is a list of all the supported options (see also $(b,--help-full) for options reserved for internal use)." - ]) + "See the manuals of individual infer commands for details about their supported \ + options. The following is a list of all the supported options (see also \ + $(b,--help-full) for options reserved for internal use)." ]) ~environment: [ `P (Printf.sprintf - "Extra arguments may be passed to all infer commands using the $(b,%s) environment variable (see the $(i,%s) section). $(b,%s) is expected to contain a string of %c-separated options. For instance, calling `%s=--debug^--print-logs infer` is equivalent to calling `infer --debug --print-logs`." - CLOpt.args_env_var Cmdliner.Manpage.s_options CLOpt.args_env_var CLOpt.env_var_sep - CLOpt.args_env_var) + "Extra arguments may be passed to all infer commands using the $(b,%s) environment \ + variable (see the $(i,%s) section). $(b,%s) is expected to contain a string of \ + %c-separated options. For instance, calling `%s=--debug^--print-logs infer` is \ + equivalent to calling `infer --debug --print-logs`." CLOpt.args_env_var + Cmdliner.Manpage.s_options CLOpt.args_env_var CLOpt.env_var_sep CLOpt.args_env_var) ; `P (Printf.sprintf "$(b,%s): Tells infer where to find the %s file. (See the %s section)" inferconfig_env_var inferconfig_file Cmdliner.Manpage.s_files) ; `P (Printf.sprintf - "If $(b,%s) is set to \"1\", then infer commands will exit with an error code in some cases when otherwise a simple warning would be emitted on stderr, for instance if a deprecated form of an option is used." - CLOpt.strict_mode_env_var) ] + "If $(b,%s) is set to \"1\", then infer commands will exit with an error code in \ + some cases when otherwise a simple warning would be emitted on stderr, for instance \ + if a deprecated form of an option is used." CLOpt.strict_mode_env_var) ] ~files: [ `P (Printf.sprintf - "$(b,%s) can be used to store infer options. Its format is that of a JSON record, where fields are infer long-form options, without their leading \"--\", and values depend on the type of the option:" - inferconfig_file) + "$(b,%s) can be used to store infer options. Its format is that of a JSON record, \ + where fields are infer long-form options, without their leading \"--\", and values \ + depend on the type of the option:" inferconfig_file) ; `Noblank ; `P "- for switches options, the value is a JSON boolean (true or false, without quotes)" ; `Noblank @@ -189,14 +216,14 @@ $(b,infer) $(i,[options])|} ; `Noblank ; `P (Printf.sprintf - "- path options have string values, and are interpreted relative to the location of the %s file" - inferconfig_file) + "- path options have string values, and are interpreted relative to the location of \ + the %s file" inferconfig_file) ; `Noblank ; `P "- cumulative options are JSON arrays of the appropriate type" ; `P (Printf.sprintf - "Infer will look for an $(b,%s) file in the current directory, then its parent, etc., stopping at the first $(b,%s) file found." - inferconfig_file inferconfig_file) + "Infer will look for an $(b,%s) file in the current directory, then its parent, \ + etc., stopping at the first $(b,%s) file found." inferconfig_file inferconfig_file) ; `P "Example:" ; `Pre {| { @@ -211,10 +238,11 @@ let report = ~synopsis:"$(b,infer) $(b,report) $(i,[options]) [$(i,file.specs)...]" ~description: [ `P - "Read, convert, and print .specs files in the results directory. Each spec is printed to standard output unless option -q is used." + "Read, convert, and print .specs files in the results directory. Each spec is printed \ + to standard output unless option -q is used." ; `P - "If no specs file are passed on the command line, process all the .specs in the results directory." - ] + "If no specs file are passed on the command line, process all the .specs in the results \ + directory." ] ~see_also:InferCommand.([ReportDiff; Run]) @@ -222,10 +250,13 @@ let reportdiff = mk_command_doc ~title:"Infer Report Difference" ~short_description:"compute the differences between two infer reports" ~synopsis: - "$(b,infer) $(b,reportdiff) $(b,--report-current) $(i,file) $(b,--report-previous) $(i,file) $(i,[options])" + "$(b,infer) $(b,reportdiff) $(b,--report-current) $(i,file) $(b,--report-previous) \ + $(i,file) $(i,[options])" ~description: [ `P - "Given two infer reports $(i,previous) and $(i,current), compute the following three reports and store them inside the \"differential/\" subdirectory of the results directory:" + "Given two infer reports $(i,previous) and $(i,current), compute the following three \ + reports and store them inside the \"differential/\" subdirectory of the results \ + directory:" ; `Noblank ; `P "- $(b,introduced.json) contains the issues found in $(i,current) but not $(i,previous);" @@ -233,7 +264,8 @@ let reportdiff = ; `P "- $(b,fixed.json) contains the issues found in $(i,previous) but not $(i,current);" ; `Noblank ; `P - "- $(b,preexisting.json) contains the issues found in both $(i,previous) and $(i,current)." + "- $(b,preexisting.json) contains the issues found in both $(i,previous) and \ + $(i,current)." ; `P "All three files follow the same format as normal infer reports." ] ~see_also:InferCommand.([Report]) @@ -244,8 +276,8 @@ let events = ~synopsis:{|$(b,infer) $(b,events)|} ~description: [ `P - "Emit to stdout one JSON object per line, each describing a logged event happened during the execution of Infer" - ] + "Emit to stdout one JSON object per line, each describing a logged event happened \ + during the execution of Infer" ] ~see_also:InferCommand.([Report; Run]) @@ -257,7 +289,8 @@ let run = $(b,infer) $(i,[options]) $(b,--) $(i,compile command)|} ~description: [ `P - "Calling \"$(b,infer) $(b,run) $(i,[options])\" is equivalent to performing the following sequence of commands:" + "Calling \"$(b,infer) $(b,run) $(i,[options])\" is equivalent to performing the \ + following sequence of commands:" ; `Pre {|$(b,infer) $(b,capture) $(i,[options]) $(b,infer) $(b,analyze) $(i,[options])|} ] ~see_also:InferCommand.([Analyze; Capture; Report]) diff --git a/infer/src/base/CommandLineOption.ml b/infer/src/base/CommandLineOption.ml index 33ec8d5df..dec36671b 100644 --- a/infer/src/base/CommandLineOption.ml +++ b/infer/src/base/CommandLineOption.ml @@ -477,7 +477,7 @@ let mk_string_list ?(default= []) ?(f= fun s -> s) ?(deprecated= []) ~long ?shor let normalize_path_in_args_being_parsed ?(f= Fn.id) ~is_anon_arg str = - if Filename.is_relative str then + if Filename.is_relative str then ( (* Replace relative paths with absolute ones on the fly in the args being parsed. This assumes that [!arg_being_parsed] points at either [str] (if [is_anon_arg]) or at the option name position in [!args_to_parse], as is the case e.g. when calling @@ -485,7 +485,7 @@ let normalize_path_in_args_being_parsed ?(f= Fn.id) ~is_anon_arg str = let root = Unix.getcwd () in let abs_path = Utils.filename_to_absolute ~root str in !args_to_parse.((!arg_being_parsed + if is_anon_arg then 0 else 1)) <- f abs_path ; - abs_path + abs_path ) else str @@ -922,7 +922,7 @@ let parse ?config_file ~usage action initial_command = in let to_export = let argv_to_export = decode_env_to_argv !args_to_export in - if argv_to_export <> [] then + if argv_to_export <> [] then ( (* We have to be careful not to add too much data to the environment because the size of the environment contributes to the length of the command to be run. If the environment + CLI is too big, running any command will fail with a cryptic "exit code 127" error. Use an argfile @@ -930,7 +930,7 @@ let parse ?config_file ~usage action initial_command = let file = Filename.temp_file "args_" "" in Out_channel.with_file file ~f:(fun oc -> Out_channel.output_lines oc argv_to_export) ; if not !keep_args_file then Utils.unlink_file_on_exit file ; - "@" ^ file + "@" ^ file ) else "" in Unix.putenv ~key:args_env_var ~data:to_export ; diff --git a/infer/src/base/Config.ml b/infer/src/base/Config.ml index 5b7eeed76..5f53c21da 100644 --- a/infer/src/base/Config.ml +++ b/infer/src/base/Config.ml @@ -614,12 +614,12 @@ and ( analysis_blacklist_files_containing_options ( mk_filtering_options ~suffix:"blacklist-files-containing" ~deprecated_suffix:["blacklist_files_containing"] ~help: - "blacklist files containing the specified string for the given analyzer (see $(b,--analyzer) for valid values)" - ~meta:"string" + "blacklist files containing the specified string for the given analyzer (see \ + $(b,--analyzer) for valid values)" ~meta:"string" , mk_filtering_options ~suffix:"blacklist-path-regex" ~deprecated_suffix:["blacklist"] ~help: - "blacklist the analysis of files whose relative path matches the specified OCaml-style regex (to whitelist: $(b,---whitelist-path-regex))" - ~meta:"path_regex" + "blacklist the analysis of files whose relative path matches the specified OCaml-style \ + regex (to whitelist: $(b,---whitelist-path-regex))" ~meta:"path_regex" , mk_filtering_options ~suffix:"whitelist-path-regex" ~deprecated_suffix:["whitelist"] ~help:"" ~meta:"path_regex" , mk_filtering_options ~suffix:"suppress-errors" ~deprecated_suffix:["suppress_errors"] @@ -660,8 +660,9 @@ and analyzer = if equal_analyzer x y then Some s else None ) in CLOpt.warnf - "WARNING: The analyzer '%s' is deprecated, use the '%s' subcommand instead:@\n@\n infer %s ..." - analyzer_str analyzer_str analyzer_str ; + "WARNING: The analyzer '%s' is deprecated, use the '%s' subcommand instead:@\n\ + @\n \ + infer %s ..." analyzer_str analyzer_str analyzer_str ; x | _ as x -> x) @@ -698,7 +699,10 @@ and ( annotation_reachability in let annotation_reachability = mk_checker ~default:true ~long:"annotation-reachability" - "the annotation reachability checker. Given a pair of source and sink annotation, e.g. @PerformanceCritical and @Expensive, this checker will warn whenever some method annotated with @PerformanceCritical calls, directly or indirectly, another method annotated with @Expensive" + "the annotation reachability checker. Given a pair of source and sink annotation, e.g. \ + @PerformanceCritical and @Expensive, this checker will warn whenever some method annotated \ + with @PerformanceCritical calls, directly or indirectly, another method annotated with \ + @Expensive" and biabduction = mk_checker ~long:"biabduction" ~default:true "the separation logic based bi-abduction analysis using the checkers framework" @@ -716,7 +720,8 @@ and ( annotation_reachability "detects when Android fragments are not explicitly nullified before becoming unreabable" and immutable_cast = mk_checker ~long:"immutable-cast" ~default:true - "the detection of object cast from immutable type to mutable type. For instance, it will detect cast from ImmutableList to List, ImmutableMap to Map, and ImmutableSet to Set." + "the detection of object cast from immutable type to mutable type. For instance, it will \ + detect cast from ImmutableList to List, ImmutableMap to Map, and ImmutableSet to Set." and linters = mk_checker ~long:"linters" ~default:true "syntactic linters" and litho = mk_checker ~long:"litho" "Experimental checkers supporting the Litho framework" and liveness = @@ -724,7 +729,9 @@ and ( annotation_reachability and ownership = mk_checker ~long:"ownership" ~default:false "the detection of C++ lifetime bugs" and printf_args = mk_checker ~long:"printf-args" ~default:true - "the detection of mismatch between the Java printf format strings and the argument types For, example, this checker will warn about the type error in `printf(\"Hello %d\", \"world\")`" + "the detection of mismatch between the Java printf format strings and the argument types \ + For, example, this checker will warn about the type error in `printf(\"Hello %d\", \ + \"world\")`" and quandary = mk_checker ~long:"quandary" ~default:true "the quandary taint analysis" and racerd = mk_checker ~long:"racerd" ~deprecated:["-threadsafety"] ~default:true @@ -804,7 +811,8 @@ Example format: for custom annotations com.my.annotation.{Source1,Source2,Sink1} and append_buck_flavors = CLOpt.mk_string_list ~long:"append-buck-flavors" ~in_help:InferCommand.([(Capture, manual_buck_flavors)]) - "Additional Buck flavors to append to targets discovered by the $(b,--buck-compilation-database) option." + "Additional Buck flavors to append to targets discovered by the \ + $(b,--buck-compilation-database) option." and array_level = @@ -840,8 +848,8 @@ and buck_build_args = and buck_compilation_database_depth = CLOpt.mk_int_opt ~long:"buck-compilation-database-depth" ~in_help:InferCommand.([(Capture, manual_buck_compilation_db)]) - "Depth of dependencies used by the $(b,--buck-compilation-database deps) option. By default, all recursive dependencies are captured." - ~meta:"int" + "Depth of dependencies used by the $(b,--buck-compilation-database deps) option. By default, \ + all recursive dependencies are captured." ~meta:"int" and buck_compilation_database = @@ -866,7 +874,8 @@ and changed_files_index = CLOpt.mk_path_opt ~long:"changed-files-index" ~in_help:InferCommand.([(Analyze, manual_generic); (Diff, manual_generic)]) ~meta:"file" - "Specify the file containing the list of source files from which reactive analysis should start. Source files should be specified relative to project root or be absolute" + "Specify the file containing the list of source files from which reactive analysis should \ + start. Source files should be specified relative to project root or be absolute" and check_version = @@ -892,12 +901,16 @@ and clang_frontend_action = and clang_include_to_override_regex = CLOpt.mk_string_opt ~long:"clang-include-to-override-regex" ~deprecated:["-clang-include-to-override"] ~meta:"dir_OCaml_regex" - "Use this option in the uncommon case where the normal compilation process overrides the location of internal compiler headers. This option should specify regular expression with the path to those headers so that infer can use its own clang internal headers instead." + "Use this option in the uncommon case where the normal compilation process overrides the \ + location of internal compiler headers. This option should specify regular expression with \ + the path to those headers so that infer can use its own clang internal headers instead." and clang_ignore_regex = CLOpt.mk_string_opt ~long:"clang-ignore-regex" ~meta:"dir_OCaml_regex" - "The files in this regex will be ignored in the compilation process and an empty file will be passed to clang instead. This is to be used with the buck flavour infer-capture-all to work around missing generated files." + "The files in this regex will be ignored in the compilation process and an empty file will be \ + passed to clang instead. This is to be used with the buck flavour infer-capture-all to work \ + around missing generated files." and classpath = CLOpt.mk_string_opt ~long:"classpath" "Specify the Java classpath" @@ -917,13 +930,15 @@ and compilation_database_escaped = CLOpt.mk_path_list ~long:"compilation-database-escaped" ~deprecated:["-clang-compilation-db-files-escaped"] ~in_help:InferCommand.([(Capture, manual_clang)]) - "File that contain compilation commands where all entries are escaped for the shell, eg coming from Xcode (can be specified multiple times)" + "File that contain compilation commands where all entries are escaped for the shell, eg \ + coming from Xcode (can be specified multiple times)" and compute_analytics = CLOpt.mk_bool ~long:"compute-analytics" ~default:false ~in_help:InferCommand.([(Capture, manual_clang); (Run, manual_clang)]) - "Emit analytics as info-level issues, like component kit line count and component kit file cyclomatic complexity" + "Emit analytics as info-level issues, like component kit line count and component kit file \ + cyclomatic complexity" (** Continue the capture for reactive mode: @@ -931,26 +946,31 @@ and compute_analytics = and continue = CLOpt.mk_bool ~deprecated:["continue"] ~long:"continue" ~in_help:InferCommand.([(Analyze, manual_generic)]) - "Continue the capture for the reactive analysis, increasing the changed files/procedures. (If a procedure was changed beforehand, keep the changed marking.)" + "Continue the capture for the reactive analysis, increasing the changed files/procedures. (If \ + a procedure was changed beforehand, keep the changed marking.)" and current_to_previous_script = CLOpt.mk_string_opt ~long:"current-to-previous-script" ~in_help:InferCommand.([(Diff, manual_generic)]) ~meta:"shell" - "Specify a script to checkout a previous version of the project to compare against, assuming we are on the current version already." + "Specify a script to checkout a previous version of the project to compare against, assuming \ + we are on the current version already." and cxx_infer_headers = CLOpt.mk_bool ~long:"cxx-infer-headers" ~default:true ~in_help:InferCommand.([(Capture, manual_clang)]) - "Include C++ header models during compilation. Infer swaps some C++ headers for its own in order to get a better model of, eg, the standard library. This can sometimes cause compilation failures." + "Include C++ header models during compilation. Infer swaps some C++ headers for its own in \ + order to get a better model of, eg, the standard library. This can sometimes cause \ + compilation failures." and cxx_scope_guards = CLOpt.mk_json ~long:"cxx-scope-guards" ~in_help:InferCommand.([(Analyze, manual_clang)]) - "Specify scope guard classes that can be read only by destructors without being reported as dead stores." + "Specify scope guard classes that can be read only by destructors without being reported as \ + dead stores." and cxx = @@ -1040,7 +1060,9 @@ and ( bo_debug let debug = CLOpt.mk_bool_group ~deprecated:["debug"; "-stats"] ~long:"debug" ~short:'g' ~in_help:all_generic_manuals - "Debug mode (also sets $(b,--debug-level 2), $(b,--developer-mode), $(b,--no-filtering), $(b,--print-buckets), $(b,--print-types), $(b,--reports-include-ml-loc), $(b,--no-only-cheap-debug), $(b,--trace-error), $(b,--write-dotty), $(b,--write-html))" + "Debug mode (also sets $(b,--debug-level 2), $(b,--developer-mode), $(b,--no-filtering), \ + $(b,--print-buckets), $(b,--print-types), $(b,--reports-include-ml-loc), \ + $(b,--no-only-cheap-debug), $(b,--trace-error), $(b,--write-dotty), $(b,--write-html))" ~f:(fun debug -> if debug then set_debug_level 2 else set_debug_level 0 ; CommandLineOption.keep_args_file := debug ; @@ -1061,8 +1083,10 @@ and ( bo_debug - 2: very verbose debugging enabled|} and debug_exceptions = CLOpt.mk_bool_group ~long:"debug-exceptions" - "Generate lightweight debugging information: just print the internal exceptions during analysis (also sets $(b,--developer-mode), $(b,--no-filtering), $(b,--print-buckets), $(b,--reports-include-ml-loc))" - [developer_mode; print_buckets; reports_include_ml_loc] [filtering; keep_going] + "Generate lightweight debugging information: just print the internal exceptions during \ + analysis (also sets $(b,--developer-mode), $(b,--no-filtering), $(b,--print-buckets), \ + $(b,--reports-include-ml-loc))" [developer_mode; print_buckets; reports_include_ml_loc] + [filtering; keep_going] and default_linters = CLOpt.mk_bool ~long:"default-linters" ~in_help:InferCommand.([(Capture, manual_clang_linters)]) @@ -1070,8 +1094,8 @@ and ( bo_debug and frontend_tests = CLOpt.mk_bool_group ~long:"frontend-tests" ~in_help:InferCommand.([(Capture, manual_clang)]) - "Save filename.ext.test.dot with the cfg in dotty format for frontend tests (also sets $(b,--print-types))" - [print_types] [] + "Save filename.ext.test.dot with the cfg in dotty format for frontend tests (also sets \ + $(b,--print-types))" [print_types] [] and models_mode = CLOpt.mk_bool_group ~long:"models-mode" "Mode for analyzing the models" [] [keep_going] and print_logs = @@ -1087,7 +1111,9 @@ and ( bo_debug let linters_developer_mode = CLOpt.mk_bool_group ~long:"linters-developer-mode" ~in_help:InferCommand.([(Capture, manual_clang_linters)]) - "Debug mode for developing new linters. (Sets the analyzer to $(b,linters); also sets $(b,--debug), $(b,--debug-level-linters 2), $(b,--developer-mode), and unsets $(b,--allowed-failures) and $(b,--default-linters)." + "Debug mode for developing new linters. (Sets the analyzer to $(b,linters); also sets \ + $(b,--debug), $(b,--debug-level-linters 2), $(b,--developer-mode), and unsets \ + $(b,--allowed-failures) and $(b,--default-linters)." ~f:(fun debug -> debug_level_linters := if debug then 2 else 0 ; debug ) @@ -1120,18 +1146,22 @@ and ( bo_debug and dependencies = CLOpt.mk_bool ~deprecated:["dependencies"] ~long:"dependencies" ~in_help:InferCommand.([(Capture, manual_java)]) - "Translate all the dependencies during the capture. The classes in the given jar file will be translated. No sources needed." + "Translate all the dependencies during the capture. The classes in the given jar file will be \ + translated. No sources needed." and differential_filter_files = CLOpt.mk_string_opt ~long:"differential-filter-files" ~in_help:InferCommand.([(Report, manual_generic)]) - "Specify the file containing the list of source files for which a differential report is desired. Source files should be specified relative to project root or be absolute" + "Specify the file containing the list of source files for which a differential report is \ + desired. Source files should be specified relative to project root or be absolute" and differential_filter_set = CLOpt.mk_symbol_seq ~long:"differential-filter-set" ~eq:PVariant.( = ) - "Specify which set of the differential results is filtered with the modified files provided through the $(b,--differential-modified-files) argument. By default it is applied to all sets ($(b,introduced), $(b,fixed), and $(b,preexisting))" + "Specify which set of the differential results is filtered with the modified files provided \ + through the $(b,--differential-modified-files) argument. By default it is applied to all \ + sets ($(b,introduced), $(b,fixed), and $(b,preexisting))" ~symbols:[("introduced", `Introduced); ("fixed", `Fixed); ("preexisting", `Preexisting)] ~default:[`Introduced; `Fixed; `Preexisting] @@ -1157,10 +1187,19 @@ and () = mk false ~default:disabled_issues_ids ~long:"disable-issue-type" ~deprecated:["disable_checks"; "-disable-checks"] (Printf.sprintf - "Do not show reports coming from this type of issue. Each checker can report a range of issue types. This option provides fine-grained filtering over which types of issue should be reported once the checkers have run. In particular, note that disabling issue types does not make the corresponding checker not run.\n By default, the following issue types are disabled: %s.\n\n See also $(b,--report-issue-type).\n" + "Do not show reports coming from this type of issue. Each checker can report a range of \ + issue types. This option provides fine-grained filtering over which types of issue should \ + be reported once the checkers have run. In particular, note that disabling issue types \ + does not make the corresponding checker not run.\n \ + By default, the following issue types are disabled: %s.\n\ + \n \ + See also $(b,--report-issue-type).\n\ + " (String.concat ~sep:", " disabled_issues_ids)) ; mk true ~long:"enable-issue-type" ~deprecated:["enable_checks"; "-enable-checks"] - "Show reports coming from this type of issue. By default, all issue types are enabled except the ones listed in $(b,--disable-issue-type). Note that enabling issue types does not make the corresponding checker run; see individual checker options to turn them on or off." + "Show reports coming from this type of issue. By default, all issue types are enabled except \ + the ones listed in $(b,--disable-issue-type). Note that enabling issue types does not make \ + the corresponding checker run; see individual checker options to turn them on or off." and dotty_cfg_libs = @@ -1228,13 +1267,23 @@ and filter_paths = and filter_report = CLOpt.mk_string_list ~long:"filter-report" ~in_help:InferCommand.([(Report, manual_generic); (Run, manual_generic)]) - "Specify a filter for issues to report. If multiple filters are specified, they are applied in the order in which they are specified. Each filter is applied to each issue detected, and only issues which are accepted by all filters are reported. Each filter is of the form: `::`. The first two components are OCaml Str regular expressions, with an optional `!` character prefix. If a regex has a `!` prefix, the polarity is inverted, and the filter becomes a \"blacklist\" instead of a \"whitelist\". Each filter is interpreted as an implication: an issue matches if it does not match the `issue_type_regex` or if it does match the `filename_regex`. The filenames that are tested by the regex are relative to the `--project-root` directory. The `` is a non-empty string used to explain why the issue was filtered." + "Specify a filter for issues to report. If multiple filters are specified, they are applied \ + in the order in which they are specified. Each filter is applied to each issue detected, and \ + only issues which are accepted by all filters are reported. Each filter is of the form: \ + `::`. The first two components are OCaml \ + Str regular expressions, with an optional `!` character prefix. If a regex has a `!` prefix, \ + the polarity is inverted, and the filter becomes a \"blacklist\" instead of a \"whitelist\". \ + Each filter is interpreted as an implication: an issue matches if it does not match the \ + `issue_type_regex` or if it does match the `filename_regex`. The filenames that are tested \ + by the regex are relative to the `--project-root` directory. The `` is a \ + non-empty string used to explain why the issue was filtered." and flavors = CLOpt.mk_bool ~deprecated:["-use-flavors"] ~long:"flavors" ~in_help:InferCommand.([(Capture, manual_buck_flavors)]) - "Buck integration using Buck flavors (clang only), eg $(i,`infer --flavors -- buck build //foo:bar#infer`)" + "Buck integration using Buck flavors (clang only), eg $(i,`infer --flavors -- buck build \ + //foo:bar#infer`)" and force_delete_results_dir = @@ -1245,7 +1294,8 @@ and force_delete_results_dir = ; (Compile, manual_generic) ; (Diff, manual_generic) ; (Run, manual_generic) ]) - "Do not refuse to delete the results directory if it doesn't look like an infer results directory." + "Do not refuse to delete the results directory if it doesn't look like an infer results \ + directory." and force_integration = @@ -1262,7 +1312,8 @@ and from_json_report = CLOpt.mk_path_opt ~long:"from-json-report" ~in_help:InferCommand.([(Report, manual_generic)]) ~meta:"report.json" - "Load analysis results from a report file (default is to load the results from the specs files generated by the analysis)." + "Load analysis results from a report file (default is to load the results from the specs \ + files generated by the analysis)." and frontend_stats = @@ -1274,7 +1325,8 @@ and gen_previous_build_command_script = CLOpt.mk_string_opt ~long:"gen-previous-build-command-script" ~in_help:InferCommand.([(Diff, manual_generic)]) ~meta:"shell" - "Specify a script that outputs the build command to capture in the previous version of the project. The script should output the command on stdout. For example \"echo make\"." + "Specify a script that outputs the build command to capture in the previous version of the \ + project. The script should output the command on stdout. For example \"echo make\"." and generated_classes = @@ -1305,7 +1357,8 @@ and help_format = ~symbols:[("auto", `Auto); ("groff", `Groff); ("pager", `Pager); ("plain", `Plain)] ~eq:PVariant.( = ) ~default:`Auto ~in_help:(List.map InferCommand.all_commands ~f:(fun command -> (command, manual_generic))) - "Show this help in the specified format. $(b,auto) sets the format to $(b,plain) if the environment variable $(b,TERM) is \"dumb\" or undefined, and to $(b,pager) otherwise." + "Show this help in the specified format. $(b,auto) sets the format to $(b,plain) if the \ + environment variable $(b,TERM) is \"dumb\" or undefined, and to $(b,pager) otherwise." and html = @@ -1316,7 +1369,8 @@ and html = and icfg_dotty_outfile = CLOpt.mk_path_opt ~long:"icfg-dotty-outfile" ~meta:"path" - "If set, specifies path where .dot file should be written, it overrides the path for all other options that would generate icfg file otherwise" + "If set, specifies path where .dot file should be written, it overrides the path for all \ + other options that would generate icfg file otherwise" and ignore_trivial_traces = @@ -1338,7 +1392,8 @@ and iphoneos_target_sdk_version = and iphoneos_target_sdk_version_path_regex = CLOpt.mk_string_list ~long:"iphoneos-target-sdk-version-path-regex" ~in_help:InferCommand.([(Capture, manual_clang_linters)]) - "To pass a specific target SDK version to use for iphoneos in a particular path, with the format path:version (can be specified multiple times)" + "To pass a specific target SDK version to use for iphoneos in a particular path, with the \ + format path:version (can be specified multiple times)" and issues_fields = @@ -1367,7 +1422,8 @@ and issues_txt = and iterations = CLOpt.mk_int ~deprecated:["iterations"] ~long:"iterations" ~default:1 ~meta:"int" - "Specify the maximum number of operations for each function, expressed as a multiple of symbolic operations and a multiple of seconds of elapsed time" + "Specify the maximum number of operations for each function, expressed as a multiple of \ + symbolic operations and a multiple of seconds of elapsed time" and java_jar_compiler = @@ -1404,7 +1460,8 @@ and log_file = and linter = CLOpt.mk_string_opt ~long:"linter" ~in_help:InferCommand.([(Capture, manual_clang_linters)]) - "From the linters available, only run this one linter. (Useful together with $(b,--linters-developer-mode))" + "From the linters available, only run this one linter. (Useful together with \ + $(b,--linters-developer-mode))" and linters_def_file = @@ -1421,7 +1478,8 @@ and linters_def_folder = in let () = CLOpt.mk_set linters_def_folder [] ~long:"reset-linters-def-folder" - "Reset the list of folders containing linters definitions to be empty (see $(b,linters-def-folder))." + "Reset the list of folders containing linters definitions to be empty (see \ + $(b,linters-def-folder))." in linters_def_folder @@ -1429,7 +1487,9 @@ and linters_def_folder = and linters_doc_url = CLOpt.mk_string_list ~long:"linters-doc-url" ~in_help:InferCommand.([(Capture, manual_clang_linters)]) - "Specify custom documentation URL for some linter that overrides the default one. Useful if your project has specific ways of fixing a lint error that is not true in general or public info. Format: linter_name:doc_url." + "Specify custom documentation URL for some linter that overrides the default one. Useful if \ + your project has specific ways of fixing a lint error that is not true in general or public \ + info. Format: linter_name:doc_url." and linters_ignore_clang_failures = @@ -1449,7 +1509,8 @@ and load_average = CLOpt.mk_float_opt ~long:"load-average" ~short:'l' ~in_help:InferCommand.([(Capture, manual_generic)]) ~meta:"float" - "Do not start new parallel jobs if the load average is greater than that specified (Buck and make only)" + "Do not start new parallel jobs if the load average is greater than that specified (Buck and \ + make only)" and margin = @@ -1460,7 +1521,8 @@ and margin = and max_nesting = CLOpt.mk_int_opt ~long:"max-nesting" ~in_help:InferCommand.([(Explore, manual_generic)]) - "Level of nested procedure calls to show. Trace elements beyond the maximum nesting level are skipped. If omitted, all levels are shown." + "Level of nested procedure calls to show. Trace elements beyond the maximum nesting level are \ + skipped. If omitted, all levels are shown." and merge = @@ -1507,15 +1569,16 @@ and only_show = and passthroughs = CLOpt.mk_bool ~long:"passthroughs" ~default:false - "In error traces, show intermediate steps that propagate data. When false, error traces are shorter and show only direct flow via souces/sinks" + "In error traces, show intermediate steps that propagate data. When false, error traces are \ + shorter and show only direct flow via souces/sinks" and patterns_modeled_expensive = let long = "modeled-expensive" in ( long , CLOpt.mk_json ~deprecated:["modeled_expensive"] ~long - "Matcher or list of matchers for methods that should be considered expensive by the performance critical checker." - ) + "Matcher or list of matchers for methods that should be considered expensive by the \ + performance critical checker." ) and patterns_never_returning_null = @@ -1529,8 +1592,8 @@ and patterns_skip_implementation = let long = "skip-implementation" in ( long , CLOpt.mk_json ~long - "Matcher or list of matchers for names of files where we only want to translate the method declaration, skipping the body of the methods (Java only)." - ) + "Matcher or list of matchers for names of files where we only want to translate the method \ + declaration, skipping the body of the methods (Java only)." ) and patterns_skip_translation = @@ -1560,7 +1623,10 @@ and previous_to_current_script = CLOpt.mk_string_opt ~long:"previous-to-current-script" ~in_help:InferCommand.([(Diff, manual_generic)]) ~meta:"shell" - "Specify a script to checkout the current version of the project. The project is supposed to already be at that current version when running $(b,infer diff); the script is used after having analyzed the current and previous versions of the project, to restore the project to the current version." + "Specify a script to checkout the current version of the project. The project is supposed to \ + already be at that current version when running $(b,infer diff); the script is used after \ + having analyzed the current and previous versions of the project, to restore the project to \ + the current version." and print_active_checkers = @@ -1587,7 +1653,9 @@ and print_using_diff = and procedures_per_process = CLOpt.mk_int ~long:"procedures-per-process" ~default:1000 ~meta:"int" - "Specify the number of procedures to analyze per process when using $(b,--per-procedure-parallelism). If 0 is specified, each file is divided into $(b,--jobs) groups of procedures." + "Specify the number of procedures to analyze per process when using \ + $(b,--per-procedure-parallelism). If 0 is specified, each file is divided into $(b,--jobs) \ + groups of procedures." and procs_csv = @@ -1652,7 +1720,8 @@ and racerd_use_path_stability = and reactive = CLOpt.mk_bool ~deprecated:["reactive"] ~long:"reactive" ~short:'r' ~in_help:InferCommand.([(Analyze, manual_generic)]) - "Reactive mode: the analysis starts from the files captured since the $(i,infer) command started" + "Reactive mode: the analysis starts from the files captured since the $(i,infer) command \ + started" and reactive_capture = @@ -1687,7 +1756,9 @@ and report_hook = ~in_help:InferCommand.([(Analyze, manual_generic); (Run, manual_generic)]) ~default:(lib_dir ^/ "python" ^/ "report.py") ~meta:"script" - "Specify a script to be executed after the analysis results are written. This script will be passed, $(b,--issues-json), $(b,--issues-txt), $(b,--issues-xml), $(b,--project-root), and $(b,--results-dir)." + "Specify a script to be executed after the analysis results are written. This script will be \ + passed, $(b,--issues-json), $(b,--issues-txt), $(b,--issues-xml), $(b,--project-root), and \ + $(b,--results-dir)." and report_previous = @@ -1732,7 +1803,8 @@ and select = and siof_safe_methods = CLOpt.mk_string_list ~long:"siof-safe-methods" ~in_help:InferCommand.([(Analyze, manual_siof)]) - "Methods that are SIOF-safe; \"foo::bar\" will match \"foo::bar()\", \"foo::bar()\", etc. (can be specified multiple times)" + "Methods that are SIOF-safe; \"foo::bar\" will match \"foo::bar()\", \"foo::bar()\", \ + etc. (can be specified multiple times)" and skip_analysis_in_path = @@ -1823,14 +1895,18 @@ and stacktrace = CLOpt.mk_path_opt ~deprecated:["st"] ~long:"stacktrace" ~in_help:InferCommand.([(Analyze, manual_crashcontext)]) ~meta:"file" - "File path containing a json-encoded Java crash stacktrace. Used to guide the analysis (only with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json for examples of the expected format." + "File path containing a json-encoded Java crash stacktrace. Used to guide the analysis (only \ + with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json for examples of \ + the expected format." and stacktraces_dir = CLOpt.mk_path_opt ~long:"stacktraces-dir" ~in_help:InferCommand.([(Analyze, manual_crashcontext)]) ~meta:"dir" - "Directory path containing multiple json-encoded Java crash stacktraces. Used to guide the analysis (only with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json for examples of the expected format." + "Directory path containing multiple json-encoded Java crash stacktraces. Used to guide the \ + analysis (only with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json \ + for examples of the expected format." and stats_report = @@ -1879,7 +1955,8 @@ and trace_rearrange = and tracing = CLOpt.mk_bool ~deprecated:["tracing"] ~long:"tracing" - "Report error traces for runtime exceptions (Java only): generate preconditions for runtimeexceptions in Java and report errors for public methods which throw runtime exceptions" + "Report error traces for runtime exceptions (Java only): generate preconditions for \ + runtimeexceptions in Java and report errors for public methods which throw runtime exceptions" and tv_commit = @@ -1947,7 +2024,8 @@ and xcode_developer_dir = and xcpretty = CLOpt.mk_bool ~long:"xcpretty" ~default:false ~in_help:InferCommand.([(Capture, manual_clang)]) - "Infer will use xcpretty together with xcodebuild to analyze an iOS app. xcpretty just needs to be in the path, infer command is still just $(i,`infer -- `)." + "Infer will use xcpretty together with xcodebuild to analyze an iOS app. xcpretty just needs \ + to be in the path, infer command is still just $(i,`infer -- `)." (* The "rest" args must appear after "--" on the command line, and hence after other args, so they @@ -1961,11 +2039,11 @@ let javac_classes_out = needed but the tests break without this for now. See discussion in D4397716. *) ~default:CLOpt.init_work_dir ~f:(fun classes_out -> - ( if !buck then - let classes_out_infer = resolve classes_out ^/ buck_results_dir_name in - (* extend env var args to pass args to children that do not receive the rest args *) - CLOpt.extend_env_args ["--results-dir"; classes_out_infer] ; - results_dir := classes_out_infer ) ; + if !buck then ( + let classes_out_infer = resolve classes_out ^/ buck_results_dir_name in + (* extend env var args to pass args to children that do not receive the rest args *) + CLOpt.extend_env_args ["--results-dir"; classes_out_infer] ; + results_dir := classes_out_infer ) ; classes_out ) "" @@ -1973,11 +2051,11 @@ let javac_classes_out = and _ = CLOpt.mk_string_opt ~parse_mode:CLOpt.Javac ~deprecated:["classpath"; "cp"] ~long:"" ~f:(fun classpath -> - ( if !buck then - let paths = String.split classpath ~on:':' in - let files = List.filter paths ~f:(fun path -> Sys.is_file path = `Yes) in - CLOpt.extend_env_args (List.concat_map files ~f:(fun file -> ["--specs-library"; file])) ; - specs_library := List.rev_append files !specs_library ) ; + if !buck then ( + let paths = String.split classpath ~on:':' in + let files = List.filter paths ~f:(fun path -> Sys.is_file path = `Yes) in + CLOpt.extend_env_args (List.concat_map files ~f:(fun file -> ["--specs-library"; file])) ; + specs_library := List.rev_append files !specs_library ) ; classpath ) "" @@ -2167,8 +2245,8 @@ let process_iphoneos_target_sdk_version_path_regex args = {path= Str.regexp path; version} | None -> L.(die UserError) - "Incorrect format for the option iphoneos-target-sdk_version-path-regex. The correct format is path:version but got %s" - arg + "Incorrect format for the option iphoneos-target-sdk_version-path-regex. The correct \ + format is path:version but got %s" arg in List.map ~f:process_iphoneos_target_sdk_version_path_regex args @@ -2182,8 +2260,8 @@ let process_linters_doc_url args = {linter; doc_url} | None -> L.(die UserError) - "Incorrect format for the option linters-doc-url. The correct format is linter:doc_url but got %s" - arg + "Incorrect format for the option linters-doc-url. The correct format is linter:doc_url \ + but got %s" arg in List.map ~f:linters_doc_url args @@ -2664,7 +2742,10 @@ let clang_frontend_action_string = let dynamic_dispatch = CLOpt.mk_bool ~long:"dynamic-dispatch" ~default:biabduction - "Specify treatment of dynamic dispatch in Java code: false 'none' treats dynamic dispatch as a call to unknown code and true triggers lazy dynamic dispatch. The latter mode follows the JVM semantics and creates procedure descriptions during symbolic execution using the type information found in the abstract state" + "Specify treatment of dynamic dispatch in Java code: false 'none' treats dynamic dispatch as \ + a call to unknown code and true triggers lazy dynamic dispatch. The latter mode follows the \ + JVM semantics and creates procedure descriptions during symbolic execution using the type \ + information found in the abstract state" ~in_help:InferCommand.([(Analyze, manual_java)]) diff --git a/infer/src/base/Die.mli b/infer/src/base/Die.mli index 20027fd06..cc398b858 100644 --- a/infer/src/base/Die.mli +++ b/infer/src/base/Die.mli @@ -17,8 +17,8 @@ exception InferInternalError of string exception InferUserError of string +(** This can be used to avoid scattering exit invocations all over the codebase *) exception InferExit of int - (** This can be used to avoid scattering exit invocations all over the codebase *) (** kind of error for [die], with similar semantics as [Logging.{external,internal,user}_error] *) type error = ExternalError | InternalError | UserError diff --git a/infer/src/base/Escape.ml b/infer/src/base/Escape.ml index f9ef7a988..1e130758e 100644 --- a/infer/src/base/Escape.ml +++ b/infer/src/base/Escape.ml @@ -15,14 +15,14 @@ open! IStd (** apply a map function for escape sequences *) let escape_map map_fun s = let needs_escape = String.exists ~f:(fun c -> Option.is_some (map_fun c)) s in - if needs_escape then + if needs_escape then ( let len = String.length s in let buf = Buffer.create len in for i = 0 to len - 1 do let c = String.unsafe_get s i in match map_fun c with None -> Buffer.add_char buf c | Some s' -> Buffer.add_string buf s' done ; - Buffer.contents buf + Buffer.contents buf ) else (* not escaping anything, so don't waste memory on a copy of the string *) s diff --git a/infer/src/base/Logging.ml b/infer/src/base/Logging.ml index a2768f6d5..d206b11d9 100644 --- a/infer/src/base/Logging.ml +++ b/infer/src/base/Logging.ml @@ -313,7 +313,9 @@ let setup_log_file () = reset_formatters () ; if CLOpt.is_originator && preexisting_logfile then phase - "============================================================@\n= New infer execution begins@\n============================================================" + "============================================================@\n\ + = New infer execution begins@\n\ + ============================================================" (** type of printable elements *) diff --git a/infer/src/base/ProcessPool.mli b/infer/src/base/ProcessPool.mli index 83713bd90..0a19e0828 100644 --- a/infer/src/base/ProcessPool.mli +++ b/infer/src/base/ProcessPool.mli @@ -21,4 +21,3 @@ val start_child : f:('a -> unit) -> pool:t -> 'a -> unit val wait_all : t -> unit (** Wait until all the currently executing processes terminate *) - diff --git a/infer/src/base/ProcessPoolState.mli b/infer/src/base/ProcessPoolState.mli index 27ed17975..bfc1b0e10 100644 --- a/infer/src/base/ProcessPoolState.mli +++ b/infer/src/base/ProcessPoolState.mli @@ -6,5 +6,6 @@ * LICENSE file in the root directory of this source tree. An additional grant * of patent rights can be found in the PATENTS file in the same directory. *) + val in_child : bool ref (** Keep track of whether the current execution is in a child process *) diff --git a/infer/src/base/ResultsDir.ml b/infer/src/base/ResultsDir.ml index efdc8917e..af8edb639 100644 --- a/infer/src/base/ResultsDir.ml +++ b/infer/src/base/ResultsDir.ml @@ -43,8 +43,9 @@ let remove_results_dir () = if not Config.force_delete_results_dir then Result.iter_error (is_results_dir ~check_correct_version:false ()) ~f:(fun err -> L.(die UserError) - "ERROR: '%s' exists but does not seem to be an infer results directory: %s@\nERROR: Please delete '%s' and try again@." - Config.results_dir err Config.results_dir ) ; + "ERROR: '%s' exists but does not seem to be an infer results directory: %s@\n\ + ERROR: Please delete '%s' and try again@." Config.results_dir err Config.results_dir + ) ; Utils.rmtree Config.results_dir ) ; RunState.reset () diff --git a/infer/src/base/RunState.ml b/infer/src/base/RunState.ml index e7c611049..09b1f2e07 100644 --- a/infer/src/base/RunState.ml +++ b/infer/src/base/RunState.ml @@ -45,8 +45,10 @@ let load_and_validate () = (fun err_msg -> Error (Printf.sprintf - "Incompatible results directory '%s':\n%s\nWas '%s' created using an older version of infer?" - Config.results_dir err_msg Config.results_dir) ) + "Incompatible results directory '%s':\n\ + %s\n\ + Was '%s' created using an older version of infer?" Config.results_dir err_msg + Config.results_dir) ) msg in if Sys.file_exists state_file_path <> `Yes then error "save state not found" diff --git a/infer/src/base/Serialization.ml b/infer/src/base/Serialization.ml index 385855b6c..2828652a9 100644 --- a/infer/src/base/Serialization.ml +++ b/infer/src/base/Serialization.ml @@ -47,13 +47,15 @@ let create_serializer (key: Key.t) : 'a serializer = let read_data ((key': Key.t), (version': int), (value: 'a)) source_msg = if key <> key' then ( L.user_error - "Wrong key in when loading data from %s -- are you running infer with results coming from a previous version of infer?@\n" - source_msg ; + "Wrong key in when loading data from %s -- are you running infer with results coming from \ + a previous version of infer?@\n\ + " source_msg ; None ) else if version <> version' then ( L.user_error - "Wrong version in when loading data from %s -- are you running infer with results coming from a previous version of infer?@\n" - source_msg ; + "Wrong version in when loading data from %s -- are you running infer with results coming \ + from a previous version of infer?@\n\ + " source_msg ; None ) else Some value in diff --git a/infer/src/base/SqliteUtils.mli b/infer/src/base/SqliteUtils.mli index bac681461..b23f2abc8 100644 --- a/infer/src/base/SqliteUtils.mli +++ b/infer/src/base/SqliteUtils.mli @@ -9,8 +9,8 @@ open! IStd +(** The functions in this module tend to raise more often than their counterparts in [Sqlite3]. In particular, they may raise if the [Sqlite3.Rc.t] result of certain operations is unexpected. *) exception Error of string - (** The functions in this module tend to raise more often than their counterparts in [Sqlite3]. In particular, they may raise if the [Sqlite3.Rc.t] result of certain operations is unexpected. *) val check_sqlite_error : ?fatal:bool -> Sqlite3.db -> log:string -> Sqlite3.Rc.t -> unit (** Assert that the result is either [Sqlite3.Rc.OK]. If [row_is_ok] then [Sqlite3.Rc.ROW] is also accepted. If the result is not valid, then if [fatal] is set raise [Error], otherwise log the error and proceed. *) diff --git a/infer/src/base/SymOp.ml b/infer/src/base/SymOp.ml index d44d45ad5..44dfdcb50 100644 --- a/infer/src/base/SymOp.ml +++ b/infer/src/base/SymOp.ml @@ -19,8 +19,8 @@ type failure_kind = | FKrecursion_timeout of int (** max recursion level exceeded *) | FKcrash of string (** uncaught exception or failed assertion *) +(** failure that prevented analysis from finishing *) exception Analysis_failure_exe of failure_kind - (** failure that prevented analysis from finishing *) let exn_not_failure = function Analysis_failure_exe _ -> false | _ -> true diff --git a/infer/src/base/SymOp.mli b/infer/src/base/SymOp.mli index def5cd905..5ad23f201 100644 --- a/infer/src/base/SymOp.mli +++ b/infer/src/base/SymOp.mli @@ -61,7 +61,8 @@ type failure_kind = | FKrecursion_timeout of int (** max recursion level exceeded *) | FKcrash of string (** uncaught exception or failed assertion *) -exception Analysis_failure_exe of failure_kind (** Timeout exception *) +(** Timeout exception *) +exception Analysis_failure_exe of failure_kind val exn_not_failure : exn -> bool (** check that the exception is not a timeout exception *) diff --git a/infer/src/bufferoverrun/arrayBlk.ml b/infer/src/bufferoverrun/arrayBlk.ml index b5b4b3447..75920371d 100644 --- a/infer/src/bufferoverrun/arrayBlk.ml +++ b/infer/src/bufferoverrun/arrayBlk.ml @@ -24,29 +24,29 @@ module ArrInfo = struct let make : Itv.t * Itv.t * Itv.t -> t = fun (o, s, stride) -> {offset= o; size= s; stride} let join : t -> t -> t = - fun a1 a2 -> - if phys_equal a1 a2 then a2 - else - { offset= Itv.join a1.offset a2.offset - ; size= Itv.join a1.size a2.size - ; stride= Itv.join a1.stride a2.stride } + fun a1 a2 -> + if phys_equal a1 a2 then a2 + else + { offset= Itv.join a1.offset a2.offset + ; size= Itv.join a1.size a2.size + ; stride= Itv.join a1.stride a2.stride } let widen : prev:t -> next:t -> num_iters:int -> t = - fun ~prev ~next ~num_iters -> - if phys_equal prev next then next - else - { offset= Itv.widen ~prev:prev.offset ~next:next.offset ~num_iters - ; size= Itv.widen ~prev:prev.size ~next:next.size ~num_iters - ; stride= Itv.widen ~prev:prev.stride ~next:next.stride ~num_iters } + fun ~prev ~next ~num_iters -> + if phys_equal prev next then next + else + { offset= Itv.widen ~prev:prev.offset ~next:next.offset ~num_iters + ; size= Itv.widen ~prev:prev.size ~next:next.size ~num_iters + ; stride= Itv.widen ~prev:prev.stride ~next:next.stride ~num_iters } let ( <= ) : lhs:t -> rhs:t -> bool = - fun ~lhs ~rhs -> - if phys_equal lhs rhs then true - else - Itv.le ~lhs:lhs.offset ~rhs:rhs.offset && Itv.le ~lhs:lhs.size ~rhs:rhs.size - && Itv.le ~lhs:lhs.stride ~rhs:rhs.stride + fun ~lhs ~rhs -> + if phys_equal lhs rhs then true + else + Itv.le ~lhs:lhs.offset ~rhs:rhs.offset && Itv.le ~lhs:lhs.size ~rhs:rhs.size + && Itv.le ~lhs:lhs.stride ~rhs:rhs.stride let plus_offset : t -> Itv.t -> t = fun arr i -> {arr with offset= Itv.plus arr.offset i} @@ -56,35 +56,35 @@ module ArrInfo = struct let diff : t -> t -> Itv.astate = fun arr1 arr2 -> Itv.minus arr1.offset arr2.offset let subst : t -> Itv.Bound.t bottom_lifted Itv.SubstMap.t -> t = - fun arr subst_map -> - {arr with offset= Itv.subst arr.offset subst_map; size= Itv.subst arr.size subst_map} + fun arr subst_map -> + {arr with offset= Itv.subst arr.offset subst_map; size= Itv.subst arr.size subst_map} let pp : Format.formatter -> t -> unit = - fun fmt arr -> Format.fprintf fmt "offset : %a, size : %a" Itv.pp arr.offset Itv.pp arr.size + fun fmt arr -> Format.fprintf fmt "offset : %a, size : %a" Itv.pp arr.offset Itv.pp arr.size let get_symbols : t -> Itv.Symbol.t list = - fun arr -> - let s1 = Itv.get_symbols arr.offset in - let s2 = Itv.get_symbols arr.size in - let s3 = Itv.get_symbols arr.stride in - List.concat [s1; s2; s3] + fun arr -> + let s1 = Itv.get_symbols arr.offset in + let s2 = Itv.get_symbols arr.size in + let s3 = Itv.get_symbols arr.stride in + List.concat [s1; s2; s3] let normalize : t -> t = - fun arr -> - { offset= Itv.normalize arr.offset - ; size= Itv.normalize arr.size - ; stride= Itv.normalize arr.stride } + fun arr -> + { offset= Itv.normalize arr.offset + ; size= Itv.normalize arr.size + ; stride= Itv.normalize arr.stride } let prune_comp : Binop.t -> t -> t -> t = - fun c arr1 arr2 -> {arr1 with offset= Itv.prune_comp c arr1.offset arr2.offset} + fun c arr1 arr2 -> {arr1 with offset= Itv.prune_comp c arr1.offset arr2.offset} let prune_eq : t -> t -> t = - fun arr1 arr2 -> {arr1 with offset= Itv.prune_eq arr1.offset arr2.offset} + fun arr1 arr2 -> {arr1 with offset= Itv.prune_eq arr1.offset arr2.offset} let set_size : Itv.t -> t -> t = fun size arr -> {arr with size} @@ -99,7 +99,7 @@ let unknown : astate = add Allocsite.unknown ArrInfo.top bot let is_bot : astate -> bool = is_empty let make : Allocsite.t -> Itv.t -> Itv.t -> Itv.t -> astate = - fun a o sz st -> add a (ArrInfo.make (o, sz, st)) bot + fun a o sz st -> add a (ArrInfo.make (o, sz, st)) bot let offsetof : astate -> Itv.t = fun a -> fold (fun _ arr -> Itv.join arr.ArrInfo.offset) a Itv.bot @@ -107,51 +107,51 @@ let offsetof : astate -> Itv.t = fun a -> fold (fun _ arr -> Itv.join arr.ArrInf let sizeof : astate -> Itv.t = fun a -> fold (fun _ arr -> Itv.join arr.ArrInfo.size) a Itv.bot let plus_offset : astate -> Itv.t -> astate = - fun arr i -> map (fun a -> ArrInfo.plus_offset a i) arr + fun arr i -> map (fun a -> ArrInfo.plus_offset a i) arr let minus_offset : astate -> Itv.t -> astate = - fun arr i -> map (fun a -> ArrInfo.minus_offset a i) arr + fun arr i -> map (fun a -> ArrInfo.minus_offset a i) arr let diff : astate -> astate -> Itv.t = - fun arr1 arr2 -> - let diff_join k a2 acc = - match find k arr1 with - | a1 -> - Itv.join acc (ArrInfo.diff a1 a2) - | exception Not_found -> - Itv.top - in - fold diff_join arr2 Itv.bot + fun arr1 arr2 -> + let diff_join k a2 acc = + match find k arr1 with + | a1 -> + Itv.join acc (ArrInfo.diff a1 a2) + | exception Not_found -> + Itv.top + in + fold diff_join arr2 Itv.bot let get_pow_loc : astate -> PowLoc.t = - fun array -> - let pow_loc_of_allocsite k _ acc = PowLoc.add (Loc.of_allocsite k) acc in - fold pow_loc_of_allocsite array PowLoc.bot + fun array -> + let pow_loc_of_allocsite k _ acc = PowLoc.add (Loc.of_allocsite k) acc in + fold pow_loc_of_allocsite array PowLoc.bot let subst : astate -> Itv.Bound.t bottom_lifted Itv.SubstMap.t -> astate = - fun a subst_map -> map (fun info -> ArrInfo.subst info subst_map) a + fun a subst_map -> map (fun info -> ArrInfo.subst info subst_map) a let get_symbols : astate -> Itv.Symbol.t list = - fun a -> List.concat_map ~f:(fun (_, ai) -> ArrInfo.get_symbols ai) (bindings a) + fun a -> List.concat_map ~f:(fun (_, ai) -> ArrInfo.get_symbols ai) (bindings a) let normalize : astate -> astate = fun a -> map ArrInfo.normalize a let do_prune : (ArrInfo.t -> ArrInfo.t -> ArrInfo.t) -> astate -> astate -> astate = - fun arr_info_prune a1 a2 -> - if Int.equal (cardinal a2) 1 then - let k, v2 = choose a2 in - if mem k a1 then add k (arr_info_prune (find k a1) v2) a1 else a1 - else a1 + fun arr_info_prune a1 a2 -> + if Int.equal (cardinal a2) 1 then + let k, v2 = choose a2 in + if mem k a1 then add k (arr_info_prune (find k a1) v2) a1 else a1 + else a1 let prune_comp : Binop.t -> astate -> astate -> astate = - fun c a1 a2 -> do_prune (ArrInfo.prune_comp c) a1 a2 + fun c a1 a2 -> do_prune (ArrInfo.prune_comp c) a1 a2 let prune_eq : astate -> astate -> astate = fun a1 a2 -> do_prune ArrInfo.prune_eq a1 a2 diff --git a/infer/src/bufferoverrun/bufferOverrunChecker.ml b/infer/src/bufferoverrun/bufferOverrunChecker.ml index 1289c3cb2..9786b13f1 100644 --- a/infer/src/bufferoverrun/bufferOverrunChecker.ml +++ b/infer/src/bufferoverrun/bufferOverrunChecker.ml @@ -41,84 +41,82 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let declare_symbolic_val : Typ.Procname.t -> Tenv.t -> CFG.node -> Location.t -> Loc.t -> Typ.typ -> inst_num:int -> new_sym_num:(unit -> int) -> Domain.t -> Domain.t = - fun pname tenv node location loc typ ~inst_num ~new_sym_num mem -> - let max_depth = 2 in - let new_alloc_num = BoUtils.counter_gen 1 in - let rec decl_sym_val pname tenv node location ~depth ~is_last_field loc typ mem = - if depth > max_depth then mem - else - let depth = depth + 1 in - match typ.Typ.desc with - | Typ.Tint ikind -> - let unsigned = Typ.ikind_is_unsigned ikind in - let v = - Dom.Val.make_sym ~unsigned pname new_sym_num - |> Dom.Val.add_trace_elem (Trace.SymAssign location) - in - Dom.Mem.add_heap loc v mem - | Typ.Tfloat _ -> - let v = - Dom.Val.make_sym pname new_sym_num - |> Dom.Val.add_trace_elem (Trace.SymAssign location) + fun pname tenv node location loc typ ~inst_num ~new_sym_num mem -> + let max_depth = 2 in + let new_alloc_num = BoUtils.counter_gen 1 in + let rec decl_sym_val pname tenv node location ~depth ~is_last_field loc typ mem = + if depth > max_depth then mem + else + let depth = depth + 1 in + match typ.Typ.desc with + | Typ.Tint ikind -> + let unsigned = Typ.ikind_is_unsigned ikind in + let v = + Dom.Val.make_sym ~unsigned pname new_sym_num + |> Dom.Val.add_trace_elem (Trace.SymAssign location) + in + Dom.Mem.add_heap loc v mem + | Typ.Tfloat _ -> + let v = + Dom.Val.make_sym pname new_sym_num + |> Dom.Val.add_trace_elem (Trace.SymAssign location) + in + Dom.Mem.add_heap loc v mem + | Typ.Tptr (typ, _) -> + BoUtils.Exec.decl_sym_arr + ~decl_sym_val:(decl_sym_val ~is_last_field:false) + pname tenv node location ~depth loc typ ~inst_num ~new_sym_num ~new_alloc_num mem + | Typ.Tarray {elt; length} -> + let size = + match length with + | Some length when is_last_field && (IntLit.iszero length || IntLit.isone length) -> + Some (Itv.make_sym pname new_sym_num) + | _ -> + Option.map ~f:Itv.of_int_lit length + in + let offset = Itv.zero in + BoUtils.Exec.decl_sym_arr + ~decl_sym_val:(decl_sym_val ~is_last_field:false) + pname tenv node location ~depth loc elt ~offset ?size ~inst_num ~new_sym_num + ~new_alloc_num mem + | Typ.Tstruct typename -> ( + match Models.TypName.dispatch typename with + | Some {Models.declare_symbolic} -> + let model_env = Models.mk_model_env pname node location tenv in + declare_symbolic ~decl_sym_val:(decl_sym_val ~is_last_field) model_env ~depth loc + ~inst_num ~new_sym_num ~new_alloc_num mem + | None -> + let decl_fld ~is_last_field mem (fn, typ, _) = + let loc_fld = Loc.append_field loc ~fn in + decl_sym_val pname tenv node location ~depth loc_fld typ ~is_last_field mem in - Dom.Mem.add_heap loc v mem - | Typ.Tptr (typ, _) -> - BoUtils.Exec.decl_sym_arr - ~decl_sym_val:(decl_sym_val ~is_last_field:false) - pname tenv node location ~depth loc typ ~inst_num ~new_sym_num ~new_alloc_num mem - | Typ.Tarray {elt; length} -> - let size = - match length with - | Some length when is_last_field && (IntLit.iszero length || IntLit.isone length) -> - Some (Itv.make_sym pname new_sym_num) - | _ -> - Option.map ~f:Itv.of_int_lit length + let decl_flds str = + IList.fold_last ~f:(decl_fld ~is_last_field:false) + ~f_last:(decl_fld ~is_last_field) ~init:mem str.Typ.Struct.fields in - let offset = Itv.zero in - BoUtils.Exec.decl_sym_arr - ~decl_sym_val:(decl_sym_val ~is_last_field:false) - pname tenv node location ~depth loc elt ~offset ?size ~inst_num ~new_sym_num - ~new_alloc_num mem - | Typ.Tstruct typename -> ( - match Models.TypName.dispatch typename with - | Some {Models.declare_symbolic} -> - let model_env = Models.mk_model_env pname node location tenv in - declare_symbolic ~decl_sym_val:(decl_sym_val ~is_last_field) model_env ~depth loc - ~inst_num ~new_sym_num ~new_alloc_num mem - | None -> - let decl_fld ~is_last_field mem (fn, typ, _) = - let loc_fld = Loc.append_field loc ~fn in - decl_sym_val pname tenv node location ~depth loc_fld typ ~is_last_field mem - in - let decl_flds str = - IList.fold_last ~f:(decl_fld ~is_last_field:false) - ~f_last:(decl_fld ~is_last_field) ~init:mem str.Typ.Struct.fields - in - let opt_struct = Tenv.lookup tenv typename in - Option.value_map opt_struct ~default:mem ~f:decl_flds ) - | _ -> - if Config.bo_debug >= 3 then - L.(debug BufferOverrun Verbose) - "/!\\ decl_fld of unhandled type: %a at %a@." (Typ.pp Pp.text) typ Location.pp - (CFG.loc node) ; - mem - in - decl_sym_val pname tenv node location ~depth:0 ~is_last_field:false loc typ mem + let opt_struct = Tenv.lookup tenv typename in + Option.value_map opt_struct ~default:mem ~f:decl_flds ) + | _ -> + if Config.bo_debug >= 3 then + L.(debug BufferOverrun Verbose) + "/!\\ decl_fld of unhandled type: %a at %a@." (Typ.pp Pp.text) typ Location.pp + (CFG.loc node) ; + mem + in + decl_sym_val pname tenv node location ~depth:0 ~is_last_field:false loc typ mem let declare_symbolic_parameters : Typ.Procname.t -> Tenv.t -> CFG.node -> Location.t -> inst_num:int -> (Pvar.t * Typ.t) list -> Dom.Mem.astate -> Dom.Mem.astate = - fun pname tenv node location ~inst_num formals mem -> - let new_sym_num = BoUtils.counter_gen 0 in - let add_formal (mem, inst_num) (pvar, typ) = - let loc = Loc.of_pvar pvar in - let mem = - declare_symbolic_val pname tenv node location loc typ ~inst_num ~new_sym_num mem - in - (mem, inst_num + 1) - in - List.fold ~f:add_formal ~init:(mem, inst_num) formals |> fst + fun pname tenv node location ~inst_num formals mem -> + let new_sym_num = BoUtils.counter_gen 0 in + let add_formal (mem, inst_num) (pvar, typ) = + let loc = Loc.of_pvar pvar in + let mem = declare_symbolic_val pname tenv node location loc typ ~inst_num ~new_sym_num mem in + (mem, inst_num + 1) + in + List.fold ~f:add_formal ~init:(mem, inst_num) formals |> fst let instantiate_ret ret callee_pname callee_exit_mem subst_map mem ret_alias location = @@ -177,120 +175,119 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let instantiate_mem : Tenv.t -> (Ident.t * Typ.t) option -> Procdesc.t option -> Typ.Procname.t -> (Exp.t * Typ.t) list -> Dom.Mem.astate -> Dom.Summary.t -> Location.t -> Dom.Mem.astate = - fun tenv ret callee_pdesc callee_pname params caller_mem summary location -> - let callee_entry_mem = Dom.Summary.get_input summary in - let callee_exit_mem = Dom.Summary.get_output summary in - let callee_ret_alias = Dom.Mem.find_ret_alias callee_exit_mem in - match callee_pdesc with - | Some pdesc -> - let subst_map, ret_alias = - Sem.get_subst_map tenv pdesc params caller_mem callee_entry_mem ~callee_ret_alias - in - instantiate_ret ret callee_pname callee_exit_mem subst_map caller_mem ret_alias location - |> instantiate_param tenv pdesc params callee_entry_mem callee_exit_mem subst_map - location - | None -> - caller_mem + fun tenv ret callee_pdesc callee_pname params caller_mem summary location -> + let callee_entry_mem = Dom.Summary.get_input summary in + let callee_exit_mem = Dom.Summary.get_output summary in + let callee_ret_alias = Dom.Mem.find_ret_alias callee_exit_mem in + match callee_pdesc with + | Some pdesc -> + let subst_map, ret_alias = + Sem.get_subst_map tenv pdesc params caller_mem callee_entry_mem ~callee_ret_alias + in + instantiate_ret ret callee_pname callee_exit_mem subst_map caller_mem ret_alias location + |> instantiate_param tenv pdesc params callee_entry_mem callee_exit_mem subst_map location + | None -> + caller_mem let print_debug_info : Sil.instr -> Dom.Mem.astate -> Dom.Mem.astate -> unit = - fun instr pre post -> - L.(debug BufferOverrun Verbose) "@\n@\n================================@\n" ; - L.(debug BufferOverrun Verbose) "@[Pre-state : @,%a" Dom.Mem.pp pre ; - L.(debug BufferOverrun Verbose) "@]@\n@\n%a" (Sil.pp_instr Pp.text) instr ; - L.(debug BufferOverrun Verbose) "@\n@\n" ; - L.(debug BufferOverrun Verbose) "@[Post-state : @,%a" Dom.Mem.pp post ; - L.(debug BufferOverrun Verbose) "@]@\n" ; - L.(debug BufferOverrun Verbose) "================================@\n@." + fun instr pre post -> + L.(debug BufferOverrun Verbose) "@\n@\n================================@\n" ; + L.(debug BufferOverrun Verbose) "@[Pre-state : @,%a" Dom.Mem.pp pre ; + L.(debug BufferOverrun Verbose) "@]@\n@\n%a" (Sil.pp_instr Pp.text) instr ; + L.(debug BufferOverrun Verbose) "@\n@\n" ; + L.(debug BufferOverrun Verbose) "@[Post-state : @,%a" Dom.Mem.pp post ; + L.(debug BufferOverrun Verbose) "@]@\n" ; + L.(debug BufferOverrun Verbose) "================================@\n@." let exec_instr : Dom.Mem.astate -> extras ProcData.t -> CFG.node -> Sil.instr -> Dom.Mem.astate = - fun mem {pdesc; tenv; extras} node instr -> - let pname = Procdesc.get_proc_name pdesc in - let output_mem = - match instr with - | Load (id, _, _, _) when Ident.is_none id -> - mem - | Load (id, exp, _, _) -> - BoUtils.Exec.load_val id (Sem.eval exp mem) mem - | Store (exp1, _, exp2, location) -> - let locs = Sem.eval exp1 mem |> Dom.Val.get_all_locs in - let v = Sem.eval exp2 mem |> Dom.Val.add_trace_elem (Trace.Assign location) in - let mem = Dom.Mem.update_mem locs v mem in - let mem = - if PowLoc.is_singleton locs then - let loc_v = PowLoc.min_elt locs in - match Typ.Procname.get_method pname with - | "__inferbo_empty" when Loc.is_return loc_v -> ( - match Sem.get_formals pdesc with - | [(formal, _)] -> - let formal_v = Dom.Mem.find_heap (Loc.of_pvar formal) mem in - Dom.Mem.store_empty_alias formal_v loc_v exp2 mem - | _ -> - assert false ) + fun mem {pdesc; tenv; extras} node instr -> + let pname = Procdesc.get_proc_name pdesc in + let output_mem = + match instr with + | Load (id, _, _, _) when Ident.is_none id -> + mem + | Load (id, exp, _, _) -> + BoUtils.Exec.load_val id (Sem.eval exp mem) mem + | Store (exp1, _, exp2, location) -> + let locs = Sem.eval exp1 mem |> Dom.Val.get_all_locs in + let v = Sem.eval exp2 mem |> Dom.Val.add_trace_elem (Trace.Assign location) in + let mem = Dom.Mem.update_mem locs v mem in + let mem = + if PowLoc.is_singleton locs then + let loc_v = PowLoc.min_elt locs in + match Typ.Procname.get_method pname with + | "__inferbo_empty" when Loc.is_return loc_v -> ( + match Sem.get_formals pdesc with + | [(formal, _)] -> + let formal_v = Dom.Mem.find_heap (Loc.of_pvar formal) mem in + Dom.Mem.store_empty_alias formal_v loc_v exp2 mem | _ -> - Dom.Mem.store_simple_alias loc_v exp2 mem - else mem - in - let mem = Dom.Mem.update_latest_prune exp1 exp2 mem in - mem - | Prune (exp, _, _, _) -> - Sem.prune exp mem - | Call (ret, Const Cfun callee_pname, params, location, _) - -> ( - let model_env = Models.mk_model_env callee_pname node location tenv ?ret in - match Models.Procname.dispatch callee_pname params with - | Some {Models.exec} -> - exec model_env mem + assert false ) + | _ -> + Dom.Mem.store_simple_alias loc_v exp2 mem + else mem + in + let mem = Dom.Mem.update_latest_prune exp1 exp2 mem in + mem + | Prune (exp, _, _, _) -> + Sem.prune exp mem + | Call (ret, Const Cfun callee_pname, params, location, _) + -> ( + let model_env = Models.mk_model_env callee_pname node location tenv ?ret in + match Models.Procname.dispatch callee_pname params with + | Some {Models.exec} -> + exec model_env mem + | None -> + match Summary.read_summary pdesc callee_pname with + | Some summary -> + let callee = extras callee_pname in + instantiate_mem tenv ret callee callee_pname params mem summary location | None -> - match Summary.read_summary pdesc callee_pname with - | Some summary -> - let callee = extras callee_pname in - instantiate_mem tenv ret callee callee_pname params mem summary location + L.(debug BufferOverrun Verbose) + "/!\\ Unknown call to %a at %a@\n" Typ.Procname.pp callee_pname Location.pp + location ; + Models.model_by_value Dom.Val.unknown model_env mem + |> Dom.Mem.add_heap Loc.unknown Dom.Val.unknown ) + | Declare_locals (locals, location) -> + (* array allocation in stack e.g., int arr[10] *) + let rec decl_local pname node location loc typ ~inst_num ~dimension mem = + match typ.Typ.desc with + | Typ.Tarray {elt= typ; length; stride} -> + let stride = Option.map ~f:IntLit.to_int stride in + BoUtils.Exec.decl_local_array ~decl_local pname node location loc typ ~length + ?stride ~inst_num ~dimension mem + | Typ.Tstruct typname -> ( + match Models.TypName.dispatch typname with + | Some {Models.declare_local} -> + let model_env = Models.mk_model_env pname node location tenv in + declare_local ~decl_local model_env loc ~inst_num ~dimension mem | None -> - L.(debug BufferOverrun Verbose) - "/!\\ Unknown call to %a at %a@\n" Typ.Procname.pp callee_pname Location.pp - location ; - Models.model_by_value Dom.Val.unknown model_env mem - |> Dom.Mem.add_heap Loc.unknown Dom.Val.unknown ) - | Declare_locals (locals, location) -> - (* array allocation in stack e.g., int arr[10] *) - let rec decl_local pname node location loc typ ~inst_num ~dimension mem = - match typ.Typ.desc with - | Typ.Tarray {elt= typ; length; stride} -> - let stride = Option.map ~f:IntLit.to_int stride in - BoUtils.Exec.decl_local_array ~decl_local pname node location loc typ ~length - ?stride ~inst_num ~dimension mem - | Typ.Tstruct typname -> ( - match Models.TypName.dispatch typname with - | Some {Models.declare_local} -> - let model_env = Models.mk_model_env pname node location tenv in - declare_local ~decl_local model_env loc ~inst_num ~dimension mem - | None -> - (mem, inst_num) ) - | _ -> - (mem, inst_num) - in - let try_decl_local (mem, inst_num) (pvar, typ) = - let loc = Loc.of_pvar pvar in - decl_local pname node location loc typ ~inst_num ~dimension:1 mem - in - let mem, inst_num = List.fold ~f:try_decl_local ~init:(mem, 1) locals in - let formals = Sem.get_formals pdesc in - declare_symbolic_parameters pname tenv node location ~inst_num formals mem - | Call (_, fun_exp, _, location, _) -> - let () = - L.(debug BufferOverrun Verbose) - "/!\\ Call to non-const function %a at %a" Exp.pp fun_exp Location.pp location - in - mem - | Remove_temps (temps, _) -> - Dom.Mem.remove_temps temps mem - | Abstract _ | Nullify _ -> - mem - in - print_debug_info instr mem output_mem ; - output_mem + (mem, inst_num) ) + | _ -> + (mem, inst_num) + in + let try_decl_local (mem, inst_num) (pvar, typ) = + let loc = Loc.of_pvar pvar in + decl_local pname node location loc typ ~inst_num ~dimension:1 mem + in + let mem, inst_num = List.fold ~f:try_decl_local ~init:(mem, 1) locals in + let formals = Sem.get_formals pdesc in + declare_symbolic_parameters pname tenv node location ~inst_num formals mem + | Call (_, fun_exp, _, location, _) -> + let () = + L.(debug BufferOverrun Verbose) + "/!\\ Call to non-const function %a at %a" Exp.pp fun_exp Location.pp location + in + mem + | Remove_temps (temps, _) -> + Dom.Mem.remove_temps temps mem + | Abstract _ | Nullify _ -> + mem + in + print_debug_info instr mem output_mem ; + output_mem end module Analyzer = AbstractInterpreter.Make (ProcCfg.Normal) (TransferFunctions) @@ -308,55 +305,55 @@ module Report = struct let add_condition : Typ.Procname.t -> Exp.t -> Location.t -> Dom.Mem.astate -> PO.ConditionSet.t -> PO.ConditionSet.t = - fun pname exp location mem cond_set -> - match exp with - | Exp.Var _ -> - let v = Sem.eval exp mem in - let arr = Dom.Val.get_array_blk v in - let arr_traces = Dom.Val.get_traces v in - BoUtils.Check.array_access ~arr ~arr_traces ~idx:Itv.zero ~idx_traces:TraceSet.empty - ~is_plus:true pname location cond_set - | Exp.Lindex (array_exp, index_exp) -> - BoUtils.Check.lindex ~array_exp ~index_exp mem pname location cond_set - | Exp.BinOp ((Binop.PlusA as bop), e1, e2) | Exp.BinOp ((Binop.MinusA as bop), e1, e2) -> - let v_arr = Sem.eval e1 mem in - let arr = Dom.Val.get_array_blk v_arr in - let arr_traces = Dom.Val.get_traces v_arr in - let v_idx = Sem.eval e2 mem in - let idx = Dom.Val.get_itv v_idx in - let idx_traces = Dom.Val.get_traces v_idx in - let is_plus = Binop.equal bop Binop.PlusA in - BoUtils.Check.array_access ~arr ~arr_traces ~idx ~idx_traces ~is_plus pname location - cond_set - | _ -> + fun pname exp location mem cond_set -> + match exp with + | Exp.Var _ -> + let v = Sem.eval exp mem in + let arr = Dom.Val.get_array_blk v in + let arr_traces = Dom.Val.get_traces v in + BoUtils.Check.array_access ~arr ~arr_traces ~idx:Itv.zero ~idx_traces:TraceSet.empty + ~is_plus:true pname location cond_set + | Exp.Lindex (array_exp, index_exp) -> + BoUtils.Check.lindex ~array_exp ~index_exp mem pname location cond_set + | Exp.BinOp ((Binop.PlusA as bop), e1, e2) | Exp.BinOp ((Binop.MinusA as bop), e1, e2) -> + let v_arr = Sem.eval e1 mem in + let arr = Dom.Val.get_array_blk v_arr in + let arr_traces = Dom.Val.get_traces v_arr in + let v_idx = Sem.eval e2 mem in + let idx = Dom.Val.get_itv v_idx in + let idx_traces = Dom.Val.get_traces v_idx in + let is_plus = Binop.equal bop Binop.PlusA in + BoUtils.Check.array_access ~arr ~arr_traces ~idx ~idx_traces ~is_plus pname location cond_set + | _ -> + cond_set let instantiate_cond : Tenv.t -> Typ.Procname.t -> Procdesc.t option -> (Exp.t * Typ.t) list -> Dom.Mem.astate -> Summary.payload -> Location.t -> PO.ConditionSet.t = - fun tenv caller_pname callee_pdesc params caller_mem summary location -> - let callee_entry_mem = Dom.Summary.get_input summary in - let callee_cond = Dom.Summary.get_cond_set summary in - match callee_pdesc with - | Some pdesc -> - let subst_map, _ = - Sem.get_subst_map tenv pdesc params caller_mem callee_entry_mem ~callee_ret_alias:None - in - let pname = Procdesc.get_proc_name pdesc in - PO.ConditionSet.subst callee_cond subst_map caller_pname pname location - | _ -> - callee_cond + fun tenv caller_pname callee_pdesc params caller_mem summary location -> + let callee_entry_mem = Dom.Summary.get_input summary in + let callee_cond = Dom.Summary.get_cond_set summary in + match callee_pdesc with + | Some pdesc -> + let subst_map, _ = + Sem.get_subst_map tenv pdesc params caller_mem callee_entry_mem ~callee_ret_alias:None + in + let pname = Procdesc.get_proc_name pdesc in + PO.ConditionSet.subst callee_cond subst_map caller_pname pname location + | _ -> + callee_cond let print_debug_info : Sil.instr -> Dom.Mem.astate -> PO.ConditionSet.t -> unit = - fun instr pre cond_set -> - L.(debug BufferOverrun Verbose) "@\n@\n================================@\n" ; - L.(debug BufferOverrun Verbose) "@[Pre-state : @,%a" Dom.Mem.pp pre ; - L.(debug BufferOverrun Verbose) "@]@\n@\n%a" (Sil.pp_instr Pp.text) instr ; - L.(debug BufferOverrun Verbose) "@[@\n@\n%a" PO.ConditionSet.pp cond_set ; - L.(debug BufferOverrun Verbose) "@]@\n" ; - L.(debug BufferOverrun Verbose) "================================@\n@." + fun instr pre cond_set -> + L.(debug BufferOverrun Verbose) "@\n@\n================================@\n" ; + L.(debug BufferOverrun Verbose) "@[Pre-state : @,%a" Dom.Mem.pp pre ; + L.(debug BufferOverrun Verbose) "@]@\n@\n%a" (Sil.pp_instr Pp.text) instr ; + L.(debug BufferOverrun Verbose) "@[@\n@\n%a" PO.ConditionSet.pp cond_set ; + L.(debug BufferOverrun Verbose) "@]@\n" ; + L.(debug BufferOverrun Verbose) "================================@\n@." module ExitStatement = struct @@ -393,167 +390,165 @@ module Report = struct let rec collect_instrs : Specs.summary -> extras ProcData.t -> CFG.node -> Sil.instr list -> Dom.Mem.astate -> PO.ConditionSet.t -> PO.ConditionSet.t = - fun summary ({pdesc; tenv; extras} as pdata) node instrs mem cond_set -> - match instrs with - | [] -> - cond_set - | instr :: rem_instrs -> - let pname = Procdesc.get_proc_name pdesc in - let cond_set = - match instr with - | Sil.Load (_, exp, _, location) | Sil.Store (exp, _, _, location) -> - add_condition pname exp location mem cond_set - | Sil.Call (_, Const Cfun callee_pname, params, location, _) -> ( - match Models.Procname.dispatch callee_pname params with - | Some {Models.check} -> - check (Models.mk_model_env pname node location tenv) mem cond_set - | None -> - match Summary.read_summary pdesc callee_pname with - | Some callee_summary -> - let callee = extras callee_pname in - instantiate_cond tenv pname callee params mem callee_summary location - |> PO.ConditionSet.join cond_set - | _ -> - cond_set ) - | _ -> - cond_set - in - let mem' = Analyzer.TransferFunctions.exec_instr mem pdata node instr in - let () = - match (mem, mem') with - | NonBottom _, Bottom -> ( - match instr with - | Sil.Prune (_, _, _, (Ik_land_lor | Ik_bexp)) -> - () - | Sil.Prune (cond, location, true_branch, _) -> - let i = match cond with Exp.Const Const.Cint i -> i | _ -> IntLit.zero in - let desc = - Errdesc.explain_condition_always_true_false tenv i cond node location - in - let exn = - Exceptions.Condition_always_true_false (desc, not true_branch, __POS__) - in - Reporting.log_warning summary ~loc:location exn - (* special case for `exit` when we're at the end of a block / procedure *) - | Sil.Call (_, Const Cfun pname, _, _, _) - when String.equal (Typ.Procname.get_method pname) "exit" - && ExitStatement.is_end_of_block_or_procedure node rem_instrs -> - () + fun summary ({pdesc; tenv; extras} as pdata) node instrs mem cond_set -> + match instrs with + | [] -> + cond_set + | instr :: rem_instrs -> + let pname = Procdesc.get_proc_name pdesc in + let cond_set = + match instr with + | Sil.Load (_, exp, _, location) | Sil.Store (exp, _, _, location) -> + add_condition pname exp location mem cond_set + | Sil.Call (_, Const Cfun callee_pname, params, location, _) -> ( + match Models.Procname.dispatch callee_pname params with + | Some {Models.check} -> + check (Models.mk_model_env pname node location tenv) mem cond_set + | None -> + match Summary.read_summary pdesc callee_pname with + | Some callee_summary -> + let callee = extras callee_pname in + instantiate_cond tenv pname callee params mem callee_summary location + |> PO.ConditionSet.join cond_set | _ -> - let location = Sil.instr_get_loc instr in - let desc = Errdesc.explain_unreachable_code_after location in - let exn = Exceptions.Unreachable_code_after (desc, __POS__) in - Reporting.log_error summary ~loc:location exn ) - | _ -> + cond_set ) + | _ -> + cond_set + in + let mem' = Analyzer.TransferFunctions.exec_instr mem pdata node instr in + let () = + match (mem, mem') with + | NonBottom _, Bottom -> ( + match instr with + | Sil.Prune (_, _, _, (Ik_land_lor | Ik_bexp)) -> () - in - print_debug_info instr mem' cond_set ; - collect_instrs summary pdata node rem_instrs mem' cond_set + | Sil.Prune (cond, location, true_branch, _) -> + let i = match cond with Exp.Const Const.Cint i -> i | _ -> IntLit.zero in + let desc = Errdesc.explain_condition_always_true_false tenv i cond node location in + let exn = + Exceptions.Condition_always_true_false (desc, not true_branch, __POS__) + in + Reporting.log_warning summary ~loc:location exn + (* special case for `exit` when we're at the end of a block / procedure *) + | Sil.Call (_, Const Cfun pname, _, _, _) + when String.equal (Typ.Procname.get_method pname) "exit" + && ExitStatement.is_end_of_block_or_procedure node rem_instrs -> + () + | _ -> + let location = Sil.instr_get_loc instr in + let desc = Errdesc.explain_unreachable_code_after location in + let exn = Exceptions.Unreachable_code_after (desc, __POS__) in + Reporting.log_error summary ~loc:location exn ) + | _ -> + () + in + print_debug_info instr mem' cond_set ; + collect_instrs summary pdata node rem_instrs mem' cond_set let collect_node : Specs.summary -> extras ProcData.t -> Analyzer.invariant_map -> PO.ConditionSet.t -> CFG.node -> PO.ConditionSet.t = - fun summary pdata inv_map cond_set node -> - match Analyzer.extract_pre (CFG.id node) inv_map with - | Some mem -> - let instrs = CFG.instrs node in - collect_instrs summary pdata node instrs mem cond_set - | _ -> - cond_set + fun summary pdata inv_map cond_set node -> + match Analyzer.extract_pre (CFG.id node) inv_map with + | Some mem -> + let instrs = CFG.instrs node in + collect_instrs summary pdata node instrs mem cond_set + | _ -> + cond_set let collect : Specs.summary -> extras ProcData.t -> Analyzer.invariant_map -> PO.ConditionSet.t = - fun summary ({pdesc} as pdata) inv_map -> - let add_node1 acc node = collect_node summary pdata inv_map acc node in - Procdesc.fold_nodes add_node1 PO.ConditionSet.empty pdesc + fun summary ({pdesc} as pdata) inv_map -> + let add_node1 acc node = collect_node summary pdata inv_map acc node in + Procdesc.fold_nodes add_node1 PO.ConditionSet.empty pdesc let make_err_trace : Trace.t -> string -> Errlog.loc_trace = - fun trace desc -> - let f elem (trace, depth) = - match elem with - | Trace.Assign location -> - (Errlog.make_trace_element depth location "Assignment" [] :: trace, depth) - | Trace.ArrDecl location -> - (Errlog.make_trace_element depth location "ArrayDeclaration" [] :: trace, depth) - | Trace.Call location -> - (Errlog.make_trace_element depth location "Call" [] :: trace, depth + 1) - | Trace.Return location -> - (Errlog.make_trace_element (depth - 1) location "Return" [] :: trace, depth - 1) - | Trace.SymAssign _ -> - (trace, depth) - | Trace.ArrAccess location -> - (Errlog.make_trace_element depth location ("ArrayAccess: " ^ desc) [] :: trace, depth) - in - List.fold_right ~f ~init:([], 0) trace.trace |> fst |> List.rev + fun trace desc -> + let f elem (trace, depth) = + match elem with + | Trace.Assign location -> + (Errlog.make_trace_element depth location "Assignment" [] :: trace, depth) + | Trace.ArrDecl location -> + (Errlog.make_trace_element depth location "ArrayDeclaration" [] :: trace, depth) + | Trace.Call location -> + (Errlog.make_trace_element depth location "Call" [] :: trace, depth + 1) + | Trace.Return location -> + (Errlog.make_trace_element (depth - 1) location "Return" [] :: trace, depth - 1) + | Trace.SymAssign _ -> + (trace, depth) + | Trace.ArrAccess location -> + (Errlog.make_trace_element depth location ("ArrayAccess: " ^ desc) [] :: trace, depth) + in + List.fold_right ~f ~init:([], 0) trace.trace |> fst |> List.rev let report_errors : Specs.summary -> Procdesc.t -> PO.ConditionSet.t -> unit = - fun summary pdesc cond_set -> - let pname = Procdesc.get_proc_name pdesc in - let report cond trace issue_type = - let caller_pname, location = - match PO.ConditionTrace.get_cond_trace trace with - | PO.ConditionTrace.Inter (caller_pname, _, location) -> - (caller_pname, location) - | PO.ConditionTrace.Intra pname -> - (pname, PO.ConditionTrace.get_location trace) - in - if Typ.Procname.equal pname caller_pname then - let description = PO.description cond trace in - let error_desc = Localise.desc_buffer_overrun description in - let exn = Exceptions.Checkers (issue_type, error_desc) in - let trace = - match TraceSet.choose_shortest trace.PO.ConditionTrace.val_traces with - | trace -> - make_err_trace trace description - | exception _ -> - [Errlog.make_trace_element 0 location description []] - in - Reporting.log_error summary ~loc:location ~ltr:trace exn + fun summary pdesc cond_set -> + let pname = Procdesc.get_proc_name pdesc in + let report cond trace issue_type = + let caller_pname, location = + match PO.ConditionTrace.get_cond_trace trace with + | PO.ConditionTrace.Inter (caller_pname, _, location) -> + (caller_pname, location) + | PO.ConditionTrace.Intra pname -> + (pname, PO.ConditionTrace.get_location trace) in - PO.ConditionSet.check_all ~report cond_set + if Typ.Procname.equal pname caller_pname then + let description = PO.description cond trace in + let error_desc = Localise.desc_buffer_overrun description in + let exn = Exceptions.Checkers (issue_type, error_desc) in + let trace = + match TraceSet.choose_shortest trace.PO.ConditionTrace.val_traces with + | trace -> + make_err_trace trace description + | exception _ -> + [Errlog.make_trace_element 0 location description []] + in + Reporting.log_error summary ~loc:location ~ltr:trace exn + in + PO.ConditionSet.check_all ~report cond_set end let compute_post : Specs.summary -> Analyzer.TransferFunctions.extras ProcData.t -> Summary.payload option = - fun summary {pdesc; tenv; extras= get_pdesc} -> - let cfg = CFG.from_pdesc pdesc in - let pdata = ProcData.make pdesc tenv get_pdesc in - let inv_map = Analyzer.exec_pdesc ~initial:Dom.Mem.init pdata in - let entry_mem = - let entry_id = CFG.id (CFG.start_node cfg) in - Analyzer.extract_post entry_id inv_map - in - let exit_mem = - let exit_id = CFG.id (CFG.exit_node cfg) in - Analyzer.extract_post exit_id inv_map - in - let cond_set = Report.collect summary pdata inv_map in - Report.report_errors summary pdesc cond_set ; - match (entry_mem, exit_mem) with - | Some entry_mem, Some exit_mem -> - Some (entry_mem, exit_mem, cond_set) - | _ -> - None + fun summary {pdesc; tenv; extras= get_pdesc} -> + let cfg = CFG.from_pdesc pdesc in + let pdata = ProcData.make pdesc tenv get_pdesc in + let inv_map = Analyzer.exec_pdesc ~initial:Dom.Mem.init pdata in + let entry_mem = + let entry_id = CFG.id (CFG.start_node cfg) in + Analyzer.extract_post entry_id inv_map + in + let exit_mem = + let exit_id = CFG.id (CFG.exit_node cfg) in + Analyzer.extract_post exit_id inv_map + in + let cond_set = Report.collect summary pdata inv_map in + Report.report_errors summary pdesc cond_set ; + match (entry_mem, exit_mem) with + | Some entry_mem, Some exit_mem -> + Some (entry_mem, exit_mem, cond_set) + | _ -> + None let print_summary : Typ.Procname.t -> Dom.Summary.t -> unit = - fun proc_name s -> - L.(debug BufferOverrun Medium) - "@\n@[Summary of %a :@,%a@]@." Typ.Procname.pp proc_name Dom.Summary.pp_summary s + fun proc_name s -> + L.(debug BufferOverrun Medium) + "@\n@[Summary of %a :@,%a@]@." Typ.Procname.pp proc_name Dom.Summary.pp_summary s let checker : Callbacks.proc_callback_args -> Specs.summary = - fun {proc_desc; tenv; summary; get_proc_desc} -> - let proc_data = ProcData.make proc_desc tenv get_proc_desc in - Preanal.do_preanalysis proc_desc tenv ; - match compute_post summary proc_data with - | Some post -> - ( if Config.bo_debug >= 1 then - let proc_name = Specs.get_proc_name summary in - print_summary proc_name post ) ; - Summary.update_summary post summary - | None -> - summary + fun {proc_desc; tenv; summary; get_proc_desc} -> + let proc_data = ProcData.make proc_desc tenv get_proc_desc in + Preanal.do_preanalysis proc_desc tenv ; + match compute_post summary proc_data with + | Some post -> + ( if Config.bo_debug >= 1 then + let proc_name = Specs.get_proc_name summary in + print_summary proc_name post ) ; + Summary.update_summary post summary + | None -> + summary diff --git a/infer/src/bufferoverrun/bufferOverrunDomain.ml b/infer/src/bufferoverrun/bufferOverrunDomain.ml index 09c5538e0..3e5925b37 100644 --- a/infer/src/bufferoverrun/bufferOverrunDomain.ml +++ b/infer/src/bufferoverrun/bufferOverrunDomain.ml @@ -61,13 +61,13 @@ module Val = struct let join : t -> t -> t = - fun x y -> - if phys_equal x y then x - else - { itv= Itv.join x.itv y.itv - ; powloc= PowLoc.join x.powloc y.powloc - ; arrayblk= ArrayBlk.join x.arrayblk y.arrayblk - ; traces= TraceSet.join x.traces y.traces } + fun x y -> + if phys_equal x y then x + else + { itv= Itv.join x.itv y.itv + ; powloc= PowLoc.join x.powloc y.powloc + ; arrayblk= ArrayBlk.join x.arrayblk y.arrayblk + ; traces= TraceSet.join x.traces y.traces } let rec joins : t list -> t = function [] -> bot | [a] -> a | a :: b -> join a (joins b) @@ -97,8 +97,8 @@ module Val = struct let modify_itv : Itv.t -> t -> t = fun i x -> {x with itv= i} let make_sym : ?unsigned:bool -> Typ.Procname.t -> (unit -> int) -> t = - fun ?(unsigned= false) pname new_sym_num -> - {bot with itv= Itv.make_sym ~unsigned pname new_sym_num} + fun ?(unsigned= false) pname new_sym_num -> + {bot with itv= Itv.make_sym ~unsigned pname new_sym_num} let unknown_bit : t -> t = fun x -> {x with itv= Itv.top} @@ -108,37 +108,37 @@ module Val = struct let lnot : t -> t = fun x -> {x with itv= Itv.lnot x.itv} let lift_itv : (Itv.t -> Itv.t -> Itv.t) -> t -> t -> t = - fun f x y -> {bot with itv= f x.itv y.itv} + fun f x y -> {bot with itv= f x.itv y.itv} let has_pointer : t -> bool = fun x -> not (PowLoc.is_bot x.powloc && ArrayBlk.is_bot x.arrayblk) let lift_cmp_itv : (Itv.t -> Itv.t -> Itv.t) -> t -> t -> t = - fun f x y -> - if has_pointer x || has_pointer y then {bot with itv= Itv.unknown_bool} else lift_itv f x y + fun f x y -> + if has_pointer x || has_pointer y then {bot with itv= Itv.unknown_bool} else lift_itv f x y let plus : t -> t -> t = - fun x y -> - { x with - itv= Itv.plus x.itv y.itv - ; arrayblk= ArrayBlk.plus_offset x.arrayblk y.itv - ; traces= TraceSet.join x.traces y.traces } + fun x y -> + { x with + itv= Itv.plus x.itv y.itv + ; arrayblk= ArrayBlk.plus_offset x.arrayblk y.itv + ; traces= TraceSet.join x.traces y.traces } let minus : t -> t -> t = - fun x y -> - let n = Itv.join (Itv.minus x.itv y.itv) (ArrayBlk.diff x.arrayblk y.arrayblk) in - let a = ArrayBlk.minus_offset x.arrayblk y.itv in - {bot with itv= n; arrayblk= a; traces= TraceSet.join x.traces y.traces} + fun x y -> + let n = Itv.join (Itv.minus x.itv y.itv) (ArrayBlk.diff x.arrayblk y.arrayblk) in + let a = ArrayBlk.minus_offset x.arrayblk y.itv in + {bot with itv= n; arrayblk= a; traces= TraceSet.join x.traces y.traces} let mult : t -> t -> t = - fun x y -> {(lift_itv Itv.mult x y) with traces= TraceSet.join x.traces y.traces} + fun x y -> {(lift_itv Itv.mult x y) with traces= TraceSet.join x.traces y.traces} let div : t -> t -> t = - fun x y -> {(lift_itv Itv.div x y) with traces= TraceSet.join x.traces y.traces} + fun x y -> {(lift_itv Itv.div x y) with traces= TraceSet.join x.traces y.traces} let mod_sem : t -> t -> t = lift_itv Itv.mod_sem @@ -168,17 +168,17 @@ module Val = struct let lift_prune2 : (Itv.t -> Itv.t -> Itv.t) -> (ArrayBlk.astate -> ArrayBlk.astate -> ArrayBlk.astate) -> t -> t -> t = - fun f g x y -> - { x with - itv= f x.itv y.itv - ; arrayblk= g x.arrayblk y.arrayblk - ; traces= TraceSet.join x.traces y.traces } + fun f g x y -> + { x with + itv= f x.itv y.itv + ; arrayblk= g x.arrayblk y.arrayblk + ; traces= TraceSet.join x.traces y.traces } let prune_zero : t -> t = lift_prune1 Itv.prune_zero let prune_comp : Binop.t -> t -> t -> t = - fun c -> lift_prune2 (Itv.prune_comp c) (ArrayBlk.prune_comp c) + fun c -> lift_prune2 (Itv.prune_comp c) (ArrayBlk.prune_comp c) let prune_eq : t -> t -> t = lift_prune2 Itv.prune_eq ArrayBlk.prune_eq @@ -186,7 +186,7 @@ module Val = struct let prune_ne : t -> t -> t = lift_prune2 Itv.prune_ne ArrayBlk.prune_eq let lift_pi : (ArrayBlk.astate -> Itv.t -> ArrayBlk.astate) -> t -> t -> t = - fun f x y -> {bot with arrayblk= f x.arrayblk y.itv; traces= TraceSet.join x.traces y.traces} + fun f x y -> {bot with arrayblk= f x.arrayblk y.itv; traces= TraceSet.join x.traces y.traces} let plus_pi : t -> t -> t = fun x y -> lift_pi ArrayBlk.plus_offset x y @@ -194,54 +194,53 @@ module Val = struct let minus_pi : t -> t -> t = fun x y -> lift_pi ArrayBlk.minus_offset x y let minus_pp : t -> t -> t = - fun x y -> - (* when we cannot precisely follow the physical memory model, return top *) - if not (PowLoc.is_bot x.powloc) && ArrayBlk.is_bot x.arrayblk - || not (PowLoc.is_bot y.powloc) && ArrayBlk.is_bot y.arrayblk - then {bot with itv= Itv.top} - else - {bot with itv= ArrayBlk.diff x.arrayblk y.arrayblk; traces= TraceSet.join x.traces y.traces} + fun x y -> + (* when we cannot precisely follow the physical memory model, return top *) + if not (PowLoc.is_bot x.powloc) && ArrayBlk.is_bot x.arrayblk + || not (PowLoc.is_bot y.powloc) && ArrayBlk.is_bot y.arrayblk + then {bot with itv= Itv.top} + else + {bot with itv= ArrayBlk.diff x.arrayblk y.arrayblk; traces= TraceSet.join x.traces y.traces} let get_symbols : t -> Itv.Symbol.t list = - fun x -> List.append (Itv.get_symbols x.itv) (ArrayBlk.get_symbols x.arrayblk) + fun x -> List.append (Itv.get_symbols x.itv) (ArrayBlk.get_symbols x.arrayblk) let normalize : t -> t = - fun x -> {x with itv= Itv.normalize x.itv; arrayblk= ArrayBlk.normalize x.arrayblk} + fun x -> {x with itv= Itv.normalize x.itv; arrayblk= ArrayBlk.normalize x.arrayblk} let subst : t -> Itv.Bound.t bottom_lifted Itv.SubstMap.t * TraceSet.t Itv.SubstMap.t -> Location.t -> t = - fun x (bound_map, trace_map) location -> - let symbols = get_symbols x in - let traces_caller = - List.fold symbols - ~f:(fun traces symbol -> - try TraceSet.join (Itv.SubstMap.find symbol trace_map) traces with Not_found -> traces - ) - ~init:TraceSet.empty - in - let traces = TraceSet.instantiate ~traces_caller ~traces_callee:x.traces location in - {x with itv= Itv.subst x.itv bound_map; arrayblk= ArrayBlk.subst x.arrayblk bound_map; traces} - |> normalize + fun x (bound_map, trace_map) location -> + let symbols = get_symbols x in + let traces_caller = + List.fold symbols + ~f:(fun traces symbol -> + try TraceSet.join (Itv.SubstMap.find symbol trace_map) traces with Not_found -> traces ) + ~init:TraceSet.empty + in + let traces = TraceSet.instantiate ~traces_caller ~traces_callee:x.traces location in + {x with itv= Itv.subst x.itv bound_map; arrayblk= ArrayBlk.subst x.arrayblk bound_map; traces} + |> normalize (* normalize bottom *) let add_trace_elem : Trace.elem -> t -> t = - fun elem x -> - let traces = TraceSet.add_elem elem x.traces in - {x with traces} + fun elem x -> + let traces = TraceSet.add_elem elem x.traces in + {x with traces} let pp_summary : F.formatter -> t -> unit = - fun fmt x -> F.fprintf fmt "(%a, %a)" Itv.pp x.itv ArrayBlk.pp x.arrayblk + fun fmt x -> F.fprintf fmt "(%a, %a)" Itv.pp x.itv ArrayBlk.pp x.arrayblk let set_array_size : Itv.t -> t -> t = - fun size v -> {v with arrayblk= ArrayBlk.set_size size v.arrayblk} + fun size v -> {v with arrayblk= ArrayBlk.set_size size v.arrayblk} module Itv = struct @@ -261,18 +260,18 @@ module Stack = struct let find : Loc.t -> astate -> Val.t = fun l m -> try find l m with Not_found -> Val.bot let find_set : PowLoc.t -> astate -> Val.t = - fun locs mem -> - let find_join loc acc = Val.join acc (find loc mem) in - PowLoc.fold find_join locs Val.bot + fun locs mem -> + let find_join loc acc = Val.join acc (find loc mem) in + PowLoc.fold find_join locs Val.bot let remove_temps : Ident.t list -> astate -> astate = - fun temps mem -> - let remove_temp mem temp = - let temp_loc = Loc.of_id temp in - remove temp_loc mem - in - List.fold temps ~init:mem ~f:remove_temp + fun temps mem -> + let remove_temp mem temp = + let temp_loc = Loc.of_id temp in + remove temp_loc mem + in + List.fold temps ~init:mem ~f:remove_temp end module Heap = struct @@ -287,35 +286,35 @@ module Heap = struct let find : Loc.t -> astate -> Val.t = fun l m -> try find l m with Not_found -> Val.Itv.top let find_set : PowLoc.t -> astate -> Val.t = - fun locs mem -> - let find_join loc acc = Val.join acc (find loc mem) in - PowLoc.fold find_join locs Val.bot + fun locs mem -> + let find_join loc acc = Val.join acc (find loc mem) in + PowLoc.fold find_join locs Val.bot let transform : f:(Val.t -> Val.t) -> PowLoc.t -> astate -> astate = - fun ~f locs mem -> PowLoc.fold (fun loc -> find loc mem |> f |> add loc) locs mem + fun ~f locs mem -> PowLoc.fold (fun loc -> find loc mem |> f |> add loc) locs mem let strong_update : PowLoc.t -> Val.t -> astate -> astate = - fun locs v mem -> PowLoc.fold (fun x -> add x v) locs mem + fun locs v mem -> PowLoc.fold (fun x -> add x v) locs mem let weak_update : PowLoc.t -> Val.t -> astate -> astate = - fun locs v mem -> PowLoc.fold (fun x -> add x (Val.join v (find x mem))) locs mem + fun locs v mem -> PowLoc.fold (fun x -> add x (Val.join v (find x mem))) locs mem let pp_summary : F.formatter -> astate -> unit = - fun fmt mem -> - let pp_map fmt (k, v) = F.fprintf fmt "%a -> %a" Loc.pp k Val.pp_summary v in - F.fprintf fmt "@[{ " ; - F.pp_print_list pp_map fmt (bindings mem) ; - F.fprintf fmt " }@]" + fun fmt mem -> + let pp_map fmt (k, v) = F.fprintf fmt "%a -> %a" Loc.pp k Val.pp_summary v in + F.fprintf fmt "@[{ " ; + F.pp_print_list pp_map fmt (bindings mem) ; + F.fprintf fmt " }@]" let get_return : astate -> Val.t = - fun mem -> - let mem = filter (fun l _ -> Loc.is_return l) mem in - if is_empty mem then Val.bot else snd (choose mem) + fun mem -> + let mem = filter (fun l _ -> Loc.is_return l) mem in + if is_empty mem then Val.bot else snd (choose mem) end module AliasTarget = struct @@ -356,56 +355,56 @@ module AliasMap = struct let bot : t = M.empty let ( <= ) : lhs:t -> rhs:t -> bool = - fun ~lhs ~rhs -> - let is_in_rhs k v = - match M.find k rhs with v' -> AliasTarget.equal v v' | exception Not_found -> false - in - M.for_all is_in_rhs lhs + fun ~lhs ~rhs -> + let is_in_rhs k v = + match M.find k rhs with v' -> AliasTarget.equal v v' | exception Not_found -> false + in + M.for_all is_in_rhs lhs let join : t -> t -> t = - fun x y -> - let join_v _ v1_opt v2_opt = - match (v1_opt, v2_opt) with - | None, None -> - None - | Some v, None | None, Some v -> - Some v - | Some v1, Some v2 -> - if AliasTarget.equal v1 v2 then Some v1 else assert false - in - M.merge join_v x y + fun x y -> + let join_v _ v1_opt v2_opt = + match (v1_opt, v2_opt) with + | None, None -> + None + | Some v, None | None, Some v -> + Some v + | Some v1, Some v2 -> + if AliasTarget.equal v1 v2 then Some v1 else assert false + in + M.merge join_v x y let widen : prev:t -> next:t -> num_iters:int -> t = - fun ~prev ~next ~num_iters:_ -> join prev next + fun ~prev ~next ~num_iters:_ -> join prev next let pp : F.formatter -> t -> unit = - fun fmt x -> - let pp_sep fmt () = F.fprintf fmt ", @," in - let pp1 fmt (k, v) = F.fprintf fmt "%a=%a" Ident.pp k AliasTarget.pp v in - (* F.fprintf fmt "@[Logical Variables :@,"; *) - F.fprintf fmt "@[{ @," ; - F.pp_print_list ~pp_sep pp1 fmt (M.bindings x) ; - F.fprintf fmt " }@]" ; - F.fprintf fmt "@]" + fun fmt x -> + let pp_sep fmt () = F.fprintf fmt ", @," in + let pp1 fmt (k, v) = F.fprintf fmt "%a=%a" Ident.pp k AliasTarget.pp v in + (* F.fprintf fmt "@[Logical Variables :@,"; *) + F.fprintf fmt "@[{ @," ; + F.pp_print_list ~pp_sep pp1 fmt (M.bindings x) ; + F.fprintf fmt " }@]" ; + F.fprintf fmt "@]" let load : Ident.t -> AliasTarget.t -> t -> t = fun id loc m -> M.add id loc m let store : Loc.t -> Exp.t -> t -> t = - fun l _ m -> M.filter (fun _ y -> not (AliasTarget.use l y)) m + fun l _ m -> M.filter (fun _ y -> not (AliasTarget.use l y)) m let find : Ident.t -> t -> AliasTarget.t option = - fun k m -> try Some (M.find k m) with Not_found -> None + fun k m -> try Some (M.find k m) with Not_found -> None let remove_temps : Ident.t list -> t -> t = - fun temps m -> - let remove_temp m temp = M.remove temp m in - List.fold temps ~init:m ~f:remove_temp + fun temps m -> + let remove_temp m temp = M.remove temp m in + List.fold temps ~init:m ~f:remove_temp end module AliasRet = struct @@ -414,40 +413,40 @@ module AliasRet = struct let bot = Bot let ( <= ) : lhs:astate -> rhs:astate -> bool = - fun ~lhs ~rhs -> - match (lhs, rhs) with - | Bot, _ | _, Top -> - true - | Top, _ | _, Bot -> - false - | L loc1, L loc2 -> - AliasTarget.equal loc1 loc2 + fun ~lhs ~rhs -> + match (lhs, rhs) with + | Bot, _ | _, Top -> + true + | Top, _ | _, Bot -> + false + | L loc1, L loc2 -> + AliasTarget.equal loc1 loc2 let join : astate -> astate -> astate = - fun x y -> - match (x, y) with - | Top, _ | _, Top -> - Top - | Bot, a | a, Bot -> - a - | L loc1, L loc2 -> - if AliasTarget.equal loc1 loc2 then x else Top + fun x y -> + match (x, y) with + | Top, _ | _, Top -> + Top + | Bot, a | a, Bot -> + a + | L loc1, L loc2 -> + if AliasTarget.equal loc1 loc2 then x else Top let widen : prev:astate -> next:astate -> num_iters:int -> astate = - fun ~prev ~next ~num_iters:_ -> join prev next + fun ~prev ~next ~num_iters:_ -> join prev next let pp : F.formatter -> astate -> unit = - fun fmt x -> - match x with - | Top -> - F.fprintf fmt "T" - | L loc -> - AliasTarget.pp fmt loc - | Bot -> - F.fprintf fmt "_|_" + fun fmt x -> + match x with + | Top -> + F.fprintf fmt "T" + | L loc -> + AliasTarget.pp fmt loc + | Bot -> + F.fprintf fmt "_|_" let find : astate -> AliasTarget.t option = fun x -> match x with L loc -> Some loc | _ -> None @@ -459,7 +458,7 @@ module Alias = struct let bot : astate = (AliasMap.bot, AliasRet.bot) let lift : (AliasMap.astate -> AliasMap.astate) -> astate -> astate = - fun f a -> (f (fst a), snd a) + fun f a -> (f (fst a), snd a) let lift_v : (AliasMap.astate -> 'a) -> astate -> 'a = fun f a -> f (fst a) @@ -469,31 +468,31 @@ module Alias = struct let find_ret : astate -> AliasTarget.t option = fun x -> AliasRet.find (snd x) let load : Ident.t -> AliasTarget.t -> astate -> astate = - fun id loc -> lift (AliasMap.load id loc) + fun id loc -> lift (AliasMap.load id loc) let store_simple : Loc.t -> Exp.t -> astate -> astate = - fun loc e a -> - let a = lift (AliasMap.store loc e) a in - match e with - | Exp.Var l when Loc.is_return loc -> - let update_ret retl = (fst a, AliasRet.L retl) in - Option.value_map (find l a) ~default:a ~f:update_ret - | _ -> - a + fun loc e a -> + let a = lift (AliasMap.store loc e) a in + match e with + | Exp.Var l when Loc.is_return loc -> + let update_ret retl = (fst a, AliasRet.L retl) in + Option.value_map (find l a) ~default:a ~f:update_ret + | _ -> + a let store_empty : Val.t -> Loc.t -> Exp.t -> astate -> astate = - fun formal loc e a -> - let a = lift (AliasMap.store loc e) a in - let locs = Val.get_all_locs formal in - if PowLoc.is_singleton locs then - (fst a, AliasRet.L (AliasTarget.of_empty (PowLoc.min_elt locs))) - else a + fun formal loc e a -> + let a = lift (AliasMap.store loc e) a in + let locs = Val.get_all_locs formal in + if PowLoc.is_singleton locs then + (fst a, AliasRet.L (AliasTarget.of_empty (PowLoc.min_elt locs))) + else a let remove_temps : Ident.t list -> astate -> astate = - fun temps a -> (AliasMap.remove_temps temps (fst a), snd a) + fun temps a -> (AliasMap.remove_temps temps (fst a), snd a) end module PrunePairs = struct @@ -605,26 +604,26 @@ module MemReach = struct let join : t -> t -> t = - fun x y -> - { stack= Stack.join x.stack y.stack - ; heap= Heap.join x.heap y.heap - ; alias= Alias.join x.alias y.alias - ; latest_prune= LatestPrune.join x.latest_prune y.latest_prune } + fun x y -> + { stack= Stack.join x.stack y.stack + ; heap= Heap.join x.heap y.heap + ; alias= Alias.join x.alias y.alias + ; latest_prune= LatestPrune.join x.latest_prune y.latest_prune } let pp : F.formatter -> t -> unit = - fun fmt x -> - F.fprintf fmt "Stack:@;" ; - F.fprintf fmt "%a@;" Stack.pp x.stack ; - F.fprintf fmt "Heap:@;" ; - F.fprintf fmt "%a" Heap.pp x.heap + fun fmt x -> + F.fprintf fmt "Stack:@;" ; + F.fprintf fmt "%a@;" Stack.pp x.stack ; + F.fprintf fmt "Heap:@;" ; + F.fprintf fmt "%a" Heap.pp x.heap let pp_summary : F.formatter -> t -> unit = - fun fmt x -> - F.fprintf fmt "@[Parameters:@," ; - F.fprintf fmt "%a" Heap.pp_summary x.heap ; - F.fprintf fmt "@]" + fun fmt x -> + F.fprintf fmt "@[Parameters:@," ; + F.fprintf fmt "%a" Heap.pp_summary x.heap ; + F.fprintf fmt "@]" let find_stack : Loc.t -> t -> Val.t = fun k m -> Stack.find k m.stack @@ -636,32 +635,32 @@ module MemReach = struct let find_heap_set : PowLoc.t -> t -> Val.t = fun k m -> Heap.find_set k m.heap let find_set : PowLoc.t -> t -> Val.t = - fun k m -> Val.join (find_stack_set k m) (find_heap_set k m) + fun k m -> Val.join (find_stack_set k m) (find_heap_set k m) let find_alias : Ident.t -> t -> AliasTarget.t option = fun k m -> Alias.find k m.alias let find_simple_alias : Ident.t -> t -> Loc.t option = - fun k m -> - match Alias.find k m.alias with - | Some AliasTarget.Simple l -> - Some l - | Some AliasTarget.Empty _ | None -> - None + fun k m -> + match Alias.find k m.alias with + | Some AliasTarget.Simple l -> + Some l + | Some AliasTarget.Empty _ | None -> + None let find_ret_alias : t -> AliasTarget.t option = fun m -> Alias.find_ret m.alias let load_alias : Ident.t -> AliasTarget.t -> t -> t = - fun id loc m -> {m with alias= Alias.load id loc m.alias} + fun id loc m -> {m with alias= Alias.load id loc m.alias} let store_simple_alias : Loc.t -> Exp.t -> t -> t = - fun loc e m -> {m with alias= Alias.store_simple loc e m.alias} + fun loc e m -> {m with alias= Alias.store_simple loc e m.alias} let store_empty_alias : Val.t -> Loc.t -> Exp.t -> t -> t = - fun formal loc e m -> {m with alias= Alias.store_empty formal loc e m.alias} + fun formal loc e m -> {m with alias= Alias.store_empty formal loc e m.alias} let add_stack : Loc.t -> Val.t -> t -> t = fun k v m -> {m with stack= Stack.add k v m.stack} @@ -669,73 +668,72 @@ module MemReach = struct let add_heap : Loc.t -> Val.t -> t -> t = fun k v m -> {m with heap= Heap.add k v m.heap} let strong_update_heap : PowLoc.t -> Val.t -> t -> t = - fun p v m -> {m with heap= Heap.strong_update p v m.heap} + fun p v m -> {m with heap= Heap.strong_update p v m.heap} let transform_heap : f:(Val.t -> Val.t) -> PowLoc.t -> t -> t = - fun ~f p m -> {m with heap= Heap.transform ~f p m.heap} + fun ~f p m -> {m with heap= Heap.transform ~f p m.heap} let weak_update_heap : PowLoc.t -> Val.t -> t -> t = - fun p v m -> {m with heap= Heap.weak_update p v m.heap} + fun p v m -> {m with heap= Heap.weak_update p v m.heap} let get_return : t -> Val.t = fun m -> Heap.get_return m.heap let can_strong_update : PowLoc.t -> bool = - fun ploc -> - if always_strong_update then true - else if Int.equal (PowLoc.cardinal ploc) 1 then Loc.is_var (PowLoc.choose ploc) - else false + fun ploc -> + if always_strong_update then true + else if Int.equal (PowLoc.cardinal ploc) 1 then Loc.is_var (PowLoc.choose ploc) + else false let update_mem : PowLoc.t -> Val.t -> t -> t = - fun ploc v s -> - if can_strong_update ploc then strong_update_heap ploc v s - else - let () = - L.(debug BufferOverrun Verbose) "Weak update for %a <- %a@." PowLoc.pp ploc Val.pp v - in - weak_update_heap ploc v s + fun ploc v s -> + if can_strong_update ploc then strong_update_heap ploc v s + else + let () = + L.(debug BufferOverrun Verbose) "Weak update for %a <- %a@." PowLoc.pp ploc Val.pp v + in + weak_update_heap ploc v s let transform_mem : f:(Val.t -> Val.t) -> PowLoc.t -> t -> t = - fun ~f ploc s -> transform_heap ~f ploc s + fun ~f ploc s -> transform_heap ~f ploc s let remove_temps : Ident.t list -> t -> t = - fun temps m -> - {m with stack= Stack.remove_temps temps m.stack; alias= Alias.remove_temps temps m.alias} + fun temps m -> + {m with stack= Stack.remove_temps temps m.stack; alias= Alias.remove_temps temps m.alias} let set_prune_pairs : PrunePairs.t -> t -> t = - fun prune_pairs m -> {m with latest_prune= LatestPrune.Latest prune_pairs} + fun prune_pairs m -> {m with latest_prune= LatestPrune.Latest prune_pairs} let apply_latest_prune : Exp.t -> t -> t = - fun e m -> - match (m.latest_prune, e) with - | LatestPrune.V (x, prunes, _), Exp.Var r - | LatestPrune.V (x, _, prunes), Exp.UnOp (Unop.LNot, Exp.Var r, _) -> ( - match find_simple_alias r m with - | Some Loc.Var Var.ProgramVar y when Pvar.equal x y -> - List.fold_left prunes ~init:m ~f:(fun acc (l, v) -> - update_mem (PowLoc.singleton l) v acc ) - | _ -> - m ) + fun e m -> + match (m.latest_prune, e) with + | LatestPrune.V (x, prunes, _), Exp.Var r + | LatestPrune.V (x, _, prunes), Exp.UnOp (Unop.LNot, Exp.Var r, _) -> ( + match find_simple_alias r m with + | Some Loc.Var Var.ProgramVar y when Pvar.equal x y -> + List.fold_left prunes ~init:m ~f:(fun acc (l, v) -> update_mem (PowLoc.singleton l) v acc) | _ -> - m + m ) + | _ -> + m let update_latest_prune : Exp.t -> Exp.t -> t -> t = - fun e1 e2 m -> - match (e1, e2, m.latest_prune) with - | Lvar x, Const Const.Cint i, LatestPrune.Latest p -> - if IntLit.isone i then {m with latest_prune= LatestPrune.TrueBranch (x, p)} - else if IntLit.iszero i then {m with latest_prune= LatestPrune.FalseBranch (x, p)} - else {m with latest_prune= LatestPrune.Top} - | _, _, _ -> - {m with latest_prune= LatestPrune.Top} + fun e1 e2 m -> + match (e1, e2, m.latest_prune) with + | Lvar x, Const Const.Cint i, LatestPrune.Latest p -> + if IntLit.isone i then {m with latest_prune= LatestPrune.TrueBranch (x, p)} + else if IntLit.iszero i then {m with latest_prune= LatestPrune.FalseBranch (x, p)} + else {m with latest_prune= LatestPrune.Top} + | _, _, _ -> + {m with latest_prune= LatestPrune.Top} end module Mem = struct @@ -748,60 +746,60 @@ module Mem = struct let init : t = NonBottom MemReach.init let f_lift_default : 'a -> (MemReach.t -> 'a) -> t -> 'a = - fun default f m -> match m with Bottom -> default | NonBottom m' -> f m' + fun default f m -> match m with Bottom -> default | NonBottom m' -> f m' let f_lift : (MemReach.t -> MemReach.t) -> t -> t = - fun f -> f_lift_default Bottom (fun m' -> NonBottom (f m')) + fun f -> f_lift_default Bottom (fun m' -> NonBottom (f m')) let pp_summary : F.formatter -> t -> unit = - fun fmt m -> - match m with - | Bottom -> - F.fprintf fmt "unreachable" - | NonBottom m' -> - MemReach.pp_summary fmt m' + fun fmt m -> + match m with + | Bottom -> + F.fprintf fmt "unreachable" + | NonBottom m' -> + MemReach.pp_summary fmt m' let find_stack : Loc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_stack k) let find_stack_set : PowLoc.t -> t -> Val.t = - fun k -> f_lift_default Val.bot (MemReach.find_stack_set k) + fun k -> f_lift_default Val.bot (MemReach.find_stack_set k) let find_heap : Loc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_heap k) let find_heap_set : PowLoc.t -> t -> Val.t = - fun k -> f_lift_default Val.bot (MemReach.find_heap_set k) + fun k -> f_lift_default Val.bot (MemReach.find_heap_set k) let find_set : PowLoc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_set k) let find_alias : Ident.t -> t -> AliasTarget.t option = - fun k -> f_lift_default None (MemReach.find_alias k) + fun k -> f_lift_default None (MemReach.find_alias k) let find_simple_alias : Ident.t -> t -> Loc.t option = - fun k -> f_lift_default None (MemReach.find_simple_alias k) + fun k -> f_lift_default None (MemReach.find_simple_alias k) let find_ret_alias : t -> AliasTarget.t option = f_lift_default None MemReach.find_ret_alias let load_alias : Ident.t -> AliasTarget.t -> t -> t = - fun id loc -> f_lift (MemReach.load_alias id loc) + fun id loc -> f_lift (MemReach.load_alias id loc) let load_simple_alias : Ident.t -> Loc.t -> t -> t = - fun id loc -> load_alias id (AliasTarget.Simple loc) + fun id loc -> load_alias id (AliasTarget.Simple loc) let store_simple_alias : Loc.t -> Exp.t -> t -> t = - fun loc e -> f_lift (MemReach.store_simple_alias loc e) + fun loc e -> f_lift (MemReach.store_simple_alias loc e) let store_empty_alias : Val.t -> Loc.t -> Exp.t -> t -> t = - fun formal loc e -> f_lift (MemReach.store_empty_alias formal loc e) + fun formal loc e -> f_lift (MemReach.store_empty_alias formal loc e) let add_stack : Loc.t -> Val.t -> t -> t = fun k v -> f_lift (MemReach.add_stack k v) @@ -809,11 +807,11 @@ module Mem = struct let add_heap : Loc.t -> Val.t -> t -> t = fun k v -> f_lift (MemReach.add_heap k v) let strong_update_heap : PowLoc.t -> Val.t -> t -> t = - fun p v -> f_lift (MemReach.strong_update_heap p v) + fun p v -> f_lift (MemReach.strong_update_heap p v) let weak_update_heap : PowLoc.t -> Val.t -> t -> t = - fun p v -> f_lift (MemReach.weak_update_heap p v) + fun p v -> f_lift (MemReach.weak_update_heap p v) let get_return : t -> Val.t = f_lift_default Val.bot MemReach.get_return @@ -821,25 +819,25 @@ module Mem = struct let update_mem : PowLoc.t -> Val.t -> t -> t = fun ploc v -> f_lift (MemReach.update_mem ploc v) let transform_mem : f:(Val.t -> Val.t) -> PowLoc.t -> t -> t = - fun ~f ploc -> f_lift (MemReach.transform_mem ~f ploc) + fun ~f ploc -> f_lift (MemReach.transform_mem ~f ploc) let remove_temps : Ident.t list -> t -> t = fun temps -> f_lift (MemReach.remove_temps temps) let set_prune_pairs : PrunePairs.t -> t -> t = - fun prune_pairs -> f_lift (MemReach.set_prune_pairs prune_pairs) + fun prune_pairs -> f_lift (MemReach.set_prune_pairs prune_pairs) let apply_latest_prune : Exp.t -> t -> t = fun e -> f_lift (MemReach.apply_latest_prune e) let update_latest_prune : Exp.t -> Exp.t -> t -> t = - fun e1 e2 -> f_lift (MemReach.update_latest_prune e1 e2) + fun e1 e2 -> f_lift (MemReach.update_latest_prune e1 e2) let update_mem_in_prune : PrunePairs.t ref -> Loc.t -> Val.t -> t -> t = - fun prune_pairs lv v m -> - prune_pairs := (lv, v) :: !prune_pairs ; - update_mem (PowLoc.singleton lv) v m + fun prune_pairs lv v m -> + prune_pairs := (lv, v) :: !prune_pairs ; + update_mem (PowLoc.singleton lv) v m end module Summary = struct @@ -856,17 +854,16 @@ module Summary = struct let pp_symbol_map : F.formatter -> t -> unit = fun fmt s -> Mem.pp_summary fmt (get_input s) let pp_return : F.formatter -> t -> unit = - fun fmt s -> F.fprintf fmt "Return value: %a" Val.pp_summary (get_return s) + fun fmt s -> F.fprintf fmt "Return value: %a" Val.pp_summary (get_return s) let pp_summary : F.formatter -> t -> unit = - fun fmt s -> - F.fprintf fmt "%a@,%a@,%a" pp_symbol_map s pp_return s PO.ConditionSet.pp_summary - (get_cond_set s) + fun fmt s -> + F.fprintf fmt "%a@,%a@,%a" pp_symbol_map s pp_return s PO.ConditionSet.pp_summary + (get_cond_set s) let pp : F.formatter -> t -> unit = - fun fmt (entry_mem, exit_mem, condition_set) -> - F.fprintf fmt "%a@,%a@,%a@," Mem.pp entry_mem Mem.pp exit_mem PO.ConditionSet.pp - condition_set + fun fmt (entry_mem, exit_mem, condition_set) -> + F.fprintf fmt "%a@,%a@,%a@," Mem.pp entry_mem Mem.pp exit_mem PO.ConditionSet.pp condition_set end diff --git a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml index 2d78fb17b..0626ca3cc 100644 --- a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml +++ b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml @@ -91,26 +91,26 @@ module ArrayAccessCondition = struct let get_symbols c = ItvPure.get_symbols c.idx @ ItvPure.get_symbols c.size let set_size_pos : t -> t = - fun c -> - let size' = ItvPure.make_positive c.size in - if phys_equal size' c.size then c else {c with size= size'} + fun c -> + let size' = ItvPure.make_positive c.size in + if phys_equal size' c.size then c else {c with size= size'} let pp : F.formatter -> t -> unit = - fun fmt c -> - let c = set_size_pos c in - F.fprintf fmt "%a < %a" ItvPure.pp c.idx ItvPure.pp c.size + fun fmt c -> + let c = set_size_pos c in + F.fprintf fmt "%a < %a" ItvPure.pp c.idx ItvPure.pp c.size let pp_description : F.formatter -> t -> unit = - fun fmt c -> - let c = set_size_pos c in - F.fprintf fmt "Offset: %a Size: %a" ItvPure.pp c.idx ItvPure.pp c.size + fun fmt c -> + let c = set_size_pos c in + F.fprintf fmt "Offset: %a Size: %a" ItvPure.pp c.idx ItvPure.pp c.size let make : idx:ItvPure.t -> size:ItvPure.t -> t option = - fun ~idx ~size -> - if ItvPure.is_invalid idx || ItvPure.is_invalid size then None else Some {idx; size} + fun ~idx ~size -> + if ItvPure.is_invalid idx || ItvPure.is_invalid size then None else Some {idx; size} let have_similar_bounds {idx= lidx; size= lsiz} {idx= ridx; size= rsiz} = @@ -163,69 +163,68 @@ module ArrayAccessCondition = struct let filter1 : t -> bool = - fun c -> - ItvPure.is_top c.idx || ItvPure.is_top c.size - || Itv.Bound.eq (ItvPure.lb c.idx) Itv.Bound.MInf - || Itv.Bound.eq (ItvPure.lb c.size) Itv.Bound.MInf - || ItvPure.is_nat c.idx && ItvPure.is_nat c.size + fun c -> + ItvPure.is_top c.idx || ItvPure.is_top c.size || Itv.Bound.eq (ItvPure.lb c.idx) Itv.Bound.MInf + || Itv.Bound.eq (ItvPure.lb c.size) Itv.Bound.MInf + || ItvPure.is_nat c.idx && ItvPure.is_nat c.size let filter2 : t -> bool = - fun c -> - (* basically, alarms involving infinity are filtered *) - (not (ItvPure.is_finite c.idx) || not (ItvPure.is_finite c.size)) - && (* except the following cases *) - not - ( Itv.Bound.is_not_infty (ItvPure.lb c.idx) - && (* idx non-infty lb < 0 *) - Itv.Bound.lt (ItvPure.lb c.idx) Itv.Bound.zero - || Itv.Bound.is_not_infty (ItvPure.lb c.idx) - && (* idx non-infty lb > size lb *) - Itv.Bound.gt (ItvPure.lb c.idx) (ItvPure.lb c.size) - || Itv.Bound.is_not_infty (ItvPure.lb c.idx) - && (* idx non-infty lb > size ub *) - Itv.Bound.gt (ItvPure.lb c.idx) (ItvPure.ub c.size) - || Itv.Bound.is_not_infty (ItvPure.ub c.idx) - && (* idx non-infty ub > size lb *) - Itv.Bound.gt (ItvPure.ub c.idx) (ItvPure.lb c.size) - || Itv.Bound.is_not_infty (ItvPure.ub c.idx) - && (* idx non-infty ub > size ub *) - Itv.Bound.gt (ItvPure.ub c.idx) (ItvPure.ub c.size) ) + fun c -> + (* basically, alarms involving infinity are filtered *) + (not (ItvPure.is_finite c.idx) || not (ItvPure.is_finite c.size)) + && (* except the following cases *) + not + ( Itv.Bound.is_not_infty (ItvPure.lb c.idx) + && (* idx non-infty lb < 0 *) + Itv.Bound.lt (ItvPure.lb c.idx) Itv.Bound.zero + || Itv.Bound.is_not_infty (ItvPure.lb c.idx) + && (* idx non-infty lb > size lb *) + Itv.Bound.gt (ItvPure.lb c.idx) (ItvPure.lb c.size) + || Itv.Bound.is_not_infty (ItvPure.lb c.idx) + && (* idx non-infty lb > size ub *) + Itv.Bound.gt (ItvPure.lb c.idx) (ItvPure.ub c.size) + || Itv.Bound.is_not_infty (ItvPure.ub c.idx) + && (* idx non-infty ub > size lb *) + Itv.Bound.gt (ItvPure.ub c.idx) (ItvPure.lb c.size) + || Itv.Bound.is_not_infty (ItvPure.ub c.idx) + && (* idx non-infty ub > size ub *) + Itv.Bound.gt (ItvPure.ub c.idx) (ItvPure.ub c.size) ) (* check buffer overrun and return its confidence *) let check : t -> IssueType.t option = - fun c -> - (* idx = [il, iu], size = [sl, su], we want to check that 0 <= idx < size *) - let c' = set_size_pos c in - (* if sl < 0, use sl' = 0 *) - let not_overrun = ItvPure.lt_sem c'.idx c'.size in - let not_underrun = ItvPure.le_sem ItvPure.zero c'.idx in - (* il >= 0 and iu < sl, definitely not an error *) - if ItvPure.is_one not_overrun && ItvPure.is_one not_underrun then None - (* iu < 0 or il >= su, definitely an error *) - else if ItvPure.is_zero not_overrun || ItvPure.is_zero not_underrun then - Some IssueType.buffer_overrun_l1 (* su <= iu < +oo, most probably an error *) - else if Itv.Bound.is_not_infty (ItvPure.ub c.idx) - && Itv.Bound.le (ItvPure.ub c.size) (ItvPure.ub c.idx) - then Some IssueType.buffer_overrun_l2 (* symbolic il >= sl, probably an error *) - else if Itv.Bound.is_symbolic (ItvPure.lb c.idx) - && Itv.Bound.le (ItvPure.lb c'.size) (ItvPure.lb c.idx) - then Some IssueType.buffer_overrun_s2 (* other symbolic bounds are probably too noisy *) - else if Config.bo_debug <= 3 && (ItvPure.is_symbolic c.idx || ItvPure.is_symbolic c.size) - then None - else if filter1 c then Some IssueType.buffer_overrun_l5 - else if filter2 c then Some IssueType.buffer_overrun_l4 - else Some IssueType.buffer_overrun_l3 + fun c -> + (* idx = [il, iu], size = [sl, su], we want to check that 0 <= idx < size *) + let c' = set_size_pos c in + (* if sl < 0, use sl' = 0 *) + let not_overrun = ItvPure.lt_sem c'.idx c'.size in + let not_underrun = ItvPure.le_sem ItvPure.zero c'.idx in + (* il >= 0 and iu < sl, definitely not an error *) + if ItvPure.is_one not_overrun && ItvPure.is_one not_underrun then None + (* iu < 0 or il >= su, definitely an error *) + else if ItvPure.is_zero not_overrun || ItvPure.is_zero not_underrun then + Some IssueType.buffer_overrun_l1 (* su <= iu < +oo, most probably an error *) + else if Itv.Bound.is_not_infty (ItvPure.ub c.idx) + && Itv.Bound.le (ItvPure.ub c.size) (ItvPure.ub c.idx) + then Some IssueType.buffer_overrun_l2 (* symbolic il >= sl, probably an error *) + else if Itv.Bound.is_symbolic (ItvPure.lb c.idx) + && Itv.Bound.le (ItvPure.lb c'.size) (ItvPure.lb c.idx) + then Some IssueType.buffer_overrun_s2 (* other symbolic bounds are probably too noisy *) + else if Config.bo_debug <= 3 && (ItvPure.is_symbolic c.idx || ItvPure.is_symbolic c.size) then + None + else if filter1 c then Some IssueType.buffer_overrun_l5 + else if filter2 c then Some IssueType.buffer_overrun_l4 + else Some IssueType.buffer_overrun_l3 let subst : Itv.Bound.t bottom_lifted Itv.SubstMap.t -> t -> t option = - fun bound_map c -> - match (ItvPure.subst c.idx bound_map, ItvPure.subst c.size bound_map) with - | NonBottom idx, NonBottom size -> - Some {idx; size} - | _ -> - None + fun bound_map c -> + match (ItvPure.subst c.idx bound_map, ItvPure.subst c.size bound_map) with + | NonBottom idx, NonBottom size -> + Some {idx; size} + | _ -> + None end module Condition = struct @@ -306,27 +305,27 @@ module ConditionTrace = struct let pp_location : F.formatter -> t -> unit = fun fmt ct -> Location.pp_file_pos fmt ct.location let pp : F.formatter -> t -> unit = - fun fmt ct -> - if Config.bo_debug <= 1 then F.fprintf fmt "at %a" pp_location ct - else - match ct.cond_trace with - | Inter (_, pname, location) -> - let pname = Typ.Procname.to_string pname in - F.fprintf fmt "at %a by call %s() at %a (%a)" pp_location ct pname Location.pp_file_pos - location ValTraceSet.pp ct.val_traces - | Intra _ -> - F.fprintf fmt "%a (%a)" pp_location ct ValTraceSet.pp ct.val_traces + fun fmt ct -> + if Config.bo_debug <= 1 then F.fprintf fmt "at %a" pp_location ct + else + match ct.cond_trace with + | Inter (_, pname, location) -> + let pname = Typ.Procname.to_string pname in + F.fprintf fmt "at %a by call %s() at %a (%a)" pp_location ct pname Location.pp_file_pos + location ValTraceSet.pp ct.val_traces + | Intra _ -> + F.fprintf fmt "%a (%a)" pp_location ct ValTraceSet.pp ct.val_traces let pp_description : F.formatter -> t -> unit = - fun fmt ct -> - match ct.cond_trace with - | Inter (_, pname, _) - when Config.bo_debug >= 1 || not (SourceFile.is_cpp_model ct.location.Location.file) -> - F.fprintf fmt " %@ %a by call %a " pp_location ct MF.pp_monospaced - (Typ.Procname.to_string pname ^ "()") - | _ -> - () + fun fmt ct -> + match ct.cond_trace with + | Inter (_, pname, _) + when Config.bo_debug >= 1 || not (SourceFile.is_cpp_model ct.location.Location.file) -> + F.fprintf fmt " %@ %a by call %a " pp_location ct MF.pp_monospaced + (Typ.Procname.to_string pname ^ "()") + | _ -> + () let get_location : t -> Location.t = fun ct -> ct.location @@ -334,8 +333,8 @@ module ConditionTrace = struct let get_cond_trace : t -> cond_trace = fun ct -> ct.cond_trace let make : Typ.Procname.t -> Location.t -> ValTraceSet.t -> t = - fun proc_name location val_traces -> - {proc_name; location; cond_trace= Intra proc_name; val_traces} + fun proc_name location val_traces -> + {proc_name; location; cond_trace= Intra proc_name; val_traces} let make_call_and_subst ~traces_caller ~caller_pname ~callee_pname location ct = @@ -455,23 +454,23 @@ module ConditionSet = struct let pp_cwt fmt cwt = F.fprintf fmt "%a %a" Condition.pp cwt.cond ConditionTrace.pp cwt.trace let pp_summary : F.formatter -> t -> unit = - fun fmt condset -> - let pp_sep fmt () = F.fprintf fmt ", @," in - F.fprintf fmt "@[Safety conditions:@," ; - F.fprintf fmt "@[{ " ; - F.pp_print_list ~pp_sep pp_cwt fmt condset ; - F.fprintf fmt " }@]" ; - F.fprintf fmt "@]" + fun fmt condset -> + let pp_sep fmt () = F.fprintf fmt ", @," in + F.fprintf fmt "@[Safety conditions:@," ; + F.fprintf fmt "@[{ " ; + F.pp_print_list ~pp_sep pp_cwt fmt condset ; + F.fprintf fmt " }@]" ; + F.fprintf fmt "@]" let pp : Format.formatter -> t -> unit = - fun fmt condset -> - let pp_sep fmt () = F.fprintf fmt ", @," in - F.fprintf fmt "@[Safety conditions :@," ; - F.fprintf fmt "@[{" ; - F.pp_print_list ~pp_sep pp_cwt fmt condset ; - F.fprintf fmt " }@]" ; - F.fprintf fmt "@]" + fun fmt condset -> + let pp_sep fmt () = F.fprintf fmt ", @," in + F.fprintf fmt "@[Safety conditions :@," ; + F.fprintf fmt "@[{" ; + F.pp_print_list ~pp_sep pp_cwt fmt condset ; + F.fprintf fmt " }@]" ; + F.fprintf fmt "@]" end let description cond trace = diff --git a/infer/src/bufferoverrun/bufferOverrunSemantics.ml b/infer/src/bufferoverrun/bufferOverrunSemantics.ml index 316647524..2a24e1df4 100644 --- a/infer/src/bufferoverrun/bufferOverrunSemantics.ml +++ b/infer/src/bufferoverrun/bufferOverrunSemantics.ml @@ -77,49 +77,49 @@ module Make (CFG : ProcCfg.S) = struct let rec must_alias : Exp.t -> Exp.t -> Mem.astate -> bool = - fun e1 e2 m -> - match (e1, e2) with - | Exp.Var x1, Exp.Var x2 -> ( - match (Mem.find_alias x1 m, Mem.find_alias x2 m) with - | Some x1', Some x2' -> - AliasTarget.equal x1' x2' - | _, _ -> - false ) - | Exp.UnOp (uop1, e1', _), Exp.UnOp (uop2, e2', _) -> - Unop.equal uop1 uop2 && must_alias e1' e2' m - | Exp.BinOp (bop1, e11, e12), Exp.BinOp (bop2, e21, e22) -> - Binop.equal bop1 bop2 && must_alias e11 e21 m && must_alias e12 e22 m - | Exp.Exn t1, Exp.Exn t2 -> - must_alias t1 t2 m - | Exp.Const c1, Exp.Const c2 -> - Const.equal c1 c2 - | Exp.Cast (t1, e1'), Exp.Cast (t2, e2') -> - Typ.equal t1 t2 && must_alias e1' e2' m - | Exp.Lvar x1, Exp.Lvar x2 -> - Pvar.equal x1 x2 - | Exp.Lfield (e1, fld1, _), Exp.Lfield (e2, fld2, _) -> - must_alias e1 e2 m && Typ.Fieldname.equal fld1 fld2 - | Exp.Lindex (e11, e12), Exp.Lindex (e21, e22) -> - must_alias e11 e21 m && must_alias e12 e22 m - | Exp.Sizeof {nbytes= Some nbytes1}, Exp.Sizeof {nbytes= Some nbytes2} -> - Int.equal nbytes1 nbytes2 - | ( Exp.Sizeof {typ= t1; dynamic_length= dynlen1; subtype= subt1} - , Exp.Sizeof {typ= t2; dynamic_length= dynlen2; subtype= subt2} ) -> - Typ.equal t1 t2 && must_alias_opt dynlen1 dynlen2 m - && Int.equal (Subtype.compare subt1 subt2) 0 + fun e1 e2 m -> + match (e1, e2) with + | Exp.Var x1, Exp.Var x2 -> ( + match (Mem.find_alias x1 m, Mem.find_alias x2 m) with + | Some x1', Some x2' -> + AliasTarget.equal x1' x2' | _, _ -> - false + false ) + | Exp.UnOp (uop1, e1', _), Exp.UnOp (uop2, e2', _) -> + Unop.equal uop1 uop2 && must_alias e1' e2' m + | Exp.BinOp (bop1, e11, e12), Exp.BinOp (bop2, e21, e22) -> + Binop.equal bop1 bop2 && must_alias e11 e21 m && must_alias e12 e22 m + | Exp.Exn t1, Exp.Exn t2 -> + must_alias t1 t2 m + | Exp.Const c1, Exp.Const c2 -> + Const.equal c1 c2 + | Exp.Cast (t1, e1'), Exp.Cast (t2, e2') -> + Typ.equal t1 t2 && must_alias e1' e2' m + | Exp.Lvar x1, Exp.Lvar x2 -> + Pvar.equal x1 x2 + | Exp.Lfield (e1, fld1, _), Exp.Lfield (e2, fld2, _) -> + must_alias e1 e2 m && Typ.Fieldname.equal fld1 fld2 + | Exp.Lindex (e11, e12), Exp.Lindex (e21, e22) -> + must_alias e11 e21 m && must_alias e12 e22 m + | Exp.Sizeof {nbytes= Some nbytes1}, Exp.Sizeof {nbytes= Some nbytes2} -> + Int.equal nbytes1 nbytes2 + | ( Exp.Sizeof {typ= t1; dynamic_length= dynlen1; subtype= subt1} + , Exp.Sizeof {typ= t2; dynamic_length= dynlen2; subtype= subt2} ) -> + Typ.equal t1 t2 && must_alias_opt dynlen1 dynlen2 m + && Int.equal (Subtype.compare subt1 subt2) 0 + | _, _ -> + false and must_alias_opt : Exp.t option -> Exp.t option -> Mem.astate -> bool = - fun e1_opt e2_opt m -> - match (e1_opt, e2_opt) with - | Some e1, Some e2 -> - must_alias e1 e2 m - | None, None -> - true - | _, _ -> - false + fun e1_opt e2_opt m -> + match (e1_opt, e2_opt) with + | Some e1, Some e2 -> + must_alias e1 e2 m + | None, None -> + true + | _, _ -> + false let comp_rev : Binop.t -> Binop.t = function @@ -157,64 +157,64 @@ module Make (CFG : ProcCfg.S) = struct let rec must_alias_cmp : Exp.t -> Mem.astate -> bool = - fun e m -> - match e with - | Exp.BinOp (Binop.Lt, e1, e2) | Exp.BinOp (Binop.Gt, e1, e2) | Exp.BinOp (Binop.Ne, e1, e2) -> - must_alias e1 e2 m - | Exp.BinOp (Binop.LAnd, e1, e2) -> - must_alias_cmp e1 m || must_alias_cmp e2 m - | Exp.BinOp (Binop.LOr, e1, e2) -> - must_alias_cmp e1 m && must_alias_cmp e2 m - | Exp.UnOp (Unop.LNot, Exp.UnOp (Unop.LNot, e1, _), _) -> - must_alias_cmp e1 m - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Lt as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Gt as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Le as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ge as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Eq as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) -> - must_alias_cmp (Exp.BinOp (comp_not c, e1, e2)) m - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) -> - let e1' = Exp.UnOp (Unop.LNot, e1, t) in - let e2' = Exp.UnOp (Unop.LNot, e2, t) in - must_alias_cmp (Exp.BinOp (Binop.LAnd, e1', e2')) m - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LAnd, e1, e2), t) -> - let e1' = Exp.UnOp (Unop.LNot, e1, t) in - let e2' = Exp.UnOp (Unop.LNot, e2, t) in - must_alias_cmp (Exp.BinOp (Binop.LOr, e1', e2')) m - | _ -> - false + fun e m -> + match e with + | Exp.BinOp (Binop.Lt, e1, e2) | Exp.BinOp (Binop.Gt, e1, e2) | Exp.BinOp (Binop.Ne, e1, e2) -> + must_alias e1 e2 m + | Exp.BinOp (Binop.LAnd, e1, e2) -> + must_alias_cmp e1 m || must_alias_cmp e2 m + | Exp.BinOp (Binop.LOr, e1, e2) -> + must_alias_cmp e1 m && must_alias_cmp e2 m + | Exp.UnOp (Unop.LNot, Exp.UnOp (Unop.LNot, e1, _), _) -> + must_alias_cmp e1 m + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Lt as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Gt as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Le as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ge as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Eq as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) -> + must_alias_cmp (Exp.BinOp (comp_not c, e1, e2)) m + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) -> + let e1' = Exp.UnOp (Unop.LNot, e1, t) in + let e2' = Exp.UnOp (Unop.LNot, e2, t) in + must_alias_cmp (Exp.BinOp (Binop.LAnd, e1', e2')) m + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LAnd, e1, e2), t) -> + let e1' = Exp.UnOp (Unop.LNot, e1, t) in + let e2' = Exp.UnOp (Unop.LNot, e2, t) in + must_alias_cmp (Exp.BinOp (Binop.LOr, e1', e2')) m + | _ -> + false let rec eval : Exp.t -> Mem.astate -> Val.t = - fun exp mem -> - if must_alias_cmp exp mem then Val.of_int 0 - else - match exp with - | Exp.Var id -> - Mem.find_stack (Var.of_id id |> Loc.of_var) mem - | Exp.Lvar pvar -> - let ploc = pvar |> Loc.of_pvar |> PowLoc.singleton in - let arr = Mem.find_stack_set ploc mem in - ploc |> Val.of_pow_loc |> Val.join arr - | Exp.UnOp (uop, e, _) -> - eval_unop uop e mem - | Exp.BinOp (bop, e1, e2) -> - eval_binop bop e1 e2 mem - | Exp.Const c -> - eval_const c - | Exp.Cast (_, e) -> - eval e mem - | Exp.Lfield (e, fn, _) -> - eval e mem |> Val.get_array_locs |> PowLoc.append_field ~fn |> Val.of_pow_loc - | Exp.Lindex (e1, e2) -> - eval_lindex e1 e2 mem - | Exp.Sizeof {nbytes= Some size} -> - Val.of_int size - | Exp.Sizeof {typ; nbytes= None} -> - Val.of_int (sizeof typ) - | Exp.Exn _ | Exp.Closure _ -> - Val.Itv.top + fun exp mem -> + if must_alias_cmp exp mem then Val.of_int 0 + else + match exp with + | Exp.Var id -> + Mem.find_stack (Var.of_id id |> Loc.of_var) mem + | Exp.Lvar pvar -> + let ploc = pvar |> Loc.of_pvar |> PowLoc.singleton in + let arr = Mem.find_stack_set ploc mem in + ploc |> Val.of_pow_loc |> Val.join arr + | Exp.UnOp (uop, e, _) -> + eval_unop uop e mem + | Exp.BinOp (bop, e1, e2) -> + eval_binop bop e1 e2 mem + | Exp.Const c -> + eval_const c + | Exp.Cast (_, e) -> + eval e mem + | Exp.Lfield (e, fn, _) -> + eval e mem |> Val.get_array_locs |> PowLoc.append_field ~fn |> Val.of_pow_loc + | Exp.Lindex (e1, e2) -> + eval_lindex e1 e2 mem + | Exp.Sizeof {nbytes= Some size} -> + Val.of_int size + | Exp.Sizeof {typ; nbytes= None} -> + Val.of_int (sizeof typ) + | Exp.Exn _ | Exp.Closure _ -> + Val.Itv.top and eval_lindex array_exp index_exp mem = @@ -227,335 +227,334 @@ module Make (CFG : ProcCfg.S) = struct and eval_unop : Unop.t -> Exp.t -> Mem.astate -> Val.t = - fun unop e mem -> - let v = eval e mem in - match unop with - | Unop.Neg -> - Val.neg v - | Unop.BNot -> - Val.unknown_bit v - | Unop.LNot -> - Val.lnot v + fun unop e mem -> + let v = eval e mem in + match unop with + | Unop.Neg -> + Val.neg v + | Unop.BNot -> + Val.unknown_bit v + | Unop.LNot -> + Val.lnot v and eval_binop : Binop.t -> Exp.t -> Exp.t -> Mem.astate -> Val.t = - fun binop e1 e2 mem -> - let v1 = eval e1 mem in - let v2 = eval e2 mem in - match binop with - | Binop.PlusA -> - Val.join (Val.plus v1 v2) (Val.plus_pi v1 v2) - | Binop.PlusPI -> - Val.plus_pi v1 v2 - | Binop.MinusA -> - Val.joins [Val.minus v1 v2; Val.minus_pi v1 v2; Val.minus_pp v1 v2] - | Binop.MinusPI -> - Val.minus_pi v1 v2 - | Binop.MinusPP -> - Val.minus_pp v1 v2 - | Binop.Mult -> - Val.mult v1 v2 - | Binop.Div -> - Val.div v1 v2 - | Binop.Mod -> - Val.mod_sem v1 v2 - | Binop.Shiftlt -> - Val.shiftlt v1 v2 - | Binop.Shiftrt -> - Val.shiftrt v1 v2 - | Binop.Lt -> - Val.lt_sem v1 v2 - | Binop.Gt -> - Val.gt_sem v1 v2 - | Binop.Le -> - Val.le_sem v1 v2 - | Binop.Ge -> - Val.ge_sem v1 v2 - | Binop.Eq -> - Val.eq_sem v1 v2 - | Binop.Ne -> - Val.ne_sem v1 v2 - | Binop.BAnd | Binop.BXor | Binop.BOr -> - Val.unknown_bit v1 - | Binop.LAnd -> - Val.land_sem v1 v2 - | Binop.LOr -> - Val.lor_sem v1 v2 + fun binop e1 e2 mem -> + let v1 = eval e1 mem in + let v2 = eval e2 mem in + match binop with + | Binop.PlusA -> + Val.join (Val.plus v1 v2) (Val.plus_pi v1 v2) + | Binop.PlusPI -> + Val.plus_pi v1 v2 + | Binop.MinusA -> + Val.joins [Val.minus v1 v2; Val.minus_pi v1 v2; Val.minus_pp v1 v2] + | Binop.MinusPI -> + Val.minus_pi v1 v2 + | Binop.MinusPP -> + Val.minus_pp v1 v2 + | Binop.Mult -> + Val.mult v1 v2 + | Binop.Div -> + Val.div v1 v2 + | Binop.Mod -> + Val.mod_sem v1 v2 + | Binop.Shiftlt -> + Val.shiftlt v1 v2 + | Binop.Shiftrt -> + Val.shiftrt v1 v2 + | Binop.Lt -> + Val.lt_sem v1 v2 + | Binop.Gt -> + Val.gt_sem v1 v2 + | Binop.Le -> + Val.le_sem v1 v2 + | Binop.Ge -> + Val.ge_sem v1 v2 + | Binop.Eq -> + Val.eq_sem v1 v2 + | Binop.Ne -> + Val.ne_sem v1 v2 + | Binop.BAnd | Binop.BXor | Binop.BOr -> + Val.unknown_bit v1 + | Binop.LAnd -> + Val.land_sem v1 v2 + | Binop.LOr -> + Val.lor_sem v1 v2 let rec eval_locs : Exp.t -> Mem.astate -> Val.t = - fun exp mem -> - match exp with - | Exp.Var id -> ( - match Mem.find_alias id mem with - | Some AliasTarget.Simple loc -> - PowLoc.singleton loc |> Val.of_pow_loc - | Some AliasTarget.Empty _ | None -> - Val.bot ) - | Exp.Lvar pvar -> - pvar |> Loc.of_pvar |> PowLoc.singleton |> Val.of_pow_loc - | Exp.BinOp (bop, e1, e2) -> - eval_binop bop e1 e2 mem - | Exp.Cast (_, e) -> - eval_locs e mem - | Exp.Lfield (e, fn, _) -> - eval e mem |> Val.get_all_locs |> PowLoc.append_field ~fn |> Val.of_pow_loc - | Exp.Lindex (e1, e2) -> - let arr = eval e1 mem in - let idx = eval e2 mem in - Val.plus_pi arr idx - | Exp.Const _ | Exp.UnOp _ | Exp.Sizeof _ | Exp.Exn _ | Exp.Closure _ -> - Val.bot + fun exp mem -> + match exp with + | Exp.Var id -> ( + match Mem.find_alias id mem with + | Some AliasTarget.Simple loc -> + PowLoc.singleton loc |> Val.of_pow_loc + | Some AliasTarget.Empty _ | None -> + Val.bot ) + | Exp.Lvar pvar -> + pvar |> Loc.of_pvar |> PowLoc.singleton |> Val.of_pow_loc + | Exp.BinOp (bop, e1, e2) -> + eval_binop bop e1 e2 mem + | Exp.Cast (_, e) -> + eval_locs e mem + | Exp.Lfield (e, fn, _) -> + eval e mem |> Val.get_all_locs |> PowLoc.append_field ~fn |> Val.of_pow_loc + | Exp.Lindex (e1, e2) -> + let arr = eval e1 mem in + let idx = eval e2 mem in + Val.plus_pi arr idx + | Exp.Const _ | Exp.UnOp _ | Exp.Sizeof _ | Exp.Exn _ | Exp.Closure _ -> + Val.bot let get_allocsite : Typ.Procname.t -> CFG.node -> int -> int -> string = - fun proc_name node inst_num dimension -> - let proc_name = Typ.Procname.to_string proc_name in - let node_num = CFG.hash node |> string_of_int in - let inst_num = string_of_int inst_num in - let dimension = string_of_int dimension in - proc_name ^ "-" ^ node_num ^ "-" ^ inst_num ^ "-" ^ dimension |> Allocsite.make + fun proc_name node inst_num dimension -> + let proc_name = Typ.Procname.to_string proc_name in + let node_num = CFG.hash node |> string_of_int in + let inst_num = string_of_int inst_num in + let dimension = string_of_int dimension in + proc_name ^ "-" ^ node_num ^ "-" ^ inst_num ^ "-" ^ dimension |> Allocsite.make let eval_array_alloc : Typ.Procname.t -> CFG.node -> Typ.t -> ?stride:int -> Itv.t -> Itv.t -> int -> int -> Val.t = - fun pdesc node typ ?stride:stride0 offset size inst_num dimension -> - let allocsite = get_allocsite pdesc node inst_num dimension in - let int_stride = match stride0 with None -> sizeof typ | Some stride -> stride in - let stride = Itv.of_int int_stride in - ArrayBlk.make allocsite offset size stride |> Val.of_array_blk + fun pdesc node typ ?stride:stride0 offset size inst_num dimension -> + let allocsite = get_allocsite pdesc node inst_num dimension in + let int_stride = match stride0 with None -> sizeof typ | Some stride -> stride in + let stride = Itv.of_int int_stride in + ArrayBlk.make allocsite offset size stride |> Val.of_array_blk let prune_unop : PrunePairs.t ref -> Exp.t -> Mem.astate -> Mem.astate = - fun prune_pairs e mem -> - match e with - | Exp.Var x -> ( - match Mem.find_alias x mem with - | Some AliasTarget.Simple lv -> - let v = Mem.find_heap lv mem in - let v' = Val.prune_zero v in - Mem.update_mem_in_prune prune_pairs lv v' mem - | Some AliasTarget.Empty lv -> - let v = Mem.find_heap lv mem in - let itv_v = Itv.prune_eq (Val.get_itv v) Itv.zero in - let v' = Val.modify_itv itv_v v in - Mem.update_mem_in_prune prune_pairs lv v' mem - | None -> - mem ) - | Exp.UnOp (Unop.LNot, Exp.Var x, _) -> ( - match Mem.find_alias x mem with - | Some AliasTarget.Simple lv -> - let v = Mem.find_heap lv mem in - let itv_v = Itv.prune_eq (Val.get_itv v) Itv.false_sem in - let v' = Val.modify_itv itv_v v in - Mem.update_mem_in_prune prune_pairs lv v' mem - | Some AliasTarget.Empty lv -> - let v = Mem.find_heap lv mem in - let itv_v = Itv.prune_comp Binop.Ge (Val.get_itv v) Itv.one in - let v' = Val.modify_itv itv_v v in - Mem.update_mem_in_prune prune_pairs lv v' mem - | None -> - mem ) - | _ -> - mem + fun prune_pairs e mem -> + match e with + | Exp.Var x -> ( + match Mem.find_alias x mem with + | Some AliasTarget.Simple lv -> + let v = Mem.find_heap lv mem in + let v' = Val.prune_zero v in + Mem.update_mem_in_prune prune_pairs lv v' mem + | Some AliasTarget.Empty lv -> + let v = Mem.find_heap lv mem in + let itv_v = Itv.prune_eq (Val.get_itv v) Itv.zero in + let v' = Val.modify_itv itv_v v in + Mem.update_mem_in_prune prune_pairs lv v' mem + | None -> + mem ) + | Exp.UnOp (Unop.LNot, Exp.Var x, _) -> ( + match Mem.find_alias x mem with + | Some AliasTarget.Simple lv -> + let v = Mem.find_heap lv mem in + let itv_v = Itv.prune_eq (Val.get_itv v) Itv.false_sem in + let v' = Val.modify_itv itv_v v in + Mem.update_mem_in_prune prune_pairs lv v' mem + | Some AliasTarget.Empty lv -> + let v = Mem.find_heap lv mem in + let itv_v = Itv.prune_comp Binop.Ge (Val.get_itv v) Itv.one in + let v' = Val.modify_itv itv_v v in + Mem.update_mem_in_prune prune_pairs lv v' mem + | None -> + mem ) + | _ -> + mem let prune_binop_left : PrunePairs.t ref -> Exp.t -> Mem.astate -> Mem.astate = - fun prune_pairs e mem -> - match e with - | Exp.BinOp ((Binop.Lt as comp), Exp.Var x, e') - | Exp.BinOp ((Binop.Gt as comp), Exp.Var x, e') - | Exp.BinOp ((Binop.Le as comp), Exp.Var x, e') - | Exp.BinOp ((Binop.Ge as comp), Exp.Var x, e') -> ( - match Mem.find_simple_alias x mem with - | Some lv -> - let v = Mem.find_heap lv mem in - let v' = Val.prune_comp comp v (eval e' mem) in - Mem.update_mem_in_prune prune_pairs lv v' mem - | None -> - mem ) - | Exp.BinOp (Binop.Eq, Exp.Var x, e') -> ( - match Mem.find_simple_alias x mem with - | Some lv -> - let v = Mem.find_heap lv mem in - let v' = Val.prune_eq v (eval e' mem) in - Mem.update_mem_in_prune prune_pairs lv v' mem - | None -> - mem ) - | Exp.BinOp (Binop.Ne, Exp.Var x, e') -> ( - match Mem.find_simple_alias x mem with - | Some lv -> - let v = Mem.find_heap lv mem in - let v' = Val.prune_ne v (eval e' mem) in - Mem.update_mem_in_prune prune_pairs lv v' mem - | None -> - mem ) - | _ -> - mem + fun prune_pairs e mem -> + match e with + | Exp.BinOp ((Binop.Lt as comp), Exp.Var x, e') + | Exp.BinOp ((Binop.Gt as comp), Exp.Var x, e') + | Exp.BinOp ((Binop.Le as comp), Exp.Var x, e') + | Exp.BinOp ((Binop.Ge as comp), Exp.Var x, e') -> ( + match Mem.find_simple_alias x mem with + | Some lv -> + let v = Mem.find_heap lv mem in + let v' = Val.prune_comp comp v (eval e' mem) in + Mem.update_mem_in_prune prune_pairs lv v' mem + | None -> + mem ) + | Exp.BinOp (Binop.Eq, Exp.Var x, e') -> ( + match Mem.find_simple_alias x mem with + | Some lv -> + let v = Mem.find_heap lv mem in + let v' = Val.prune_eq v (eval e' mem) in + Mem.update_mem_in_prune prune_pairs lv v' mem + | None -> + mem ) + | Exp.BinOp (Binop.Ne, Exp.Var x, e') -> ( + match Mem.find_simple_alias x mem with + | Some lv -> + let v = Mem.find_heap lv mem in + let v' = Val.prune_ne v (eval e' mem) in + Mem.update_mem_in_prune prune_pairs lv v' mem + | None -> + mem ) + | _ -> + mem let prune_binop_right : PrunePairs.t ref -> Exp.t -> Mem.astate -> Mem.astate = - fun prune_pairs e mem -> - match e with - | Exp.BinOp ((Binop.Lt as c), e', Exp.Var x) - | Exp.BinOp ((Binop.Gt as c), e', Exp.Var x) - | Exp.BinOp ((Binop.Le as c), e', Exp.Var x) - | Exp.BinOp ((Binop.Ge as c), e', Exp.Var x) - | Exp.BinOp ((Binop.Eq as c), e', Exp.Var x) - | Exp.BinOp ((Binop.Ne as c), e', Exp.Var x) -> - prune_binop_left prune_pairs (Exp.BinOp (comp_rev c, Exp.Var x, e')) mem - | _ -> - mem + fun prune_pairs e mem -> + match e with + | Exp.BinOp ((Binop.Lt as c), e', Exp.Var x) + | Exp.BinOp ((Binop.Gt as c), e', Exp.Var x) + | Exp.BinOp ((Binop.Le as c), e', Exp.Var x) + | Exp.BinOp ((Binop.Ge as c), e', Exp.Var x) + | Exp.BinOp ((Binop.Eq as c), e', Exp.Var x) + | Exp.BinOp ((Binop.Ne as c), e', Exp.Var x) -> + prune_binop_left prune_pairs (Exp.BinOp (comp_rev c, Exp.Var x, e')) mem + | _ -> + mem let is_unreachable_constant : Exp.t -> Mem.astate -> bool = - fun e m -> Val.( <= ) ~lhs:(eval e m) ~rhs:(Val.of_int 0) + fun e m -> Val.( <= ) ~lhs:(eval e m) ~rhs:(Val.of_int 0) let prune_unreachable : Exp.t -> Mem.astate -> Mem.astate = - fun e mem -> if is_unreachable_constant e mem then Mem.bot else mem + fun e mem -> if is_unreachable_constant e mem then Mem.bot else mem let prune : Exp.t -> Mem.astate -> Mem.astate = - fun e mem -> - let prune_pairs = ref PrunePairs.empty in - let rec prune_helper e mem = - let mem = - mem |> prune_unreachable e |> prune_unop prune_pairs e |> prune_binop_left prune_pairs e - |> prune_binop_right prune_pairs e - in - match e with - | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i -> - prune_helper e mem - | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i -> - prune_helper (Exp.UnOp (Unop.LNot, e, None)) mem - | Exp.UnOp (Unop.Neg, Exp.Var x, _) -> - prune_helper (Exp.Var x) mem - | Exp.BinOp (Binop.LAnd, e1, e2) -> - mem |> prune_helper e1 |> prune_helper e2 - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) -> - mem |> prune_helper (Exp.UnOp (Unop.LNot, e1, t)) - |> prune_helper (Exp.UnOp (Unop.LNot, e2, t)) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Lt as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Gt as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Le as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ge as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Eq as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) -> - prune_helper (Exp.BinOp (comp_not c, e1, e2)) mem - | _ -> - mem + fun e mem -> + let prune_pairs = ref PrunePairs.empty in + let rec prune_helper e mem = + let mem = + mem |> prune_unreachable e |> prune_unop prune_pairs e |> prune_binop_left prune_pairs e + |> prune_binop_right prune_pairs e in - let mem = Mem.apply_latest_prune e mem in - let mem = prune_helper e mem in - Mem.set_prune_pairs !prune_pairs mem + match e with + | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i -> + prune_helper e mem + | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i -> + prune_helper (Exp.UnOp (Unop.LNot, e, None)) mem + | Exp.UnOp (Unop.Neg, Exp.Var x, _) -> + prune_helper (Exp.Var x) mem + | Exp.BinOp (Binop.LAnd, e1, e2) -> + mem |> prune_helper e1 |> prune_helper e2 + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) -> + mem |> prune_helper (Exp.UnOp (Unop.LNot, e1, t)) + |> prune_helper (Exp.UnOp (Unop.LNot, e2, t)) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Lt as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Gt as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Le as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ge as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Eq as c), e1, e2), _) + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) -> + prune_helper (Exp.BinOp (comp_not c, e1, e2)) mem + | _ -> + mem + in + let mem = Mem.apply_latest_prune e mem in + let mem = prune_helper e mem in + Mem.set_prune_pairs !prune_pairs mem let get_formals : Procdesc.t -> (Pvar.t * Typ.t) list = - fun pdesc -> - let proc_name = Procdesc.get_proc_name pdesc in - Procdesc.get_formals pdesc |> List.map ~f:(fun (name, typ) -> (Pvar.mk name proc_name, typ)) + fun pdesc -> + let proc_name = Procdesc.get_proc_name pdesc in + Procdesc.get_formals pdesc |> List.map ~f:(fun (name, typ) -> (Pvar.mk name proc_name, typ)) let get_matching_pairs : Tenv.t -> Val.t -> Val.t -> Typ.t -> Mem.astate -> Mem.astate -> callee_ret_alias:AliasTarget.t option -> (Itv.Bound.t * Itv.Bound.t bottom_lifted * TraceSet.t) list * AliasTarget.t option = - fun tenv formal actual typ caller_mem callee_mem ~callee_ret_alias -> - let get_itv v = Val.get_itv v in - let get_offset v = v |> Val.get_array_blk |> ArrayBlk.offsetof in - let get_size v = v |> Val.get_array_blk |> ArrayBlk.sizeof in - let get_field_name (fn, _, _) = fn in - let append_field v fn = PowLoc.append_field (Val.get_all_locs v) ~fn in - let deref_field v fn mem = Mem.find_heap_set (append_field v fn) mem in - let deref_ptr v mem = - let array_locs = Val.get_array_locs v in - let locs = if PowLoc.is_empty array_locs then Val.get_pow_loc v else array_locs in - Mem.find_heap_set locs mem - in - let ret_alias = ref None in - let add_ret_alias v1 v2 = - match callee_ret_alias with - | Some ret_loc -> - if PowLoc.is_singleton v1 && PowLoc.is_singleton v2 - && AliasTarget.use (PowLoc.min_elt v1) ret_loc - then ret_alias := Some (AliasTarget.replace (PowLoc.min_elt v2) ret_loc) - | None -> - () - in - let add_pair_itv itv1 itv2 traces l = - let open Itv in - if itv1 <> bot && itv1 <> top then - if Itv.eq itv2 bot then - (lb itv1, Bottom, TraceSet.empty) :: (ub itv1, Bottom, TraceSet.empty) :: l - else - (lb itv1, NonBottom (lb itv2), traces) :: (ub itv1, NonBottom (ub itv2), traces) :: l - else l - in - let add_pair_val v1 v2 pairs = - add_ret_alias (Val.get_all_locs v1) (Val.get_all_locs v2) ; - pairs |> add_pair_itv (get_itv v1) (get_itv v2) (Val.get_traces v2) - |> add_pair_itv (get_offset v1) (get_offset v2) (Val.get_traces v2) - |> add_pair_itv (get_size v1) (get_size v2) (Val.get_traces v2) - in - let add_pair_field v1 v2 pairs fn = - add_ret_alias (append_field v1 fn) (append_field v2 fn) ; - let v1' = deref_field v1 fn callee_mem in - let v2' = deref_field v2 fn caller_mem in - add_pair_val v1' v2' pairs - in - let add_pair_ptr typ v1 v2 pairs = - add_ret_alias (Val.get_all_locs v1) (Val.get_all_locs v2) ; - match typ.Typ.desc with - | Typ.Tptr ({desc= Tstruct typename}, _) -> ( - match Tenv.lookup tenv typename with - | Some str -> - let fns = List.map ~f:get_field_name str.Typ.Struct.fields in - List.fold ~f:(add_pair_field v1 v2) ~init:pairs fns - | _ -> - pairs ) - | Typ.Tptr (_, _) -> - let v1' = deref_ptr v1 callee_mem in - let v2' = deref_ptr v2 caller_mem in - add_pair_val v1' v2' pairs + fun tenv formal actual typ caller_mem callee_mem ~callee_ret_alias -> + let get_itv v = Val.get_itv v in + let get_offset v = v |> Val.get_array_blk |> ArrayBlk.offsetof in + let get_size v = v |> Val.get_array_blk |> ArrayBlk.sizeof in + let get_field_name (fn, _, _) = fn in + let append_field v fn = PowLoc.append_field (Val.get_all_locs v) ~fn in + let deref_field v fn mem = Mem.find_heap_set (append_field v fn) mem in + let deref_ptr v mem = + let array_locs = Val.get_array_locs v in + let locs = if PowLoc.is_empty array_locs then Val.get_pow_loc v else array_locs in + Mem.find_heap_set locs mem + in + let ret_alias = ref None in + let add_ret_alias v1 v2 = + match callee_ret_alias with + | Some ret_loc -> + if PowLoc.is_singleton v1 && PowLoc.is_singleton v2 + && AliasTarget.use (PowLoc.min_elt v1) ret_loc + then ret_alias := Some (AliasTarget.replace (PowLoc.min_elt v2) ret_loc) + | None -> + () + in + let add_pair_itv itv1 itv2 traces l = + let open Itv in + if itv1 <> bot && itv1 <> top then + if Itv.eq itv2 bot then + (lb itv1, Bottom, TraceSet.empty) :: (ub itv1, Bottom, TraceSet.empty) :: l + else (lb itv1, NonBottom (lb itv2), traces) :: (ub itv1, NonBottom (ub itv2), traces) :: l + else l + in + let add_pair_val v1 v2 pairs = + add_ret_alias (Val.get_all_locs v1) (Val.get_all_locs v2) ; + pairs |> add_pair_itv (get_itv v1) (get_itv v2) (Val.get_traces v2) + |> add_pair_itv (get_offset v1) (get_offset v2) (Val.get_traces v2) + |> add_pair_itv (get_size v1) (get_size v2) (Val.get_traces v2) + in + let add_pair_field v1 v2 pairs fn = + add_ret_alias (append_field v1 fn) (append_field v2 fn) ; + let v1' = deref_field v1 fn callee_mem in + let v2' = deref_field v2 fn caller_mem in + add_pair_val v1' v2' pairs + in + let add_pair_ptr typ v1 v2 pairs = + add_ret_alias (Val.get_all_locs v1) (Val.get_all_locs v2) ; + match typ.Typ.desc with + | Typ.Tptr ({desc= Tstruct typename}, _) -> ( + match Tenv.lookup tenv typename with + | Some str -> + let fns = List.map ~f:get_field_name str.Typ.Struct.fields in + List.fold ~f:(add_pair_field v1 v2) ~init:pairs fns | _ -> - pairs - in - let pairs = [] |> add_pair_val formal actual |> add_pair_ptr typ formal actual in - (pairs, !ret_alias) + pairs ) + | Typ.Tptr (_, _) -> + let v1' = deref_ptr v1 callee_mem in + let v2' = deref_ptr v2 caller_mem in + add_pair_val v1' v2' pairs + | _ -> + pairs + in + let pairs = [] |> add_pair_val formal actual |> add_pair_ptr typ formal actual in + (pairs, !ret_alias) let subst_map_of_pairs : (Itv.Bound.t * Itv.Bound.t bottom_lifted * TraceSet.t) list -> Itv.Bound.t bottom_lifted Itv.SubstMap.t * TraceSet.t Itv.SubstMap.t = - fun pairs -> - let add_pair (bound_map, trace_map) (formal, actual, traces) = - match formal with - | Itv.Bound.Linear (_, se1) when Itv.SymLinear.is_zero se1 -> - (bound_map, trace_map) - | Itv.Bound.Linear (0, se1) -> - let symbol = Itv.SymLinear.get_one_symbol se1 in - (Itv.SubstMap.add symbol actual bound_map, Itv.SubstMap.add symbol traces trace_map) - | Itv.Bound.MinMax (0, Itv.Bound.Plus, Itv.Bound.Max, 0, symbol) -> - (Itv.SubstMap.add symbol actual bound_map, Itv.SubstMap.add symbol traces trace_map) - | _ -> - assert false - in - List.fold ~f:add_pair ~init:(Itv.SubstMap.empty, Itv.SubstMap.empty) pairs + fun pairs -> + let add_pair (bound_map, trace_map) (formal, actual, traces) = + match formal with + | Itv.Bound.Linear (_, se1) when Itv.SymLinear.is_zero se1 -> + (bound_map, trace_map) + | Itv.Bound.Linear (0, se1) -> + let symbol = Itv.SymLinear.get_one_symbol se1 in + (Itv.SubstMap.add symbol actual bound_map, Itv.SubstMap.add symbol traces trace_map) + | Itv.Bound.MinMax (0, Itv.Bound.Plus, Itv.Bound.Max, 0, symbol) -> + (Itv.SubstMap.add symbol actual bound_map, Itv.SubstMap.add symbol traces trace_map) + | _ -> + assert false + in + List.fold ~f:add_pair ~init:(Itv.SubstMap.empty, Itv.SubstMap.empty) pairs let rec list_fold2_def : default:Val.t -> f:('a -> Val.t -> 'b -> 'b) -> 'a list -> Val.t list -> init:'b -> 'b = - fun ~default ~f xs ys ~init:acc -> - match (xs, ys) with - | [], _ -> - acc - | x :: xs', [] -> - list_fold2_def ~default ~f xs' ys ~init:(f x default acc) - | [x], _ :: _ -> - f x (List.fold ~f:Val.join ~init:Val.bot ys) acc - | x :: xs', y :: ys' -> - list_fold2_def ~default ~f xs' ys' ~init:(f x y acc) + fun ~default ~f xs ys ~init:acc -> + match (xs, ys) with + | [], _ -> + acc + | x :: xs', [] -> + list_fold2_def ~default ~f xs' ys ~init:(f x default acc) + | [x], _ :: _ -> + f x (List.fold ~f:Val.join ~init:Val.bot ys) acc + | x :: xs', y :: ys' -> + list_fold2_def ~default ~f xs' ys' ~init:(f x y acc) let get_subst_map @@ -563,18 +562,18 @@ module Make (CFG : ProcCfg.S) = struct -> callee_ret_alias:AliasTarget.t option -> (Itv.Bound.t bottom_lifted Itv.SubstMap.t * TraceSet.t Itv.SubstMap.t) * AliasTarget.t option = - fun tenv callee_pdesc params caller_mem callee_entry_mem ~callee_ret_alias -> - let add_pair (formal, typ) actual (l, ret_alias) = - let formal = Mem.find_heap (Loc.of_pvar formal) callee_entry_mem in - let new_matching, ret_alias' = - get_matching_pairs tenv formal actual typ caller_mem callee_entry_mem ~callee_ret_alias - in - (List.rev_append new_matching l, Option.first_some ret_alias ret_alias') - in - let formals = get_formals callee_pdesc in - let actuals = List.map ~f:(fun (a, _) -> eval a caller_mem) params in - let pairs, ret_alias = - list_fold2_def ~default:Val.Itv.top ~f:add_pair formals actuals ~init:([], None) + fun tenv callee_pdesc params caller_mem callee_entry_mem ~callee_ret_alias -> + let add_pair (formal, typ) actual (l, ret_alias) = + let formal = Mem.find_heap (Loc.of_pvar formal) callee_entry_mem in + let new_matching, ret_alias' = + get_matching_pairs tenv formal actual typ caller_mem callee_entry_mem ~callee_ret_alias in - (subst_map_of_pairs pairs, ret_alias) + (List.rev_append new_matching l, Option.first_some ret_alias ret_alias') + in + let formals = get_formals callee_pdesc in + let actuals = List.map ~f:(fun (a, _) -> eval a caller_mem) params in + let pairs, ret_alias = + list_fold2_def ~default:Val.Itv.top ~f:add_pair formals actuals ~init:([], None) + in + (subst_map_of_pairs pairs, ret_alias) end diff --git a/infer/src/bufferoverrun/bufferOverrunTrace.ml b/infer/src/bufferoverrun/bufferOverrunTrace.ml index 0b626cbe8..39778e733 100644 --- a/infer/src/bufferoverrun/bufferOverrunTrace.ml +++ b/infer/src/bufferoverrun/bufferOverrunTrace.ml @@ -31,26 +31,26 @@ module BoTrace = struct let append x y = {length= x.length + y.length; trace= x.trace @ y.trace} let pp_elem : F.formatter -> elem -> unit = - fun fmt elem -> - match elem with - | Assign location -> - F.fprintf fmt "Assign (%a)" Location.pp_file_pos location - | ArrDecl location -> - F.fprintf fmt "ArrDecl (%a)" Location.pp_file_pos location - | Call location -> - F.fprintf fmt "Call (%a)" Location.pp_file_pos location - | Return location -> - F.fprintf fmt "Return (%a)" Location.pp_file_pos location - | SymAssign location -> - F.fprintf fmt "SymAssign (%a)" Location.pp_file_pos location - | ArrAccess location -> - F.fprintf fmt "ArrAccess (%a)" Location.pp_file_pos location + fun fmt elem -> + match elem with + | Assign location -> + F.fprintf fmt "Assign (%a)" Location.pp_file_pos location + | ArrDecl location -> + F.fprintf fmt "ArrDecl (%a)" Location.pp_file_pos location + | Call location -> + F.fprintf fmt "Call (%a)" Location.pp_file_pos location + | Return location -> + F.fprintf fmt "Return (%a)" Location.pp_file_pos location + | SymAssign location -> + F.fprintf fmt "SymAssign (%a)" Location.pp_file_pos location + | ArrAccess location -> + F.fprintf fmt "ArrAccess (%a)" Location.pp_file_pos location let pp : F.formatter -> t -> unit = - fun fmt t -> - let pp_sep fmt () = F.fprintf fmt " :: " in - F.pp_print_list ~pp_sep pp_elem fmt t.trace + fun fmt t -> + let pp_sep fmt () = F.fprintf fmt " :: " in + F.pp_print_list ~pp_sep pp_elem fmt t.trace end module Set = struct diff --git a/infer/src/bufferoverrun/bufferOverrunUtils.ml b/infer/src/bufferoverrun/bufferOverrunUtils.ml index 0d9493421..197c79fd1 100644 --- a/infer/src/bufferoverrun/bufferOverrunUtils.ml +++ b/infer/src/bufferoverrun/bufferOverrunUtils.ml @@ -89,21 +89,21 @@ module Make (CFG : ProcCfg.S) = struct : decl_local:decl_local -> Typ.Procname.t -> CFG.node -> Location.t -> Loc.t -> Typ.t -> length:IntLit.t option -> ?stride:int -> inst_num:int -> dimension:int -> Dom.Mem.astate -> Dom.Mem.astate * int = - fun ~decl_local pname node location loc typ ~length ?stride ~inst_num ~dimension mem -> - let size = Option.value_map ~default:Itv.top ~f:Itv.of_int_lit length in - let arr = - Sem.eval_array_alloc pname node typ Itv.zero size ?stride inst_num dimension - |> Dom.Val.add_trace_elem (Trace.ArrDecl location) - in - let mem = - if Int.equal dimension 1 then Dom.Mem.add_stack loc arr mem - else Dom.Mem.add_heap loc arr mem - in - let loc = Loc.of_allocsite (Sem.get_allocsite pname node inst_num dimension) in - let mem, _ = - decl_local pname node location loc typ ~inst_num ~dimension:(dimension + 1) mem - in - (mem, inst_num + 1) + fun ~decl_local pname node location loc typ ~length ?stride ~inst_num ~dimension mem -> + let size = Option.value_map ~default:Itv.top ~f:Itv.of_int_lit length in + let arr = + Sem.eval_array_alloc pname node typ Itv.zero size ?stride inst_num dimension + |> Dom.Val.add_trace_elem (Trace.ArrDecl location) + in + let mem = + if Int.equal dimension 1 then Dom.Mem.add_stack loc arr mem + else Dom.Mem.add_heap loc arr mem + in + let loc = Loc.of_allocsite (Sem.get_allocsite pname node inst_num dimension) in + let mem, _ = + decl_local pname node location loc typ ~inst_num ~dimension:(dimension + 1) mem + in + (mem, inst_num + 1) type decl_sym_val = @@ -114,21 +114,21 @@ module Make (CFG : ProcCfg.S) = struct : decl_sym_val:decl_sym_val -> Typ.Procname.t -> Tenv.t -> CFG.node -> Location.t -> depth:int -> Loc.t -> Typ.t -> ?offset:Itv.t -> ?size:Itv.t -> inst_num:int -> new_sym_num:counter -> new_alloc_num:counter -> Dom.Mem.astate -> Dom.Mem.astate = - fun ~decl_sym_val pname tenv node location ~depth loc typ ?offset ?size ~inst_num - ~new_sym_num ~new_alloc_num mem -> - let option_value opt_x default_f = match opt_x with Some x -> x | None -> default_f () in - let itv_make_sym () = Itv.make_sym pname new_sym_num in - let offset = option_value offset itv_make_sym in - let size = option_value size itv_make_sym in - let alloc_num = new_alloc_num () in - let elem = Trace.SymAssign location in - let arr = - Sem.eval_array_alloc pname node typ offset size inst_num alloc_num - |> Dom.Val.add_trace_elem elem - in - let mem = Dom.Mem.add_heap loc arr mem in - let deref_loc = Loc.of_allocsite (Sem.get_allocsite pname node inst_num alloc_num) in - decl_sym_val pname tenv node location ~depth deref_loc typ mem + fun ~decl_sym_val pname tenv node location ~depth loc typ ?offset ?size ~inst_num ~new_sym_num + ~new_alloc_num mem -> + let option_value opt_x default_f = match opt_x with Some x -> x | None -> default_f () in + let itv_make_sym () = Itv.make_sym pname new_sym_num in + let offset = option_value offset itv_make_sym in + let size = option_value size itv_make_sym in + let alloc_num = new_alloc_num () in + let elem = Trace.SymAssign location in + let arr = + Sem.eval_array_alloc pname node typ offset size inst_num alloc_num + |> Dom.Val.add_trace_elem elem + in + let mem = Dom.Mem.add_heap loc arr mem in + let deref_loc = Loc.of_allocsite (Sem.get_allocsite pname node inst_num alloc_num) in + decl_sym_val pname tenv node location ~depth deref_loc typ mem let init_array_fields tenv pname node typ locs ?dyn_length mem = diff --git a/infer/src/bufferoverrun/itv.ml b/infer/src/bufferoverrun/itv.ml index 5ad84a87e..98d5e721c 100644 --- a/infer/src/bufferoverrun/itv.ml +++ b/infer/src/bufferoverrun/itv.ml @@ -23,14 +23,14 @@ module Symbol = struct let equal = [%compare.equal : t] let make : unsigned:bool -> Typ.Procname.t -> int -> t = - fun ~unsigned pname id -> {pname; id; unsigned} + fun ~unsigned pname id -> {pname; id; unsigned} let pp : F.formatter -> t -> unit = - fun fmt {pname; id; unsigned} -> - let symbol_name = if unsigned then "u" else "s" in - if Config.bo_debug <= 1 then F.fprintf fmt "%s$%d" symbol_name id - else F.fprintf fmt "%s-%s$%d" (Typ.Procname.to_string pname) symbol_name id + fun fmt {pname; id; unsigned} -> + let symbol_name = if unsigned then "u" else "s" in + if Config.bo_debug <= 1 then F.fprintf fmt "%s$%d" symbol_name id + else F.fprintf fmt "%s-%s$%d" (Typ.Procname.to_string pname) symbol_name id let is_unsigned : t -> bool = fun x -> x.unsigned @@ -99,18 +99,18 @@ module SymLinear = struct include Caml.Map.Make (Symbol) let for_all2 : (key -> 'a option -> 'b option -> bool) -> 'a t -> 'b t -> bool = - fun cond x y -> - let merge_function k x y = if cond k x y then None else raise Exit in - match merge merge_function x y with _ -> true | exception Exit -> false + fun cond x y -> + let merge_function k x y = if cond k x y then None else raise Exit in + match merge merge_function x y with _ -> true | exception Exit -> false let is_singleton : 'a t -> (key * 'a) option = - fun m -> - if is_empty m then None - else - let (kmin, _) as binding = min_binding m in - let kmax, _ = max_binding m in - if Symbol.equal kmin kmax then Some binding else None + fun m -> + if is_empty m then None + else + let (kmin, _) as binding = min_binding m in + let kmax, _ = max_binding m in + if Symbol.equal kmin kmax then Some binding else None end (** @@ -134,46 +134,46 @@ module SymLinear = struct let use_symbol : Symbol.t -> t -> bool = fun s x -> M.mem s x let is_le_zero : t -> bool = - fun x -> M.for_all (fun s v -> Symbol.is_unsigned s && NonZeroInt.is_negative v) x + fun x -> M.for_all (fun s v -> Symbol.is_unsigned s && NonZeroInt.is_negative v) x let is_ge_zero : t -> bool = - fun x -> M.for_all (fun s v -> Symbol.is_unsigned s && NonZeroInt.is_positive v) x + fun x -> M.for_all (fun s v -> Symbol.is_unsigned s && NonZeroInt.is_positive v) x let le : t -> t -> bool = - fun x y -> - let le_one_pair s (v1_opt: NonZeroInt.t option) (v2_opt: NonZeroInt.t option) = - let v1 = Option.value (v1_opt :> int option) ~default:0 in - let v2 = Option.value (v2_opt :> int option) ~default:0 in - Int.equal v1 v2 || Symbol.is_unsigned s && v1 <= v2 - in - M.for_all2 le_one_pair x y + fun x y -> + let le_one_pair s (v1_opt: NonZeroInt.t option) (v2_opt: NonZeroInt.t option) = + let v1 = Option.value (v1_opt :> int option) ~default:0 in + let v2 = Option.value (v2_opt :> int option) ~default:0 in + Int.equal v1 v2 || Symbol.is_unsigned s && v1 <= v2 + in + M.for_all2 le_one_pair x y let make : unsigned:bool -> Typ.Procname.t -> int -> t = - fun ~unsigned pname i -> singleton_one (Symbol.make ~unsigned pname i) + fun ~unsigned pname i -> singleton_one (Symbol.make ~unsigned pname i) let eq : t -> t -> bool = - fun x y -> - let eq_pair _ (coeff1: NonZeroInt.t option) (coeff2: NonZeroInt.t option) = - [%compare.equal : int option] (coeff1 :> int option) (coeff2 :> int option) - in - M.for_all2 eq_pair x y + fun x y -> + let eq_pair _ (coeff1: NonZeroInt.t option) (coeff2: NonZeroInt.t option) = + [%compare.equal : int option] (coeff1 :> int option) (coeff2 :> int option) + in + M.for_all2 eq_pair x y let pp1 : F.formatter -> Symbol.t * NonZeroInt.t -> unit = - fun fmt (s, c) -> - let c = (c :> int) in - if Int.equal c 1 then F.fprintf fmt "%a" Symbol.pp s - else if c < 0 then F.fprintf fmt "(%d)x%a" c Symbol.pp s - else F.fprintf fmt "%dx%a" c Symbol.pp s + fun fmt (s, c) -> + let c = (c :> int) in + if Int.equal c 1 then F.fprintf fmt "%a" Symbol.pp s + else if c < 0 then F.fprintf fmt "(%d)x%a" c Symbol.pp s + else F.fprintf fmt "%dx%a" c Symbol.pp s let pp : F.formatter -> t -> unit = - fun fmt x -> - if M.is_empty x then F.fprintf fmt "empty" else Pp.seq ~sep:" + " pp1 fmt (M.bindings x) + fun fmt x -> + if M.is_empty x then F.fprintf fmt "empty" else Pp.seq ~sep:" + " pp1 fmt (M.bindings x) let zero : t = M.empty @@ -183,51 +183,51 @@ module SymLinear = struct let neg : t -> t = fun x -> M.map NonZeroInt.( ~- ) x let plus : t -> t -> t = - fun x y -> - let plus' _ (n_opt: NonZeroInt.t option) (m_opt: NonZeroInt.t option) = - match (n_opt, m_opt) with - | None, None -> - None - | (Some _ as some_v), None | None, (Some _ as some_v) -> - some_v - | Some n, Some m -> - NonZeroInt.of_int ((n :> int) + (m :> int)) - in - M.merge plus' x y + fun x y -> + let plus' _ (n_opt: NonZeroInt.t option) (m_opt: NonZeroInt.t option) = + match (n_opt, m_opt) with + | None, None -> + None + | (Some _ as some_v), None | None, (Some _ as some_v) -> + some_v + | Some n, Some m -> + NonZeroInt.of_int ((n :> int) + (m :> int)) + in + M.merge plus' x y (** [se1] * [c] + [se2] *) let mult_const_plus : t -> NonZeroInt.t -> t -> t = - fun se1 c se2 -> - let f _ (coeff1: NonZeroInt.t option) (coeff2: NonZeroInt.t option) = - match (coeff1, coeff2) with - | None, None -> - None - | None, (Some _ as some_v) -> - some_v - | Some v, None -> - Some (NonZeroInt.( * ) v c) - | Some v1, Some v2 -> - NonZeroInt.of_int ((v1 :> int) * (c :> int) + (v2 :> int)) - in - M.merge f se1 se2 + fun se1 c se2 -> + let f _ (coeff1: NonZeroInt.t option) (coeff2: NonZeroInt.t option) = + match (coeff1, coeff2) with + | None, None -> + None + | None, (Some _ as some_v) -> + some_v + | Some v, None -> + Some (NonZeroInt.( * ) v c) + | Some v1, Some v2 -> + NonZeroInt.of_int ((v1 :> int) * (c :> int) + (v2 :> int)) + in + M.merge f se1 se2 let mult_const : t -> NonZeroInt.t -> t = fun x n -> M.map (NonZeroInt.( * ) n) x let exact_div_const_exn : t -> NonZeroInt.t -> t = - fun x n -> M.map (fun c -> NonZeroInt.exact_div_exn c n) x + fun x n -> M.map (fun c -> NonZeroInt.exact_div_exn c n) x (* Returns a symbol when the map contains only one symbol s with a given coefficient. *) let one_symbol_of_coeff : NonZeroInt.t -> t -> Symbol.t option = - fun coeff x -> - match M.is_singleton x with - | Some (k, v) when Int.equal (v :> int) (coeff :> int) -> - Some k - | _ -> - None + fun coeff x -> + match M.is_singleton x with + | Some (k, v) when Int.equal (v :> int) (coeff :> int) -> + Some k + | _ -> + None let get_one_symbol_opt : t -> Symbol.t option = one_symbol_of_coeff NonZeroInt.one @@ -235,23 +235,23 @@ module SymLinear = struct let get_mone_symbol_opt : t -> Symbol.t option = one_symbol_of_coeff NonZeroInt.minus_one let get_one_symbol : t -> Symbol.t = - fun x -> match get_one_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + fun x -> match get_one_symbol_opt x with Some s -> s | None -> raise Not_one_symbol let get_mone_symbol : t -> Symbol.t = - fun x -> match get_mone_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + fun x -> match get_mone_symbol_opt x with Some s -> s | None -> raise Not_one_symbol let is_one_symbol : t -> bool = - fun x -> match get_one_symbol_opt x with Some _ -> true | None -> false + fun x -> match get_one_symbol_opt x with Some _ -> true | None -> false let is_mone_symbol : t -> bool = - fun x -> match get_mone_symbol_opt x with Some _ -> true | None -> false + fun x -> match get_mone_symbol_opt x with Some _ -> true | None -> false let get_symbols : t -> Symbol.t list = - fun x -> M.fold (fun symbol _coeff acc -> symbol :: acc) x [] + fun x -> M.fold (fun symbol _coeff acc -> symbol :: acc) x [] end module Bound = struct @@ -267,8 +267,7 @@ module Bound = struct let eval_int x i1 i2 = match x with Plus -> i1 + i2 | Minus -> i1 - i2 let pp ~need_plus : F.formatter -> t -> unit = - fun fmt -> - function Plus -> if need_plus then F.fprintf fmt "+" | Minus -> F.fprintf fmt "-" + fun fmt -> function Plus -> if need_plus then F.fprintf fmt "+" | Minus -> F.fprintf fmt "-" end type min_max = Min | Max [@@deriving compare] @@ -283,7 +282,7 @@ module Bound = struct let eval_int x i1 i2 = match x with Min -> min i1 i2 | Max -> max i1 i2 let pp : F.formatter -> t -> unit = - fun fmt -> function Min -> F.fprintf fmt "min" | Max -> F.fprintf fmt "max" + fun fmt -> function Min -> F.fprintf fmt "min" | Max -> F.fprintf fmt "max" end (* MinMax constructs a bound that is in the "int [+|-] [min|max](int, symbol)" format. @@ -298,20 +297,19 @@ module Bound = struct let equal = [%compare.equal : t] let pp : F.formatter -> t -> unit = - fun fmt -> - function - | MInf -> - F.fprintf fmt "-oo" - | PInf -> - F.fprintf fmt "+oo" - | Linear (c, x) -> - if SymLinear.is_zero x then F.fprintf fmt "%d" c - else if Int.equal c 0 then F.fprintf fmt "%a" SymLinear.pp x - else F.fprintf fmt "%a + %d" SymLinear.pp x c - | MinMax (c, sign, m, d, x) -> - if Int.equal c 0 then F.fprintf fmt "%a" (Sign.pp ~need_plus:false) sign - else F.fprintf fmt "%d%a" c (Sign.pp ~need_plus:true) sign ; - F.fprintf fmt "%a(%d, %a)" MinMax.pp m d Symbol.pp x + fun fmt -> function + | MInf -> + F.fprintf fmt "-oo" + | PInf -> + F.fprintf fmt "+oo" + | Linear (c, x) -> + if SymLinear.is_zero x then F.fprintf fmt "%d" c + else if Int.equal c 0 then F.fprintf fmt "%a" SymLinear.pp x + else F.fprintf fmt "%a + %d" SymLinear.pp x c + | MinMax (c, sign, m, d, x) -> + if Int.equal c 0 then F.fprintf fmt "%a" (Sign.pp ~need_plus:false) sign + else F.fprintf fmt "%d%a" c (Sign.pp ~need_plus:true) sign ; + F.fprintf fmt "%a(%d, %a)" MinMax.pp m d Symbol.pp x let of_int : int -> t = fun n -> Linear (n, SymLinear.empty) @@ -332,16 +330,15 @@ module Bound = struct let eq_symbol : Symbol.t -> t -> bool = - fun s -> - function - | Linear (0, se) -> ( - match SymLinear.get_one_symbol_opt se with None -> false | Some s' -> Symbol.equal s s' ) - | _ -> - false + fun s -> function + | Linear (0, se) -> ( + match SymLinear.get_one_symbol_opt se with None -> false | Some s' -> Symbol.equal s s' ) + | _ -> + false let lift_symlinear : (SymLinear.t -> 'a option) -> t -> 'a option = - fun f -> function Linear (0, se) -> f se | _ -> None + fun f -> function Linear (0, se) -> f se | _ -> None let get_one_symbol_opt : t -> Symbol.t option = lift_symlinear SymLinear.get_one_symbol_opt @@ -349,11 +346,11 @@ module Bound = struct let get_mone_symbol_opt : t -> Symbol.t option = lift_symlinear SymLinear.get_mone_symbol_opt let get_one_symbol : t -> Symbol.t = - fun x -> match get_one_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + fun x -> match get_one_symbol_opt x with Some s -> s | None -> raise Not_one_symbol let get_mone_symbol : t -> Symbol.t = - fun x -> match get_mone_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + fun x -> match get_mone_symbol_opt x with Some s -> s | None -> raise Not_one_symbol let is_one_symbol : t -> bool = fun x -> get_one_symbol_opt x <> None @@ -377,14 +374,13 @@ module Bound = struct let use_symbol : Symbol.t -> t -> bool = - fun s -> - function - | PInf | MInf -> - false - | Linear (_, se) -> - SymLinear.use_symbol s se - | MinMax (_, _, _, _, s') -> - Symbol.equal s s' + fun s -> function + | PInf | MInf -> + false + | Linear (_, se) -> + SymLinear.use_symbol s se + | MinMax (_, _, _, _, s') -> + Symbol.equal s s' type subst_pos_t = SubstLowerBound | SubstUpperBound @@ -531,43 +527,43 @@ module Bound = struct let le_opt2 le n opt_m = Option.value_map opt_m ~default:false ~f:(fun m -> le n m) let rec le : t -> t -> bool = - fun x y -> - match (x, y) with - | MInf, _ | _, PInf -> - true - | _, MInf | PInf, _ -> - false - | Linear (c0, x0), Linear (c1, x1) -> - c0 <= c1 && SymLinear.le x0 x1 - | MinMax (c1, sign1, m1, d1, x1), MinMax (c2, sign2, m2, d2, x2) - when Sign.equal sign1 sign2 && MinMax.equal m1 m2 -> - c1 <= c2 && Int.equal d1 d2 && Symbol.equal x1 x2 - | MinMax _, MinMax _ when le_minmax_by_int x y -> - true - | MinMax (c1, Plus, Min, _, x1), MinMax (c2, Plus, Max, _, x2) - | MinMax (c1, Minus, Max, _, x1), MinMax (c2, Minus, Min, _, x2) -> - c1 <= c2 && Symbol.equal x1 x2 - | MinMax _, Linear (c, se) -> - SymLinear.is_ge_zero se && le_opt1 Int.( <= ) (int_ub_of_minmax x) c - || le_opt1 le (linear_ub_of_minmax x) y - | Linear (c, se), MinMax _ -> - SymLinear.is_le_zero se && le_opt2 Int.( <= ) c (int_lb_of_minmax y) - || le_opt2 le x (linear_lb_of_minmax y) - | _, _ -> - false + fun x y -> + match (x, y) with + | MInf, _ | _, PInf -> + true + | _, MInf | PInf, _ -> + false + | Linear (c0, x0), Linear (c1, x1) -> + c0 <= c1 && SymLinear.le x0 x1 + | MinMax (c1, sign1, m1, d1, x1), MinMax (c2, sign2, m2, d2, x2) + when Sign.equal sign1 sign2 && MinMax.equal m1 m2 -> + c1 <= c2 && Int.equal d1 d2 && Symbol.equal x1 x2 + | MinMax _, MinMax _ when le_minmax_by_int x y -> + true + | MinMax (c1, Plus, Min, _, x1), MinMax (c2, Plus, Max, _, x2) + | MinMax (c1, Minus, Max, _, x1), MinMax (c2, Minus, Min, _, x2) -> + c1 <= c2 && Symbol.equal x1 x2 + | MinMax _, Linear (c, se) -> + SymLinear.is_ge_zero se && le_opt1 Int.( <= ) (int_ub_of_minmax x) c + || le_opt1 le (linear_ub_of_minmax x) y + | Linear (c, se), MinMax _ -> + SymLinear.is_le_zero se && le_opt2 Int.( <= ) c (int_lb_of_minmax y) + || le_opt2 le x (linear_lb_of_minmax y) + | _, _ -> + false let lt : t -> t -> bool = - fun x y -> - match (x, y) with - | MInf, Linear _ | MInf, MinMax _ | MInf, PInf | Linear _, PInf | MinMax _, PInf -> - true - | Linear (c, x), _ -> - le (Linear (c + 1, x)) y - | MinMax (c, sign, min_max, d, x), _ -> - le (mk_MinMax (c + 1, sign, min_max, d, x)) y - | _, _ -> - false + fun x y -> + match (x, y) with + | MInf, Linear _ | MInf, MinMax _ | MInf, PInf | Linear _, PInf | MinMax _, PInf -> + true + | Linear (c, x), _ -> + le (Linear (c + 1, x)) y + | MinMax (c, sign, min_max, d, x), _ -> + le (mk_MinMax (c + 1, sign, min_max, d, x)) y + | _, _ -> + false let gt : t -> t -> bool = fun x y -> lt y x @@ -589,92 +585,92 @@ module Bound = struct let remove_max_int : t -> t = - fun x -> - match x with - | MinMax (c, Plus, Max, _, s) -> - Linear (c, SymLinear.singleton_one s) - | MinMax (c, Minus, Min, _, s) -> - Linear (c, SymLinear.singleton_minus_one s) - | _ -> - x + fun x -> + match x with + | MinMax (c, Plus, Max, _, s) -> + Linear (c, SymLinear.singleton_one s) + | MinMax (c, Minus, Min, _, s) -> + Linear (c, SymLinear.singleton_minus_one s) + | _ -> + x let rec lb : ?default:t -> t -> t -> t = - fun ?(default= MInf) x y -> - if le x y then x - else if le y x then y - else - match (x, y) with - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 -> - mk_MinMax (c2, Plus, Min, c1 - c2, SymLinear.get_one_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> - mk_MinMax (c1, Plus, Min, c2 - c1, SymLinear.get_one_symbol x1) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> - mk_MinMax (c2, Minus, Max, c2 - c1, SymLinear.get_mone_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> - mk_MinMax (c1, Minus, Max, c1 - c2, SymLinear.get_mone_symbol x1) - | MinMax (c1, Plus, Min, d1, s), Linear (c2, se) - | Linear (c2, se), MinMax (c1, Plus, Min, d1, s) - when SymLinear.is_zero se -> - mk_MinMax (c1, Plus, Min, min d1 (c2 - c1), s) - | MinMax (c1, Plus, Max, _, s), Linear (c2, se) - | Linear (c2, se), MinMax (c1, Plus, Max, _, s) - when SymLinear.is_zero se -> - mk_MinMax (c1, Plus, Min, c2 - c1, s) - | MinMax (c1, Minus, Min, _, s), Linear (c2, se) - | Linear (c2, se), MinMax (c1, Minus, Min, _, s) - when SymLinear.is_zero se -> - mk_MinMax (c1, Minus, Max, c1 - c2, s) - | MinMax (c1, Minus, Max, d1, s), Linear (c2, se) - | Linear (c2, se), MinMax (c1, Minus, Max, d1, s) - when SymLinear.is_zero se -> - mk_MinMax (c1, Minus, Max, max d1 (c1 - c2), s) - | MinMax (_, Plus, Min, _, _), MinMax (_, Plus, Max, _, _) - | MinMax (_, Plus, Min, _, _), MinMax (_, Minus, Min, _, _) - | MinMax (_, Minus, Max, _, _), MinMax (_, Plus, Max, _, _) - | MinMax (_, Minus, Max, _, _), MinMax (_, Minus, Min, _, _) -> - lb ~default x (remove_max_int y) - | MinMax (_, Plus, Max, _, _), MinMax (_, Plus, Min, _, _) - | MinMax (_, Minus, Min, _, _), MinMax (_, Plus, Min, _, _) - | MinMax (_, Plus, Max, _, _), MinMax (_, Minus, Max, _, _) - | MinMax (_, Minus, Min, _, _), MinMax (_, Minus, Max, _, _) -> - lb ~default (remove_max_int x) y - | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Plus, Max, d2, _) -> - Linear (min (c1 + d1) (c2 + d2), SymLinear.zero) - | _, _ -> - default + fun ?(default= MInf) x y -> + if le x y then x + else if le y x then y + else + match (x, y) with + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 -> + mk_MinMax (c2, Plus, Min, c1 - c2, SymLinear.get_one_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Plus, Min, c2 - c1, SymLinear.get_one_symbol x1) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> + mk_MinMax (c2, Minus, Max, c2 - c1, SymLinear.get_mone_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Minus, Max, c1 - c2, SymLinear.get_mone_symbol x1) + | MinMax (c1, Plus, Min, d1, s), Linear (c2, se) + | Linear (c2, se), MinMax (c1, Plus, Min, d1, s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Plus, Min, min d1 (c2 - c1), s) + | MinMax (c1, Plus, Max, _, s), Linear (c2, se) + | Linear (c2, se), MinMax (c1, Plus, Max, _, s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Plus, Min, c2 - c1, s) + | MinMax (c1, Minus, Min, _, s), Linear (c2, se) + | Linear (c2, se), MinMax (c1, Minus, Min, _, s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Minus, Max, c1 - c2, s) + | MinMax (c1, Minus, Max, d1, s), Linear (c2, se) + | Linear (c2, se), MinMax (c1, Minus, Max, d1, s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Minus, Max, max d1 (c1 - c2), s) + | MinMax (_, Plus, Min, _, _), MinMax (_, Plus, Max, _, _) + | MinMax (_, Plus, Min, _, _), MinMax (_, Minus, Min, _, _) + | MinMax (_, Minus, Max, _, _), MinMax (_, Plus, Max, _, _) + | MinMax (_, Minus, Max, _, _), MinMax (_, Minus, Min, _, _) -> + lb ~default x (remove_max_int y) + | MinMax (_, Plus, Max, _, _), MinMax (_, Plus, Min, _, _) + | MinMax (_, Minus, Min, _, _), MinMax (_, Plus, Min, _, _) + | MinMax (_, Plus, Max, _, _), MinMax (_, Minus, Max, _, _) + | MinMax (_, Minus, Min, _, _), MinMax (_, Minus, Max, _, _) -> + lb ~default (remove_max_int x) y + | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Plus, Max, d2, _) -> + Linear (min (c1 + d1) (c2 + d2), SymLinear.zero) + | _, _ -> + default let ub : ?default:t -> t -> t -> t = - fun ?(default= PInf) x y -> - if le x y then y - else if le y x then x - else - match (x, y) with - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 -> - mk_MinMax (c2, Plus, Max, c1 - c2, SymLinear.get_one_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> - mk_MinMax (c1, Plus, Max, c2 - c1, SymLinear.get_one_symbol x1) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> - mk_MinMax (c2, Minus, Min, c2 - c1, SymLinear.get_mone_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> - mk_MinMax (c1, Minus, Min, c1 - c2, SymLinear.get_mone_symbol x1) - | _, _ -> - default + fun ?(default= PInf) x y -> + if le x y then y + else if le y x then x + else + match (x, y) with + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 -> + mk_MinMax (c2, Plus, Max, c1 - c2, SymLinear.get_one_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Plus, Max, c2 - c1, SymLinear.get_one_symbol x1) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> + mk_MinMax (c2, Minus, Min, c2 - c1, SymLinear.get_mone_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Minus, Min, c1 - c2, SymLinear.get_mone_symbol x1) + | _, _ -> + default let widen_l : t -> t -> t = - fun x y -> - if equal x PInf || equal y PInf then L.(die InternalError) "Lower bound cannot be +oo." - else if le x y then x - else MInf + fun x y -> + if equal x PInf || equal y PInf then L.(die InternalError) "Lower bound cannot be +oo." + else if le x y then x + else MInf let widen_u : t -> t -> t = - fun x y -> - if equal x MInf || equal y MInf then L.(die InternalError) "Upper bound cannot be -oo." - else if le y x then x - else PInf + fun x y -> + if equal x MInf || equal y MInf then L.(die InternalError) "Upper bound cannot be -oo." + else if le y x then x + else PInf let zero : t = Linear (0, SymLinear.zero) @@ -684,7 +680,7 @@ module Bound = struct let mone : t = Linear (-1, SymLinear.zero) let is_some_const : int -> t -> bool = - fun c x -> match x with Linear (c', y) -> Int.equal c c' && SymLinear.is_zero y | _ -> false + fun c x -> match x with Linear (c', y) -> Int.equal c c' && SymLinear.is_zero y | _ -> false let is_zero : t -> bool = is_some_const 0 @@ -692,23 +688,23 @@ module Bound = struct let is_one : t -> bool = is_some_const 1 let is_const : t -> int option = - fun x -> match x with Linear (c, y) when SymLinear.is_zero y -> Some c | _ -> None + fun x -> match x with Linear (c, y) when SymLinear.is_zero y -> Some c | _ -> None (* substitution symbols in ``x'' with respect to ``map'' *) let subst : subst_pos:subst_pos_t -> t -> t bottom_lifted SubstMap.t -> t bottom_lifted = - fun ~subst_pos x map -> - let subst_helper s y x = - let y' = - match y with - | Bottom -> - Bottom - | NonBottom r -> - NonBottom (if Symbol.is_unsigned s then ub ~default:r zero r else r) - in - subst1 ~subst_pos x s y' + fun ~subst_pos x map -> + let subst_helper s y x = + let y' = + match y with + | Bottom -> + Bottom + | NonBottom r -> + NonBottom (if Symbol.is_unsigned s then ub ~default:r zero r else r) in - SubstMap.fold subst_helper map (NonBottom x) + subst1 ~subst_pos x s y' + in + SubstMap.fold subst_helper map (NonBottom x) let subst_lb x map = subst ~subst_pos:SubstLowerBound x map @@ -716,79 +712,79 @@ module Bound = struct let subst_ub x map = subst ~subst_pos:SubstUpperBound x map let plus_l : t -> t -> t = - fun x y -> - match (x, y) with - | _, _ when is_zero x -> - y - | _, _ when is_zero y -> - x - | Linear (c1, x1), Linear (c2, x2) -> - Linear (c1 + c2, SymLinear.plus x1 x2) - | MinMax (c1, sign, min_max, d1, x1), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, sign, min_max, d1, x1) - when SymLinear.is_zero x2 -> - mk_MinMax (c1 + c2, sign, min_max, d1, x1) - | MinMax (c1, Plus, Max, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Plus, Max, d1, _) -> - Linear (c1 + d1 + c2, x2) - | MinMax (c1, Minus, Min, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Minus, Min, d1, _) -> - Linear (c1 - d1 + c2, x2) - | _, _ -> - MInf + fun x y -> + match (x, y) with + | _, _ when is_zero x -> + y + | _, _ when is_zero y -> + x + | Linear (c1, x1), Linear (c2, x2) -> + Linear (c1 + c2, SymLinear.plus x1 x2) + | MinMax (c1, sign, min_max, d1, x1), Linear (c2, x2) + | Linear (c2, x2), MinMax (c1, sign, min_max, d1, x1) + when SymLinear.is_zero x2 -> + mk_MinMax (c1 + c2, sign, min_max, d1, x1) + | MinMax (c1, Plus, Max, d1, _), Linear (c2, x2) + | Linear (c2, x2), MinMax (c1, Plus, Max, d1, _) -> + Linear (c1 + d1 + c2, x2) + | MinMax (c1, Minus, Min, d1, _), Linear (c2, x2) + | Linear (c2, x2), MinMax (c1, Minus, Min, d1, _) -> + Linear (c1 - d1 + c2, x2) + | _, _ -> + MInf let plus_u : t -> t -> t = - fun x y -> - match (x, y) with - | _, _ when is_zero x -> - y - | _, _ when is_zero y -> - x - | Linear (c1, x1), Linear (c2, x2) -> - Linear (c1 + c2, SymLinear.plus x1 x2) - | MinMax (c1, sign, min_max, d1, x1), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, sign, min_max, d1, x1) - when SymLinear.is_zero x2 -> - mk_MinMax (c1 + c2, sign, min_max, d1, x1) - | MinMax (c1, Plus, Min, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Plus, Min, d1, _) -> - Linear (c1 + d1 + c2, x2) - | MinMax (c1, Minus, Max, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Minus, Max, d1, _) -> - Linear (c1 - d1 + c2, x2) - | _, _ -> - PInf + fun x y -> + match (x, y) with + | _, _ when is_zero x -> + y + | _, _ when is_zero y -> + x + | Linear (c1, x1), Linear (c2, x2) -> + Linear (c1 + c2, SymLinear.plus x1 x2) + | MinMax (c1, sign, min_max, d1, x1), Linear (c2, x2) + | Linear (c2, x2), MinMax (c1, sign, min_max, d1, x1) + when SymLinear.is_zero x2 -> + mk_MinMax (c1 + c2, sign, min_max, d1, x1) + | MinMax (c1, Plus, Min, d1, _), Linear (c2, x2) + | Linear (c2, x2), MinMax (c1, Plus, Min, d1, _) -> + Linear (c1 + d1 + c2, x2) + | MinMax (c1, Minus, Max, d1, _), Linear (c2, x2) + | Linear (c2, x2), MinMax (c1, Minus, Max, d1, _) -> + Linear (c1 - d1 + c2, x2) + | _, _ -> + PInf let mult_const : t -> NonZeroInt.t -> t option = - fun x n -> - match x with - | MInf -> - Some (if NonZeroInt.is_positive n then MInf else PInf) - | PInf -> - Some (if NonZeroInt.is_positive n then PInf else MInf) - | Linear (c, x') -> - Some (Linear (c * (n :> int), SymLinear.mult_const x' n)) - | _ -> - None + fun x n -> + match x with + | MInf -> + Some (if NonZeroInt.is_positive n then MInf else PInf) + | PInf -> + Some (if NonZeroInt.is_positive n then PInf else MInf) + | Linear (c, x') -> + Some (Linear (c * (n :> int), SymLinear.mult_const x' n)) + | _ -> + None let div_const : t -> NonZeroInt.t -> t option = - fun x n -> - match x with - | MInf -> - Some (if NonZeroInt.is_positive n then MInf else PInf) - | PInf -> - Some (if NonZeroInt.is_positive n then PInf else MInf) - | Linear (c, x') when NonZeroInt.is_multiple c n -> ( - match SymLinear.exact_div_const_exn x' n with - | x'' -> - Some (Linear (c / (n :> int), x'')) - | exception NonZeroInt.DivisionNotExact -> - None ) - | _ -> - None + fun x n -> + match x with + | MInf -> + Some (if NonZeroInt.is_positive n then MInf else PInf) + | PInf -> + Some (if NonZeroInt.is_positive n then PInf else MInf) + | Linear (c, x') when NonZeroInt.is_multiple c n -> ( + match SymLinear.exact_div_const_exn x' n with + | x'' -> + Some (Linear (c / (n :> int), x'')) + | exception NonZeroInt.DivisionNotExact -> + None ) + | _ -> + None let neg : t -> t option = function @@ -839,23 +835,23 @@ module ItvPure = struct let ub : t -> Bound.t = snd let is_finite : t -> bool = - fun (l, u) -> - match (Bound.is_const l, Bound.is_const u) with Some _, Some _ -> true | _, _ -> false + fun (l, u) -> + match (Bound.is_const l, Bound.is_const u) with Some _, Some _ -> true | _, _ -> false let have_similar_bounds (l1, u1) (l2, u2) = Bound.are_similar l1 l2 && Bound.are_similar u1 u2 let subst : t -> Bound.t bottom_lifted SubstMap.t -> t bottom_lifted = - fun x map -> - match (Bound.subst_lb (lb x) map, Bound.subst_ub (ub x) map) with - | NonBottom l, NonBottom u -> - NonBottom (l, u) - | _ -> - Bottom + fun x map -> + match (Bound.subst_lb (lb x) map, Bound.subst_ub (ub x) map) with + | NonBottom l, NonBottom u -> + NonBottom (l, u) + | _ -> + Bottom let ( <= ) : lhs:t -> rhs:t -> bool = - fun ~lhs:(l1, u1) ~rhs:(l2, u2) -> Bound.le l2 l1 && Bound.le u1 u2 + fun ~lhs:(l1, u1) ~rhs:(l2, u2) -> Bound.le l2 l1 && Bound.le u1 u2 let xcompare ~lhs:(l1, u1) ~rhs:(l2, u2) = @@ -891,11 +887,11 @@ module ItvPure = struct let join : t -> t -> t = fun (l1, u1) (l2, u2) -> (Bound.lb l1 l2, Bound.ub u1 u2) let widen : prev:t -> next:t -> num_iters:int -> t = - fun ~prev:(l1, u1) ~next:(l2, u2) ~num_iters:_ -> (Bound.widen_l l1 l2, Bound.widen_u u1 u2) + fun ~prev:(l1, u1) ~next:(l2, u2) ~num_iters:_ -> (Bound.widen_l l1 l2, Bound.widen_u u1 u2) let pp : F.formatter -> t -> unit = - fun fmt (l, u) -> F.fprintf fmt "[%a, %a]" Bound.pp l Bound.pp u + fun fmt (l, u) -> F.fprintf fmt "[%a, %a]" Bound.pp l Bound.pp u let of_bound bound = (bound, bound) @@ -903,10 +899,10 @@ module ItvPure = struct let of_int n = of_bound (Bound.of_int n) let make_sym : unsigned:bool -> Typ.Procname.t -> (unit -> int) -> t = - fun ~unsigned pname new_sym_num -> - let lower = Bound.of_sym (SymLinear.make ~unsigned pname (new_sym_num ())) in - let upper = Bound.of_sym (SymLinear.make ~unsigned pname (new_sym_num ())) in - (lower, upper) + fun ~unsigned pname new_sym_num -> + let lower = Bound.of_sym (SymLinear.make ~unsigned pname (new_sym_num ())) in + let upper = Bound.of_sym (SymLinear.make ~unsigned pname (new_sym_num ())) in + (lower, upper) let mone = of_bound Bound.mone @@ -934,12 +930,12 @@ module ItvPure = struct let is_nat : t -> bool = function l, Bound.PInf -> Bound.is_zero l | _ -> false let is_const : t -> int option = - fun (l, u) -> - match (Bound.is_const l, Bound.is_const u) with - | Some n, Some m when Int.equal n m -> - Some n - | _, _ -> - None + fun (l, u) -> + match (Bound.is_const l, Bound.is_const u) with + | Some n, Some m when Int.equal n m -> + Some n + | _, _ -> + None let is_one : t -> bool = fun (l, u) -> Bound.is_one l && Bound.is_one u @@ -947,7 +943,7 @@ module ItvPure = struct let is_zero : t -> bool = fun (l, u) -> Bound.is_zero l && Bound.is_zero u let is_true : t -> bool = - fun (l, u) -> Bound.le (Bound.of_int 1) l || Bound.le u (Bound.of_int (-1)) + fun (l, u) -> Bound.le (Bound.of_int 1) l || Bound.le u (Bound.of_int (-1)) let is_false : t -> bool = is_zero @@ -959,14 +955,14 @@ module ItvPure = struct let is_le_zero : t -> bool = fun (_, ub) -> Bound.le ub Bound.zero let neg : t -> t = - fun (l, u) -> - let l' = Option.value ~default:Bound.MInf (Bound.neg u) in - let u' = Option.value ~default:Bound.PInf (Bound.neg l) in - (l', u') + fun (l, u) -> + let l' = Option.value ~default:Bound.MInf (Bound.neg u) in + let u' = Option.value ~default:Bound.PInf (Bound.neg l) in + (l', u') let lnot : t -> t = - fun x -> if is_true x then false_sem else if is_false x then true_sem else unknown_bool + fun x -> if is_true x then false_sem else if is_false x then true_sem else unknown_bool let plus : t -> t -> t = fun (l1, u1) (l2, u2) -> (Bound.plus_l l1 l2, Bound.plus_u u1 u2) @@ -974,133 +970,133 @@ module ItvPure = struct let minus : t -> t -> t = fun i1 i2 -> plus i1 (neg i2) let mult_const : t -> int -> t = - fun ((l, u) as itv) n -> - match NonZeroInt.of_int n with - | None -> - zero - | Some n -> - if NonZeroInt.is_one n then itv - else if NonZeroInt.is_minus_one n then neg itv - else if NonZeroInt.is_positive n then - let l' = Option.value ~default:Bound.MInf (Bound.mult_const l n) in - let u' = Option.value ~default:Bound.PInf (Bound.mult_const u n) in - (l', u') - else - let l' = Option.value ~default:Bound.MInf (Bound.mult_const u n) in - let u' = Option.value ~default:Bound.PInf (Bound.mult_const l n) in - (l', u') + fun ((l, u) as itv) n -> + match NonZeroInt.of_int n with + | None -> + zero + | Some n -> + if NonZeroInt.is_one n then itv + else if NonZeroInt.is_minus_one n then neg itv + else if NonZeroInt.is_positive n then + let l' = Option.value ~default:Bound.MInf (Bound.mult_const l n) in + let u' = Option.value ~default:Bound.PInf (Bound.mult_const u n) in + (l', u') + else + let l' = Option.value ~default:Bound.MInf (Bound.mult_const u n) in + let u' = Option.value ~default:Bound.PInf (Bound.mult_const l n) in + (l', u') (* Returns a precise value only when all coefficients are divided by n without remainder. *) let div_const : t -> int -> t = - fun ((l, u) as itv) n -> - match NonZeroInt.of_int n with - | None -> - top - | Some n -> - if NonZeroInt.is_one n then itv - else if NonZeroInt.is_minus_one n then neg itv - else if NonZeroInt.is_positive n then - let l' = Option.value ~default:Bound.MInf (Bound.div_const l n) in - let u' = Option.value ~default:Bound.PInf (Bound.div_const u n) in - (l', u') - else - let l' = Option.value ~default:Bound.MInf (Bound.div_const u n) in - let u' = Option.value ~default:Bound.PInf (Bound.div_const l n) in - (l', u') + fun ((l, u) as itv) n -> + match NonZeroInt.of_int n with + | None -> + top + | Some n -> + if NonZeroInt.is_one n then itv + else if NonZeroInt.is_minus_one n then neg itv + else if NonZeroInt.is_positive n then + let l' = Option.value ~default:Bound.MInf (Bound.div_const l n) in + let u' = Option.value ~default:Bound.PInf (Bound.div_const u n) in + (l', u') + else + let l' = Option.value ~default:Bound.MInf (Bound.div_const u n) in + let u' = Option.value ~default:Bound.PInf (Bound.div_const l n) in + (l', u') let mult : t -> t -> t = - fun x y -> - match (is_const x, is_const y) with - | _, Some n -> - mult_const x n - | Some n, _ -> - mult_const y n - | None, None -> - top + fun x y -> + match (is_const x, is_const y) with + | _, Some n -> + mult_const x n + | Some n, _ -> + mult_const y n + | None, None -> + top let div : t -> t -> t = fun x y -> match is_const y with None -> top | Some n -> div_const x n let mod_sem : t -> t -> t = - fun x y -> - match is_const y with + fun x y -> + match is_const y with + | None -> + top + | Some 0 -> + x (* x % [0,0] does nothing. *) + | Some m -> + match is_const x with + | Some n -> + of_int (n mod m) | None -> - top - | Some 0 -> - x (* x % [0,0] does nothing. *) - | Some m -> - match is_const x with - | Some n -> - of_int (n mod m) - | None -> - let abs_m = abs m in - if is_ge_zero x then (Bound.zero, Bound.of_int (abs_m - 1)) - else if is_le_zero x then (Bound.of_int (-abs_m + 1), Bound.zero) - else (Bound.of_int (-abs_m + 1), Bound.of_int (abs_m - 1)) + let abs_m = abs m in + if is_ge_zero x then (Bound.zero, Bound.of_int (abs_m - 1)) + else if is_le_zero x then (Bound.of_int (-abs_m + 1), Bound.zero) + else (Bound.of_int (-abs_m + 1), Bound.of_int (abs_m - 1)) (* x << [-1,-1] does nothing. *) let shiftlt : t -> t -> t = - fun x y -> match is_const y with Some n -> mult_const x (1 lsl n) | None -> top + fun x y -> match is_const y with Some n -> mult_const x (1 lsl n) | None -> top (* x >> [-1,-1] does nothing. *) let shiftrt : t -> t -> t = - fun x y -> - match is_const y with - | Some n when Int.( <= ) n 0 -> - x - | Some n when n >= 64 -> - zero - | Some n -> - div_const x (1 lsl n) - | None -> - top + fun x y -> + match is_const y with + | Some n when Int.( <= ) n 0 -> + x + | Some n when n >= 64 -> + zero + | Some n -> + div_const x (1 lsl n) + | None -> + top let lt_sem : t -> t -> t = - fun (l1, u1) (l2, u2) -> - if Bound.lt u1 l2 then true_sem else if Bound.le u2 l1 then false_sem else unknown_bool + fun (l1, u1) (l2, u2) -> + if Bound.lt u1 l2 then true_sem else if Bound.le u2 l1 then false_sem else unknown_bool let gt_sem : t -> t -> t = fun x y -> lt_sem y x let le_sem : t -> t -> t = - fun (l1, u1) (l2, u2) -> - if Bound.le u1 l2 then true_sem else if Bound.lt u2 l1 then false_sem else unknown_bool + fun (l1, u1) (l2, u2) -> + if Bound.le u1 l2 then true_sem else if Bound.lt u2 l1 then false_sem else unknown_bool let ge_sem : t -> t -> t = fun x y -> le_sem y x let eq_sem : t -> t -> t = - fun (l1, u1) (l2, u2) -> - if Bound.eq l1 u1 && Bound.eq u1 l2 && Bound.eq l2 u2 then true_sem - else if Bound.lt u1 l2 || Bound.lt u2 l1 then false_sem - else unknown_bool + fun (l1, u1) (l2, u2) -> + if Bound.eq l1 u1 && Bound.eq u1 l2 && Bound.eq l2 u2 then true_sem + else if Bound.lt u1 l2 || Bound.lt u2 l1 then false_sem + else unknown_bool let ne_sem : t -> t -> t = - fun (l1, u1) (l2, u2) -> - if Bound.eq l1 u1 && Bound.eq u1 l2 && Bound.eq l2 u2 then false_sem - else if Bound.lt u1 l2 || Bound.lt u2 l1 then true_sem - else unknown_bool + fun (l1, u1) (l2, u2) -> + if Bound.eq l1 u1 && Bound.eq u1 l2 && Bound.eq l2 u2 then false_sem + else if Bound.lt u1 l2 || Bound.lt u2 l1 then true_sem + else unknown_bool let land_sem : t -> t -> t = - fun x y -> - if is_true x && is_true y then true_sem - else if is_false x || is_false y then false_sem - else unknown_bool + fun x y -> + if is_true x && is_true y then true_sem + else if is_false x || is_false y then false_sem + else unknown_bool let lor_sem : t -> t -> t = - fun x y -> - if is_true x || is_true y then true_sem - else if is_false x && is_false y then false_sem - else unknown_bool + fun x y -> + if is_true x || is_true y then true_sem + else if is_false x && is_false y then false_sem + else unknown_bool let min_sem : t -> t -> t = fun (l1, u1) (l2, u2) -> (Bound.lb l1 l2, Bound.lb ~default:u1 u1 u2) @@ -1113,57 +1109,57 @@ module ItvPure = struct let prune_le : t -> t -> t = - fun x y -> - match (x, y) with - | (l1, Bound.PInf), (_, u2) -> - (l1, u2) - | (l1, Bound.Linear (c1, s1)), (_, Bound.Linear (c2, s2)) when SymLinear.eq s1 s2 -> - (l1, Bound.Linear (min c1 c2, s1)) - | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_one_symbol u -> - (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) - | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_one_symbol u -> - (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) - | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_mone_symbol u -> - (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) - | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_mone_symbol u -> - (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) - | (l1, Bound.Linear (c1, se)), (_, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')) - | (l1, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')), (_, Bound.Linear (c1, se)) - when SymLinear.is_zero se -> - (l1, Bound.mk_MinMax (c2, Bound.Plus, Bound.Min, min (c1 - c2) d2, se')) - | ( (l1, Bound.MinMax (c1, Bound.Plus, Bound.Min, d1, se1)) - , (_, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se2)) ) - when Int.equal c1 c2 && Symbol.equal se1 se2 -> - (l1, Bound.mk_MinMax (c1, Bound.Plus, Bound.Min, min d1 d2, se1)) - | _ -> - x + fun x y -> + match (x, y) with + | (l1, Bound.PInf), (_, u2) -> + (l1, u2) + | (l1, Bound.Linear (c1, s1)), (_, Bound.Linear (c2, s2)) when SymLinear.eq s1 s2 -> + (l1, Bound.Linear (min c1 c2, s1)) + | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_one_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) + | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_one_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) + | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_mone_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) + | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_mone_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) + | (l1, Bound.Linear (c1, se)), (_, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')) + | (l1, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')), (_, Bound.Linear (c1, se)) + when SymLinear.is_zero se -> + (l1, Bound.mk_MinMax (c2, Bound.Plus, Bound.Min, min (c1 - c2) d2, se')) + | ( (l1, Bound.MinMax (c1, Bound.Plus, Bound.Min, d1, se1)) + , (_, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se2)) ) + when Int.equal c1 c2 && Symbol.equal se1 se2 -> + (l1, Bound.mk_MinMax (c1, Bound.Plus, Bound.Min, min d1 d2, se1)) + | _ -> + x let prune_ge : t -> t -> t = - fun x y -> - match (x, y) with - | (Bound.MInf, u1), (l2, _) -> - (l2, u1) - | (Bound.Linear (c1, s1), u1), (Bound.Linear (c2, s2), _) when SymLinear.eq s1 s2 -> - (Bound.Linear (max c1 c2, s1), u1) - | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_one_symbol l -> - (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) - | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_one_symbol l -> - (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) - | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_mone_symbol l -> - (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) - | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_mone_symbol l -> - (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) - | (Bound.Linear (c1, se), u1), (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), _) - | (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), u1), (Bound.Linear (c1, se), _) - when SymLinear.is_zero se -> - (Bound.mk_MinMax (c2, Bound.Plus, Bound.Max, max (c1 - c2) d2, se'), u1) - | ( (Bound.MinMax (c1, Bound.Plus, Bound.Max, d1, se1), u1) - , (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se2), _) ) - when Int.equal c1 c2 && Symbol.equal se1 se2 -> - (Bound.mk_MinMax (c1, Bound.Plus, Bound.Max, max d1 d2, se1), u1) - | _ -> - x + fun x y -> + match (x, y) with + | (Bound.MInf, u1), (l2, _) -> + (l2, u1) + | (Bound.Linear (c1, s1), u1), (Bound.Linear (c2, s2), _) when SymLinear.eq s1 s2 -> + (Bound.Linear (max c1 c2, s1), u1) + | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_one_symbol l -> + (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) + | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_one_symbol l -> + (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) + | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_mone_symbol l -> + (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) + | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_mone_symbol l -> + (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) + | (Bound.Linear (c1, se), u1), (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), _) + | (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), u1), (Bound.Linear (c1, se), _) + when SymLinear.is_zero se -> + (Bound.mk_MinMax (c2, Bound.Plus, Bound.Max, max (c1 - c2) d2, se'), u1) + | ( (Bound.MinMax (c1, Bound.Plus, Bound.Max, d1, se1), u1) + , (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se2), _) ) + when Int.equal c1 c2 && Symbol.equal se1 se2 -> + (Bound.mk_MinMax (c1, Bound.Plus, Bound.Max, max d1 d2, se1), u1) + | _ -> + x let prune_lt : t -> t -> t = fun x y -> prune_le x (minus y one) @@ -1171,53 +1167,53 @@ module ItvPure = struct let prune_gt : t -> t -> t = fun x y -> prune_ge x (plus y one) let diff : t -> Bound.t -> t = - fun (l, u) b -> - if Bound.eq l b then (Bound.plus_l l Bound.one, u) - else if Bound.eq u b then (l, Bound.plus_u u Bound.mone) - else (l, u) + fun (l, u) b -> + if Bound.eq l b then (Bound.plus_l l Bound.one, u) + else if Bound.eq u b then (l, Bound.plus_u u Bound.mone) + else (l, u) let prune_zero : t -> t = fun x -> diff x Bound.zero let prune_comp : Binop.t -> t -> t -> t option = - fun c x y -> - if is_invalid y then Some x - else - let x = - match c with - | Binop.Le -> - prune_le x y - | Binop.Ge -> - prune_ge x y - | Binop.Lt -> - prune_lt x y - | Binop.Gt -> - prune_gt x y - | _ -> - assert false - in - if is_invalid x then None else Some x + fun c x y -> + if is_invalid y then Some x + else + let x = + match c with + | Binop.Le -> + prune_le x y + | Binop.Ge -> + prune_ge x y + | Binop.Lt -> + prune_lt x y + | Binop.Gt -> + prune_gt x y + | _ -> + assert false + in + if is_invalid x then None else Some x let prune_eq : t -> t -> t option = - fun x y -> - match prune_comp Binop.Le x y with None -> None | Some x' -> prune_comp Binop.Ge x' y + fun x y -> + match prune_comp Binop.Le x y with None -> None | Some x' -> prune_comp Binop.Ge x' y let prune_ne : t -> t -> t option = - fun x (l, u) -> - if is_invalid (l, u) then Some x - else - let x = if Bound.eq l u then diff x l else x in - if is_invalid x then None else Some x + fun x (l, u) -> + if is_invalid (l, u) then Some x + else + let x = if Bound.eq l u then diff x l else x in + if is_invalid x then None else Some x let get_symbols : t -> Symbol.t list = - fun (l, u) -> List.append (Bound.get_symbols l) (Bound.get_symbols u) + fun (l, u) -> List.append (Bound.get_symbols l) (Bound.get_symbols u) let make_positive : t -> t = - fun ((l, u) as x) -> if Bound.lt l Bound.zero then (Bound.zero, u) else x + fun ((l, u) as x) -> if Bound.lt l Bound.zero then (Bound.zero, u) else x let normalize : t -> t option = fun (l, u) -> if is_invalid (l, u) then None else Some (l, u) @@ -1228,16 +1224,16 @@ include AbstractDomain.BottomLifted (ItvPure) type t = astate let compare : t -> t -> int = - fun x y -> - match (x, y) with - | Bottom, Bottom -> - 0 - | Bottom, _ -> - -1 - | _, Bottom -> - 1 - | NonBottom x, NonBottom y -> - ItvPure.compare_astate x y + fun x y -> + match (x, y) with + | Bottom, Bottom -> + 0 + | Bottom, _ -> + -1 + | _, Bottom -> + 1 + | NonBottom x, NonBottom y -> + ItvPure.compare_astate x y let bot : t = Bottom @@ -1263,7 +1259,7 @@ let of_int : int -> astate = fun n -> NonBottom (ItvPure.of_int n) let of_int_lit n = try of_int (IntLit.to_int n) with _ -> top let of_int64 : Int64.t -> astate = - fun n -> Int64.to_int n |> Option.value_map ~f:of_int ~default:top + fun n -> Int64.to_int n |> Option.value_map ~f:of_int ~default:top let is_false : t -> bool = function NonBottom x -> ItvPure.is_false x | Bottom -> false @@ -1287,31 +1283,33 @@ let le : lhs:t -> rhs:t -> bool = ( <= ) let eq : t -> t -> bool = fun x y -> ( <= ) ~lhs:x ~rhs:y && ( <= ) ~lhs:y ~rhs:x let lift1 : (ItvPure.t -> ItvPure.t) -> t -> t = - fun f -> function Bottom -> Bottom | NonBottom x -> NonBottom (f x) + fun f -> function Bottom -> Bottom | NonBottom x -> NonBottom (f x) let lift1_opt : (ItvPure.t -> ItvPure.t option) -> t -> t = - fun f -> - function - | Bottom -> Bottom | NonBottom x -> match f x with None -> Bottom | Some v -> NonBottom v + fun f -> function + | Bottom -> + Bottom + | NonBottom x -> + match f x with None -> Bottom | Some v -> NonBottom v let lift2 : (ItvPure.t -> ItvPure.t -> ItvPure.t) -> t -> t -> t = - fun f x y -> - match (x, y) with - | Bottom, _ | _, Bottom -> - Bottom - | NonBottom x, NonBottom y -> - NonBottom (f x y) + fun f x y -> + match (x, y) with + | Bottom, _ | _, Bottom -> + Bottom + | NonBottom x, NonBottom y -> + NonBottom (f x y) let lift2_opt : (ItvPure.t -> ItvPure.t -> ItvPure.t option) -> t -> t -> t = - fun f x y -> - match (x, y) with - | Bottom, _ | _, Bottom -> - Bottom - | NonBottom x, NonBottom y -> - match f x y with Some v -> NonBottom v | None -> Bottom + fun f x y -> + match (x, y) with + | Bottom, _ | _, Bottom -> + Bottom + | NonBottom x, NonBottom y -> + match f x y with Some v -> NonBottom v | None -> Bottom let plus : t -> t -> t = lift2 ItvPure.plus @@ -1319,8 +1317,8 @@ let plus : t -> t -> t = lift2 ItvPure.plus let minus : t -> t -> t = lift2 ItvPure.minus let make_sym : ?unsigned:bool -> Typ.Procname.t -> (unit -> int) -> t = - fun ?(unsigned= false) pname new_sym_num -> - NonBottom (ItvPure.make_sym ~unsigned pname new_sym_num) + fun ?(unsigned= false) pname new_sym_num -> + NonBottom (ItvPure.make_sym ~unsigned pname new_sym_num) let neg : t -> t = lift1 ItvPure.neg @@ -1364,7 +1362,7 @@ let prune_eq : t -> t -> t = lift2_opt ItvPure.prune_eq let prune_ne : t -> t -> t = lift2_opt ItvPure.prune_ne let subst : t -> Bound.t bottom_lifted SubstMap.t -> t = - fun x map -> match x with NonBottom x' -> ItvPure.subst x' map | _ -> x + fun x map -> match x with NonBottom x' -> ItvPure.subst x' map | _ -> x let get_symbols : t -> Symbol.t list = function diff --git a/infer/src/checkers/BoundedCallTree.ml b/infer/src/checkers/BoundedCallTree.ml index 7e3b93763..70748fa57 100644 --- a/infer/src/checkers/BoundedCallTree.ml +++ b/infer/src/checkers/BoundedCallTree.ml @@ -177,7 +177,10 @@ let checker {Callbacks.proc_desc; tenv; get_proc_desc; summary} : Specs.summary ( match loaded_stacktraces with | None -> L.(die UserError) - "Missing command line option. Either '--stacktrace stack.json' or '--stacktrace-dir ./dir' must be used when running '-a crashcontext'. This options expects a JSON formated stack trace or a directory containing multiple such traces, respectively. See tests/codetoanalyze/java/crashcontext/*.json for examples of the expected format." + "Missing command line option. Either '--stacktrace stack.json' or '--stacktrace-dir \ + ./dir' must be used when running '-a crashcontext'. This options expects a JSON formated \ + stack trace or a directory containing multiple such traces, respectively. See \ + tests/codetoanalyze/java/crashcontext/*.json for examples of the expected format." | Some stacktraces -> let extras = {get_proc_desc; stacktraces} in ignore (Analyzer.exec_pdesc (ProcData.make proc_desc tenv extras) ~initial:Domain.empty) ) ; diff --git a/infer/src/checkers/NullabilityCheck.ml b/infer/src/checkers/NullabilityCheck.ml index 9de6f022b..6042a871c 100644 --- a/infer/src/checkers/NullabilityCheck.ml +++ b/infer/src/checkers/NullabilityCheck.ml @@ -130,13 +130,15 @@ module TransferFunctions (CFG : ProcCfg.S) = struct if is_direct_dereference then (* direct dereference without intermediate variable *) F.asprintf - "The return value of %s is annotated with %a and is dereferenced without being checked for null at %a" + "The return value of %s is annotated with %a and is dereferenced without being \ + checked for null at %a" (MF.monospaced_to_string simplified_pname) MF.pp_monospaced annotation Location.pp loc else (* dereference with intermediate variable *) F.asprintf - "Variable %a is indirectly annotated with %a (source %a) and is dereferenced without being checked for null at %a" + "Variable %a is indirectly annotated with %a (source %a) and is dereferenced without \ + being checked for null at %a" (MF.wrap_monospaced AccessPath.pp) ap MF.pp_monospaced annotation (MF.wrap_monospaced CallSite.pp) call_site Location.pp loc diff --git a/infer/src/checkers/SimpleChecker.ml b/infer/src/checkers/SimpleChecker.ml index b693e0e10..d7002179f 100644 --- a/infer/src/checkers/SimpleChecker.ml +++ b/infer/src/checkers/SimpleChecker.ml @@ -57,7 +57,8 @@ module Make (Spec : Spec) : S = struct (* failsafe for accidental non-finite height domains *) if num_iters >= iters_befor_timeout then L.(die InternalError) - "Stopping analysis after 1000 iterations without convergence. Make sure your domain is finite height." + "Stopping analysis after 1000 iterations without convergence. Make sure your domain is \ + finite height." else widen ~prev ~next ~num_iters end diff --git a/infer/src/checkers/accessTree.ml b/infer/src/checkers/accessTree.ml index 3511d6c52..372086a81 100644 --- a/infer/src/checkers/accessTree.ml +++ b/infer/src/checkers/accessTree.ml @@ -440,6 +440,7 @@ module PathSet (Config : Config) = struct let mem access_path tree = match get_node access_path tree with None -> false | Some (is_mem, _) -> is_mem + (* print as a set of paths rather than a map of paths to bools *) let pp fmt tree = let collect_path acc access_path (is_mem, _) = if is_mem then access_path :: acc else acc in diff --git a/infer/src/checkers/immutableChecker.ml b/infer/src/checkers/immutableChecker.ml index 44683ea50..aacfaab63 100644 --- a/infer/src/checkers/immutableChecker.ml +++ b/infer/src/checkers/immutableChecker.ml @@ -34,7 +34,8 @@ let check_immutable_cast tenv curr_pname curr_pdesc typ_expected typ_found_opt l if in_casts name_expected name_given then let description = Format.asprintf - "Method %s returns %a but the return type is %a. Make sure that users of this method do not try to modify the collection." + "Method %s returns %a but the return type is %a. Make sure that users of this \ + method do not try to modify the collection." (Typ.Procname.to_simplified_string curr_pname) Typ.Name.pp name_given Typ.Name.pp name_expected in diff --git a/infer/src/clang/CTLExceptions.mli b/infer/src/clang/CTLExceptions.mli index 5a14eb2f0..072759f16 100644 --- a/infer/src/clang/CTLExceptions.mli +++ b/infer/src/clang/CTLExceptions.mli @@ -7,13 +7,13 @@ * of patent rights can be found in the PATENTS file in the same directory. *) +(** Raised when the parser encounters a violation of a certain invariant *) exception ALParserInvariantViolationException of string - (** Raised when the parser encounters a violation of a certain invariant *) type exc_info +(** Raised when any exception from the lexer/parser of AL is caught, to include source-location info *) exception ALFileException of exc_info - (** Raised when any exception from the lexer/parser of AL is caught, to include source-location info *) val create_exc_info : string -> Lexing.lexbuf -> exc_info diff --git a/infer/src/clang/Capture.ml b/infer/src/clang/Capture.ml index 49266cb74..28e06dad0 100644 --- a/infer/src/clang/Capture.ml +++ b/infer/src/clang/Capture.ml @@ -118,21 +118,21 @@ let run_clang clang_command read = let run_plugin_and_frontend source_path frontend clang_cmd = let clang_plugin_cmd = ClangCommand.with_plugin_args clang_cmd in - ( if debug_mode then - (* -cc1 clang commands always set -o explicitly *) - let basename = source_path ^ ".ast" in - (* Emit the clang command with the extra args piped to infer-as-clang *) - let frontend_script_fname = Printf.sprintf "%s.sh" basename in - let debug_script_out = Out_channel.create frontend_script_fname in - let debug_script_fmt = Format.formatter_of_out_channel debug_script_out in - let biniou_fname = Printf.sprintf "%s.biniou" basename in - Format.fprintf debug_script_fmt "%s \\@\n > %s@\n" - (ClangCommand.command_to_run clang_plugin_cmd) - biniou_fname ; - Format.fprintf debug_script_fmt - "bdump -x -d \"%s/clang_ast.dict\" -w '!!DUMMY!!' %s \\@\n > %s.bdump" Config.etc_dir - biniou_fname basename ; - Out_channel.close debug_script_out ) ; + if debug_mode then ( + (* -cc1 clang commands always set -o explicitly *) + let basename = source_path ^ ".ast" in + (* Emit the clang command with the extra args piped to infer-as-clang *) + let frontend_script_fname = Printf.sprintf "%s.sh" basename in + let debug_script_out = Out_channel.create frontend_script_fname in + let debug_script_fmt = Format.formatter_of_out_channel debug_script_out in + let biniou_fname = Printf.sprintf "%s.biniou" basename in + Format.fprintf debug_script_fmt "%s \\@\n > %s@\n" + (ClangCommand.command_to_run clang_plugin_cmd) + biniou_fname ; + Format.fprintf debug_script_fmt + "bdump -x -d \"%s/clang_ast.dict\" -w '!!DUMMY!!' %s \\@\n > %s.bdump" Config.etc_dir + biniou_fname basename ; + Out_channel.close debug_script_out ) ; run_clang clang_plugin_cmd frontend diff --git a/infer/src/clang/ClangWrapper.ml b/infer/src/clang/ClangWrapper.ml index bc2156568..938f8fd96 100644 --- a/infer/src/clang/ClangWrapper.ml +++ b/infer/src/clang/ClangWrapper.ml @@ -119,8 +119,13 @@ let exec_action_item ~prog ~args = function (* An error in the output of `clang -### ...`. Outputs the error and fail. This is because `clang -###` pretty much never fails, but warns of failures on stderr instead. *) L.(die UserError) - "Failed to execute compilation command:@\n'%s' %a@\n@\nError message:@\n%s@\n@\n*** Infer needs a working compilation command to run." - prog Pp.cli_args args error + "Failed to execute compilation command:@\n\ + '%s' %a@\n\ + @\n\ + Error message:@\n\ + %s@\n\ + @\n\ + *** Infer needs a working compilation command to run." prog Pp.cli_args args error | ClangWarning warning -> L.external_warning "%s@\n" warning | Command clang_cmd -> @@ -156,6 +161,9 @@ let exe ~prog ~args = will fail with the appropriate error message from clang instead of silently analyzing 0 files. *) L.(debug Capture Quiet) - "WARNING: `clang -### ` returned an empty set of commands to run and no error. Will run the original command directly:@\n %s@\n" + "WARNING: `clang -### ` returned an empty set of commands to run and no error. Will \ + run the original command directly:@\n \ + %s@\n\ + " (String.concat ~sep:" " @@ prog :: args) ; Process.create_process_and_wait ~prog ~args ) diff --git a/infer/src/clang/ComponentKit.ml b/infer/src/clang/ComponentKit.ml index 2ac376ada..ecd3d8415 100644 --- a/infer/src/clang/ComponentKit.ml +++ b/infer/src/clang/ComponentKit.ml @@ -185,7 +185,8 @@ let component_factory_function_advice context an = ; description= "Break out composite components" ; suggestion= Some - "Prefer subclassing CKCompositeComponent to static helper functions that return a CKComponent subclass." + "Prefer subclassing CKCompositeComponent to static helper functions that return \ + a CKComponent subclass." ; doc_url= None ; loc= CFrontend_checkers.location_from_dinfo context decl_info } else None @@ -298,7 +299,8 @@ let component_with_multiple_factory_methods_advice context an = ; description= "Avoid Overrides" ; suggestion= Some - "Instead, always expose all parameters in a single designated initializer and document which are optional." + "Instead, always expose all parameters in a single designated initializer and \ + document which are optional." ; doc_url= None ; loc= CFrontend_checkers.location_from_decl context meth_decl } ) (List.drop factory_methods 1) diff --git a/infer/src/clang/cArithmetic_trans.ml b/infer/src/clang/cArithmetic_trans.ml index 2a37d001f..be42d3875 100644 --- a/infer/src/clang/cArithmetic_trans.ml +++ b/infer/src/clang/cArithmetic_trans.ml @@ -172,8 +172,10 @@ let unary_operation_instruction translation_unit_context uoi e typ loc = | `Real | `Imag | `Extension | `Coawait -> let uok = Clang_ast_j.string_of_unary_operator_kind uoi.Clang_ast_t.uoi_kind in L.(debug Capture Medium) - "@\nWARNING: Missing translation for Unary Operator Kind %s. The construct has been ignored...@\n" - uok ; + "@\n\ + WARNING: Missing translation for Unary Operator Kind %s. The construct has been \ + ignored...@\n\ + " uok ; (e, []) diff --git a/infer/src/clang/cAst_utils.ml b/infer/src/clang/cAst_utils.ml index 2166d94a2..fcdda05be 100644 --- a/infer/src/clang/cAst_utils.ml +++ b/infer/src/clang/cAst_utils.ml @@ -562,13 +562,14 @@ let get_superclass_curr_class_objc_from_decl (decl: Clang_ast_t.decl) = otdi.otdi_super | _ -> Logging.die InternalError - "Expected that ObjCImplementationDecl always has a pointer to it's interface, but wasn't the case with %s" - ni.Clang_ast_t.ni_name ) + "Expected that ObjCImplementationDecl always has a pointer to it's interface, but \ + wasn't the case with %s" ni.Clang_ast_t.ni_name ) | ObjCCategoryDecl (_, _, _, _, ocdi) -> ocdi.odi_class_interface | ObjCCategoryImplDecl (_, _, _, _, ocidi) -> ocidi.ocidi_class_interface | decl -> Logging.die InternalError - "Expected to be called only with ObjCInterfaceDecl, ObjCImplementationDecl, ObjCCategoryDecl or ObjCCategoryImplDecl, but got %s" + "Expected to be called only with ObjCInterfaceDecl, ObjCImplementationDecl, \ + ObjCCategoryDecl or ObjCCategoryImplDecl, but got %s" (Clang_ast_proj.get_decl_kind_string decl) diff --git a/infer/src/clang/cFrontend_checkers.ml b/infer/src/clang/cFrontend_checkers.ml index b5d74e594..0518995d2 100644 --- a/infer/src/clang/cFrontend_checkers.ml +++ b/infer/src/clang/cFrontend_checkers.ml @@ -52,8 +52,8 @@ let decl_ref_or_selector_name an = "The reference " ^ Ctl_parser_types.ast_node_name decl_an | _ -> L.(die ExternalError) - "decl_ref_or_selector_name must be called with a DeclRefExpr or an ObjCMessageExpr, but got %s" - (tag_name_of_node an) + "decl_ref_or_selector_name must be called with a DeclRefExpr or an ObjCMessageExpr, but \ + got %s" (tag_name_of_node an) let iphoneos_target_sdk_version context _ = diff --git a/infer/src/clang/cFrontend_errors.ml b/infer/src/clang/cFrontend_errors.ml index 339cff653..bea13c340 100644 --- a/infer/src/clang/cFrontend_errors.ml +++ b/infer/src/clang/cFrontend_errors.ml @@ -25,7 +25,9 @@ let filter_parsed_linters_developer parsed_linters = match Config.linter with | None -> L.(die UserError) - "In linters developer mode you should debug only one linter at a time. This is important for debugging the rule. Pass the flag --linter to specify the linter you want to debug." + "In linters developer mode you should debug only one linter at a time. This is \ + important for debugging the rule. Pass the flag --linter to specify the linter \ + you want to debug." | Some lint -> List.filter ~f:(fun (rule: linter) -> String.equal rule.issue_desc.id lint) parsed_linters else parsed_linters diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index 77caf8fac..f9ce3d190 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -275,8 +275,8 @@ let get_superclass_curr_class_objc context = CAst_utils.get_superclass_curr_class_objc_from_decl decl | None -> Logging.die InternalError - "Expected that the current class ptr in the context is a valid pointer to class decl, but didn't find declaration, ptr is %d " - ptr ) + "Expected that the current class ptr in the context is a valid pointer to class decl, \ + but didn't find declaration, ptr is %d " ptr ) | CContext.ContextNoCls -> Logging.die InternalError "This should only be called in the context of a class, but got CContext.ContextNoCls" @@ -625,13 +625,13 @@ let create_local_procdesc ?(set_objc_accessor_attr= false) trans_unit_ctx cfg te in Cfg.create_proc_desc cfg proc_attributes in - if defined then + if defined then ( let start_kind = Procdesc.Node.Start_node proc_name in let start_node = Procdesc.create_node procdesc loc_start start_kind [] in let exit_kind = Procdesc.Node.Exit_node proc_name in let exit_node = Procdesc.create_node procdesc loc_exit exit_kind [] in Procdesc.set_start_node procdesc start_node ; - Procdesc.set_exit_node procdesc exit_node + Procdesc.set_exit_node procdesc exit_node ) in if should_create_procdesc cfg proc_name defined set_objc_accessor_attr then ( create_new_procdesc () ; true ) diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index 467a13587..08c64528e 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -450,7 +450,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s {empty_res_trans with exps= [(Exp.Sizeof sizeof_data, sizeof_typ)]} | k -> L.(debug Capture Medium) - "@\nWARNING: Missing translation of Uniry_Expression_Or_Trait of kind: %s . Expression ignored, returned -1... @\n" + "@\n\ + WARNING: Missing translation of Uniry_Expression_Or_Trait of kind: %s . Expression \ + ignored, returned -1... @\n\ + " (Clang_ast_j.string_of_unary_expr_or_type_trait_kind k) ; {empty_res_trans with exps= [(Exp.minus_one, typ)]} @@ -1007,7 +1010,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let res_trans_callee = instruction trans_state_callee fun_exp_stmt in let sil_fe, _ = extract_exp_from_list res_trans_callee.exps - "WARNING: The translation of fun_exp did not return an expression.Returning -1. NEED TO BE FIXED" + "WARNING: The translation of fun_exp did not return an expression.Returning -1. NEED TO \ + BE FIXED" in let callee_pname_opt = match sil_fe with Exp.Const Const.Cfun pn -> Some pn | _ -> None @@ -1042,8 +1046,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s else (* FIXME(t21762295) this is reachable *) CFrontend_config.incorrect_assumption __POS__ si.Clang_ast_t.si_source_range - "In call to %a: stmt_list and res_trans_par.exps must have same size but they don't:@\nstmt_list(%d)=[%a]@\nres_trans_par.exps(%d)=[%a]@\n" - Typ.Procname.pp procname (List.length params) (Pp.seq Exp.pp) + "In call to %a: stmt_list and res_trans_par.exps must have same size but they don't:@\n\ + stmt_list(%d)=[%a]@\n\ + res_trans_par.exps(%d)=[%a]@\n\ + " Typ.Procname.pp procname (List.length params) (Pp.seq Exp.pp) (List.map ~f:fst params) (List.length params_stmt) (Pp.seq (Pp.to_string ~f:Clang_ast_j.string_of_stmt)) params_stmt @@ -2413,7 +2419,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let stmt = extract_stmt_from_singleton stmt_list - "WARNING: We expect only one element in stmt list defining the operand in UnaryOperator. NEED FIXING@\n" + "WARNING: We expect only one element in stmt list defining the operand in UnaryOperator. \ + NEED FIXING@\n\ + " in let trans_state' = {trans_state_pri with succ_nodes= []} in let res_trans_stmt = instruction trans_state' stmt in @@ -2524,7 +2532,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s {empty_res_trans with root_nodes= [ret_node]; leaf_nodes= []} | _ -> L.(debug Capture Verbose) - "@\nWARNING: Missing translation of Return Expression. Return Statement ignored. Need fixing!@\n" ; + "@\n\ + WARNING: Missing translation of Return Expression. Return Statement ignored. Need \ + fixing!@\n\ + " ; {empty_res_trans with root_nodes= succ_nodes} in (* We expect a return with only one expression *) diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index cd3172271..89bd51990 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -230,7 +230,7 @@ module PriorityNode = struct let compute_results_to_parent trans_state loc nd_name stmt_info res_states_children = let res_state = collect_res_trans trans_state.context.procdesc res_states_children in let create_node = own_priority_node trans_state.priority stmt_info && res_state.instrs <> [] in - if create_node then + if create_node then ( (* We need to create a node *) let node_kind = Procdesc.Node.Stmt_node nd_name in let node = Nodes.create_node node_kind res_state.instrs loc trans_state.context in @@ -240,7 +240,7 @@ module PriorityNode = struct res_state.leaf_nodes ; (* Invariant: if root_nodes is empty then the params have not created a node.*) let root_nodes = if res_state.root_nodes <> [] then res_state.root_nodes else [node] in - {res_state with root_nodes; leaf_nodes= [node]; instrs= []; exps= []} + {res_state with root_nodes; leaf_nodes= [node]; instrs= []; exps= []} ) else (* The node is created by the parent. We just pass back nodes/leafs params *) {res_state with exps= []} diff --git a/infer/src/clang/ctl_parser_types.ml b/infer/src/clang/ctl_parser_types.ml index 4381d4897..d2c56d3df 100644 --- a/infer/src/clang/ctl_parser_types.ml +++ b/infer/src/clang/ctl_parser_types.ml @@ -357,7 +357,9 @@ type abs_ctype = let display_equality_warning () = L.(debug Linters Medium) - "[WARNING:] Type Comparison failed... This might indicate that the types are different or the specified type is internally represented in a different way and therefore not recognized.@\n" + "[WARNING:] Type Comparison failed... This might indicate that the types are different or the \ + specified type is internally represented in a different way and therefore not recognized.@\n\ + " let rec abs_ctype_to_string t = @@ -483,7 +485,11 @@ and check_type_ptr type_ptr abs_ctype = comparison function for Clang_ast_t.c_type *) and c_type_equal c_type abs_ctype = L.(debug Linters Medium) - "@\nComparing c_type/abs_ctype for equality... Type compared: @\nc_type = `%s` @\nabs_ctype =`%s`@\n" + "@\n\ + Comparing c_type/abs_ctype for equality... Type compared: @\n\ + c_type = `%s` @\n\ + abs_ctype =`%s`@\n\ + " (Clang_ast_j.string_of_c_type c_type) (abs_ctype_to_string abs_ctype) ; let open Clang_ast_t in diff --git a/infer/src/clang/tableaux.ml b/infer/src/clang/tableaux.ml index 7004b788d..62ab431ae 100644 --- a/infer/src/clang/tableaux.ml +++ b/infer/src/clang/tableaux.ml @@ -257,8 +257,11 @@ let add_valid_formulae an checker lcxt cl = add_in_set phi acc_set | AG _ | AX _ | AF _ | AU _ | EH _ | ET _ | Implies _ -> Logging.die InternalError - "@\n We should not have operators AG, AX, AF, AU, EH, ET.\n Failing with formula @\n %a@\n" - CTL.Debug.pp_formula phi + "@\n \ + We should not have operators AG, AX, AF, AU, EH, ET.\n \ + Failing with formula @\n \ + %a@\n\ + " CTL.Debug.pp_formula phi | _ -> acc_set in @@ -329,11 +332,11 @@ let build_valuation an lcxt linter_map_context = closure_map := ClosureHashtbl.add normalized_condition (is_state_only, cl') !closure_map ; (is_state_only, cl') in - if not (is_state_only && skip_evaluation_InNode_formula an normalized_condition) then + if not (is_state_only && skip_evaluation_InNode_formula an normalized_condition) then ( let sat_set = add_valid_formulae an linter.issue_desc.id lcxt cl in (*L.progress " [Set Size: %i] @\n" (CTLFormulaSet.cardinal sat_set);*) if CTLFormulaSet.mem normalized_condition sat_set then report_issue an lcxt linter ; - add_formula_to_valuation (node_pointer, linter.issue_desc.id) sat_set + add_formula_to_valuation (node_pointer, linter.issue_desc.id) sat_set ) in List.iter ~f:(fun (linter: linter) -> diff --git a/infer/src/concurrency/RacerD.ml b/infer/src/concurrency/RacerD.ml index 6fd7cbcdc..8294b096b 100644 --- a/infer/src/concurrency/RacerD.ml +++ b/infer/src/concurrency/RacerD.ml @@ -844,13 +844,13 @@ let get_reporting_explanation_java report_kind tenv pname thread = | _, Some threadsafe_explanation when RacerDDomain.ThreadsDomain.is_any thread -> ( IssueType.thread_safety_violation , F.asprintf - "%s, so we assume that this method can run in parallel with other non-private methods in the class (including itself)." - threadsafe_explanation ) + "%s, so we assume that this method can run in parallel with other non-private methods \ + in the class (including itself)." threadsafe_explanation ) | _, Some threadsafe_explanation -> ( IssueType.thread_safety_violation , F.asprintf - "%s. Although this access is not known to run on a background thread, it may happen in parallel with another access that does." - threadsafe_explanation ) + "%s. Although this access is not known to run on a background thread, it may happen in \ + parallel with another access that does." threadsafe_explanation ) | _, None -> (* failed to explain based on @ThreadSafe annotation; have to justify using background thread *) if RacerDDomain.ThreadsDomain.is_any thread then @@ -859,8 +859,9 @@ let get_reporting_explanation_java report_kind tenv pname thread = else ( IssueType.thread_safety_violation , F.asprintf - "@\n Reporting because another access to the same memory occurs on a background thread, although this access may not." - ) + "@\n \ + Reporting because another access to the same memory occurs on a background thread, \ + although this access may not." ) (** Explain why we are reporting this access, in C++ *) @@ -995,8 +996,12 @@ let get_contaminated_race_message access wobbly_paths = in Option.map wobbly_path_opt ~f:(fun (wobbly_path, access_path) -> F.asprintf - "@\n\nNote that the prefix path %a has been contaminated during the execution, so the reported race on %a might be a false positive.@\n\n" - AccessPath.pp wobbly_path AccessPath.pp access_path ) + "@\n\ + \n\ + Note that the prefix path %a has been contaminated during the execution, so the reported \ + race on %a might be a false positive.@\n\ + \n\ + " AccessPath.pp wobbly_path AccessPath.pp access_path ) let report_thread_safety_violation tenv pdesc ~make_description ~report_kind access thread @@ -1058,7 +1063,8 @@ let report_unannotated_interface_violation tenv pdesc access thread reported_pna let class_name = Typ.Procname.Java.get_class_name java_pname in let make_description _ _ _ _ = F.asprintf - "Unprotected call to method of un-annotated interface %s. Consider annotating the class with %a, adding a lock, or using an interface that is known to be thread-safe." + "Unprotected call to method of un-annotated interface %s. Consider annotating the class \ + with %a, adding a lock, or using an interface that is known to be thread-safe." class_name MF.pp_monospaced "@ThreadSafe" in report_thread_safety_violation tenv pdesc ~make_description ~report_kind:UnannotatedInterface @@ -1222,12 +1228,12 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi in if AccessData.is_unprotected precondition && (not (List.is_empty writes_on_background_thread) || ThreadsDomain.is_any threads) - then + then ( let conflict = List.hd writes_on_background_thread in report_thread_safety_violation tenv procdesc ~make_description:make_unprotected_write_description ~report_kind:(WriteWriteRace conflict) access threads wobbly_paths ; - update_reported access pname reported_acc + update_reported access pname reported_acc ) else reported_acc | _ -> (* Do not report unprotected writes when an access can't run in parallel with itself, or @@ -1252,12 +1258,12 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi is_conflict other_access precondition other_threads ) accesses in - if not (List.is_empty all_writes) then + if not (List.is_empty all_writes) then ( let conflict = List.hd_exn all_writes in report_thread_safety_violation tenv procdesc ~make_description:(make_read_write_race_description ~read_is_sync:false conflict) ~report_kind:(ReadWriteRace conflict.access) access threads wobbly_paths ; - update_reported access pname reported_acc + update_reported access pname reported_acc ) else reported_acc | Access.Read _ | ContainerRead _ -> (* protected read. report unprotected writes and opposite protected writes as conflicts *) @@ -1279,13 +1285,13 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi ) accesses in - if not (List.is_empty conflicting_writes) then + if not (List.is_empty conflicting_writes) then ( let conflict = List.hd_exn conflicting_writes in (* protected read with conflicting unprotected write(s). warn. *) report_thread_safety_violation tenv procdesc ~make_description:(make_read_write_race_description ~read_is_sync:true conflict) ~report_kind:(ReadWriteRace conflict.access) access threads wobbly_paths ; - update_reported access pname reported_acc + update_reported access pname reported_acc ) else reported_acc in AccessListMap.fold diff --git a/infer/src/concurrency/RacerDDomain.ml b/infer/src/concurrency/RacerDDomain.ml index 6499d06fd..0dfc401db 100644 --- a/infer/src/concurrency/RacerDDomain.ml +++ b/infer/src/concurrency/RacerDDomain.ml @@ -615,16 +615,25 @@ type summary = let pp_summary fmt {threads; locks; accesses; return_ownership; return_attributes; wobbly_paths} = F.fprintf fmt - "@\nThreads: %a, Locks: %a @\nAccesses %a @\nOwnership: %a @\nReturn Attributes: %a @\nWobbly Paths: %a@\n" - ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses + "@\n\ + Threads: %a, Locks: %a @\n\ + Accesses %a @\n\ + Ownership: %a @\n\ + Return Attributes: %a @\n\ + Wobbly Paths: %a@\n\ + " ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipAbstractValue.pp return_ownership AttributeSetDomain.pp return_attributes StabilityDomain.pp wobbly_paths let pp fmt {threads; locks; accesses; ownership; attribute_map; wobbly_paths} = F.fprintf fmt - "Threads: %a, Locks: %a @\nAccesses %a @\n Ownership: %a @\nAttributes: %a @\nNon-stable Paths: %a@\n" - ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipDomain.pp + "Threads: %a, Locks: %a @\n\ + Accesses %a @\n \ + Ownership: %a @\n\ + Attributes: %a @\n\ + Non-stable Paths: %a@\n\ + " ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipDomain.pp ownership AttributeMapDomain.pp attribute_map StabilityDomain.pp wobbly_paths diff --git a/infer/src/eradicate/eradicate.ml b/infer/src/eradicate/eradicate.ml index a99ef8b93..a09cc84e2 100644 --- a/infer/src/eradicate/eradicate.ml +++ b/infer/src/eradicate/eradicate.ml @@ -111,13 +111,14 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct curr_pname curr_pdesc find_canonical_duplicate annotated_signature typestate node linereader in - ( if Config.write_html then - let d_typestate ts = L.d_strln (F.asprintf "%a" (TypeState.pp Extension.ext) ts) in - L.d_strln "before:" ; - d_typestate typestate ; - L.d_strln "after:" ; - List.iter ~f:d_typestate typestates_succ ) ; - NodePrinter.finish_session node ; (typestates_succ, typestates_exn) + if Config.write_html then ( + let d_typestate ts = L.d_strln (F.asprintf "%a" (TypeState.pp Extension.ext) ts) in + L.d_strln "before:" ; + d_typestate typestate ; + L.d_strln "after:" ; + List.iter ~f:d_typestate typestates_succ ) ; + NodePrinter.finish_session node ; + (typestates_succ, typestates_exn) let proc_throws _ = DontKnow diff --git a/infer/src/eradicate/eradicateChecks.ml b/infer/src/eradicate/eradicateChecks.ml index 102065a44..598455929 100644 --- a/infer/src/eradicate/eradicateChecks.ml +++ b/infer/src/eradicate/eradicateChecks.ml @@ -209,15 +209,15 @@ let check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_r true ) && not (field_is_mutable ()) in - ( if should_report_nullable || should_report_absent then - let ann = - if should_report_nullable then AnnotatedSignature.Nullable else AnnotatedSignature.Present - in - if Models.Inference.enabled then Models.Inference.field_add_nullable_annotation fname ; - let origin_descr = TypeAnnotation.descr_origin tenv ta_rhs in - report_error tenv find_canonical_duplicate - (TypeErr.Field_annotation_inconsistent (ann, fname, origin_descr)) (Some instr_ref) loc - curr_pdesc ) ; + if should_report_nullable || should_report_absent then ( + let ann = + if should_report_nullable then AnnotatedSignature.Nullable else AnnotatedSignature.Present + in + if Models.Inference.enabled then Models.Inference.field_add_nullable_annotation fname ; + let origin_descr = TypeAnnotation.descr_origin tenv ta_rhs in + report_error tenv find_canonical_duplicate + (TypeErr.Field_annotation_inconsistent (ann, fname, origin_descr)) (Some instr_ref) loc + curr_pdesc ) ; if should_report_mutable then let origin_descr = TypeAnnotation.descr_origin tenv ta_rhs in report_error tenv find_canonical_duplicate (TypeErr.Field_not_mutable (fname, origin_descr)) diff --git a/infer/src/eradicate/modelTables.ml b/infer/src/eradicate/modelTables.ml index 6aafb4ed7..d37f2ff11 100644 --- a/infer/src/eradicate/modelTables.ml +++ b/infer/src/eradicate/modelTables.ml @@ -295,29 +295,30 @@ let annotated_list_nullable = , "javax.lang.model.util.Elements.getAllAnnotationMirrors(javax.lang.model.element.Element):java.util.List" ) ; ( o2 - , "javax.lang.model.util.Elements.hides(javax.lang.model.element.Element, javax.lang.model.element.Element):boolean" - ) + , "javax.lang.model.util.Elements.hides(javax.lang.model.element.Element, \ + javax.lang.model.element.Element):boolean" ) ; ( o3 - , "javax.lang.model.util.Elements.overrides(javax.lang.model.element.ExecutableElement, javax.lang.model.element.ExecutableElement, javax.lang.model.element.TypeElement):boolean" + , "javax.lang.model.util.Elements.overrides(javax.lang.model.element.ExecutableElement, \ + javax.lang.model.element.ExecutableElement, javax.lang.model.element.TypeElement):boolean" ) ; ( o1 , "javax.lang.model.util.Types.asElement(javax.lang.model.type.TypeMirror):javax.lang.model.element.Element" ) ; ( o2 - , "javax.lang.model.util.Types.isSameType(javax.lang.model.type.TypeMirror, javax.lang.model.type.TypeMirror):boolean" - ) + , "javax.lang.model.util.Types.isSameType(javax.lang.model.type.TypeMirror, \ + javax.lang.model.type.TypeMirror):boolean" ) ; ( o2 - , "javax.lang.model.util.Types.isSubtype(javax.lang.model.type.TypeMirror, javax.lang.model.type.TypeMirror):boolean" - ) + , "javax.lang.model.util.Types.isSubtype(javax.lang.model.type.TypeMirror, \ + javax.lang.model.type.TypeMirror):boolean" ) ; ( o2 - , "javax.lang.model.util.Types.isAssignable(javax.lang.model.type.TypeMirror, javax.lang.model.type.TypeMirror):boolean" - ) + , "javax.lang.model.util.Types.isAssignable(javax.lang.model.type.TypeMirror, \ + javax.lang.model.type.TypeMirror):boolean" ) ; ( o2 - , "javax.lang.model.util.Types.contains(javax.lang.model.type.TypeMirror, javax.lang.model.type.TypeMirror):boolean" - ) + , "javax.lang.model.util.Types.contains(javax.lang.model.type.TypeMirror, \ + javax.lang.model.type.TypeMirror):boolean" ) ; ( o2 - , "javax.lang.model.util.Types.isSubsignature(javax.lang.model.type.ExecutableType, javax.lang.model.type.ExecutableType):boolean" - ) + , "javax.lang.model.util.Types.isSubsignature(javax.lang.model.type.ExecutableType, \ + javax.lang.model.type.ExecutableType):boolean" ) ; ( o1 , "javax.lang.model.util.Types.directSupertypes(javax.lang.model.type.TypeMirror):java.util.List" ) @@ -337,34 +338,35 @@ let annotated_list_nullable = , "javax.lang.model.util.Types.getArrayType(javax.lang.model.type.TypeMirror):javax.lang.model.type.ArrayType" ) ; ( o2 - , "javax.lang.model.util.Types.getWildcardType(javax.lang.model.type.TypeMirror, javax.lang.model.type.TypeMirror):javax.lang.model.type.WildcardType" - ) + , "javax.lang.model.util.Types.getWildcardType(javax.lang.model.type.TypeMirror, \ + javax.lang.model.type.TypeMirror):javax.lang.model.type.WildcardType" ) ; ( o2 - , "javax.lang.model.util.Types.getDeclaredType(javax.lang.model.element.TypeElement, javax.lang.model.type.TypeMirror[]):javax.lang.model.type.DeclaredType" - ) + , "javax.lang.model.util.Types.getDeclaredType(javax.lang.model.element.TypeElement, \ + javax.lang.model.type.TypeMirror[]):javax.lang.model.type.DeclaredType" ) ; ( o3 - , "javax.lang.model.util.Types.getDeclaredType(javax.lang.model.type.DeclaredType, javax.lang.model.element.TypeElement, javax.lang.model.type.TypeMirror[]):javax.lang.model.type.DeclaredType" - ) + , "javax.lang.model.util.Types.getDeclaredType(javax.lang.model.type.DeclaredType, \ + javax.lang.model.element.TypeElement, \ + javax.lang.model.type.TypeMirror[]):javax.lang.model.type.DeclaredType" ) ; ( o2 - , "javax.lang.model.util.Types.asMemberOf(javax.lang.model.type.DeclaredType, javax.lang.model.element.Element):javax.lang.model.type.TypeMirror" - ) + , "javax.lang.model.util.Types.asMemberOf(javax.lang.model.type.DeclaredType, \ + javax.lang.model.element.Element):javax.lang.model.type.TypeMirror" ) ; ( n3 , "javax.tools.JavaCompiler.getStandardFileManager(javax.tools.DiagnosticListener,java.util.Locale,java.nio.charset.Charset):javax.tools.StandardJavaFileManager" ) ; (ng, "javax.tools.JavaFileObject.getAccessLevel():javax.lang.model.element.Modifier") ; (ng, "javax.tools.JavaFileObject.getNestingKind():javax.lang.model.element.NestingKind") ; ( o2 - , "com.sun.source.util.SourcePositions.getStartPosition(com.sun.source.tree.CompilationUnitTree, com.sun.source.tree.Tree):long" - ) + , "com.sun.source.util.SourcePositions.getStartPosition(com.sun.source.tree.CompilationUnitTree, \ + com.sun.source.tree.Tree):long" ) ; ( o2 - , "com.sun.source.util.SourcePositions.getEndPosition(com.sun.source.tree.CompilationUnitTree, com.sun.source.tree.Tree):long" - ) + , "com.sun.source.util.SourcePositions.getEndPosition(com.sun.source.tree.CompilationUnitTree, \ + com.sun.source.tree.Tree):long" ) ; ( (n, [o; o]) - , "com.sun.source.util.TreePath.getPath(com.sun.source.tree.CompilationUnitTree, com.sun.source.tree.Tree):com.sun.source.util.TreePath" - ) + , "com.sun.source.util.TreePath.getPath(com.sun.source.tree.CompilationUnitTree, \ + com.sun.source.tree.Tree):com.sun.source.util.TreePath" ) ; ( (n, [o; o]) - , "com.sun.source.util.TreePath.getPath(com.sun.source.util.TreePath, com.sun.source.tree.Tree):com.sun.source.util.TreePath" - ) + , "com.sun.source.util.TreePath.getPath(com.sun.source.util.TreePath, \ + com.sun.source.tree.Tree):com.sun.source.util.TreePath" ) ; ( (n, [o]) , "com.sun.source.util.Trees.getTree(javax.lang.model.element.Element):com.sun.source.tree.Tree" ) @@ -375,23 +377,25 @@ let annotated_list_nullable = , "com.sun.source.util.Trees.getTree(javax.lang.model.element.ExecutableElement):com.sun.source.tree.MethodTree" ) ; ( (n, [o; o]) - , "com.sun.source.util.Trees.getTree(javax.lang.model.element.Element, javax.lang.model.element.AnnotationMirror):com.sun.source.tree.Tree" - ) + , "com.sun.source.util.Trees.getTree(javax.lang.model.element.Element, \ + javax.lang.model.element.AnnotationMirror):com.sun.source.tree.Tree" ) ; ( (n, [o; o; o]) - , "com.sun.source.util.Trees.getTree(javax.lang.model.element.Element, javax.lang.model.element.AnnotationMirror, javax.lang.model.element.AnnotationValue):com.sun.source.tree.Tree" - ) + , "com.sun.source.util.Trees.getTree(javax.lang.model.element.Element, \ + javax.lang.model.element.AnnotationMirror, \ + javax.lang.model.element.AnnotationValue):com.sun.source.tree.Tree" ) ; ( o2 - , "com.sun.source.util.Trees.getPath(com.sun.source.tree.CompilationUnitTree, com.sun.source.tree.Tree):com.sun.source.util.TreePath" - ) + , "com.sun.source.util.Trees.getPath(com.sun.source.tree.CompilationUnitTree, \ + com.sun.source.tree.Tree):com.sun.source.util.TreePath" ) ; ( (n, [o]) , "com.sun.source.util.Trees.getPath(javax.lang.model.element.Element):com.sun.source.util.TreePath" ) ; ( (n, [o; o]) - , "com.sun.source.util.Trees.getPath(javax.lang.model.element.Element, javax.lang.model.element.AnnotationMirror):com.sun.source.util.TreePath" - ) + , "com.sun.source.util.Trees.getPath(javax.lang.model.element.Element, \ + javax.lang.model.element.AnnotationMirror):com.sun.source.util.TreePath" ) ; ( (n, [o; o; o]) - , "com.sun.source.util.Trees.getPath(javax.lang.model.element.Element, javax.lang.model.element.AnnotationMirror, javax.lang.model.element.AnnotationValue):com.sun.source.util.TreePath" - ) + , "com.sun.source.util.Trees.getPath(javax.lang.model.element.Element, \ + javax.lang.model.element.AnnotationMirror, \ + javax.lang.model.element.AnnotationValue):com.sun.source.util.TreePath" ) ; ( (n, [o]) , "com.sun.source.util.Trees.getElement(com.sun.source.util.TreePath):javax.lang.model.element.Element" ) @@ -404,17 +408,18 @@ let annotated_list_nullable = ; ( (n, [o]) , "com.sun.source.util.Trees.getDocComment(com.sun.source.util.TreePath):java.lang.String" ) ; ( o2 - , "com.sun.source.util.Trees.isAccessible(com.sun.source.tree.Scope, javax.lang.model.element.TypeElement):boolean" - ) + , "com.sun.source.util.Trees.isAccessible(com.sun.source.tree.Scope, \ + javax.lang.model.element.TypeElement):boolean" ) ; ( o3 - , "com.sun.source.util.Trees.isAccessible(com.sun.source.tree.Scope, javax.lang.model.element.Element, javax.lang.model.type.DeclaredType):boolean" - ) + , "com.sun.source.util.Trees.isAccessible(com.sun.source.tree.Scope, \ + javax.lang.model.element.Element, javax.lang.model.type.DeclaredType):boolean" ) ; ( o1 , "com.sun.source.util.Trees.getOriginalType(javax.lang.model.type.ErrorType):javax.lang.model.type.TypeMirror" ) ; ( (o, [o; o; o; o]) - , "com.sun.source.util.Trees.printMessage(javax.tools.Diagnostic.Kind, java.lang.CharSequence, com.sun.source.tree.Tree, com.sun.source.tree.CompilationUnitTree):void" - ) + , "com.sun.source.util.Trees.printMessage(javax.tools.Diagnostic.Kind, \ + java.lang.CharSequence, com.sun.source.tree.Tree, \ + com.sun.source.tree.CompilationUnitTree):void" ) ; ( o1 , "com.sun.source.util.Trees.getLub(com.sun.source.tree.CatchTree):javax.lang.model.type.TypeMirror" ) diff --git a/infer/src/eradicate/typeErr.ml b/infer/src/eradicate/typeErr.ml index dea48ff41..ead9de0e2 100644 --- a/infer/src/eradicate/typeErr.ml +++ b/infer/src/eradicate/typeErr.ml @@ -447,8 +447,8 @@ let report_error_now tenv (st_report_error: st_report_error) err_instance loc pd in ( IssueType.eradicate_inconsistent_subclass_parameter_annotation , Format.asprintf - "%s parameter %a of method %a is not %a but is declared %ain the parent class method %a." - (translate_position pos) MF.pp_monospaced param_name MF.pp_monospaced + "%s parameter %a of method %a is not %a but is declared %ain the parent class method \ + %a." (translate_position pos) MF.pp_monospaced param_name MF.pp_monospaced (Typ.Procname.to_simplified_string ~withclass:true pn) MF.pp_monospaced "@Nullable" MF.pp_monospaced "@Nullable" MF.pp_monospaced (Typ.Procname.to_simplified_string ~withclass:true opn) diff --git a/infer/src/integration/Buck.ml b/infer/src/integration/Buck.ml index 1e05fc2c8..6a0071f77 100644 --- a/infer/src/integration/Buck.ml +++ b/infer/src/integration/Buck.ml @@ -258,12 +258,12 @@ let rec exceed_length ~max = function let store_args_in_file args = - if exceed_length ~max:max_command_line_length args then + if exceed_length ~max:max_command_line_length args then ( let file = Filename.temp_file "buck_targets_" ".txt" in let write_args outc = Out_channel.output_string outc (String.concat ~sep:"\n" args) in let () = Utils.with_file_out file ~f:write_args in L.(debug Capture Quiet) "Buck targets options stored in file '%s'@\n" file ; - [Printf.sprintf "@%s" file] + [Printf.sprintf "@%s" file] ) else args diff --git a/infer/src/integration/CaptureCompilationDatabase.ml b/infer/src/integration/CaptureCompilationDatabase.ml index f329a1886..5e5847641 100644 --- a/infer/src/integration/CaptureCompilationDatabase.ml +++ b/infer/src/integration/CaptureCompilationDatabase.ml @@ -84,7 +84,8 @@ let run_compilation_database compilation_database should_capture_file = L.(debug Analysis Medium) "Ran %d jobs" number_of_jobs ; if sentinel_exists fail_sentinel then ( L.progress - "Failure detected, capture did not finish successfully. Use `--linters-ignore-clang-failures` to ignore compilation errors. Terminating@." ; + "Failure detected, capture did not finish successfully. Use \ + `--linters-ignore-clang-failures` to ignore compilation errors. Terminating@." ; L.exit 1 ) diff --git a/infer/src/integration/Diff.ml b/infer/src/integration/Diff.ml index 64a366c03..2411ec0db 100644 --- a/infer/src/integration/Diff.ml +++ b/infer/src/integration/Diff.ml @@ -27,8 +27,8 @@ let checkout revision = match script_opt with | None -> L.(die UserError) - "Please specify a script to checkout the %a revision of your project using --checkout-%a