diff --git a/infer/src/backend/DB.ml b/infer/src/backend/DB.ml index 59196c366..be0721f44 100644 --- a/infer/src/backend/DB.ml +++ b/infer/src/backend/DB.ml @@ -142,12 +142,12 @@ let find_source_dirs () = let add_cg_files_from_dir dir = let files = Array.to_list (Sys.readdir dir) in list_iter (fun fname -> - let path = Filename.concat dir fname in - if Filename.check_suffix path ".cg" then source_dirs := dir :: !source_dirs) + let path = Filename.concat dir fname in + if Filename.check_suffix path ".cg" then source_dirs := dir :: !source_dirs) files in list_iter (fun fname -> - let dir = Filename.concat capt_dir fname in - if Sys.is_directory dir then add_cg_files_from_dir dir) + let dir = Filename.concat capt_dir fname in + if Sys.is_directory dir then add_cg_files_from_dir dir) files_in_results_dir; list_rev !source_dirs @@ -193,15 +193,15 @@ let create_dir dir = try if (Unix.stat dir).Unix.st_kind != Unix.S_DIR then (L.err "@.ERROR: file %s exists and is not a directory@." dir; - assert false) + assert false) with Unix.Unix_error _ -> - (try Unix.mkdir dir 0o700 with - Unix.Unix_error _ -> - let created_concurrently = (* check if another process created it meanwhile *) - (Unix.stat dir).Unix.st_kind = Unix.S_DIR in - if not created_concurrently then - (L.err "@.ERROR: cannot create directory %s@." dir; - assert false)) + (try Unix.mkdir dir 0o700 with + Unix.Unix_error _ -> + let created_concurrently = (* check if another process created it meanwhile *) + (Unix.stat dir).Unix.st_kind = Unix.S_DIR in + if not created_concurrently then + (L.err "@.ERROR: cannot create directory %s@." dir; + assert false)) let read_whole_file fd = let stats = Unix.fstat fd in @@ -216,9 +216,9 @@ let read_whole_file fd = buf (** Update the file contents with the update function provided. -If the directory does not exist, it is created. -If the file does not exist, it is created, and update is given the empty string. -A lock is used to allow write attempts in parallel. *) + If the directory does not exist, it is created. + If the file does not exist, it is created, and update is given the empty string. + A lock is used to allow write attempts in parallel. *) let update_file_with_lock dir fname update = let reset_file fd = let n = Unix.lseek fd 0 Unix.SEEK_SET in @@ -238,7 +238,7 @@ let update_file_with_lock dir fname update = if (i = (String.length str)) then (Unix.lockf fd Unix.F_ULOCK 0; Unix.close fd) else (L.err "@.save_with_lock: fail on path: %s@." path; - assert false) + assert false) (** Read a file using a lock to allow write attempts in parallel. *) let read_file_with_lock dir fname = @@ -252,8 +252,8 @@ let read_file_with_lock dir fname = Unix.close fd; Some buf with Unix.Unix_error _ -> - L.stderr "read_file_with_lock: Unix error"; - assert false + L.stderr "read_file_with_lock: Unix error"; + assert false with Unix.Unix_error _ -> None (** {2 Results Directory} *) diff --git a/infer/src/backend/abs.ml b/infer/src/backend/abs.ml index e4a0f1bb0..0abb70745 100644 --- a/infer/src/backend/abs.ml +++ b/infer/src/backend/abs.ml @@ -421,10 +421,10 @@ let typ_get_recursive_flds tenv te = match te with | Sil.Sizeof (typ, _) -> (match typ with - | Sil.Tvar _ -> assert false (* there should be no indirection *) - | Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> [] - | Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> list_map (fun (x, y, z) -> x) (list_filter filter fld_typ_ann_list) - | Sil.Tarray _ -> []) + | Sil.Tvar _ -> assert false (* there should be no indirection *) + | Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> [] + | Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> list_map (fun (x, y, z) -> x) (list_filter filter fld_typ_ann_list) + | Sil.Tarray _ -> []) | Sil.Var _ -> [] (* type of |-> not known yet *) | Sil.Const _ -> [] | _ -> @@ -933,7 +933,7 @@ let create_absrules_from_tdecl tenv tname = match is_simply_recursive tenv tname with | None -> () | Some (fld) -> - (* L.out "@[.... Adding Abstraction Rules ....@\n@."; *) + (* L.out "@[.... Adding Abstraction Rules ....@\n@."; *) let para = create_hpara_from_tname_flds tenv tname fld [] [] Sil.inst_abstraction in abs_rules_add_sll para else () @@ -949,27 +949,27 @@ let abstract_pure_part p ~(from_abstract_footprint: bool) = let filter atom = let fav' = Sil.atom_fav atom in Sil.fav_for_all fav' (fun id -> - if Ident.is_primed id then Sil.fav_mem fav_sigma id - else if Ident.is_footprint id then Sil.fav_mem fav_nonpure id - else true) in + if Ident.is_primed id then Sil.fav_mem fav_sigma id + else if Ident.is_footprint id then Sil.fav_mem fav_nonpure id + else true) in list_filter filter pure in let new_pure = list_fold_left (fun pi a -> - match a with - | Sil.Aneq (Sil.Var name, _) -> a:: pi - (* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *) - | Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Lt, _, _)) - | Sil.Aeq (Sil.BinOp (Sil.Lt, _, _), Sil.Const (Sil.Cint i)) - | Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Le, _, _)) - | Sil.Aeq (Sil.BinOp (Sil.Le, _, _), Sil.Const (Sil.Cint i)) when Sil.Int.isone i -> - a :: pi - | Sil.Aeq (Sil.Var name, e) when not (Ident.is_primed name) -> - (match e with - | Sil.Var _ - | Sil.Const _ -> a :: pi - | _ -> pi) - | _ -> pi) + match a with + | Sil.Aneq (Sil.Var name, _) -> a:: pi + (* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *) + | Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Lt, _, _)) + | Sil.Aeq (Sil.BinOp (Sil.Lt, _, _), Sil.Const (Sil.Cint i)) + | Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Le, _, _)) + | Sil.Aeq (Sil.BinOp (Sil.Le, _, _), Sil.Const (Sil.Cint i)) when Sil.Int.isone i -> + a :: pi + | Sil.Aeq (Sil.Var name, e) when not (Ident.is_primed name) -> + (match e with + | Sil.Var _ + | Sil.Const _ -> a :: pi + | _ -> pi) + | _ -> pi) [] pi_filtered in list_rev new_pure in @@ -988,8 +988,8 @@ let abstract_gc p = let p_without_pi = Prop.normalize (Prop.replace_pi [] p) in let fav_p_without_pi = Prop.prop_fav p_without_pi in (* let weak_filter atom = - let fav_atom = atom_fav atom in - list_intersect compare fav_p_without_pi fav_atom in *) + let fav_atom = atom_fav atom in + list_intersect compare fav_p_without_pi fav_atom in *) let strong_filter = function | Sil.Aeq(e1, e2) | Sil.Aneq(e1, e2) -> let fav_e1 = Sil.exp_fav e1 in @@ -1046,8 +1046,8 @@ let sigma_reachable root_fav sigma = if modified then find_fixpoint edges_to_revisit in find_fixpoint !edges; (* L.d_str "reachable: "; - Ident.IdentSet.iter (fun id -> Sil.d_exp (Sil.Var id); L.d_str " ") !reach_set; - L.d_ln (); *) + Ident.IdentSet.iter (fun id -> Sil.d_exp (Sil.Var id); L.d_str " ") !reach_set; + L.d_ln (); *) !reach_set let get_cycle root prop = @@ -1056,19 +1056,19 @@ let get_cycle root prop = match e with | Sil.Eexp(e', _) -> (try - Some(list_find (fun hpred -> match hpred with - | Sil.Hpointsto(e'', _, _) -> Sil.exp_equal e'' e' - | _ -> false) sigma) - with _ -> None) + Some(list_find (fun hpred -> match hpred with + | Sil.Hpointsto(e'', _, _) -> Sil.exp_equal e'' e' + | _ -> false) sigma) + with _ -> None) | _ -> None in let print_cycle cyc = (L.d_str "Cycle= "; - list_iter (fun ((e, t), f, e') -> - match e, e' with - | Sil.Eexp (e, _), Sil.Eexp (e', _) -> - L.d_str ("("^(Sil.exp_to_string e)^": "^(Sil.typ_to_string t)^", "^(Ident.fieldname_to_string f)^", "^(Sil.exp_to_string e')^")") - | _ -> ()) cyc; - L.d_strln "") in + list_iter (fun ((e, t), f, e') -> + match e, e' with + | Sil.Eexp (e, _), Sil.Eexp (e', _) -> + L.d_str ("("^(Sil.exp_to_string e)^": "^(Sil.typ_to_string t)^", "^(Ident.fieldname_to_string f)^", "^(Sil.exp_to_string e')^")") + | _ -> ()) cyc; + L.d_strln "") in (* perform a dfs of a graph stopping when e_root is reached. *) (* Returns a pair (path, bool) where path is a list of edges ((e1,type_e1),f,e2) *) (* describing the path to e_root and bool is true if e_root is reached. *) @@ -1129,7 +1129,7 @@ let full_reachability_algorithm = true let should_raise_objc_leak prop hpred = match hpred with | Sil.Hpointsto(e, Sil.Estruct((fn, Sil.Eexp( (Sil.Const (Sil.Cint i)), _)):: _, _), Sil.Sizeof (typ, _)) - when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) -> + when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) -> Mleak_buckets.should_raise_leak typ | _ -> None @@ -1155,7 +1155,7 @@ let get_var_retain_cycle _prop = let is_hpred_block v h = match h, v with | Sil.Hpointsto (e, _, Sil.Sizeof(typ, _)), Sil.Eexp (e', _) - when Sil.exp_equal e e' && Sil.is_block_type typ -> true + when Sil.exp_equal e e' && Sil.is_block_type typ -> true | _, _ -> false in let find_pvar v = try @@ -1171,8 +1171,8 @@ let get_var_retain_cycle _prop = match find_pvar e with | Some pvar -> [((sexp pvar, t), f, e')] | _ -> (match find_block e with - | Some blk -> [((sexp blk, t), f, e')] - | _ -> [((sexp (Sil.Sizeof(t, Sil.Subtype.exact)), t), f, e')]) in + | Some blk -> [((sexp blk, t), f, e')] + | _ -> [((sexp (Sil.Sizeof(t, Sil.Subtype.exact)), t), f, e')]) in (* returns the pvars of the first cycle we find in sigma. *) (* This is an heuristic that works if there is one cycle. *) (* In case there are more than one cycle we may return not necessarily*) @@ -1202,7 +1202,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle = | Sil.Tstruct(nsf, sf, _, _, _, _, _) -> let ia = ref [] in list_iter (fun (fn', t', ia') -> - if Ident.fieldname_equal fn fn' then ia := ia') (nsf@sf); + if Ident.fieldname_equal fn fn' then ia := ia') (nsf@sf); !ia | _ -> [] in let rec has_weak_or_unretained_or_assign params = @@ -1212,7 +1212,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle = | _:: params' -> has_weak_or_unretained_or_assign params' in let do_annotation (a, _) = ((a.Sil.class_name = Config.property_attributes) || - (a.Sil.class_name = Config.ivar_attributes)) && has_weak_or_unretained_or_assign a.Sil.parameters in + (a.Sil.class_name = Config.ivar_attributes)) && has_weak_or_unretained_or_assign a.Sil.parameters in let rec do_cycle c = match c with | [] -> false @@ -1308,26 +1308,26 @@ let check_junk ?original_prop pname tenv prop = Exceptions.Leak (fp_part, prop, hpred, Errdesc.explain_leak tenv hpred prop alloc_attribute objc_ml_bucket_opt, !Absarray.array_abstraction_performed, resource, try assert false with Assert_failure x -> x) in let ignore_resource, exn = (match alloc_attribute, resource with - | Some _, Sil.Rmemory Sil.Mobjc when (hpred_in_cycle hpred) -> - (* When there is a cycle in objc we ignore it only if it has weak or unsafe_unretained fields *) - (* Otherwise we report a retain cycle*) - let cycle = get_var_retain_cycle (remove_opt original_prop) in - if cycle_has_weak_or_unretained_or_assign_field cycle then - true, exn_retain_cycle cycle - else false, exn_retain_cycle cycle - | Some _, Sil.Rmemory Sil.Mobjc -> - objc_ml_bucket_opt = None, exn_leak - | Some _, Sil.Rmemory _ -> !Sil.curr_language = Sil.Java, exn_leak - | Some _, Sil.Rignore -> true, exn_leak - | Some _, Sil.Rfile -> false, exn_leak - | Some _, Sil.Rlock -> false, exn_leak - | _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter hpred -> - (* When its a cycle and the object has a ref counter then *) - (* we have a retain cycle. Objc object may not have the *) - (* Sil.Mobjc qualifier when added in footprint doing abduction *) - let cycle = get_var_retain_cycle (remove_opt original_prop) in - false, exn_retain_cycle cycle - | _ -> !Sil.curr_language = Sil.Java, exn_leak) in + | Some _, Sil.Rmemory Sil.Mobjc when (hpred_in_cycle hpred) -> + (* When there is a cycle in objc we ignore it only if it has weak or unsafe_unretained fields *) + (* Otherwise we report a retain cycle*) + let cycle = get_var_retain_cycle (remove_opt original_prop) in + if cycle_has_weak_or_unretained_or_assign_field cycle then + true, exn_retain_cycle cycle + else false, exn_retain_cycle cycle + | Some _, Sil.Rmemory Sil.Mobjc -> + objc_ml_bucket_opt = None, exn_leak + | Some _, Sil.Rmemory _ -> !Sil.curr_language = Sil.Java, exn_leak + | Some _, Sil.Rignore -> true, exn_leak + | Some _, Sil.Rfile -> false, exn_leak + | Some _, Sil.Rlock -> false, exn_leak + | _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter hpred -> + (* When its a cycle and the object has a ref counter then *) + (* we have a retain cycle. Objc object may not have the *) + (* Sil.Mobjc qualifier when added in footprint doing abduction *) + let cycle = get_var_retain_cycle (remove_opt original_prop) in + false, exn_retain_cycle cycle + | _ -> !Sil.curr_language = Sil.Java, exn_leak) in let ignore_leak = !Config.allowleak || ignore_resource || is_undefined in let report_and_continue = !Config.footprint in (* in footprint mode, report leak and continue *) let already_reported () = @@ -1367,7 +1367,7 @@ let check_junk ?original_prop pname tenv prop = else Prop.normalize (Prop.replace_sigma sigma_new (Prop.replace_sigma_footprint sigma_fp_new prop)) (** Check whether the prop contains junk. -If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *) + If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *) let abstract_junk ?original_prop pname tenv prop = Absarray.array_abstraction_performed := false; check_junk ~original_prop: original_prop pname tenv prop @@ -1427,7 +1427,7 @@ let remove_local_stack sigma pvars = list_filter filter_non_stack sigma (** [prop_set_fooprint p p_foot] removes a local stack from [p_foot], -and sets proposition [p_foot] as footprint of [p]. *) + and sets proposition [p_foot] as footprint of [p]. *) let set_footprint_for_abs (p : 'a Prop.t) (p_foot : 'a Prop.t) local_stack_pvars : Prop.exposed Prop.t = let p_foot_pure = Prop.get_pure p_foot in let p_foot_sigma = Prop.get_sigma p_foot in diff --git a/infer/src/backend/absarray.ml b/infer/src/backend/absarray.ml index bf5eb314a..fceea95fe 100644 --- a/infer/src/backend/absarray.ml +++ b/infer/src/backend/absarray.ml @@ -18,7 +18,7 @@ type sigma = Sil.hpred list (** Matcher for the sigma part specialized to strexps *) module StrexpMatch : sig -(** path through a strexp *) + (** path through a strexp *) type path (** convert a path into a list of expressions *) @@ -156,7 +156,7 @@ end = struct let t = (fun (x,y,z) -> y) (list_find (fun (f', t, a) -> Sil.fld_equal f' f) ftal) in find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t with Not_found -> - L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find") + L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find") end; find_offset_fsel sigma_other hpred root offs fsel' ftal typ and find_offset_esel sigma_other hpred root offs esel t = match esel with @@ -247,20 +247,20 @@ end = struct end (** This function renames expressions in [p]. The renaming is, roughly -speaking, to replace [path.i] by [path.i'] for all (i, i') in [map]. *) + speaking, to replace [path.i] by [path.i'] for all (i, i') in [map]. *) let prop_replace_path_index (p: Prop.exposed Prop.t) (path: StrexpMatch.path) (map : (Sil.exp * Sil.exp) list) : Prop.exposed Prop.t -= + = let elist_path = StrexpMatch.path_to_exps path in let expmap_list = list_fold_left (fun acc_outer e_path -> - list_fold_left (fun acc_inner (old_index, new_index) -> - let old_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, old_index)) in - let new_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, new_index)) in - (old_e_path_index, new_e_path_index) :: acc_inner - ) acc_outer map + list_fold_left (fun acc_inner (old_index, new_index) -> + let old_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, old_index)) in + let new_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, new_index)) in + (old_e_path_index, new_e_path_index) :: acc_inner + ) acc_outer map ) [] elist_path in let expmap_fun e' = try @@ -270,11 +270,11 @@ let prop_replace_path_index Prop.prop_expmap expmap_fun p (** This function uses [update] and transforms the two sigma parts of [p], -the sigma of the current SH of [p] and that of the footprint of [p]. *) + the sigma of the current SH of [p] and that of the footprint of [p]. *) let prop_update_sigma_and_fp_sigma (p : Prop.normal Prop.t) (update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool -= + = let sigma', changed = update false (Prop.get_sigma p) in let ep1 = Prop.replace_sigma sigma' p in let ep2, changed2 = @@ -285,13 +285,13 @@ let prop_update_sigma_and_fp_sigma (Prop.normalize ep2, changed || changed2) (** This function uses [update] and transforms the sigma of the -current SH of [p] or that of the footprint of [p], depending on -[footprint_part]. *) + current SH of [p] or that of the footprint of [p], depending on + [footprint_part]. *) let prop_update_sigma_or_fp_sigma (footprint_part : bool) (p : Prop.normal Prop.t) (update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool -= + = let ep1, changed1 = if footprint_part then (Prop.expose p, false) else @@ -311,15 +311,15 @@ let prop_update_sigma_or_fp_sigma let array_abstraction_performed = ref false (** This function abstracts strexps. The parameter [can_abstract] spots strexps -where the abstraction might be applicable, and the parameter [do_abstract] does -the abstraction to those spotted strexps. *) + where the abstraction might be applicable, and the parameter [do_abstract] does + the abstraction to those spotted strexps. *) let generic_strexp_abstract (abstraction_name : string) (p_in : Prop.normal Prop.t) (_can_abstract : sigma -> StrexpMatch.strexp_data -> bool) (do_abstract : bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool) -: Prop.normal Prop.t -= + : Prop.normal Prop.t + = let can_abstract s data = let r = _can_abstract s data in if r then array_abstraction_performed := true; @@ -382,7 +382,7 @@ let blur_array_index (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Sil.exp) : Prop.normal Prop.t -= + = try let fresh_index = Sil.Var (Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) in let p2 = @@ -415,7 +415,7 @@ let blur_array_indices (p: Prop.normal Prop.t) (root: StrexpMatch.path) (indices: Sil.exp list) : Prop.normal Prop.t * bool -= + = let f prop index = blur_array_index footprint_part prop root index in (list_fold_left f p indices, list_length indices > 0) @@ -426,7 +426,7 @@ let keep_only_indices (p: Prop.normal Prop.t) (path: StrexpMatch.path) (indices: Sil.exp list) : Prop.normal Prop.t * bool -= + = let prune_sigma footprint_part sigma = try let matched = StrexpMatch.find_path sigma path in @@ -559,8 +559,8 @@ let check_after_array_abstraction prop = else list_iter (fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) esel | Sil.Estruct (fsel, _) -> list_iter (fun (f, se) -> - let typ_f = Sil.struct_typ_fld (Some Sil.Tvoid) f typ in - check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in + let typ_f = Sil.struct_typ_fld (Some Sil.Tvoid) f typ in + check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in let check_hpred = function | Sil.Hpointsto (root, se, texp) -> let typ = Sil.texp_to_typ (Some Sil.Tvoid) texp in @@ -593,7 +593,7 @@ let remove_redundant_elements prop = let favl_foot = Sil.fav_to_list fav_foot in Sil.fav_duplicates := false; (* L.d_str "favl_curr "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_curr; L.d_ln(); - L.d_str "favl_foot "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_foot; L.d_ln(); *) + L.d_str "favl_foot "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_foot; L.d_ln(); *) let num_occur l id = list_length (list_filter (fun id' -> Ident.equal id id') l) in let at_most_once v = num_occur favl_curr v <= 1 && num_occur favl_foot v <= 1 in diff --git a/infer/src/backend/autounit.ml b/infer/src/backend/autounit.ml index 063db1373..16965257f 100644 --- a/infer/src/backend/autounit.ml +++ b/infer/src/backend/autounit.ml @@ -21,7 +21,7 @@ module IdMap = Map.Make (Ident) (** maps from identifiers *) (** Constraint solving module *) module Constraint : sig -(** Collect constraints on [vars] from [pi], and return a satisfying instantiation *) + (** Collect constraints on [vars] from [pi], and return a satisfying instantiation *) val solve_from_pure : Sil.atom list -> Ident.t list -> Sil.Int.t IdMap.t end = struct (** flag for debug mode of the module *) @@ -162,9 +162,9 @@ end = struct if !found = None then search_down (); if !found = None then (L.err "Constraint Error: empty range %a@." (pp_range id) rng; - rng.top <- Some Sil.Int.zero; - rng.bottom <- Some Sil.Int.zero; - rng.excluded <- []) + rng.top <- Some Sil.Int.zero; + rng.bottom <- Some Sil.Int.zero; + rng.excluded <- []) (** return the solution if the id is solved (has unique solution) *) let solved ev id = @@ -239,20 +239,20 @@ end = struct add_excluded rng id n | Sil.Var id1, Sil.Var id2 -> (match solved ev id1, solved ev id2 with - | None, None -> () - | Some _, Some _ -> () - | Some n1, None -> - do_neq (Sil.exp_int n1) e2 - | None, Some n2 -> - do_neq e1 (Sil.exp_int n2)) + | None, None -> () + | Some _, Some _ -> () + | Some n1, None -> + do_neq (Sil.exp_int n1) e2 + | None, Some n2 -> + do_neq e1 (Sil.exp_int n2)) | Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint n)) -> (match solved ev id1, solved ev id2 with - | None, None -> () - | Some _, Some _ -> () - | Some n1, None -> - do_neq (Sil.exp_int (n1 -- n)) (Sil.Var id2) - | None, Some n2 -> - do_neq (Sil.Var id1) (Sil.exp_int (n2 ++ n))) + | None, None -> () + | Some _, Some _ -> () + | Some n1, None -> + do_neq (Sil.exp_int (n1 -- n)) (Sil.Var id2) + | None, Some n2 -> + do_neq (Sil.Var id1) (Sil.exp_int (n2 ++ n))) | _ -> if debug then assert false in let do_ident id = if debug then F.fprintf F.std_formatter "constraints before doing %a:@.%a@." (Ident.pp pe_text) id pp_eval ev; @@ -442,9 +442,9 @@ let gen_sigma code proc_name spec_num env idmap sigma = list_iter (fun (f, se) -> do_strexp code' (base ^ accessor ^ Ident.fieldname_to_string f) false se) fsel | Sil.Earray (size, esel, _) -> list_iter (fun (e, se) -> - let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in - let index = pp_to_string pp () in - do_strexp code' (base ^ "[" ^ index ^ "]") false se) esel in + let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in + let index = pp_to_string pp () in + do_strexp code' (base ^ "[" ^ index ^ "]") false se) esel in let gen_hpred = function | Sil.Hpointsto (Sil.Lvar pvar, se, _) -> diff --git a/infer/src/backend/buckets.ml b/infer/src/backend/buckets.ml index 5f9dafc03..e59465e60 100644 --- a/infer/src/backend/buckets.ml +++ b/infer/src/backend/buckets.ml @@ -17,7 +17,7 @@ open Utils let verbose = Config.trace_error (** check if the error was reported inside a nested loop -the implementation is approximate: check if the last two visits to a loop were entering loops *) + the implementation is approximate: check if the last two visits to a loop were entering loops *) let check_nested_loop path pos_opt = let trace_length = ref 0 in let loop_visits_log = ref [] in @@ -28,7 +28,7 @@ let check_nested_loop path pos_opt = | _ -> false in let do_node_caller node = match Cfg.Node.get_kind node with | Cfg.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _) -> - (* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *) + (* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *) loop_visits_log := b :: !loop_visits_log | _ -> () in let do_any_node level node = @@ -44,7 +44,7 @@ let check_nested_loop path pos_opt = in_nested_loop () (** Check that we know where the value was last assigned, -and that there is a local access instruction at that line. **) + and that there is a local access instruction at that line. **) let check_access access_opt de_opt = let find_bucket line_number null_case_flag = let find_formal_ids node = (* find ids obtained by a letref on a formal parameter *) diff --git a/infer/src/backend/callbacks.ml b/infer/src/backend/callbacks.ml index 118f3d245..571318537 100644 --- a/infer/src/backend/callbacks.ml +++ b/infer/src/backend/callbacks.ml @@ -29,24 +29,24 @@ let inline_synthetic_method ret_ids etl proc_desc proc_name loc_call : Sil.instr let instr' = Sil.Letderef (ret_id, Sil.Lfield (e1, fn, ft), bt, loc_call) in found instr instr' | Sil.Letderef (id1, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc), [ret_id], [] - when Sil.pvar_is_global pvar -> (* getter for static fields *) + when Sil.pvar_is_global pvar -> (* getter for static fields *) let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in found instr instr' | Sil.Set (Sil.Lfield (ex1, fn, ft), bt , ex2, loc), _, [(e1, t1); (e2, t2)] -> (* setter for fields *) let instr' = Sil.Set (Sil.Lfield (e1, fn, ft), bt , e2, loc_call) in found instr instr' | Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , ex2, loc), _, [(e1, t1)] - when Sil.pvar_is_global pvar -> (* setter for static fields *) + when Sil.pvar_is_global pvar -> (* setter for static fields *) let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in found instr instr' | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _ - when list_length ret_ids = list_length ret_ids' - && list_length etl' = list_length etl -> + when list_length ret_ids = list_length ret_ids' + && list_length etl' = list_length etl -> let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in found instr instr' | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _ - when list_length ret_ids = list_length ret_ids' - && list_length etl' + 1 = list_length etl -> + when list_length ret_ids = list_length ret_ids' + && list_length etl' + 1 = list_length etl -> let etl1 = match list_rev etl with (* remove last element *) | _ :: l -> list_rev l | [] -> assert false in @@ -61,15 +61,15 @@ let proc_inline_synthetic_methods cfg proc_desc : unit = let instr_inline_synthetic_method = function | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc, _) -> (match Cfg.Procdesc.find_from_name cfg pn with - | Some pd -> - let is_access = Procname.java_is_access_method pn in - let attributes = Cfg.Procdesc.get_attributes pd in - let is_synthetic = attributes.Sil.is_synthetic_method in - let is_bridge = attributes.Sil.is_bridge_method in - if is_access || is_bridge || is_synthetic - then inline_synthetic_method ret_ids etl pd pn loc - else None - | None -> None) + | Some pd -> + let is_access = Procname.java_is_access_method pn in + let attributes = Cfg.Procdesc.get_attributes pd in + let is_synthetic = attributes.Sil.is_synthetic_method in + let is_bridge = attributes.Sil.is_bridge_method in + if is_access || is_bridge || is_synthetic + then inline_synthetic_method ret_ids etl pd pn loc + else None + | None -> None) | _ -> None in let node_inline_synthetic_methods node = let modified = ref false in @@ -119,10 +119,10 @@ let get_procedure_definition exe_env proc_name = let tenv = Exe_env.get_tenv exe_env proc_name in Option.map (fun proc_desc -> - proc_inline_synthetic_methods cfg proc_desc; - let idenv = Idenv.create cfg proc_desc - and language = (Cfg.Procdesc.get_attributes proc_desc).Sil.language in - (idenv, tenv, proc_name, proc_desc, language)) + proc_inline_synthetic_methods cfg proc_desc; + let idenv = Idenv.create cfg proc_desc + and language = (Cfg.Procdesc.get_attributes proc_desc).Sil.language in + (idenv, tenv, proc_name, proc_desc, language)) (Cfg.Procdesc.find_from_name cfg proc_name) let get_language proc_name = if Procname.is_java proc_name then Sil.Java else Sil.C_CPP @@ -146,19 +146,19 @@ let iterate_procedure_callbacks all_procs exe_env proc_name = Option.may (fun (idenv, tenv, proc_name, proc_desc, language) -> - list_iter - (fun (language_opt, proc_callback) -> - let language_matches = match language_opt with - | Some language -> language = procedure_language - | None -> true in - if language_matches then - begin - let init_time = Unix.gettimeofday () in - proc_callback all_procs get_procdesc idenv tenv proc_name proc_desc; - let elapsed = Unix.gettimeofday () -. init_time in - update_time proc_name elapsed - end) - !procedure_callbacks) + list_iter + (fun (language_opt, proc_callback) -> + let language_matches = match language_opt with + | Some language -> language = procedure_language + | None -> true in + if language_matches then + begin + let init_time = Unix.gettimeofday () in + proc_callback all_procs get_procdesc idenv tenv proc_name proc_desc; + let elapsed = Unix.gettimeofday () -. init_time in + update_time proc_name elapsed + end) + !procedure_callbacks) (get_procedure_definition exe_env proc_name) (** Invoke all registered cluster callbacks on a cluster of procedures. *) @@ -187,9 +187,9 @@ let iterate_cluster_callbacks all_procs exe_env proc_names = list_iter (fun (language_opt, cluster_callback) -> - let proc_names = relevant_procedures language_opt in - if list_length proc_names > 0 then - cluster_callback all_procs get_procdesc environment) + let proc_names = relevant_procedures language_opt in + if list_length proc_names > 0 then + cluster_callback all_procs get_procdesc environment) !cluster_callbacks (** Invoke all procedure and cluster callbacks on a given environment. *) @@ -205,9 +205,9 @@ let iterate_callbacks store_summary call_graph exe_env = let cluster_map = list_fold_left (fun map proc_name -> - let proc_cluster = cluster_id proc_name in - let bucket = try StringMap.find proc_cluster map with Not_found -> [] in - StringMap.add proc_cluster (proc_name:: bucket) map) + let proc_cluster = cluster_id proc_name in + let bucket = try StringMap.find proc_cluster map with Not_found -> [] in + StringMap.add proc_cluster (proc_name:: bucket) map) StringMap.empty proc_names in (* Return all values of the map *) diff --git a/infer/src/backend/cfg.ml b/infer/src/backend/cfg.ml index 18baf8f35..2a6b07774 100644 --- a/infer/src/backend/cfg.ml +++ b/infer/src/backend/cfg.ml @@ -249,7 +249,7 @@ module Node = struct | Join_node, _ -> -1 | _, Join_node -> 1 | Prune_node (is_true_branch1, if_kind1, descr1), - Prune_node (is_true_branch2, if_kind2, descr2) -> + Prune_node (is_true_branch2, if_kind2, descr2) -> let n = bool_compare is_true_branch1 is_true_branch2 in if n <> 0 then n else let n = Pervasives.compare if_kind1 if_kind2 in if n <> 0 then n else string_compare descr1 descr2 @@ -373,11 +373,11 @@ module Node = struct let proc_desc_remove cfg name remove_nodes = (if remove_nodes then - let pdesc = pdesc_tbl_find cfg name in - let proc_nodes = - list_fold_right (fun node set -> NodeSet.add node set) - pdesc.pd_nodes NodeSet.empty in - remove_node_set cfg proc_nodes); + let pdesc = pdesc_tbl_find cfg name in + let proc_nodes = + list_fold_right (fun node set -> NodeSet.add node set) + pdesc.pd_nodes NodeSet.empty in + remove_node_set cfg proc_nodes); pdesc_tbl_remove cfg name let proc_desc_get_start_node proc_desc = @@ -546,27 +546,27 @@ module Node = struct let proc_desc_iter_slope f proc_desc = let visited = ref NodeSet.empty in let rec do_node node = begin - visited := NodeSet.add node !visited; - f node; - match get_succs node with - | [n] -> if not (NodeSet.mem n !visited) then do_node n - | _ -> () - end in + visited := NodeSet.add node !visited; + f node; + match get_succs node with + | [n] -> if not (NodeSet.mem n !visited) then do_node n + | _ -> () + end in do_node (proc_desc_get_start_node proc_desc) (** iterate between two nodes or until we reach a branching structure *) let proc_desc_iter_slope_range f proc_desc src_node dst_node = let visited = ref NodeSet.empty in let rec do_node node = begin - visited := NodeSet.add node !visited; - f node; - match get_succs node with - | [n] -> - if not (NodeSet.mem n !visited) - && not (equal node dst_node) - then do_node n - | _ -> () - end in + visited := NodeSet.add node !visited; + f node; + match get_succs node with + | [n] -> + if not (NodeSet.mem n !visited) + && not (equal node dst_node) + then do_node n + | _ -> () + end in do_node src_node let proc_desc_iter_slope_calls f proc_desc = @@ -611,7 +611,7 @@ let save_source_files cfg = Node.proc_desc_is_defined pdesc && Sys.file_exists source_file_str && (not (Sys.file_exists dest_file_str) || - DB.file_modified_time (DB.filename_from_string source_file_str) > DB.file_modified_time dest_file) in + DB.file_modified_time (DB.filename_from_string source_file_str) > DB.file_modified_time dest_file) in if needs_copy then match Utils.copy_file source_file_str dest_file_str with | Some _ -> () @@ -727,8 +727,8 @@ let get_defined_procs cfg = (** Get the objc procedures whose body is generated *) let get_objc_generated_procs cfg = list_filter ( - fun procdesc -> - (Procdesc.get_attributes procdesc).Sil.is_generated) (get_all_procs cfg) + fun procdesc -> + (Procdesc.get_attributes procdesc).Sil.is_generated) (get_all_procs cfg) (** get the function names which should be analyzed before the other ones *) let get_priority_procnames cfg = @@ -849,12 +849,12 @@ let remove_abducted_retvars p = let abducted_pvars, normal_pvars = list_fold_left (fun pvars hpred -> - match hpred with - | Sil.Hpointsto (Sil.Lvar pvar, _, _) -> - let abducted_pvars, normal_pvars = pvars in - if Sil.pvar_is_abducted pvar then pvar :: abducted_pvars, normal_pvars - else abducted_pvars, pvar :: normal_pvars - | _ -> pvars) + match hpred with + | Sil.Hpointsto (Sil.Lvar pvar, _, _) -> + let abducted_pvars, normal_pvars = pvars in + if Sil.pvar_is_abducted pvar then pvar :: abducted_pvars, normal_pvars + else abducted_pvars, pvar :: normal_pvars + | _ -> pvars) ([], []) (Prop.get_sigma p) in let _, p' = Prop.deallocate_stack_vars p abducted_pvars in @@ -894,7 +894,7 @@ let remove_locals_ret (curr_f : Procdesc.t) p = snd (remove_locals curr_f (remove_ret curr_f p)) (** Remove locals and formal parameters from the prop. -Return the list of stack variables whose address was still present after deallocation. *) + Return the list of stack variables whose address was still present after deallocation. *) let remove_locals_formals (curr_f : Procdesc.t) p = let pvars1, p1 = remove_formals curr_f p in let pvars2, p2 = remove_locals curr_f p1 in @@ -924,11 +924,11 @@ let check_cfg_connectedness cfg = | Node.Stmt_node _ | Node.Prune_node _ | Node.Skip_node _ -> (list_length succs = 0) || (list_length preds = 0) | Node.Join_node -> - (* Join node has the exception that it may be without predecessors and pointing to an exit node *) - (* if the if brances end with a return *) + (* Join node has the exception that it may be without predecessors and pointing to an exit node *) + (* if the if brances end with a return *) (match succs with - | [n'] when is_exit_node n' -> false - | _ -> (list_length preds = 0)) in + | [n'] when is_exit_node n' -> false + | _ -> (list_length preds = 0)) in let do_pdesc pd = let pname = Procname.to_string (Procdesc.get_proc_name pd) in let nodes = Procdesc.get_nodes pd in diff --git a/infer/src/backend/cg.ml b/infer/src/backend/cg.ml index db1f58168..95b1e9f02 100644 --- a/infer/src/backend/cg.ml +++ b/infer/src/backend/cg.ml @@ -53,15 +53,15 @@ let _add_node g n defined = let info = Procname.Hash.find g.node_map n in if defined then info.defined <- true with Not_found -> - let info = - { defined = defined; - parents = Procname.Set.empty; - children = Procname.Set.empty; - ancestors = None; - heirs = None; - recursive_dependents = None; - in_out_calls = None } in - Procname.Hash.add g.node_map n info + let info = + { defined = defined; + parents = Procname.Set.empty; + children = Procname.Set.empty; + ancestors = None; + heirs = None; + recursive_dependents = None; + in_out_calls = None } in + Procname.Hash.add g.node_map n info let add_node g n = _add_node g n true diff --git a/infer/src/backend/checkCopyright.ml b/infer/src/backend/checkCopyright.ml index 33592c2d8..c5b2d9bd3 100644 --- a/infer/src/backend/checkCopyright.ml +++ b/infer/src/backend/checkCopyright.ml @@ -56,10 +56,10 @@ let find_comment_start_and_style lines_arr n = let is_start line = match cur_line_comment with | Some (Line (s)) -> if string_is_prefix s line then None else Some (Line (s)) | _ -> try - Some (list_find (function - | Block(s, _, _) -> string_contains s line - | _ -> false) comment_styles) - with Not_found -> None in + Some (list_find (function + | Block(s, _, _) -> string_contains s line + | _ -> false) comment_styles) + with Not_found -> None in let i = ref (n - 1) in (* hacky fake line comment to avoid an option type *) let found = ref (-1, Line(">>>>>>>>>>>")) in diff --git a/infer/src/backend/config.ml b/infer/src/backend/config.ml index a48c5c9f2..04a5c5030 100644 --- a/infer/src/backend/config.ml +++ b/infer/src/backend/config.ml @@ -113,31 +113,31 @@ let project_root : string option ref = ref None (** FLAGS AND GLOBAL VARIABLES *) (** Flag for abstracting fields of structs -0 = no -1 = forget some fields during matching (and so lseg abstraction) *) + 0 = no + 1 = forget some fields during matching (and so lseg abstraction) *) let abs_struct = ref 1 (** Flag for abstracting numerical values -0 = no abstraction. -1 = evaluate all expressions abstractly. -2 = 1 + abstract constant integer values during join. + 0 = no abstraction. + 1 = evaluate all expressions abstractly. + 2 = 1 + abstract constant integer values during join. *) let abs_val = ref 2 (** if true, completely ignore the possibility that errors can be caused by unknown procedures -* during the symbolic execution phase *) + * during the symbolic execution phase *) let angelic_execution = ref true (** Flag for forgetting memory leak -false = no -true = forget leaked memory cells during abstraction + false = no + true = forget leaked memory cells during abstraction *) let allowleak = ref false (** Flag for ignoring arrays and pointer arithmetic. -0 = treats both features soundly. -1 = assumes that the size of every array is infinite. -2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct. + 0 = treats both features soundly. + 1 = assumes that the size of every array is infinite. + 2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct. *) let array_level = ref 0 @@ -186,14 +186,14 @@ let intraprocedural = ref false let join_plus = ref true (** Flag to tune the final information-loss check used by the join -0 = use the most aggressive join for preconditions -1 = use the least aggressive join for preconditions + 0 = use the most aggressive join for preconditions + 1 = use the least aggressive join for preconditions *) let join_cond = ref 1 (** Flag for turning on the transformation that -null is assigned to a program variable when it becomes dead. -**) + null is assigned to a program variable when it becomes dead. + **) let liveness = ref true (** if true, give static procs a long name filename::procname *) @@ -212,9 +212,9 @@ let max_num_proc = ref 0 let max_recursion = ref 5 (** Flag to tune the level of applying the meet operator for -preconditions during the footprint analysis. -0 = do not use the meet. -1 = use the meet to generate new preconditions. + preconditions during the footprint analysis. + 0 = do not use the meet. + 1 = use the meet to generate new preconditions. *) let meet_level = ref 1 @@ -258,9 +258,9 @@ let results_dir = ref default_results_dir let slice_fun = ref "" (** Flag to tune the level of abstracting the postconditions of specs discovered -by the footprint analysis. -0 = nothing special. -1 = filter out redundant posts implied by other posts. *) + by the footprint analysis. + 0 = nothing special. + 1 = filter out redundant posts implied by other posts. *) let spec_abs_level = ref 1 (** Flag for test mode *) @@ -294,15 +294,15 @@ let taint_analysis = ref false let trace_anal = ref false (** Flag for turning on the optimization based on locality -0 = no -1 = based on reachability + 0 = no + 1 = based on reachability *) let undo_join = ref true (** visit mode for the worklist: -0 depth - fist visit -1 bias towards exit node -2 least visited first *) + 0 depth - fist visit + 1 bias towards exit node + 2 least visited first *) let worklist_mode = ref 0 (** flag: if true write dot files in db dir*) @@ -328,16 +328,16 @@ let show_ml_buckets = ref false let dotty_cfg_libs = ref true (** if true, it deals with messages (method calls) in objective-c using the objective-c -typical semantics. That is: if the receiver is nil then the method is nop and it returns 0. -When the flag is false we deal with messages as standard method / function calls *) + typical semantics. That is: if the receiver is nil then the method is nop and it returns 0. + When the flag is false we deal with messages as standard method / function calls *) let objc_method_call_semantics = ref true (** if true, generate preconditions for runtime exceptions in Java and report errors for the public -methods having preconditions to throw runtime exceptions *) + methods having preconditions to throw runtime exceptions *) let report_runtime_exceptions = ref false (** if true, sanity-check inferred preconditions against Nullable annotations and report -inconsistencies *) + inconsistencies *) let report_nullable_inconsistency = ref true (** true if the current objective-c source file is compiled with automatic reference counting (ARC) *) @@ -356,11 +356,11 @@ module Experiment = struct let activate_subtyping_in_cpp = ref false (** if true, a precondition with e.g. index 3 in an array does not require the caller to have index 3 too - this mimics what happens with direct access to the array without a procedure call, where the index is simply materialized if not there *) + this mimics what happens with direct access to the array without a procedure call, where the index is simply materialized if not there *) let allow_missing_index_in_proc_call = ref true (** if true, a procedure call succeeds even when there is a bound error - this mimics what happens with a direct array access where an error is produced and the analysis continues *) + this mimics what happens with a direct array access where an error is produced and the analysis continues *) let bound_error_allowed_in_procedure_call = ref true end diff --git a/infer/src/backend/dom.ml b/infer/src/backend/dom.ml index 6e17741ab..933ed7907 100644 --- a/infer/src/backend/dom.ml +++ b/infer/src/backend/dom.ml @@ -85,13 +85,13 @@ let do_side side f e1 e2 = (** {2 Sets for expression pairs} *) module EPset = Set.Make - (struct - type t = Sil.exp * Sil.exp - let compare (e1, e1') (e2, e2') = - match (Sil.exp_compare e1 e2) with - | i when i <> 0 -> i - | _ -> Sil.exp_compare e1' e2' - end) + (struct + type t = Sil.exp * Sil.exp + let compare (e1, e1') (e2, e2') = + match (Sil.exp_compare e1 e2) with + | i when i <> 0 -> i + | _ -> Sil.exp_compare e1' e2' + end) let epset_add e e' set = match (Sil.exp_compare e e') with @@ -479,16 +479,16 @@ end = struct let (_, _, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e1 e1' && Sil.exp_equal e2 e2') !t in e with Not_found -> - let e = Sil.exp_get_undefined (JoinState.get_footprint ()) in - t := (e1, e2, e)::!t; - e + let e = Sil.exp_get_undefined (JoinState.get_footprint ()) in + t := (e1, e2, e)::!t; + e let lookup side e = try let (e1, e2, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e (select side e1' e2')) !t in Some (e, select (opposite side) e1 e2) with Not_found -> - None + None let get_induced_atom acc strict_lower upper e = let ineq_lower = Prop.mk_inequality (Sil.BinOp(Sil.Lt, strict_lower, e)) in @@ -516,8 +516,8 @@ end = struct let eqs_acc' = eq:: eqs_acc in f_eqs_entry entry eqs_acc' t_seen t_rest' with Not_found -> - let t_seen' = entry':: t_seen in - f_eqs_entry entry eqs_acc t_seen' t_rest' in + let t_seen' = entry':: t_seen in + f_eqs_entry entry eqs_acc t_seen' t_rest' in let rec f_eqs eqs_acc t_acc = function | [] -> (eqs_acc, t_acc) | entry:: t_rest -> @@ -610,12 +610,12 @@ end = struct let res = ref [] in let f v = match v, side with | (Sil.BinOp (Sil.PlusA, e1', Sil.Const (Sil.Cint i)), e2, e'), Lhs - when Sil.exp_equal e e1' -> + when Sil.exp_equal e e1' -> let c' = Sil.exp_int (Sil.Int.neg i) in let v' = (e1', Sil.BinOp(Sil.PlusA, e2, c'), Sil.BinOp (Sil.PlusA, e', c')) in res := v'::!res | (e1, Sil.BinOp (Sil.PlusA, e2', Sil.Const (Sil.Cint i)), e'), Rhs - when Sil.exp_equal e e2' -> + when Sil.exp_equal e e2' -> let c' = Sil.exp_int (Sil.Int.neg i) in let v' = (Sil.BinOp(Sil.PlusA, e1, c'), e2', Sil.BinOp (Sil.PlusA, e', c')) in res := v'::!res @@ -705,11 +705,11 @@ end = struct let others = get_others_direct_or_induced side e in let others' = get_others_direct_or_induced side e' in (match others, others' with - | None, _ | _, None -> None - | Some (e_res, e_op), Some(e_res', e_op') -> - let e_res'' = Sil.BinOp(op, e_res, e_res') in - let e_op'' = Sil.BinOp(op, e_op, e_op') in - Some (e_res'', e_op'')) + | None, _ | _, None -> None + | Some (e_res, e_op), Some(e_res', e_op') -> + let e_res'' = Sil.BinOp(op, e_res, e_res') in + let e_op'' = Sil.BinOp(op, e_op, e_op') in + Some (e_res'', e_op'')) | _ -> None let get_other_atoms side atom_in = @@ -739,22 +739,22 @@ end = struct begin match atom_in with | Sil.Aneq((Sil.Var id as e), e') | Sil.Aneq(e', (Sil.Var id as e)) - when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) -> + when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) -> build_other_atoms (fun e0 -> Prop.mk_neq e0 e') side e | Sil.Aeq((Sil.Var id as e), e') | Sil.Aeq(e', (Sil.Var id as e)) - when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) -> + when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) -> build_other_atoms (fun e0 -> Prop.mk_eq e0 e') side e | Sil.Aeq(Sil.BinOp(Sil.Le, e, e'), Sil.Const (Sil.Cint i)) | Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Le, e, e')) - when Sil.Int.isone i && (exp_contains_only_normal_ids e') -> + when Sil.Int.isone i && (exp_contains_only_normal_ids e') -> let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Le, e0, e')) in build_other_atoms construct side e | Sil.Aeq(Sil.BinOp(Sil.Lt, e', e), Sil.Const (Sil.Cint i)) | Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Lt, e', e)) - when Sil.Int.isone i && (exp_contains_only_normal_ids e') -> + when Sil.Int.isone i && (exp_contains_only_normal_ids e') -> let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Lt, e', e0)) in build_other_atoms construct side e @@ -764,31 +764,31 @@ end = struct type data_opt = ExtFresh | ExtDefault of Sil.exp (* Extend the renaming relation. At least one of e1 and e2 - * should be a primed or footprint variable *) + * should be a primed or footprint variable *) let extend e1 e2 default_op = try let eq_to_e (f1, f2, _) = Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2 in let _, _, res = list_find eq_to_e !tbl in res with Not_found -> - let fav1 = Sil.exp_fav e1 in - let fav2 = Sil.exp_fav e2 in - let no_ren1 = not (Sil.fav_exists fav1 can_rename) in - let no_ren2 = not (Sil.fav_exists fav2 can_rename) in - let some_primed () = Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in - let e = - if (no_ren1 && no_ren2) then - if (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise Fail) - else - match default_op with - | ExtDefault e -> e - | ExtFresh -> - let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in - Sil.Var (Ident.create_fresh kind) in - let entry = e1, e2, e in - push entry; - Todo.push entry; - e + let fav1 = Sil.exp_fav e1 in + let fav2 = Sil.exp_fav e2 in + let no_ren1 = not (Sil.fav_exists fav1 can_rename) in + let no_ren2 = not (Sil.fav_exists fav2 can_rename) in + let some_primed () = Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in + let e = + if (no_ren1 && no_ren2) then + if (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise Fail) + else + match default_op with + | ExtDefault e -> e + | ExtFresh -> + let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in + Sil.Var (Ident.create_fresh kind) in + let entry = e1, e2, e in + push entry; + Todo.push entry; + e let pp pe f renaming = let pp_triple f (e1, e2, e3) = @@ -928,15 +928,15 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp = | Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const _), Sil.Var id2 | Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const _) - when ident_same_kind_primed_footprint id1 id2 -> + when ident_same_kind_primed_footprint id1 id2 -> Rename.extend e1 e2 Rename.ExtFresh | Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const (Sil.Cint c1)), Sil.Const (Sil.Cint c2) - when can_rename id1 -> + when can_rename id1 -> let c2' = c2 -- c1 in let e_res = Rename.extend (Sil.Var id1) (Sil.exp_int c2') Rename.ExtFresh in Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c1) | Sil.Const (Sil.Cint c1), Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint c2)) - when can_rename id2 -> + when can_rename id2 -> let c1' = c1 -- c2 in let e_res = Rename.extend (Sil.exp_int c1') (Sil.Var id2) Rename.ExtFresh in Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c2) @@ -1062,10 +1062,10 @@ let run_without_absval f e1 e2 = e end with exn -> - begin - Config.abs_val := old_abs_val; - raise exn - end + begin + Config.abs_val := old_abs_val; + raise exn + end let exp_partial_join_without_absval e1 e2 = run_without_absval exp_partial_join e1 e2 @@ -1187,7 +1187,7 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st let inst = Sil.inst_partial_meet inst1 inst2 in f_fld_se_list inst [] fld_se_list1 fld_se_list2 | Sil.Earray (size1, idx_se_list1, inst1), Sil.Earray (size2, idx_se_list2, inst2) - when Sil.exp_equal size1 size2 -> + when Sil.exp_equal size1 size2 -> let inst = Sil.inst_partial_meet inst1 inst2 in f_idx_se_list inst size1 [] idx_se_list1 idx_se_list2 | _ -> (L.d_strln "failure reason 52"; raise Fail) @@ -1250,7 +1250,7 @@ let hpred_partial_join mode (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpr let shared' = exp_list_partial_join shared1 shared2 in Prop.mk_lseg (kind_join k1 k2) hpara' e next' shared' | Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1), - Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) -> + Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) -> let fwd1 = Sil.exp_equal e1 iF1 in let fwd2 = Sil.exp_equal e2 iF2 in let hpara' = hpara_dll_partial_join para1 para2 in @@ -1278,7 +1278,7 @@ let hpred_partial_meet (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) ( let shared' = exp_list_partial_meet shared1 shared2 in Prop.mk_lseg (kind_meet k1 k2) hpara' e next' shared' | Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1), - Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) -> + Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) -> let fwd1 = Sil.exp_equal e1 iF1 in let fwd2 = Sil.exp_equal e2 iF2 in let hpara' = hpara_dll_partial_meet para1 para2 in @@ -1321,11 +1321,11 @@ let same_pred (hpred1: Sil.hpred) (hpred2: Sil.hpred) : bool = | _ -> false (* check that applying renaming to the lhs / rhs of [sigma_new] -* gives [sigma] and that the renaming is injective *) + * gives [sigma] and that the renaming is injective *) let sigma_renaming_check (lhs: side) (sigma: sigma) (sigma_new: sigma) = (* apply the lhs / rhs of the renaming to sigma, - * and check that the renaming of primed vars is injective *) + * and check that the renaming of primed vars is injective *) let fav_sigma = Prop.sigma_fav sigma_new in let sub = Rename.to_subst_proj lhs fav_sigma in let sigma' = Prop.sigma_sub sub sigma_new in @@ -1352,7 +1352,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma) Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared') | Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared) - when Sil.exp_equal iF e -> + when Sil.exp_equal iF e -> let oF' = do_side side exp_partial_join oF opposite in let shared' = Rename.lookup_list side shared in let oB', iB' = lookup_and_expand side oB iB in @@ -1365,7 +1365,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma) Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared') | Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared) - when Sil.exp_equal iB e -> + when Sil.exp_equal iB e -> let oB' = do_side side exp_partial_join oB opposite in let shared' = Rename.lookup_list side shared in let oF', iF' = lookup_and_expand side oF iF in @@ -1397,8 +1397,8 @@ let rec sigma_partial_join' mode (sigma_acc: sigma) | _ -> assert false in (* Drop the part of 'other' sigma corresponding to 'target' sigma if possible. - 'side' describes that target is Lhs or Rhs. - 'todo' describes the start point. *) + 'side' describes that target is Lhs or Rhs. + 'todo' describes the start point. *) let cut_sigma side todo (target: sigma) (other: sigma) = let list_is_empty l = if l != [] then (L.d_strln "failure reason 61"; raise Fail) in @@ -1482,7 +1482,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma) sigma_partial_join' mode sigma_acc' sigma1' sigma2 | Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some (hpred2) - when Sil.exp_equal e1 iF1 -> + when Sil.exp_equal e1 iF1 -> let iB_res = exp_partial_join iB1 e2 in let sigma2' = cut_dllseg Lhs todo_curr iF1 dllseg (hpred2:: sigma2) in let sigma_acc' = update_dllseg Lhs dllseg e iB_res :: sigma_acc in @@ -1498,7 +1498,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma) sigma_partial_join' mode sigma_acc' sigma1 sigma2' | Some (hpred1), Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) - when Sil.exp_equal e2 iF2 -> + when Sil.exp_equal e2 iF2 -> let iB_res = exp_partial_join e1 iB2 in let sigma1' = cut_dllseg Rhs todo_curr iF2 dllseg (hpred1:: sigma1) in let sigma_acc' = update_dllseg Rhs dllseg e iB_res :: sigma_acc in @@ -1516,9 +1516,9 @@ let rec sigma_partial_join' mode (sigma_acc: sigma) assert false (* Should be handled by a guarded case *) with Todo.Empty -> - match sigma1_in, sigma2_in with - | _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail - | _ -> sigma_acc, sigma1_in, sigma2_in + match sigma1_in, sigma2_in with + | _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail + | _ -> sigma_acc, sigma1_in, sigma2_in let sigma_partial_join mode (sigma1: sigma) (sigma2: sigma) : (sigma * sigma * sigma) = CheckJoin.init mode sigma1 sigma2; @@ -1568,9 +1568,9 @@ let rec sigma_partial_meet' (sigma_acc: sigma) (sigma1_in: sigma) (sigma2_in: si (L.d_strln "failure reason 65"; raise Fail) with Todo.Empty -> - match sigma1_in, sigma2_in with - | [], [] -> sigma_acc - | _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail + match sigma1_in, sigma2_in with + | [], [] -> sigma_acc + | _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail let sigma_partial_meet (sigma1: sigma) (sigma2: sigma) : sigma = sigma_partial_meet' [] sigma1 sigma2 @@ -1582,7 +1582,7 @@ let widening_bottom = Sil.Int.of_int64 Int64.min_int ++ Sil.Int.of_int 1000 (* n let pi_partial_join mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) (pi1: Sil.atom list) (pi2: Sil.atom list) : Sil.atom list -= + = let exp_is_const = function (* | Sil.Var id -> is_normal id *) | Sil.Const _ -> true @@ -1668,19 +1668,19 @@ let pi_partial_join mode match join_atom size p_op pi_op a with | None -> (match widening_atom a with - | None -> atom_list - | Some a' -> - (match join_atom size p_op pi_op a' with - | None -> atom_list - | Some a' -> a' :: atom_list)) + | None -> atom_list + | Some a' -> + (match join_atom size p_op pi_op a' with + | None -> atom_list + | Some a' -> a' :: atom_list)) | Some a' -> a' :: atom_list in let filter_atom = function | Sil.Aneq(e, e') | Sil.Aeq(e, e') - when (exp_is_const e && exp_is_const e') -> + when (exp_is_const e && exp_is_const e') -> true | Sil.Aneq(Sil.Var id, e') | Sil.Aneq(e', Sil.Var id) | Sil.Aeq(Sil.Var id, e') | Sil.Aeq(e', Sil.Var id) - when (exp_is_const e') -> + when (exp_is_const e') -> true | Sil.Aneq _ -> false | e -> Prop.atom_is_inequality e in @@ -1769,12 +1769,12 @@ let prop_partial_meet p1 p2 = Rename.final (); FreshVarExp.final (); Todo.final (); Some res with exn -> - begin - Rename.final (); FreshVarExp.final (); Todo.final (); - match exn with - | Fail -> None - | _ -> raise exn - end + begin + Rename.final (); FreshVarExp.final (); Todo.final (); + match exn with + | Fail -> None + | _ -> raise exn + end let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t = SymOp.pay(); (* pay one symop *) @@ -1872,11 +1872,11 @@ let prop_partial_join pname tenv mode p1 p2 = Rename.final (); FreshVarExp.final (); Todo.final (); res with exn -> - begin - Rename.final (); FreshVarExp.final (); Todo.final (); - (if !Config.footprint then JoinState.set_footprint false); - (match exn with Fail -> None | _ -> raise exn) - end + begin + Rename.final (); FreshVarExp.final (); Todo.final (); + (if !Config.footprint then JoinState.set_footprint false); + (match exn with Fail -> None | _ -> raise exn) + end end | Some _ -> res_by_implication_only @@ -1894,19 +1894,19 @@ let list_reduce name dd f list = let rec element_list_reduce acc (x, p1) = function | [] -> ((x, p1), list_rev acc) | (y, p2):: ys -> begin - L.d_strln ("COMBINE[" ^ name ^ "] ...."); - L.d_str "ENTRY1: "; L.d_ln (); dd x; L.d_ln (); - L.d_str "ENTRY2: "; L.d_ln (); dd y; L.d_ln (); - L.d_ln (); - match f x y with - | None -> - L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ..."); - element_list_reduce ((y, p2):: acc) (x, p1) ys - | Some x' -> - L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ...."); - L.d_strln "RESULT:"; dd x'; L.d_ln (); - element_list_reduce acc (x', p1) ys - end in + L.d_strln ("COMBINE[" ^ name ^ "] ...."); + L.d_str "ENTRY1: "; L.d_ln (); dd x; L.d_ln (); + L.d_str "ENTRY2: "; L.d_ln (); dd y; L.d_ln (); + L.d_ln (); + match f x y with + | None -> + L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ..."); + element_list_reduce ((y, p2):: acc) (x, p1) ys + | Some x' -> + L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ...."); + L.d_strln "RESULT:"; dd x'; L.d_ln (); + element_list_reduce acc (x', p1) ys + end in let rec reduce acc = function | [] -> list_rev acc | x:: xs -> @@ -1966,7 +1966,7 @@ let join_time = ref 0.0 let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) -: Paths.PathSet.t * Paths.PathSet.t = + : Paths.PathSet.t * Paths.PathSet.t = let mode = JoinState.Post in let initial_time = Unix.gettimeofday () in let pset_to_plist pset = @@ -1977,18 +1977,18 @@ let pathset_join let rec join_proppath_plist ppalist2_acc ((p2, pa2) as ppa2) = function | [] -> (ppa2, list_rev ppalist2_acc) | ((p2', pa2') as ppa2') :: ppalist2_rest -> begin - L.d_strln ".... JOIN ...."; - L.d_strln "JOIN SYM HEAP1: "; Prop.d_prop p2; L.d_ln (); - L.d_strln "JOIN SYM HEAP2: "; Prop.d_prop p2'; L.d_ln (); L.d_ln (); - match prop_partial_join pname tenv mode p2 p2' with - | None -> - L.d_strln_color Red ".... JOIN FAILED ...."; L.d_ln (); - join_proppath_plist (ppa2':: ppalist2_acc) ppa2 ppalist2_rest - | Some p2'' -> - L.d_strln_color Green ".... JOIN SUCCEEDED ...."; - L.d_strln "RESULT SYM HEAP:"; Prop.d_prop p2''; L.d_ln (); L.d_ln (); - join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest - end in + L.d_strln ".... JOIN ...."; + L.d_strln "JOIN SYM HEAP1: "; Prop.d_prop p2; L.d_ln (); + L.d_strln "JOIN SYM HEAP2: "; Prop.d_prop p2'; L.d_ln (); L.d_ln (); + match prop_partial_join pname tenv mode p2 p2' with + | None -> + L.d_strln_color Red ".... JOIN FAILED ...."; L.d_ln (); + join_proppath_plist (ppa2':: ppalist2_acc) ppa2 ppalist2_rest + | Some p2'' -> + L.d_strln_color Green ".... JOIN SUCCEEDED ...."; + L.d_strln "RESULT SYM HEAP:"; Prop.d_prop p2''; L.d_ln (); L.d_ln (); + join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest + end in let rec join ppalist1_cur ppalist2_acc = function | [] -> (ppalist1_cur, ppalist2_acc) | ppa2:: ppalist2_rest -> @@ -2004,14 +2004,14 @@ let pathset_join res (** -The meet operator does two things: -1) makes the result logically stronger (just like additive conjunction) -2) makes the result spatially larger (just like multiplicative conjunction). -Assuming that the meet operator forms a partial commutative monoid (soft assumption: it means -that the results are more predictable), try to combine every element of plist with any other element. -Return a list of the same lenght, with each element maximally combined. The algorithm is quadratic. -The operation is dependent on the order in which elements are combined; there is a straightforward -order - independent algorithm but it is exponential. + The meet operator does two things: + 1) makes the result logically stronger (just like additive conjunction) + 2) makes the result spatially larger (just like multiplicative conjunction). + Assuming that the meet operator forms a partial commutative monoid (soft assumption: it means + that the results are more predictable), try to combine every element of plist with any other element. + Return a list of the same lenght, with each element maximally combined. The algorithm is quadratic. + The operation is dependent on the order in which elements are combined; there is a straightforward + order - independent algorithm but it is exponential. *) let proplist_meet_generate plist = let props_done = ref Propset.empty in @@ -2031,9 +2031,9 @@ let proplist_meet_generate plist = let rec proplist_meet = function | [] -> () | (porig, pcombined) :: pplist -> - (* use porig instead of pcombined because it might be combinable with more othe props *) - (* e.g. porig might contain a global var to add to the ture branch of a conditional *) - (* but pcombined might have been combined with the false branch already *) + (* use porig instead of pcombined because it might be combinable with more othe props *) + (* e.g. porig might contain a global var to add to the ture branch of a conditional *) + (* but pcombined might have been combined with the false branch already *) let pplist' = list_map (combine porig) pplist in props_done := Propset.add pcombined !props_done; proplist_meet pplist' in diff --git a/infer/src/backend/dotty.ml b/infer/src/backend/dotty.ml index 80c289f56..4fd601b66 100644 --- a/infer/src/backend/dotty.ml +++ b/infer/src/backend/dotty.ml @@ -264,32 +264,32 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list incr dotty_state_count; let coo = mk_coordinate n lambda in (match hpred with - | Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> - let e_color_str = color_to_str (exp_color hpred e) in - [Dotdangling(coo, e, e_color_str)] - | Sil.Hlseg (k, hpara, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> - let e2_color_str = color_to_str (exp_color hpred e2) in - [Dotdangling(coo, e2, e2_color_str)] - | Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, elist) -> - let e2_color_str = color_to_str (exp_color hpred e2) in - let e3_color_str = color_to_str (exp_color hpred e3) in - let ll = if not (Sil.exp_equal e2 Sil.exp_zero) then - [Dotdangling(coo, e2, e2_color_str)] - else [] in - if not (Sil.exp_equal e3 Sil.exp_zero) then Dotdangling(coo, e3, e3_color_str):: ll - else ll - | Sil.Hpointsto (_, _, _) - | _ -> [] (* arrays and struct do not give danglings*) + | Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> + let e_color_str = color_to_str (exp_color hpred e) in + [Dotdangling(coo, e, e_color_str)] + | Sil.Hlseg (k, hpara, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> + let e2_color_str = color_to_str (exp_color hpred e2) in + [Dotdangling(coo, e2, e2_color_str)] + | Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, elist) -> + let e2_color_str = color_to_str (exp_color hpred e2) in + let e3_color_str = color_to_str (exp_color hpred e3) in + let ll = if not (Sil.exp_equal e2 Sil.exp_zero) then + [Dotdangling(coo, e2, e2_color_str)] + else [] in + if not (Sil.exp_equal e3 Sil.exp_zero) then Dotdangling(coo, e3, e3_color_str):: ll + else ll + | Sil.Hpointsto (_, _, _) + | _ -> [] (* arrays and struct do not give danglings*) ) in let is_allocated d = match d with | Dotdangling(_, e, _) -> list_exists (fun a -> match a with - | Dotpointsto(_, e', _) - | Dotarray(_, _, e', _, _, _) - | Dotlseg(_, e', _, _, _, _) - | Dotdllseg(_, e', _, _, _, _, _, _) -> Sil.exp_equal e e' - | _ -> false + | Dotpointsto(_, e', _) + | Dotarray(_, _, e', _, _, _) + | Dotlseg(_, e', _, _, _, _) + | Dotdllseg(_, e', _, _, _, _, _, _) -> Sil.exp_equal e e' + | _ -> false ) allocated_nodes | _ -> false (*this should never happen since d must be a dangling node *) in let rec filter_duplicate l seen_exp = @@ -353,7 +353,7 @@ let set_exps_neq_zero pi = let box_dangling e = let entry_e = list_filter (fun b -> match b with - | Dotdangling(_, e', _) -> Sil.exp_equal e e' | _ -> false ) !dangling_dotboxes in + | Dotdangling(_, e', _) -> Sil.exp_equal e e' | _ -> false ) !dangling_dotboxes in match entry_e with |[] -> None | Dotdangling(coo, _, _):: _ -> Some coo.id @@ -417,20 +417,20 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda = end else let nodes_e = select_nodes_exp_lambda dotnodes e lambda in (match nodes_e with - | [] -> - (match box_dangling e with - | None -> [] - | Some n' -> [(LinkStructToExp, Ident.fieldname_to_string fn, n',"")] - ) - | [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] -> - let n = get_coordinate_id node in - if list_mem Sil.exp_equal e !struct_exp_nodes then begin - let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in - [(LinkStructToStruct, Ident.fieldname_to_string fn, n, e_no_special_char)] - end else - [(LinkStructToExp, Ident.fieldname_to_string fn, n,"")] - | _ -> (* by construction there must be at most 2 nodes for an expression*) - L.out "@\n Too many nodes! Error! @\n@.@."; assert false + | [] -> + (match box_dangling e with + | None -> [] + | Some n' -> [(LinkStructToExp, Ident.fieldname_to_string fn, n',"")] + ) + | [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] -> + let n = get_coordinate_id node in + if list_mem Sil.exp_equal e !struct_exp_nodes then begin + let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in + [(LinkStructToStruct, Ident.fieldname_to_string fn, n, e_no_special_char)] + end else + [(LinkStructToExp, Ident.fieldname_to_string fn, n,"")] + | _ -> (* by construction there must be at most 2 nodes for an expression*) + L.out "@\n Too many nodes! Error! @\n@.@."; assert false ) | Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *) | Sil.Earray _ ->[] (* inner arrays are printed by print_array function *) @@ -453,20 +453,20 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda = end else let nodes_e = select_nodes_exp_lambda dotnodes e lambda in (match nodes_e with - | [] -> - (match box_dangling e with - | None -> [] - | Some n' -> [(LinkArrayToExp, Sil.exp_to_string idx, n',"")] - ) - | [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] -> - let n = get_coordinate_id node in - if list_mem Sil.exp_equal e !struct_exp_nodes then begin - let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in - [(LinkArrayToStruct, Sil.exp_to_string idx, n, e_no_special_char)] - end else - [(LinkArrayToExp, Sil.exp_to_string idx, n,"")] - | _ -> (* by construction there must be at most 2 nodes for an expression*) - L.out "@\n Too many nodes! Error! @\n@.@."; assert false + | [] -> + (match box_dangling e with + | None -> [] + | Some n' -> [(LinkArrayToExp, Sil.exp_to_string idx, n',"")] + ) + | [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] -> + let n = get_coordinate_id node in + if list_mem Sil.exp_equal e !struct_exp_nodes then begin + let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in + [(LinkArrayToStruct, Sil.exp_to_string idx, n, e_no_special_char)] + end else + [(LinkArrayToExp, Sil.exp_to_string idx, n,"")] + | _ -> (* by construction there must be at most 2 nodes for an expression*) + L.out "@\n Too many nodes! Error! @\n@.@."; assert false ) | Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *) | Sil.Earray _ ->[] (* inner arrays are printed by print_array function *) @@ -486,12 +486,12 @@ let rec compute_target_from_eexp dotnodes e p f lambda = let nodes_e_no_struct = list_filter is_not_struct nodes_e in let trg = list_map get_coordinate_id nodes_e_no_struct in (match trg with - | [] -> - (match box_dangling e with - | None -> [] - | Some n -> [(LinkExpToExp, n, "")] - ) - | _ -> list_map (fun n -> (LinkExpToExp, n, "")) trg + | [] -> + (match box_dangling e with + | None -> [] + | Some n -> [(LinkExpToExp, n, "")] + ) + | _ -> list_map (fun n -> (LinkExpToExp, n, "")) trg ) (* build the set of edges between nodes *) @@ -516,60 +516,60 @@ let rec dotty_mk_set_links dotnodes sigma p f = | (Sil.Hpointsto (e, Sil.Estruct (lfld, _), t), lambda):: sigma' -> let src = look_up dotnodes e lambda in (match src with - | [] -> assert false - | nl -> - (* L.out "@\n@\n List of nl= "; list_iter (L.out " %i ") nl; L.out "@.@.@."; *) - let target_list = compute_target_struct_fields dotnodes lfld p f lambda in - let ff n = list_map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in - let nodes_e = select_nodes_exp_lambda dotnodes e lambda in - let address_struct_id = - try get_coordinate_id (list_hd (list_filter (is_source_node_of_exp e) nodes_e)) - with exn when exn_not_timeout exn -> (* L.out "@\n@\n PROBLEMS!!!!!!!!!!@.@.@."; *) assert false in - (* we need to exclude the address node from the sorce of fields. no fields should start from there*) - let nl'= list_filter (fun id -> address_struct_id != id) nl in - let links_from_fields = list_flatten (list_map ff nl') in - - let trg_label = strip_special_chars (Sil.exp_to_string e) in - let lnk_from_address_struct = mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) "" (mk_coordinate (address_struct_id + 1) lambda) trg_label in - lnk_from_address_struct:: links_from_fields @ dotty_mk_set_links dotnodes sigma' p f + | [] -> assert false + | nl -> + (* L.out "@\n@\n List of nl= "; list_iter (L.out " %i ") nl; L.out "@.@.@."; *) + let target_list = compute_target_struct_fields dotnodes lfld p f lambda in + let ff n = list_map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in + let nodes_e = select_nodes_exp_lambda dotnodes e lambda in + let address_struct_id = + try get_coordinate_id (list_hd (list_filter (is_source_node_of_exp e) nodes_e)) + with exn when exn_not_timeout exn -> (* L.out "@\n@\n PROBLEMS!!!!!!!!!!@.@.@."; *) assert false in + (* we need to exclude the address node from the sorce of fields. no fields should start from there*) + let nl'= list_filter (fun id -> address_struct_id != id) nl in + let links_from_fields = list_flatten (list_map ff nl') in + + let trg_label = strip_special_chars (Sil.exp_to_string e) in + let lnk_from_address_struct = mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) "" (mk_coordinate (address_struct_id + 1) lambda) trg_label in + lnk_from_address_struct:: links_from_fields @ dotty_mk_set_links dotnodes sigma' p f ) | (Sil.Hpointsto (e, Sil.Eexp (e', inst'), t), lambda):: sigma' -> let src = look_up dotnodes e lambda in (match src with - | [] -> assert false - | nl -> - let target_list = compute_target_from_eexp dotnodes e' p f lambda in - let ff n = list_map (fun (k, m, lab_target) -> mk_link k (mk_coordinate n lambda) "" (mk_coordinate m lambda) (strip_special_chars lab_target)) target_list in - let ll = list_flatten (list_map ff nl) in - ll @ dotty_mk_set_links dotnodes sigma' p f + | [] -> assert false + | nl -> + let target_list = compute_target_from_eexp dotnodes e' p f lambda in + let ff n = list_map (fun (k, m, lab_target) -> mk_link k (mk_coordinate n lambda) "" (mk_coordinate m lambda) (strip_special_chars lab_target)) target_list in + let ll = list_flatten (list_map ff nl) in + ll @ dotty_mk_set_links dotnodes sigma' p f ) | (Sil.Hlseg (_, pred, e1, e2, elist), lambda):: sigma' -> let src = look_up dotnodes e1 lambda in (match src with - | [] -> assert false - | n:: _ -> - let (_, m, lab) = list_hd (compute_target_from_eexp dotnodes e2 p f lambda) in - let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in - lnk:: dotty_mk_set_links dotnodes sigma' p f + | [] -> assert false + | n:: _ -> + let (_, m, lab) = list_hd (compute_target_from_eexp dotnodes e2 p f lambda) in + let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in + lnk:: dotty_mk_set_links dotnodes sigma' p f ) | (Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist), lambda):: sigma' -> let src = look_up dotnodes e1 lambda in (match src with - | [] -> assert false - | n:: _ -> (* n is e1's box and n+1 is e4's box *) - let targetF = look_up dotnodes e3 lambda in - let target_Flink = (match targetF with - | [] -> [] - | m:: _ -> [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""] - ) in - let targetB = look_up dotnodes e2 lambda in - let target_Blink = (match targetB with - | [] -> [] - | m:: _ -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""] - ) in - target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f + | [] -> assert false + | n:: _ -> (* n is e1's box and n+1 is e4's box *) + let targetF = look_up dotnodes e3 lambda in + let target_Flink = (match targetF with + | [] -> [] + | m:: _ -> [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""] + ) in + let targetB = look_up dotnodes e2 lambda in + let target_Blink = (match targetB with + | [] -> [] + | m:: _ -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""] + ) in + target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f ) let print_kind f kind = @@ -628,8 +628,8 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) = let remove_links_from ln = list_filter (fun n' -> not (list_mem Pervasives.(=) n' ln)) !tmp_links in let remove_node n ns = list_filter (fun n' -> match n' with - | Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n) - | _ -> true + | Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n) + | _ -> true ) ns in let rec boxes_pointed_by n lns = match lns with @@ -758,11 +758,11 @@ and build_visual_graph f pe p = compute_fields_struct sigma; compute_struct_exp_nodes sigma; (* L.out "@\n@\n Computed fields structs: "; - list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs; - L.out "@\n@."; - L.out "@\n@\n Computed exp structs nodes: "; - list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes; - L.out "@\n@."; *) + list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs; + L.out "@\n@."; + L.out "@\n@\n Computed exp structs nodes: "; + list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes; + L.out "@\n@."; *) let sigma_lambda = list_map (fun hp -> (hp,!lambda_counter)) sigma in let nodes = (dotty_mk_node pe) sigma_lambda in make_dangling_boxes pe nodes sigma_lambda; @@ -833,10 +833,10 @@ let pp_dotty_one_spec f pre posts = pp_dotty f (Spec_precondition) pre; invisible_arrows:= false; list_iter (fun (po, path) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po; - for j = 1 to 4 do - F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre; - done - ) posts; + for j = 1 to 4 do + F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre; + done + ) posts; F.fprintf f "\n } \n" (* this is used to print a list of proposition when considered in a path of nodes *) @@ -851,7 +851,7 @@ let pp_dotty_prop_list_in_path f plist prev_n curr_n = if prev_n <> - 1 then F.fprintf f "\n state%iN ->state%iN\n" prev_n curr_n; F.fprintf f "\n } \n" with exn when exn_not_timeout exn -> - () + () (* create a dotty file with a single proposition *) let dotty_prop_to_dotty_file fname prop = @@ -865,7 +865,7 @@ let dotty_prop_to_dotty_file fname prop = Format.fprintf fmt_dot "@\n}"; close_out out_dot with exn when exn_not_timeout exn -> - () + () (* this is used only to print a list of prop parsed with the external parser. Basically deprecated.*) let pp_proplist_parsed2dotty_file filename plist = @@ -882,7 +882,7 @@ let pp_proplist_parsed2dotty_file filename plist = F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist; close_out outc with exn when exn_not_timeout exn -> - () + () (********** START of Print interprocedural cfgs in dotty format *) (********** Print control flow graph (in dot form) for fundec to *) @@ -893,19 +893,19 @@ let pp_cfgnodename fmt (n : Cfg.Node.t) = let pp_etlist fmt etl = list_iter (fun (id, ty) -> - Format.fprintf fmt " %s:%a" id (Sil.pp_typ_full pe_text) ty) etl + Format.fprintf fmt " %s:%a" id (Sil.pp_typ_full pe_text) ty) etl let pp_local_list fmt etl = list_iter (fun (id, ty) -> - Format.fprintf fmt " %a:%a" Mangled.pp id (Sil.pp_typ_full pe_text) ty) etl + Format.fprintf fmt " %a:%a" Mangled.pp id (Sil.pp_typ_full pe_text) ty) etl let pp_cfgnodelabel fmt (n : Cfg.Node.t) = let pp_label fmt n = match Cfg.Node.get_kind n with | Cfg.Node.Start_node (pdesc) -> - let gen = if (Cfg.Procdesc.get_attributes pdesc).Sil.is_generated then " (generated)" else "" in - (* let def = if Cfg.Procdesc.is_defined pdesc then "defined" else "declared" in *) - (* Format.fprintf fmt "Start %a (%s)" pp_id (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) def *) + let gen = if (Cfg.Procdesc.get_attributes pdesc).Sil.is_generated then " (generated)" else "" in + (* let def = if Cfg.Procdesc.is_defined pdesc then "defined" else "declared" in *) + (* Format.fprintf fmt "Start %a (%s)" pp_id (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) def *) Format.fprintf fmt "Start %s%s\\nFormals: %a\\nLocals: %a" (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) gen @@ -1025,7 +1025,7 @@ let pp_speclist_to_file (filename : DB.filename) spec_list = let pp_speclist_dotty_file (filename : DB.filename) spec_list = try pp_speclist_to_file filename spec_list with exn when exn_not_timeout exn -> - () + () (**********************************************************************) (* Code prodicing a xml version of a graph *) @@ -1077,7 +1077,7 @@ let atom_to_xml_string a = (* return the dangling node corresponding to an expression it exists or None *) let exp_dangling_node e = let entry_e = list_filter (fun b -> match b with - | VH_dangling(_, e') -> Sil.exp_equal e e' | _ -> false ) !set_dangling_nodes in + | VH_dangling(_, e') -> Sil.exp_equal e e' | _ -> false ) !set_dangling_nodes in match entry_e with |[] -> None | VH_dangling(n, e') :: _ -> Some (VH_dangling(n, e')) @@ -1126,7 +1126,7 @@ let rec select_node_at_address nodes e = (* look-up the ids in the list of nodes corresponding to expression e*) (* let look_up_nodes_ids nodes e = -list_map get_node_id (select_nodes_exp nodes e) *) + list_map get_node_id (select_nodes_exp nodes e) *) (* create a list of dangling nodes *) let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) = @@ -1136,22 +1136,22 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) = VH_dangling(n, e) in let get_rhs_predicate hpred = (match hpred with - | Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> [e] - | Sil.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> [e2] - | Sil.Hdllseg (_, _, e1, e2, e3, _, _) -> - if (Sil.exp_equal e2 Sil.exp_zero) then - if (Sil.exp_equal e3 Sil.exp_zero) then [] - else [e3] - else [e2; e3] - | Sil.Hpointsto (_, _, _) - | _ -> [] (* arrays and struct do not give danglings. CHECK THIS!*) + | Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> [e] + | Sil.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> [e2] + | Sil.Hdllseg (_, _, e1, e2, e3, _, _) -> + if (Sil.exp_equal e2 Sil.exp_zero) then + if (Sil.exp_equal e3 Sil.exp_zero) then [] + else [e3] + else [e2; e3] + | Sil.Hpointsto (_, _, _) + | _ -> [] (* arrays and struct do not give danglings. CHECK THIS!*) ) in let is_not_allocated e = let allocated = list_exists (fun a -> match a with - | VH_pointsto(_, e', _, _) - | VH_lseg(_, e', _ , _) - | VH_dllseg(_, e', _, _, _, _) -> Sil.exp_equal e e' - | _ -> false ) allocated_nodes in + | VH_pointsto(_, e', _, _) + | VH_lseg(_, e', _ , _) + | VH_dllseg(_, e', _, _, _, _) -> Sil.exp_equal e e' + | _ -> false ) allocated_nodes in not allocated in let rec filter_duplicate l seen_exp = match l with @@ -1173,27 +1173,27 @@ let rec compute_target_nodes_from_sexp nodes se prop field_lab = | Sil.Eexp (e, inst) -> let e_node = select_node_at_address nodes e in (match e_node with - | None -> - (match exp_dangling_node e with - | None -> [] - | Some dang_node -> [(dang_node, field_lab)] - ) - | Some n -> [(n, field_lab)] + | None -> + (match exp_dangling_node e with + | None -> [] + | Some dang_node -> [(dang_node, field_lab)] + ) + | Some n -> [(n, field_lab)] ) | Sil.Estruct (lfld, inst) -> (match lfld with - | [] -> [] - | (fn, se2):: l' -> - compute_target_nodes_from_sexp nodes se2 prop (Ident.fieldname_to_string fn) @ - compute_target_nodes_from_sexp nodes (Sil.Estruct (l', inst)) prop "" + | [] -> [] + | (fn, se2):: l' -> + compute_target_nodes_from_sexp nodes se2 prop (Ident.fieldname_to_string fn) @ + compute_target_nodes_from_sexp nodes (Sil.Estruct (l', inst)) prop "" ) | Sil.Earray(size, lie, inst) -> (match lie with - | [] -> [] - | (idx, se2):: l' -> - let lab ="["^exp_to_xml_string idx^"]" in - compute_target_nodes_from_sexp nodes se2 prop lab @ - compute_target_nodes_from_sexp nodes (Sil.Earray(size, l', inst)) prop "" + | [] -> [] + | (idx, se2):: l' -> + let lab ="["^exp_to_xml_string idx^"]" in + compute_target_nodes_from_sexp nodes se2 prop lab @ + compute_target_nodes_from_sexp nodes (Sil.Earray(size, l', inst)) prop "" ) @@ -1206,32 +1206,32 @@ let rec make_visual_heap_edges nodes sigma prop = | Sil.Hpointsto (e, se, t):: sigma' -> let e_node = select_node_at_address nodes e in (match e_node with - | None -> assert false - | Some n -> - let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in - let ll = list_map (combine_source_target_label n) target_nodes in - ll @ make_visual_heap_edges nodes sigma' prop + | None -> assert false + | Some n -> + let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in + let ll = list_map (combine_source_target_label n) target_nodes in + ll @ make_visual_heap_edges nodes sigma' prop ) | Sil.Hlseg (_, pred, e1, e2, elist):: sigma' -> let e1_node = select_node_at_address nodes e1 in (match e1_node with - | None -> assert false - | Some n -> - let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in - let ll = list_map (combine_source_target_label n) target_nodes in - ll @ make_visual_heap_edges nodes sigma' prop + | None -> assert false + | Some n -> + let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in + let ll = list_map (combine_source_target_label n) target_nodes in + ll @ make_visual_heap_edges nodes sigma' prop ) | Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist):: sigma' -> let e1_node = select_node_at_address nodes e1 in (match e1_node with - | None -> assert false - | Some n -> - let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in - let target_nodesB = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in - let llF = list_map (combine_source_target_label n) target_nodesF in - let llB = list_map (combine_source_target_label n) target_nodesB in - llF @ llB @ make_visual_heap_edges nodes sigma' prop + | None -> assert false + | Some n -> + let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in + let target_nodesB = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in + let llF = list_map (combine_source_target_label n) target_nodesF in + let llB = list_map (combine_source_target_label n) target_nodesB in + llF @ llB @ make_visual_heap_edges nodes sigma' prop ) (* from a prop generate and return visual proposition *) @@ -1348,8 +1348,8 @@ let print_specs_xml signature specs loc fmt = let list_of_specs_xml = list_map (fun s -> - j:=!j + 1; - do_one_spec (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts !j) + j:=!j + 1; + do_one_spec (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts !j) specs in let xml_specifications = Io_infer.Xml.create_tree "specifications" [] list_of_specs_xml in let xml_signature = Io_infer.Xml.create_tree "signature" [("name", signature)] [] in diff --git a/infer/src/backend/errdesc.ml b/infer/src/backend/errdesc.ml index 6cdaae72b..c52c9dd74 100644 --- a/infer/src/backend/errdesc.ml +++ b/infer/src/backend/errdesc.ml @@ -21,8 +21,8 @@ let pvar_to_string pvar = let hpred_is_open_resource prop = function | Sil.Hpointsto(e, _, _) -> (match Prop.get_resource_undef_attribute prop e with - | Some (Sil.Aresource { Sil.ra_kind = Sil.Racquire; Sil.ra_res = res }) -> Some res - | _ -> None) + | Some (Sil.Aresource { Sil.ra_kind = Sil.Racquire; Sil.ra_res = res }) -> Some res + | _ -> None) | _ -> None @@ -69,9 +69,9 @@ let find_other_prune_node node = match Cfg.Node.get_preds node with | [n_pre] -> (match Cfg.Node.get_succs n_pre with - | [n1; n2] -> - if Cfg.Node.equal n1 node then Some n2 else Some n1 - | _ -> None) + | [n1; n2] -> + if Cfg.Node.equal n1 node then Some n2 else Some n1 + | _ -> None) | _ -> None (** Return true if [id] is assigned to a program variable which is then nullified *) @@ -84,15 +84,15 @@ let id_is_assigned_then_dead node id = let prune_check = function (* if prune node, check that it's also nullified in the other branch *) | Some node' -> (match Cfg.Node.get_instrs node' with - | instr':: _ -> find_nullify_after_instr node' instr' pvar - | _ -> false) + | instr':: _ -> find_nullify_after_instr node' instr' pvar + | _ -> false) | _ -> false in find_nullify_after_instr node instr pvar && (not is_prune || prune_check (find_other_prune_node node)) | _ -> false (** Find the function call instruction used to initialize normal variable [id], -and return the function name and arguments *) + and return the function name and arguments *) let find_normal_variable_funcall (node: Cfg.Node.t) (id: Ident.t): (Sil.exp * (Sil.exp list) * Sil.location * Sil.call_flags) option = @@ -105,7 +105,7 @@ let find_normal_variable_funcall | _ -> false in ignore (list_exists find_declaration node_instrs); if !verbose && !res == None then (L.d_str ("find_normal_variable_funcall could not find " ^ - Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ()); + Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ()); !res (** Find a program variable assignment in the current node or predecessors. *) @@ -129,8 +129,8 @@ let find_program_variable_assignment node pvar : (Cfg.Node.t * Ident.t) option = find pred_node | [pn1; pn2] -> (match find pn1 with - | None -> find pn2 - | x -> x) + | None -> find pn2 + | x -> x) | _ -> None (* either 0 or >2 predecessors *) end in find node @@ -156,14 +156,14 @@ let find_ident_assignment node id : (Cfg.Node.t * Sil.exp) option = find pred_node | [pn1; pn2] -> (match find pn1 with - | None -> find pn2 - | x -> x) + | None -> find pn2 + | x -> x) | _ -> None (* either 0 or >2 predecessors *) end in find node (** Find a boolean assignment to a temporary variable holding a boolean condition. -The boolean parameter indicates whether the true or false branch is required. *) + The boolean parameter indicates whether the true or false branch is required. *) let rec find_boolean_assignment node pvar true_branch : Cfg.Node.t option = let find_instr n = let filter = function @@ -213,7 +213,7 @@ let pvar_is_frontend_tmp pvar = else pvar_is_cil_tmp pvar || pvar_is_edg_tmp pvar (** Find the Letderef instruction used to declare normal variable [id], -and return the expression dereferenced to initialize [id] *) + and return the expression dereferenced to initialize [id] *) let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp option = let res = ref None in let node_instrs = Cfg.Node.get_instrs node in @@ -227,7 +227,7 @@ let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp res := _exp_rv_dexp seen node e; true | Sil.Call ([id0], (Sil.Const (Sil.Cfun pname) as fun_exp), args, loc, call_flags) - when Ident.equal id id0 -> + when Ident.equal id id0 -> if !verbose then (L.d_str "find_normal_variable_letderef function call "; Sil.d_exp fun_exp; L.d_ln ()); let fun_dexp = Sil.Dconst (Sil.Cfun pname) in @@ -244,7 +244,7 @@ let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp | _ -> false in ignore (list_exists find_declaration node_instrs); if !verbose && !res == None then (L.d_str ("find_normal_variable_letderef could not find " ^ - Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ()); + Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ()); !res (** describe lvalue [e] as a dexp *) @@ -260,13 +260,13 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option = | Sil.BinOp(Sil.PlusPI, e1, e2) -> if !verbose then (L.d_str "exp_lv_dexp: (e1 +PI e2) "; Sil.d_exp e; L.d_ln ()); (match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with - | Some de1, Some de2 -> Some (Sil.Dbinop(Sil.PlusPI, de1, de2)) - | _ -> None) + | Some de1, Some de2 -> Some (Sil.Dbinop(Sil.PlusPI, de1, de2)) + | _ -> None) | Sil.Var id when Ident.is_normal id -> if !verbose then (L.d_str "exp_lv_dexp: normal var "; Sil.d_exp e; L.d_ln ()); (match _find_normal_variable_letderef seen node id with - | None -> None - | Some de -> Some (Sil.Dderef de)) + | None -> None + | Some de -> Some (Sil.Dderef de)) | Sil.Lvar pvar -> if !verbose then (L.d_str "exp_lv_dexp: program var "; Sil.d_exp e; L.d_ln ()); if pvar_is_frontend_tmp pvar then @@ -302,8 +302,8 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option = L.d_ln () end; (match _find_normal_variable_letderef seen node id with - | None -> None - | Some de -> Some (Sil.Darrow (de, f))) + | None -> None + | Some de -> Some (Sil.Darrow (de, f))) | Sil.Lfield (e1, f, typ) -> if !verbose then begin @@ -313,8 +313,8 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option = L.d_ln () end; (match _exp_lv_dexp seen node e1 with - | None -> None - | Some de -> Some (Sil.Ddot (de, f))) + | None -> None + | Some de -> Some (Sil.Ddot (de, f))) | Sil.Lindex (e1, e2) -> if !verbose then begin @@ -325,11 +325,11 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option = L.d_ln () end; (match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with - | None, _ -> None - | Some de1, None -> - (* even if the index is unknown, the array info is useful for bound errors *) - Some (Sil.Darray (de1, Sil.Dunknown)) - | Some de1, Some de2 -> Some (Sil.Darray (de1, de2))) + | None, _ -> None + | Some de1, None -> + (* even if the index is unknown, the array info is useful for bound errors *) + Some (Sil.Darray (de1, Sil.Dunknown)) + | Some de1, Some de2 -> Some (Sil.Darray (de1, de2))) | _ -> if !verbose then (L.d_str "exp_lv_dexp: no match for "; Sil.d_exp e; L.d_ln ()); None @@ -361,8 +361,8 @@ and _exp_rv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option = L.d_ln () end; (match _exp_rv_dexp seen node e1 with - | None -> None - | Some de -> Some (Sil.Ddot(de, f))) + | None -> None + | Some de -> Some (Sil.Ddot(de, f))) | Sil.Lindex (e1, e2) -> if !verbose then begin @@ -373,18 +373,18 @@ and _exp_rv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option = L.d_ln () end; (match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with - | None, _ | _, None -> None - | Some de1, Some de2 -> Some (Sil.Darray(de1, de2))) + | None, _ | _, None -> None + | Some de1, Some de2 -> Some (Sil.Darray(de1, de2))) | Sil.BinOp (op, e1, e2) -> if !verbose then (L.d_str "exp_rv_dexp: BinOp "; Sil.d_exp e; L.d_ln ()); (match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with - | None, _ | _, None -> None - | Some de1, Some de2 -> Some (Sil.Dbinop (op, de1, de2))) + | None, _ | _, None -> None + | Some de1, Some de2 -> Some (Sil.Dbinop (op, de1, de2))) | Sil.UnOp (op, e1, _) -> if !verbose then (L.d_str "exp_rv_dexp: UnOp "; Sil.d_exp e; L.d_ln ()); (match _exp_rv_dexp seen node e1 with - | None -> None - | Some de1 -> Some (Sil.Dunop (op, de1))) + | None -> None + | Some de1 -> Some (Sil.Dunop (op, de1))) | Sil.Cast (_, e1) -> if !verbose then (L.d_str "exp_rv_dexp: Cast "; Sil.d_exp e; L.d_ln ()); _exp_rv_dexp seen node e1 @@ -453,9 +453,9 @@ let find_pvar_typ_without_ptr tenv prop pvar = !res (** Produce a description of a leak by looking at the current state. -If the current instruction is a variable nullify, blame the variable. -If it is an abstraction, blame any variable nullify at the current node. -If there is an alloc attribute, print the function call and line number. *) + If the current instruction is a variable nullify, blame the variable. + If it is an abstraction, blame any variable nullify at the current node. + If there is an alloc attribute, print the function call and line number. *) let explain_leak tenv hpred prop alloc_att_opt bucket = let instro = State.get_instr () in let loc = State.get_loc () in @@ -486,9 +486,9 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = match hpred_typ_opt, find_pvar_typ_without_ptr tenv prop pvar with | Some (Sil.Sizeof (t1, st1)), Some (Sil.Sizeof (Sil.Tptr (_t2, _), st2)) -> (try - let t2 = Sil.expand_type tenv _t2 in - Sil.typ_equal t1 t2 - with exn when exn_not_timeout exn -> false) + let t2 = Sil.expand_type tenv _t2 in + Sil.typ_equal t1 t2 + with exn when exn_not_timeout exn -> false) | Some (Sil.Sizeof (Sil.Tint _, _)), Some (Sil.Sizeof (Sil.Tint _, _)) when is_file -> (* must be a file opened with "open" *) true | _ -> false in @@ -499,8 +499,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = | Some (Sil.Nullify (pvar, loc, _)) when check_pvar pvar -> if !verbose then (L.d_str "explain_leak: current instruction is Nullify for pvar "; Sil.d_pvar pvar; L.d_ln ()); (match exp_lv_dexp (State.get_node ()) (Sil.Lvar pvar) with - | None -> None - | Some de -> Some (Sil.dexp_to_string de)) + | None -> None + | Some de -> Some (Sil.dexp_to_string de)) | Some (Sil.Abstract _) -> if !verbose then (L.d_str "explain_leak: current instruction is Abstract"; L.d_ln ()); let get_nullify = function @@ -514,8 +514,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = | Some (Sil.Set (lexp, _, _, _)) when vpath = None -> if !verbose then (L.d_str "explain_leak: current instruction Set for "; Sil.d_exp lexp; L.d_ln ()); (match exp_lv_dexp node lexp with - | Some dexp -> Some (Sil.dexp_to_string dexp) - | None -> None) + | Some dexp -> Some (Sil.dexp_to_string dexp) + | None -> None) | Some instr -> if !verbose then (L.d_str "explain_leak: case not matched in instr "; Sil.d_instr instr; L.d_ln()); value_str_from_pvars_vpath [] vpath in @@ -530,7 +530,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = exn_cat, Localise.desc_leak value_str resource_opt res_action_opt loc bucket (** find the dexp, if any, where the given value is stored -also return the type of the value if found *) + also return the type of the value if found *) let vpath_find prop _exp : Sil.dexp option * Sil.typ option = if !verbose then (L.d_str "in vpath_find exp:"; Sil.d_exp _exp; L.d_ln ()); let rec find sigma_acc sigma_todo exp = @@ -538,38 +538,38 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option = | Sil.Eexp (e, _) when Sil.exp_equal exp e -> let sigma' = (list_rev_append sigma_acc' sigma_todo') in (match lexp with - | Sil.Lvar pv -> - let typo = match texp with - | Sil.Sizeof (Sil.Tstruct (ftl, ftal, _, _, _, _, _), _) -> - (try + | Sil.Lvar pv -> + let typo = match texp with + | Sil.Sizeof (Sil.Tstruct (ftl, ftal, _, _, _, _, _), _) -> + (try let _, t, _ = list_find (fun (_f, _t, _) -> Ident.fieldname_equal _f f) ftl in Some t with Not_found -> None) - | _ -> None in - res := Some (Sil.Ddot (Sil.Dpvar pv, f)), typo - | Sil.Var id -> - (match find [] sigma' (Sil.Var id) with - | None, _ -> () - | Some de, typo -> res := Some (Sil.Darrow (de, f)), typo) - | lexp -> - if !verbose then (L.d_str "vpath_find do_fse: no match on Eexp "; Sil.d_exp lexp; L.d_ln ())) + | _ -> None in + res := Some (Sil.Ddot (Sil.Dpvar pv, f)), typo + | Sil.Var id -> + (match find [] sigma' (Sil.Var id) with + | None, _ -> () + | Some de, typo -> res := Some (Sil.Darrow (de, f)), typo) + | lexp -> + if !verbose then (L.d_str "vpath_find do_fse: no match on Eexp "; Sil.d_exp lexp; L.d_ln ())) | _ -> () in let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with | Sil.Eexp (e, _) when Sil.exp_equal exp e -> let sigma' = (list_rev_append sigma_acc' sigma_todo') in (match lexp with - | Sil.Lvar pv when not (pvar_is_frontend_tmp pv) -> - let typo = match texp with - | Sil.Sizeof (typ, _) -> Some typ - | _ -> None in - Some (Sil.Dpvar pv), typo - | Sil.Var id -> - (match find [] sigma' (Sil.Var id) with - | None, typo -> None, typo - | Some de, typo -> Some (Sil.Dderef de), typo) - | lexp -> - if !verbose then (L.d_str "vpath_find do_sexp: no match on Eexp "; Sil.d_exp lexp; L.d_ln ()); - None, None) + | Sil.Lvar pv when not (pvar_is_frontend_tmp pv) -> + let typo = match texp with + | Sil.Sizeof (typ, _) -> Some typ + | _ -> None in + Some (Sil.Dpvar pv), typo + | Sil.Var id -> + (match find [] sigma' (Sil.Var id) with + | None, typo -> None, typo + | Some de, typo -> Some (Sil.Dderef de), typo) + | lexp -> + if !verbose then (L.d_str "vpath_find do_sexp: no match on Eexp "; Sil.d_exp lexp; L.d_ln ()); + None, None) | Sil.Estruct (fsel, _) -> let res = ref (None, None) in list_iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel; @@ -588,14 +588,14 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option = | Sil.Hpointsto (Sil.Var id, sexp, texp) when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) -> do_sexp sigma_acc' sigma_todo' (Sil.Var id) sexp texp | hpred -> - (* if !verbose then (L.d_str "vpath_find do_hpred: no match "; Sil.d_hpred hpred; L.d_ln ()); *) + (* if !verbose then (L.d_str "vpath_find do_hpred: no match "; Sil.d_hpred hpred; L.d_ln ()); *) None, None in match sigma_todo with | [] -> None, None | hpred:: sigma_todo' -> (match do_hpred sigma_acc sigma_todo' hpred with - | Some de, typo -> Some de, typo - | None, _ -> find (hpred:: sigma_acc) sigma_todo' exp) in + | Some de, typo -> Some de, typo + | None, _ -> find (hpred:: sigma_acc) sigma_todo' exp) in let res = find [] (Prop.get_sigma prop) _exp in if !verbose then begin match res with @@ -644,45 +644,45 @@ let explain_dexp_access prop dexp is_nullable = Some (Sil.Eexp (Sil.Const c, Sil.inst_none)) | Sil.Darray (de1, de2) -> (match lookup de1, lookup de2 with - | None, _ | _, None -> None - | Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) -> - lookup_esel esel e - | Some se1, Some se2 -> - if !verbose then (L.d_str "lookup: case not matched on Darray "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln()); - None) + | None, _ | _, None -> None + | Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) -> + lookup_esel esel e + | Some se1, Some se2 -> + if !verbose then (L.d_str "lookup: case not matched on Darray "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln()); + None) | Sil.Darrow (de1, f) -> (match lookup (Sil.Dderef de1) with - | None -> None - | Some Sil.Estruct (fsel, _) -> - lookup_fld fsel f - | Some _ -> - if !verbose then (L.d_str "lookup: case not matched on Darrow "; L.d_ln ()); - None) + | None -> None + | Some Sil.Estruct (fsel, _) -> + lookup_fld fsel f + | Some _ -> + if !verbose then (L.d_str "lookup: case not matched on Darrow "; L.d_ln ()); + None) | Sil.Ddot (de1, f) -> (match lookup de1 with - | None -> None - | Some Sil.Estruct (fsel, _) -> - lookup_fld fsel f - | Some _ -> - if !verbose then (L.d_str "lookup: case not matched on Ddot "; L.d_ln ()); - None) + | None -> None + | Some Sil.Estruct (fsel, _) -> + lookup_fld fsel f + | Some _ -> + if !verbose then (L.d_str "lookup: case not matched on Ddot "; L.d_ln ()); + None) | Sil.Dpvar pvar -> if !verbose then (L.d_str "lookup: found Dpvar "; L.d_ln ()); (find_ptsto (Sil.Lvar pvar)) | Sil.Dderef de -> (match lookup de with - | None -> None - | Some (Sil.Eexp (e, _)) -> find_ptsto e - | Some _ -> None) + | None -> None + | Some (Sil.Eexp (e, _)) -> find_ptsto e + | Some _ -> None) | (Sil.Dbinop(Sil.PlusPI, Sil.Dpvar pvar, Sil.Dconst c) as de) -> if !verbose then (L.d_strln ("lookup: case )pvar + constant) " ^ Sil.dexp_to_string de)); None | Sil.Dfcall (Sil.Dconst c, _, loc, _) -> if !verbose then (L.d_strln "lookup: found Dfcall "); (match c with - | Sil.Cfun pn -> (* Treat function as an update *) - Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Sil.line)) - | _ -> None) + | Sil.Cfun pn -> (* Treat function as an update *) + Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Sil.line)) + | _ -> None) | de -> if !verbose then (L.d_strln ("lookup: unknown case not matched " ^ Sil.dexp_to_string de)); None in @@ -749,17 +749,17 @@ let create_dereference_desc | Some (Sil.Dpvar pvar) | Some (Sil.Dpvaraddr pvar) -> (match Prop.get_objc_null_attribute prop (Sil.Lvar pvar) with - | Some (Sil.Aobjc_null info) -> Localise.parameter_field_not_null_checked_desc desc info - | _ -> desc) + | Some (Sil.Aobjc_null info) -> Localise.parameter_field_not_null_checked_desc desc info + | _ -> desc) | _ -> desc else desc in if use_buckets then Buckets.classify_access desc access_opt' de_opt is_nullable else desc (** explain memory access performed by the current instruction -if outermost_array is true, the outermost array access is removed -if outermost_dereference is true, stop at the outermost dereference -(skipping e.g. outermost field access) *) + if outermost_array is true, the outermost array access is removed + if outermost_dereference is true, stop at the outermost dereference + (skipping e.g. outermost field access) *) let _explain_access ?use_buckets: (use_buckets = false) ?outermost_array: (outermost_array = false) @@ -824,7 +824,7 @@ let _explain_access de_opt deref_str prop loc (** Produce a description of which expression is dereferenced in the current instruction, if any. -The subexpression to focus on is obtained by removing field and index accesses. *) + The subexpression to focus on is obtained by removing field and index accesses. *) let explain_dereference ?use_buckets: (use_buckets = false) ?is_nullable: (is_nullable = false) @@ -835,7 +835,7 @@ let explain_dereference deref_str prop loc (** Produce a description of the array access performed in the current instruction, if any. -The subexpression to focus on is obtained by removing the outermost array access. *) + The subexpression to focus on is obtained by removing the outermost array access. *) let explain_array_access deref_str prop loc = _explain_access ~outermost_array: true deref_str prop loc @@ -859,21 +859,21 @@ let dexp_apply_pvar_off dexp pvar_off = | Fstruct [] -> dexp (* case should not happen *) (** Produce a description of the nth parameter of the function call, if the current instruction -is a function call with that parameter *) + is a function call with that parameter *) let explain_nth_function_parameter use_buckets deref_str prop n pvar_off = let node = State.get_node () in let loc = State.get_loc () in match State.get_instr () with | Some Sil.Call (_, _, args, _, _) -> (try - let arg = fst (list_nth args (n - 1)) in - let dexp_opt = exp_rv_dexp node arg in - let dexp_opt' = match dexp_opt with - | Some de -> - Some (dexp_apply_pvar_off de pvar_off) - | None -> None in - create_dereference_desc ~use_buckets dexp_opt' deref_str prop loc - with exn when exn_not_timeout exn -> Localise.no_desc) + let arg = fst (list_nth args (n - 1)) in + let dexp_opt = exp_rv_dexp node arg in + let dexp_opt' = match dexp_opt with + | Some de -> + Some (dexp_apply_pvar_off de pvar_off) + | None -> None in + create_dereference_desc ~use_buckets dexp_opt' deref_str prop loc + with exn when exn_not_timeout exn -> Localise.no_desc) | _ -> Localise.no_desc (** Find a program variable whose value is [exp] or pointing to a struct containing [exp] *) @@ -902,7 +902,7 @@ let find_pvar_with_exp prop exp = !res (** return a description explaining value [exp] in [prop] in terms of a source expression -using the formal parameters of the call *) + using the formal parameters of the call *) let explain_dereference_as_caller_expression ?use_buckets: (use_buckets = false) deref_str actual_pre spec_pre exp node loc formal_params = diff --git a/infer/src/backend/errlog.ml b/infer/src/backend/errlog.ml index eaffe1948..23a3beee0 100644 --- a/infer/src/backend/errlog.ml +++ b/infer/src/backend/errlog.ml @@ -55,8 +55,8 @@ module ErrLogHash = Hashtbl.Make (struct end) (** Type of the error log, to be reset once per function. -Map err_kind, fotprint / re - execution flag, error name, -error description, severity, to set of err_data. *) + Map err_kind, fotprint / re - execution flag, error name, + error description, severity, to set of err_data. *) type t = ErrDataSet.t ErrLogHash.t (** Empty error log *) @@ -70,19 +70,19 @@ type iter_fun = (** Apply f to nodes and error names *) let iter (f: iter_fun) (err_log: t) = ErrLogHash.iter (fun (ekind, in_footprint, err_name, desc, severity) set -> - ErrDataSet.iter - (fun (node_id_key, section, loc, mloco, ltr, pre_opt, eclass) -> - f - node_id_key loc ekind in_footprint err_name - desc severity ltr pre_opt eclass) - set) + ErrDataSet.iter + (fun (node_id_key, section, loc, mloco, ltr, pre_opt, eclass) -> + f + node_id_key loc ekind in_footprint err_name + desc severity ltr pre_opt eclass) + set) err_log (** Return the number of elements in the error log which satisfy [filter] *) let size filter (err_log: t) = let count = ref 0 in ErrLogHash.iter (fun (ekind, in_footprint, _, _, _) eds -> - if filter ekind in_footprint then count := !count + (ErrDataSet.cardinal eds)) err_log; + if filter ekind in_footprint then count := !count + (ErrDataSet.cardinal eds)) err_log; !count (** Print an error log *) @@ -125,7 +125,7 @@ let severity_to_str severity = match severity with | Exceptions.Low -> "LOW" (** Add an error description to the error log unless there is -one already at the same node + session; return true if added *) + one already at the same node + session; return true if added *) let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataSet.t) : bool = try let current_eds = ErrLogHash.find tbl (ekind, in_footprint, err_name, desc, severity) in @@ -138,16 +138,16 @@ let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataS true end with Not_found -> - begin - ErrLogHash.add tbl (ekind, in_footprint, err_name, desc, severity) eds; - true - end + begin + ErrLogHash.add tbl (ekind, in_footprint, err_name, desc, severity) eds; + true + end (** Update an old error log with a new one *) let update errlog_old errlog_new = ErrLogHash.iter (fun (ekind, infp, s, desc, severity) l -> - ignore (add_issue errlog_old (ekind, infp, s, desc, severity) l)) errlog_new + ignore (add_issue errlog_old (ekind, infp, s, desc, severity) l)) errlog_new let log_issue _ekind err_log loc node_id_key session ltr pre_opt exn = @@ -237,26 +237,26 @@ module Err_table = struct let err_list = LocMap.find nslm !map in map := LocMap.add nslm ((err_name, desc) :: err_list) !map with Not_found -> - map := LocMap.add nslm [(err_name, desc)] !map in + map := LocMap.add nslm [(err_name, desc)] !map in let f err_name eds = ErrDataSet.iter (fun loc -> add_err loc err_name) eds in ErrLogHash.iter f err_table; let pp ekind (nodeidkey, session, loc, mloco, ltr, pre_opt, eclass) fmt err_names = list_iter (fun (err_name, desc) -> - Exceptions.pp_err nodeidkey loc ekind err_name desc mloco fmt ()) err_names in + Exceptions.pp_err nodeidkey loc ekind err_name desc mloco fmt ()) err_names in F.fprintf fmt "@.Detailed errors during footprint phase:@."; LocMap.iter (fun nslm err_names -> - F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp; + F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp; F.fprintf fmt "@.Detailed errors during re-execution phase:@."; LocMap.iter (fun nslm err_names -> - F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re; + F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re; F.fprintf fmt "@.Detailed warnings during footprint phase:@."; LocMap.iter (fun nslm err_names -> - F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp; + F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp; F.fprintf fmt "@.Detailed warnings during re-execution phase:@."; LocMap.iter (fun nslm err_names -> - F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re + F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re end type err_table = Err_table.t diff --git a/infer/src/backend/exe_env.ml b/infer/src/backend/exe_env.ml index 4656d24f7..ac51d0568 100644 --- a/infer/src/backend/exe_env.ml +++ b/infer/src/backend/exe_env.ml @@ -27,10 +27,10 @@ type file_data = (** get the path to the tenv file, which either one tenv file per source file or a global tenv file *) let tenv_filename file_base = let per_source_tenv_filename = DB.filename_add_suffix file_base ".tenv" in - if Sys.file_exists (DB.filename_to_string per_source_tenv_filename) then - per_source_tenv_filename - else - DB.global_tenv_fname () + if Sys.file_exists (DB.filename_to_string per_source_tenv_filename) then + per_source_tenv_filename + else + DB.global_tenv_fname () (** create a new file_data *) let new_file_data source nLOC cg_fname = @@ -90,14 +90,14 @@ let add_callee (exe_env: t) (source_file : DB.source_file) (pname: Procname.t) = let file_data_opt = try Some (Hashtbl.find exe_env.file_map source_file) with Not_found -> - let source_dir = DB.source_dir_from_source_file source_file in - let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in - (match Cg.load_from_file cg_fname with - | None -> None - | Some cg -> - let nLOC = Cg.get_nLOC cg in - let file_data = new_file_data source_file nLOC cg_fname in - Some file_data) in + let source_dir = DB.source_dir_from_source_file source_file in + let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in + (match Cg.load_from_file cg_fname with + | None -> None + | Some cg -> + let nLOC = Cg.get_nLOC cg in + let file_data = new_file_data source_file nLOC cg_fname in + Some file_data) in match file_data_opt with | None -> () | Some file_data -> @@ -120,14 +120,14 @@ let add_cg_exclude_fun (exe_env: t) (source_dir : DB.source_dir) exclude_fun = let file_data = new_file_data source nLOC cg_fname in let defined_procs = Cg.get_defined_nodes cg in list_iter (fun pname -> - let should_update = - if Procname.Hash.mem exe_env.proc_map pname then - let old_source = (Procname.Hash.find exe_env.proc_map pname).source in - exe_env.procs_defined_in_several_files <- Procname.Set.add pname exe_env.procs_defined_in_several_files; - (* L.err "Warning: procedure %a is defined in both %s and %s@." Procname.pp pname (DB.source_file_to_string source) (DB.source_file_to_string old_source); *) - source < old_source (* when a procedure is defined in several files, map to the first alphabetically *) - else true in - if should_update then Procname.Hash.replace exe_env.proc_map pname file_data) defined_procs; + let should_update = + if Procname.Hash.mem exe_env.proc_map pname then + let old_source = (Procname.Hash.find exe_env.proc_map pname).source in + exe_env.procs_defined_in_several_files <- Procname.Set.add pname exe_env.procs_defined_in_several_files; + (* L.err "Warning: procedure %a is defined in both %s and %s@." Procname.pp pname (DB.source_file_to_string source) (DB.source_file_to_string old_source); *) + source < old_source (* when a procedure is defined in several files, map to the first alphabetically *) + else true in + if should_update then Procname.Hash.replace exe_env.proc_map pname file_data) defined_procs; Hashtbl.add exe_env.file_map source file_data; Some cg @@ -160,8 +160,8 @@ let get_file_data exe_env pname = try Procname.Hash.find exe_env.proc_map pname with Not_found -> - L.err "can't find tenv_cfg_object for %a@." Procname.pp pname; - raise Not_found + L.err "can't find tenv_cfg_object for %a@." Procname.pp pname; + raise Not_found (** return the source file associated to the procedure *) let get_source exe_env pname = diff --git a/infer/src/backend/fork.ml b/infer/src/backend/fork.ml index 081ae63a2..fa81e55b6 100644 --- a/infer/src/backend/fork.ml +++ b/infer/src/backend/fork.ml @@ -137,8 +137,8 @@ module Process_fork : Process_signature = struct let (summ : Specs.summary) = Marshal.from_channel p_str.c2p_in in (p_str, summ) with Not_found -> - L.err "@.ERROR: process %d was killed while trying to communicate with the parent@." sender_pid; - receive_from_child () (* wait for communication from the next process *) + L.err "@.ERROR: process %d was killed while trying to communicate with the parent@." sender_pid; + receive_from_child () (* wait for communication from the next process *) let receive_from_parent p_str : val_t = Marshal.from_channel p_str.p2c_in @@ -290,20 +290,20 @@ let compute_weighed_pnameset gr = !pnameset (* Return true if there are no children of [pname] whose specs -have changed since [pname] was last analyzed. *) + have changed since [pname] was last analyzed. *) let proc_is_up_to_date gr pname = match Specs.get_summary pname with | None -> false | Some summary -> let filter dependent_proc = Specs.get_timestamp summary = - Procname.Map.find dependent_proc summary.Specs.dependency_map in + Procname.Map.find dependent_proc summary.Specs.dependency_map in let res = Specs.is_inactive pname && Procname.Set.for_all filter (Cg.get_defined_children gr pname) in res (** Return the list of procedures which should perform a phase -transition from [FOOTPRINT] to [RE_EXECUTION] *) + transition from [FOOTPRINT] to [RE_EXECUTION] *) let should_perform_transition gr proc_name : Procname.t list = let recursive_dependents = Cg.get_recursive_dependents gr proc_name in let recursive_dependents_plus_self = Procname.Set.add proc_name recursive_dependents in @@ -332,10 +332,10 @@ let transition_footprint_re_exe proc_name joined_pres = let specs = list_map (fun jp -> - Specs.spec_normalize - { Specs.pre = jp; - Specs.posts = []; - Specs.visited = Specs.Visitedset.empty }) + Specs.spec_normalize + { Specs.pre = jp; + Specs.posts = []; + Specs.visited = Specs.Visitedset.empty }) joined_pres in Specs.PrePosts specs } in @@ -355,11 +355,11 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec. let current_specs = ref (list_fold_left - (fun map spec -> - SpecMap.add - spec.Specs.pre - (Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map) - SpecMap.empty old_specs) in + (fun map spec -> + SpecMap.add + spec.Specs.pre + (Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map) + SpecMap.empty old_specs) in let re_exe_filter old_spec = (* filter out pres which failed re-exe *) if phase == Specs.RE_EXECUTION && not (list_exists (fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) new_specs) then begin @@ -381,9 +381,9 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec. current_specs := SpecMap.add spec.Specs.pre (new_post, new_visited) (SpecMap.remove spec.Specs.pre !current_specs) end with Not_found -> - changed := true; - L.out "Specs changed: added new pre@\n%a@." (Specs.Jprop.pp_short pe_text) spec.Specs.pre; - current_specs := + changed := true; + L.out "Specs changed: added new pre@\n%a@." (Specs.Jprop.pp_short pe_text) spec.Specs.pre; + current_specs := SpecMap.add spec.Specs.pre ((Paths.PathSet.from_renamed_list spec.Specs.posts), spec.Specs.visited) @@ -391,10 +391,10 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec. let res = ref [] in let convert pre (post_set, visited) = res := - Specs.spec_normalize - { Specs.pre = pre; - Specs.posts = Paths.PathSet.elements post_set; - Specs.visited = visited }:: !res in + Specs.spec_normalize + { Specs.pre = pre; + Specs.posts = Paths.PathSet.elements post_set; + Specs.visited = visited }:: !res in list_iter re_exe_filter old_specs; (* filter out pre's which failed re-exe *) list_iter add_spec new_specs; (* add new specs *) SpecMap.iter convert !current_specs; @@ -420,10 +420,10 @@ let procs_become_done gr pname : Procname.t list = let nonrecursive_dependents = Cg.get_nonrecursive_dependents gr pname in let summary = Specs.get_summary_unsafe pname in let is_done = Specs.get_timestamp summary <> 0 && - Specs.is_inactive pname && - (!Config.only_footprint || Specs.get_phase pname == Specs.RE_EXECUTION) && - Procname.Set.for_all (proc_is_done gr) nonrecursive_dependents && - Procname.Set.for_all (proc_is_up_to_date gr) recursive_dependents in + Specs.is_inactive pname && + (!Config.only_footprint || Specs.get_phase pname == Specs.RE_EXECUTION) && + Procname.Set.for_all (proc_is_done gr) nonrecursive_dependents && + Procname.Set.for_all (proc_is_up_to_date gr) recursive_dependents in if !trace then L.err "proc is%s done@." (if is_done then "" else " not"); if is_done then @@ -441,30 +441,30 @@ let post_process_procs exe_env procs_done = end in let cg = Exe_env.get_cg exe_env in list_iter (fun pn -> - let elem = (pn, Cg.get_calls cg pn) in - if WeightedPnameSet.mem elem !wpnames_todo then - begin - incr num_procs_done; - wpnames_todo := WeightedPnameSet.remove (pn, Cg.get_calls cg pn) !wpnames_todo; - let whole_seconds = false in - check_no_specs pn; - Printer.proc_write_log whole_seconds (Exe_env.get_cfg exe_env pn) pn - end + let elem = (pn, Cg.get_calls cg pn) in + if WeightedPnameSet.mem elem !wpnames_todo then + begin + incr num_procs_done; + wpnames_todo := WeightedPnameSet.remove (pn, Cg.get_calls cg pn) !wpnames_todo; + let whole_seconds = false in + check_no_specs pn; + Printer.proc_write_log whole_seconds (Exe_env.get_cfg exe_env pn) pn + end ) procs_done (** Activate a check which ensures that multi-core mode gives the same result as one-core. -If true, detect when a dependent proc is active (analyzed concurrently) -and in that case wait for a process to terminate next *) + If true, detect when a dependent proc is active (analyzed concurrently) + and in that case wait for a process to terminate next *) let one_core_compatibility_mode = ref true (** Find the max string in the [set] which satisfies [filter], and count the number of attempts. -Precedence is given to strings in [priority_set] *) + Precedence is given to strings in [priority_set] *) let filter_max exe_env cg filter set priority_set = let rec find_max n filter set = let elem = WeightedPnameSet.max_elt set in let check_one_core_compatibility () = if !one_core_compatibility_mode && - Procname.Set.exists (fun child -> Specs.is_active child) (Cg.get_dependents cg (fst elem)) + Procname.Set.exists (fun child -> Specs.is_active child) (Cg.get_dependents cg (fst elem)) then raise Not_found in check_one_core_compatibility (); if filter elem then @@ -499,8 +499,8 @@ end = struct match Config.os_type with | Config.Unix | Config.Cygwin -> ignore (Unix.setitimer Unix.ITIMER_REAL - { Unix.it_interval = 3.0; (* try again after 3 seconds if the signal is lost *) - Unix.it_value = float_of_int nsecs }) + { Unix.it_interval = 3.0; (* try again after 3 seconds if the signal is lost *) + Unix.it_value = float_of_int nsecs }) | Config.Win32 -> SymOp.set_wallclock_alarm nsecs @@ -522,14 +522,14 @@ end = struct raise (Timeout_exe (TOtime)) let () = begin - match Config.os_type with - | Config.Unix | Config.Cygwin -> - Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action); - Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action) - | Config.Win32 -> - SymOp.set_wallclock_timeout_handler timeout_action; - ignore (Gc.create_alarm SymOp.check_wallclock_alarm) (* use the Gc alarm for periodic timeout checks *) - end + match Config.os_type with + | Config.Unix | Config.Cygwin -> + Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action); + Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action) + | Config.Win32 -> + SymOp.set_wallclock_timeout_handler timeout_action; + ignore (Gc.create_alarm SymOp.check_wallclock_alarm) (* use the Gc alarm for periodic timeout checks *) + end let exe_timeout iterations f x = try @@ -555,8 +555,8 @@ end module Process = Process_fork (** Main algorithm responsible for driving the analysis of an Exe_env (set of procedures). -The algorithm computes dependencies between procedures, spawns processes if required, -propagates results, and handles fixpoints in the call graph. *) + The algorithm computes dependencies between procedures, spawns processes if required, + propagates results, and handles fixpoints in the call graph. *) let parallel_execution exe_env num_processes analyze_proc filter_out process_result : unit = parallel_mode := num_processes > 1 || !Config.max_num_proc > 0; let call_graph = Exe_env.get_cg exe_env in @@ -579,7 +579,7 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res Procname.Set.for_all (fun child -> Specs.is_inactive child) (Cg.get_defined_children call_graph pname) && (Specs.get_timestamp (Specs.get_summary_unsafe pname) = 0 - || not (proc_is_up_to_date call_graph pname)) in + || not (proc_is_up_to_date call_graph pname)) in let process_one_proc pname (calls: Cg.in_out_calls) = DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file; if !trace then @@ -634,9 +634,9 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res | Some (p_str, summ) -> let (pname, weight) = Process.get_last_input p_str in (try - DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file; - process_result exe_env (pname, weight) summ - with exn -> assert false); + DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file; + process_result exe_env (pname, weight) summ + with exn -> assert false); Timing_log.event_finish (Procname.to_string pname); Process.kill_process p_str; incr avail_num @@ -654,21 +654,21 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res let pname, calls = filter_max exe_env call_graph wpname_can_be_analyzed !wpnames_todo wpnames_address_of in (** find max analyzable proc *) process_one_proc pname calls with Not_found -> (* no analyzable procs *) - if !avail_num < num_processes (* some other process is doing work *) - then wait_for_next_result () - else - (L.err "Error: can't analyze any procs. Printing current spec table@\n@[%a@]@." (Specs.pp_spec_table pe_text false) (); - raise (Failure "Stopping")) + if !avail_num < num_processes (* some other process is doing work *) + then wait_for_next_result () + else + (L.err "Error: can't analyze any procs. Printing current spec table@\n@[%a@]@." (Specs.pp_spec_table pe_text false) (); + raise (Failure "Stopping")) end else wait_for_next_result () done (** [parallel_iter_nodes cfg call_graph analyze_proc process_result filter_out] -executes [analyze_proc] in parallel as much as possible as allowed -by the call graph, and applies [process_result] to the result as -soon as it is returned by a child process. If [filter_out] returns -true, no execution. *) + executes [analyze_proc] in parallel as much as possible as allowed + by the call graph, and applies [process_result] to the result as + soon as it is returned by a child process. If [filter_out] returns + true, no execution. *) let parallel_iter_nodes (exe_env: Exe_env.t) (_analyze_proc: Exe_env.t -> Procname.t -> 'a) (_process_result: Exe_env.t -> (Procname.t * Cg.in_out_calls) -> 'a -> unit) (filter_out: Cg.t -> Procname.t -> bool) : unit = let analyze_proc exe_env pname = (* wrap _analyze_proc and handle exceptions *) try _analyze_proc exe_env pname with diff --git a/infer/src/backend/ident.ml b/infer/src/backend/ident.ml index 8ff76a9d0..c69eb7ab2 100644 --- a/infer/src/backend/ident.ml +++ b/infer/src/backend/ident.ml @@ -73,10 +73,10 @@ let ident_list_equal ids1 ids2 = (ident_list_compare ids1 ids2 = 0) (** {2 Set for identifiers} *) module IdentSet = Set.Make - (struct - type t = _ident - let compare = compare - end) + (struct + type t = _ident + let compare = compare + end) module IdentHash = Hashtbl.Make(struct @@ -86,14 +86,14 @@ module IdentHash = end) module FieldSet = Set.Make(struct - type t = fieldname - let compare = fieldname_compare -end) + type t = fieldname + let compare = fieldname_compare + end) module FieldMap = Map.Make(struct - type t = fieldname - let compare = fieldname_compare -end) + type t = fieldname + let compare = fieldname_compare + end) let idlist_to_idset ids = list_fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids @@ -136,8 +136,8 @@ let fieldname_to_simplified_string fn = match string_split_character s '.' with | Some s1, s2 -> (match string_split_character s1 '.' with - | Some s3, s4 -> s4 ^ "." ^ s2 - | _ -> s) + | Some s3, s4 -> s4 ^ "." ^ s2 + | _ -> s) | _ -> s (** Convert a fieldname to a flat string without path. *) @@ -221,7 +221,7 @@ let create_with_stamp kind name stamp = let new_stamp = max curr_stamp stamp in NameHash.replace name_map name new_stamp with Not_found -> - NameHash.add name_map name stamp in + NameHash.add name_map name stamp in update_name_hash (); { kind = kind; name = name; stamp = stamp } @@ -290,8 +290,8 @@ let create_fresh_ident kind name = NameHash.replace name_map name (stamp + 1); stamp + 1 with Not_found -> - NameHash.add name_map name 0; - 0 in + NameHash.add name_map name 0; + 0 in { kind = kind; name = name; stamp = stamp } (** Create a fresh identifier with default name for the given kind. *) diff --git a/infer/src/backend/inferanalyze.ml b/infer/src/backend/inferanalyze.ml index d82f65f98..852e91342 100644 --- a/infer/src/backend/inferanalyze.ml +++ b/infer/src/backend/inferanalyze.ml @@ -93,9 +93,9 @@ let objc_ml_buckets_arg = ref "cf" let allow_specs_cleanup = ref false (** Compute the exclude function from excluded_files and source_path. -The exclude function builds an exclude list of file path prefixes, and checks if one -of them is a prefix of the given source file. -Prefixes are obtained by prepending source_path, if any, to relative paths in excluded_fies *) + The exclude function builds an exclude list of file path prefixes, and checks if one + of them is a prefix of the given source file. + Prefixes are obtained by prepending source_path, if any, to relative paths in excluded_fies *) let compute_exclude_fun () : DB.source_file -> bool = let prepend_source_path s = if Filename.is_relative s then Filename.concat !source_path s @@ -133,53 +133,53 @@ let arg_desc = let desc = base_arg_desc @ [ - "-err_file", Arg.Set_string err_file_cmdline, Some "file", "use file for the err channel"; - "-exclude", Arg.String exclude, Some "file", "exclude from analysis the files and directories specified in file"; - "-incremental_ignore_dependencies", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_ONLY), None, "only analyze files captured since the last analysis"; - "-incremental", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_AND_DEPENDENCIES), None, "analyze files captured since the last analysis plus any dependencies"; - "-iterations", Arg.Set_int iterations_cmdline, Some "n", "set the max number of operations for each function, expressed as a multiple of symbolic operations (default n=1)"; - "-nonstop", Arg.Set Config.nonstop, None, "activate the nonstop mode: the analysis continues after finding errors. With this option the analysis can become less precise."; - "-out_file", Arg.Set_string out_file_cmdline, Some "file", "use file for the out channel"; - "-print_builtins", Arg.Unit SymExec.print_builtins, None, "print the builtin functions and exit"; - "-source_path", Arg.String source_path, Some "path", "specify the absolute path to the root of the source files. Used to interpret relative paths when using option -exclude."; - (* TODO: merge with the -project_root option *) - "-java", Arg.Unit (fun () -> Sil.curr_language := Sil.Java), None, "Set language to Java"; - "-version", Arg.Unit print_version, None, "print version information and exit"; - "-version_json", Arg.Unit print_version_json, None, "print version json formatted"; - "-objcm", Arg.Set Config.objc_memory_model_on, None, "Use ObjC memory model"; - "-objc_ml_buckets", Arg.Set_string objc_ml_buckets_arg, Some "objc_ml_buckets", - "memory leak buckets to be checked, separated by commas. The possible buckets are cf (Core Foundation), arc, narc (No arc)"; + "-err_file", Arg.Set_string err_file_cmdline, Some "file", "use file for the err channel"; + "-exclude", Arg.String exclude, Some "file", "exclude from analysis the files and directories specified in file"; + "-incremental_ignore_dependencies", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_ONLY), None, "only analyze files captured since the last analysis"; + "-incremental", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_AND_DEPENDENCIES), None, "analyze files captured since the last analysis plus any dependencies"; + "-iterations", Arg.Set_int iterations_cmdline, Some "n", "set the max number of operations for each function, expressed as a multiple of symbolic operations (default n=1)"; + "-nonstop", Arg.Set Config.nonstop, None, "activate the nonstop mode: the analysis continues after finding errors. With this option the analysis can become less precise."; + "-out_file", Arg.Set_string out_file_cmdline, Some "file", "use file for the out channel"; + "-print_builtins", Arg.Unit SymExec.print_builtins, None, "print the builtin functions and exit"; + "-source_path", Arg.String source_path, Some "path", "specify the absolute path to the root of the source files. Used to interpret relative paths when using option -exclude."; + (* TODO: merge with the -project_root option *) + "-java", Arg.Unit (fun () -> Sil.curr_language := Sil.Java), None, "Set language to Java"; + "-version", Arg.Unit print_version, None, "print version information and exit"; + "-version_json", Arg.Unit print_version_json, None, "print version json formatted"; + "-objcm", Arg.Set Config.objc_memory_model_on, None, "Use ObjC memory model"; + "-objc_ml_buckets", Arg.Set_string objc_ml_buckets_arg, Some "objc_ml_buckets", + "memory leak buckets to be checked, separated by commas. The possible buckets are cf (Core Foundation), arc, narc (No arc)"; ] in Arg2.create_options_desc false "Analysis Options" desc in let reserved_arg = let desc = reserved_arg_desc @ [ - "-analysis_stops", Arg.Set Config.analysis_stops, None, "issue a warning when the analysis stops"; - "-angelic_execution", Arg.Set Config.angelic_execution, None, "activate angelic execution: the analysis ignores errors caused by unknown procedure calls."; - "-checkers", Arg.Set checkers, None, " run only the checkers instead of the full analysis"; - "-cluster", Arg.String (fun s -> cluster_cmdline := Some s), Some "fname", "specify a .cluster file to be analyzed"; - "-codequery", Arg.String (fun s -> CodeQuery.query := Some s), Some "query", " execute the code query"; - "-eradicate", Arg.Set Config.eradicate, None, " activate the eradicate checker for java annotations"; - "-file", Arg.String (fun s -> only_files_cmdline := s :: !only_files_cmdline), Some "fname", "specify one file to be analyzed (without path); the option can be repeated"; - "-intraprocedural", Arg.Set Config.intraprocedural, None, "perform an intraprocedural analysis only"; - "-makefile", Arg.Set_string makefile_cmdline, Some "file", "create a makefile to perform the analysis"; - "-max_cluster", Arg.Set_int Config.max_cluster_size, Some "n", "set the max number of procedures in each cluster (default n=2000)"; - "-only_nospecs", Arg.Set Config.only_nospecs, None, " only analyze procedures which were analyzed before but have no specs"; - "-only_skips", Arg.Set Config.only_skips, None, " only analyze procedures dependent on previous skips which now have a .specs file"; - "-seconds_per_iteration", Arg.Set_int seconds_per_iteration, Some "n", "set the number of seconds per iteration (default n=30)"; - "-simulate", Arg.Set simulate, None, " run a simulation of the analysis only"; - "-subtype_multirange", Arg.Set Config.subtype_multirange, None, "use the multirange subtyping domain"; - "-optimistic_cast", Arg.Set Config.optimistic_cast, None, "allow cast of undefined values"; - "-select_proc", Arg.String (fun s -> select_proc := Some s), Some "string", "only consider procedures whose name contains the given string"; - "-symops_per_iteration", Arg.Set_int symops_per_iteration, Some "n", "set the number of symbolic operations per iteration (default n="^(string_of_int !symops_per_iteration)^")"; - "-type_size", Arg.Set Config.type_size, None, "consider the size of types during analysis"; - "-tracing", Arg.Unit (fun () -> Config.report_runtime_exceptions := true), None, - "Report error traces for runtime exceptions (Only for Java)"; - "-allow_specs_cleanup", Arg.Unit (fun () -> allow_specs_cleanup := true), None, - "Allow to remove existing specs before running analysis when it's not incremental"; - "-print_buckets", Arg.Unit (fun() -> Config.show_buckets := true; Config.show_ml_buckets := true), None, - "Add buckets to issue descriptions, useful when developing infer" + "-analysis_stops", Arg.Set Config.analysis_stops, None, "issue a warning when the analysis stops"; + "-angelic_execution", Arg.Set Config.angelic_execution, None, "activate angelic execution: the analysis ignores errors caused by unknown procedure calls."; + "-checkers", Arg.Set checkers, None, " run only the checkers instead of the full analysis"; + "-cluster", Arg.String (fun s -> cluster_cmdline := Some s), Some "fname", "specify a .cluster file to be analyzed"; + "-codequery", Arg.String (fun s -> CodeQuery.query := Some s), Some "query", " execute the code query"; + "-eradicate", Arg.Set Config.eradicate, None, " activate the eradicate checker for java annotations"; + "-file", Arg.String (fun s -> only_files_cmdline := s :: !only_files_cmdline), Some "fname", "specify one file to be analyzed (without path); the option can be repeated"; + "-intraprocedural", Arg.Set Config.intraprocedural, None, "perform an intraprocedural analysis only"; + "-makefile", Arg.Set_string makefile_cmdline, Some "file", "create a makefile to perform the analysis"; + "-max_cluster", Arg.Set_int Config.max_cluster_size, Some "n", "set the max number of procedures in each cluster (default n=2000)"; + "-only_nospecs", Arg.Set Config.only_nospecs, None, " only analyze procedures which were analyzed before but have no specs"; + "-only_skips", Arg.Set Config.only_skips, None, " only analyze procedures dependent on previous skips which now have a .specs file"; + "-seconds_per_iteration", Arg.Set_int seconds_per_iteration, Some "n", "set the number of seconds per iteration (default n=30)"; + "-simulate", Arg.Set simulate, None, " run a simulation of the analysis only"; + "-subtype_multirange", Arg.Set Config.subtype_multirange, None, "use the multirange subtyping domain"; + "-optimistic_cast", Arg.Set Config.optimistic_cast, None, "allow cast of undefined values"; + "-select_proc", Arg.String (fun s -> select_proc := Some s), Some "string", "only consider procedures whose name contains the given string"; + "-symops_per_iteration", Arg.Set_int symops_per_iteration, Some "n", "set the number of symbolic operations per iteration (default n="^(string_of_int !symops_per_iteration)^")"; + "-type_size", Arg.Set Config.type_size, None, "consider the size of types during analysis"; + "-tracing", Arg.Unit (fun () -> Config.report_runtime_exceptions := true), None, + "Report error traces for runtime exceptions (Only for Java)"; + "-allow_specs_cleanup", Arg.Unit (fun () -> allow_specs_cleanup := true), None, + "Allow to remove existing specs before running analysis when it's not incremental"; + "-print_buckets", Arg.Unit (fun() -> Config.show_buckets := true; Config.show_ml_buckets := true), None, + "Add buckets to issue descriptions, useful when developing infer" ] in Arg2.create_options_desc false "Reserved Options: Experimental features, use with caution!" desc in base_arg @ reserved_arg @@ -210,7 +210,7 @@ module Simulator = struct (** Simulate the analysis only *) (Cg.get_nodes_and_calls cg) (** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for - the procedures enabled after the analysis of [proc_name] *) + the procedures enabled after the analysis of [proc_name] *) let perform_transition exe_env proc_name = let proc_names = Fork.should_perform_transition (Exe_env.get_cg exe_env) proc_name in let f proc_name = @@ -242,23 +242,23 @@ let analyze exe_env = Random.self_init (); let line_reader = Printer.LineReader.create () in if !checkers then (* run the checkers only *) - begin - let call_graph = Exe_env.get_cg exe_env in - Callbacks.iterate_callbacks Checkers.ST.store_summary call_graph exe_env - end + begin + let call_graph = Exe_env.get_cg exe_env in + Callbacks.iterate_callbacks Checkers.ST.store_summary call_graph exe_env + end else if !simulate then (* simulate the analysis *) - begin - Simulator.reset_summaries (Exe_env.get_cg exe_env); - Fork.parallel_iter_nodes exe_env (Simulator.analyze_proc exe_env) Simulator.process_result Simulator.filter_out - end + begin + Simulator.reset_summaries (Exe_env.get_cg exe_env); + Fork.parallel_iter_nodes exe_env (Simulator.analyze_proc exe_env) Simulator.process_result Simulator.filter_out + end else (* full analysis *) - begin - Interproc.do_analysis exe_env; - Printer.c_files_write_html line_reader exe_env; - Interproc.print_stats exe_env; - let elapsed = Unix.gettimeofday () -. init_time in - L.out "Interprocedural footprint analysis terminated in %f sec@." elapsed - end + begin + Interproc.do_analysis exe_env; + Printer.c_files_write_html line_reader exe_env; + Interproc.print_stats exe_env; + let elapsed = Unix.gettimeofday () -. init_time in + L.out "Interprocedural footprint analysis terminated in %f sec@." elapsed + end (** add [x] to list [l] at position [nth] *) let list_add_nth x l nth = @@ -270,7 +270,7 @@ let list_add_nth x l nth = add [] l nth (** sort a list weakly w.r.t. a compare function which doest not have to be a total order -the number returned by [compare x y] indicates 'how strongly' x should come before y *) + the number returned by [compare x y] indicates 'how strongly' x should come before y *) let weak_sort compare list = let weak_add l x = let length = list_length l in @@ -280,14 +280,14 @@ let weak_sort compare list = let best_value = ref (fitness.(0)) in let i = ref 0 in list_iter (fun y -> - incr i; - let new_value = fitness.(!i - 1) - (compare x y) + (compare y x) in - fitness.(!i) <- new_value; - if new_value < !best_value then - begin - best_value := new_value; - best_position := !i - end) + incr i; + let new_value = fitness.(!i - 1) - (compare x y) + (compare y x) in + fitness.(!i) <- new_value; + if new_value < !best_value then + begin + best_value := new_value; + best_position := !i + end) l; list_add_nth x l !best_position in list_fold_left weak_add [] list @@ -316,8 +316,8 @@ let weak_sort_nodes cg = weak_sort cmp nodes (** cluster element: the file name, the number of procedures defined in it, and the list of active procedures -A procedure is active if it is defined only in this file, or if it is defined in several files and this -is the representative file for it (see Exe_env.add_cg) *) + A procedure is active if it is defined only in this file, or if it is defined in several files and this + is the representative file for it (see Exe_env.add_cg) *) type cluster_elem = { ce_file : DB.source_file; ce_naprocs : int; (** number of active procedures defined in the file *) @@ -364,7 +364,7 @@ let create_minimal_clusters file_cg exe_env (only_analyze : Procname.Set.t optio match Cg.load_from_file cg_fname with | None -> { ce_file = source_file; ce_naprocs = 0; ce_active_procs = []; ce_source_map = Procname.Map.empty } | Some cg -> - (* decide whether a proc is active using pname_to_fname, i.e. whether this is the file associated to it *) + (* decide whether a proc is active using pname_to_fname, i.e. whether this is the file associated to it *) let proc_is_selected pname = match !select_proc with | None -> true | Some pattern_str -> string_is_prefix pattern_str (Procname.to_unique_id pname) in @@ -411,9 +411,9 @@ let create_minimal_clusters file_cg exe_env (only_analyze : Procname.Set.t optio let cluster, list'' = list_partition (fun node -> Procname.Set.mem node cluster_set) list in seen := Procname.Set.union !seen cluster_set; let files_to_analyze = list_filter (fun node -> - match only_analyze with - | None -> true - | Some files_to_analyze -> Procname.Set.mem node files_to_analyze) cluster in + match only_analyze with + | None -> true + | Some files_to_analyze -> Procname.Set.mem node files_to_analyze) cluster in if files_to_analyze <> [] then begin let cluster = list_map create_cluster_elem files_to_analyze in @@ -553,7 +553,7 @@ module ClusterMakefile = struct list_iter (fun ce -> file_to_cluster := DB.SourceFileMap.add ce.ce_file !cluster_nr !file_to_cluster) cluster; list_iter do_file cluster; pp_cluster_dependency !cluster_nr tot_clusters_nr cluster print_files fmt (IntSet.elements !dependent_clusters); - (* L.err "cluster %d has %d dependencies@." !cluster_nr (IntSet.cardinal !dependent_clusters) *) in + (* L.err "cluster %d has %d dependencies@." !cluster_nr (IntSet.cardinal !dependent_clusters) *) in pp_prolog fmt tot_clusters_nr; list_iter do_cluster clusters; pp_epilog fmt (); @@ -590,12 +590,12 @@ let compute_clusters exe_env (files_changed : Procname.Set.t) : cluster list = if !incremental_mode != ANALYZE_ALL then begin Procname.Set.iter (fun c_file -> - let ancestors = - try Cg.get_ancestors file_cg c_file with - | Not_found -> - L.err "Warning: modified file %s is ignored, all its functions might be already defined in another file@." (Procname.to_string c_file); - Procname.Set.empty in - files_changed_and_dependents := Procname.Set.union ancestors !files_changed_and_dependents) files_changed; + let ancestors = + try Cg.get_ancestors file_cg c_file with + | Not_found -> + L.err "Warning: modified file %s is ignored, all its functions might be already defined in another file@." (Procname.to_string c_file); + Procname.Set.empty in + files_changed_and_dependents := Procname.Set.union ancestors !files_changed_and_dependents) files_changed; L.err "Number of files changed since the last analysis: %d.@." (Procname.Set.cardinal files_changed) end else L.err ".@."; @@ -625,7 +625,7 @@ let compute_clusters exe_env (files_changed : Procname.Set.t) : cluster list = clusters' (** Check whether the cg file is changed. It is unchanged if for each defined procedure, the .specs -file exists and is more recent than the cg file. *) + file exists and is more recent than the cg file. *) let cg_check_changed exe_env source_dir cg = let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in let defined_nodes = Cg.get_defined_nodes cg in @@ -637,7 +637,7 @@ let cg_check_changed exe_env source_dir cg = let spec_fname = Specs.res_dir_specs_filename pname in if is_active then changed := (!changed || not (Sys.file_exists (DB.filename_to_string spec_fname)) || - DB.file_modified_time cg_fname > DB.file_modified_time spec_fname) in + DB.file_modified_time cg_fname > DB.file_modified_time spec_fname) in list_iter check_needs_update defined_nodes; !changed @@ -658,13 +658,13 @@ let load_cg_files _exe_env check_changed (source_dirs : DB.source_dir list) excl let check_cg_changed (source_dir, cg) = let is_changed = cg_check_changed exe_env source_dir cg in if is_changed then files_changed := - Procname.Set.add (source_file_to_pname (Cg.get_source cg)) !files_changed in + Procname.Set.add (source_file_to_pname (Cg.get_source cg)) !files_changed in list_iter check_cg_changed !cg_list in list_iter (fun source_dir -> - match load_cg_file _exe_env source_dir exclude_fun with - | None -> () - | Some cg -> - if check_changed then cg_list := (source_dir, cg) :: !cg_list) sorted_dirs; + match load_cg_file _exe_env source_dir exclude_fun with + | None -> () + | Some cg -> + if check_changed then cg_list := (source_dir, cg) :: !cg_list) sorted_dirs; let exe_env = Exe_env.freeze _exe_env in if check_changed then check_cgs_changed exe_env; !files_changed, exe_env @@ -706,14 +706,14 @@ let process_cluster_cmdline_exit () = | None -> () | Some fname -> (match load_cluster_from_file (DB.filename_from_string fname) with - | None -> - L.err "Cannot find cluster file %s@." fname; - exit 0 - | Some (nr, tot_nr, cluster) -> - Fork.tot_files_done := (nr - 1) * list_length cluster; - Fork.tot_files := tot_nr * list_length cluster; - analyze_cluster (ref (nr -1)) tot_nr cluster; - exit 0) + | None -> + L.err "Cannot find cluster file %s@." fname; + exit 0 + | Some (nr, tot_nr, cluster) -> + Fork.tot_files_done := (nr - 1) * list_length cluster; + Fork.tot_files := tot_nr * list_length cluster; + analyze_cluster (ref (nr -1)) tot_nr cluster; + exit 0) let open_output_file f fname = try @@ -722,8 +722,8 @@ let open_output_file f fname = f fmt; Some (fmt, cout) with Sys_error _ -> - Format.fprintf Format.std_formatter "Error: cannot open output file %s@." fname; - exit(-1) + Format.fprintf Format.std_formatter "Error: cannot open output file %s@." fname; + exit(-1) let close_output_file = function | None -> () diff --git a/infer/src/backend/inferconfig.ml b/infer/src/backend/inferconfig.ml index fd8f4bd50..344c7edd9 100644 --- a/infer/src/backend/inferconfig.ml +++ b/infer/src/backend/inferconfig.ml @@ -66,13 +66,13 @@ let load_filters analyzer = let is_matching patterns = fun source_file -> - let path = DB.source_file_to_rel_path source_file in - Utils.list_exists - (fun pattern -> - try - (Str.search_forward pattern path 0) = 0 - with Not_found -> false) - patterns + let path = DB.source_file_to_rel_path source_file in + Utils.list_exists + (fun pattern -> + try + (Str.search_forward pattern path 0) = 0 + with Not_found -> false) + patterns module FileContainsStringMatcher = struct type matcher = DB.source_file -> bool @@ -96,16 +96,16 @@ module FileContainsStringMatcher = struct let regexp = Str.regexp (join_strings "\\|" s_patterns) in fun source_file -> + try + DB.SourceFileMap.find source_file !source_map + with Not_found -> try - DB.SourceFileMap.find source_file !source_map - with Not_found -> - try - let file_in = open_in (DB.source_file_to_string source_file) in - let pattern_found = file_contains regexp file_in in - close_in file_in; - source_map := DB.SourceFileMap.add source_file pattern_found !source_map; - pattern_found - with Sys_error _ -> false + let file_in = open_in (DB.source_file_to_string source_file) in + let pattern_found = file_contains regexp file_in in + close_in file_in; + source_map := DB.SourceFileMap.add source_file pattern_found !source_map; + pattern_found + with Sys_error _ -> false end let filters_from_inferconfig inferconfig : filters = @@ -118,13 +118,13 @@ let filters_from_inferconfig inferconfig : filters = let blacklist_files_containing_filter : path_filter = FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing in function source_file -> - whitelist_filter source_file && - not (blacklist_filter source_file) && - not (blacklist_files_containing_filter source_file) in + whitelist_filter source_file && + not (blacklist_filter source_file) && + not (blacklist_files_containing_filter source_file) in let error_filter = function error_name -> - let error_str = Localise.to_string error_name in - not (list_exists (string_equal error_str) inferconfig.suppress_errors) in + let error_str = Localise.to_string error_name in + not (list_exists (string_equal error_str) inferconfig.suppress_errors) in { path_filter = path_filter; error_filter = error_filter; @@ -268,25 +268,25 @@ module NeverReturnNull = struct let pattern_map = list_fold_left (fun map pattern -> - let previous = - try - StringMap.find pattern.class_name map - with Not_found -> [] in - StringMap.add pattern.class_name (pattern:: previous) map) + let previous = + try + StringMap.find pattern.class_name map + with Not_found -> [] in + StringMap.add pattern.class_name (pattern:: previous) map) StringMap.empty m_patterns in fun source_file proc_name -> - let class_name = Procname.java_get_class proc_name - and method_name = Procname.java_get_method proc_name in - try - let class_patterns = StringMap.find class_name pattern_map in - list_exists - (fun p -> - match p.method_name with - | None -> true - | Some m -> string_equal m method_name) - class_patterns - with Not_found -> false + let class_name = Procname.java_get_class proc_name + and method_name = Procname.java_get_method proc_name in + try + let class_patterns = StringMap.find class_name pattern_map in + list_exists + (fun p -> + match p.method_name with + | None -> true + | Some m -> string_equal m method_name) + class_patterns + with Not_found -> false let create_file_matcher language patterns = let s_patterns, m_patterns = @@ -301,7 +301,7 @@ module NeverReturnNull = struct fun source_file proc_name -> matcher source_file and m_matcher = create_method_matcher language m_patterns in fun source_file proc_name -> - m_matcher source_file proc_name || s_matcher source_file proc_name + m_matcher source_file proc_name || s_matcher source_file proc_name let load_matcher language = try @@ -313,7 +313,7 @@ module NeverReturnNull = struct list_fold_left translate [] found in create_file_matcher language patterns with Sys_error _ -> - default_matcher + default_matcher end (* of module NeverReturnNull *) @@ -330,14 +330,14 @@ let test () = [] filters in Utils.directory_iter (fun path -> - if DB.is_source_file path then - let source_file = (DB.source_file_from_string path) in - let matching = matching_analyzers source_file in - if matching <> [] then - let matching_s = - Utils.join_strings ", " - (Utils.list_map Utils.string_of_analyzer matching) in - Logging.stderr "%s -> {%s}@." - (DB.source_file_to_rel_path source_file) - matching_s) + if DB.is_source_file path then + let source_file = (DB.source_file_from_string path) in + let matching = matching_analyzers source_file in + if matching <> [] then + let matching_s = + Utils.join_strings ", " + (Utils.list_map Utils.string_of_analyzer matching) in + Logging.stderr "%s -> {%s}@." + (DB.source_file_to_rel_path source_file) + matching_s) (Sys.getcwd ()) diff --git a/infer/src/backend/inferprint.ml b/infer/src/backend/inferprint.ml index d7e0d6bbe..c5aa3533d 100644 --- a/infer/src/backend/inferprint.ml +++ b/infer/src/backend/inferprint.ml @@ -91,38 +91,38 @@ let arg_desc = let base_arg = let desc = [ - "-bugs", Arg.String (fun s -> bugs_csv := create_outfile s), Some "bugs.csv", "create file bugs.csv containing a list of bugs in CSV format"; - "-bugs_json", Arg.String (fun s -> bugs_json := create_outfile s), Some "bugs.json", "create file bugs.json containing a list of bugs in JSON format"; - "-bugs_txt", Arg.String (fun s -> bugs_txt := create_outfile s), Some "bugs.txt", "create file bugs.txt containing a list of bugs in text format"; - "-bugs_xml", Arg.String (fun s -> bugs_xml := create_outfile s), Some "bugs.xml", "create file bugs.xml containing a list of bugs in XML format"; - "-calls", Arg.String (fun s -> calls_csv := create_outfile s), Some "calls.csv", "write individual calls in csv format to file.csv"; - "-load_results", Arg.String (fun s -> load_analysis_results := Some s), Some "file.iar", "load analysis results from Infer Analysis Results file file.iar"; - "-procs", Arg.String (fun s -> procs_csv := create_outfile s), Some "procs.csv", "create file procs.csv containing statistics for each procedure in CSV format"; - "-procs_xml", Arg.String (fun s -> procs_xml := create_outfile s), Some "procs.xml", "create file procs.xml containing statistics for each procedure in XML format"; - "-results_dir", Arg.String (fun s -> results_dir_cmdline := true; Config.results_dir := s), Some "dir", "read all the .specs files in the results dir"; - "-q", Arg.Set quiet, None, "quiet: do not print specs on standard output"; - "-save_results", Arg.String (fun s -> save_analysis_results := Some s), Some "file.iar", "save analysis results to Infer Analysis Results file file.iar"; - "-unit_test", Arg.Set unit_test, None, "print unit test code"; - "-xml", Arg.Set xml_specs, None, "export specs into XML files file1.xml ... filen.xml"; - "-test_filtering", Arg.Set test_filtering, None, - "list all the files Infer can report on (should be call at the root of the procject, where + "-bugs", Arg.String (fun s -> bugs_csv := create_outfile s), Some "bugs.csv", "create file bugs.csv containing a list of bugs in CSV format"; + "-bugs_json", Arg.String (fun s -> bugs_json := create_outfile s), Some "bugs.json", "create file bugs.json containing a list of bugs in JSON format"; + "-bugs_txt", Arg.String (fun s -> bugs_txt := create_outfile s), Some "bugs.txt", "create file bugs.txt containing a list of bugs in text format"; + "-bugs_xml", Arg.String (fun s -> bugs_xml := create_outfile s), Some "bugs.xml", "create file bugs.xml containing a list of bugs in XML format"; + "-calls", Arg.String (fun s -> calls_csv := create_outfile s), Some "calls.csv", "write individual calls in csv format to file.csv"; + "-load_results", Arg.String (fun s -> load_analysis_results := Some s), Some "file.iar", "load analysis results from Infer Analysis Results file file.iar"; + "-procs", Arg.String (fun s -> procs_csv := create_outfile s), Some "procs.csv", "create file procs.csv containing statistics for each procedure in CSV format"; + "-procs_xml", Arg.String (fun s -> procs_xml := create_outfile s), Some "procs.xml", "create file procs.xml containing statistics for each procedure in XML format"; + "-results_dir", Arg.String (fun s -> results_dir_cmdline := true; Config.results_dir := s), Some "dir", "read all the .specs files in the results dir"; + "-q", Arg.Set quiet, None, "quiet: do not print specs on standard output"; + "-save_results", Arg.String (fun s -> save_analysis_results := Some s), Some "file.iar", "save analysis results to Infer Analysis Results file file.iar"; + "-unit_test", Arg.Set unit_test, None, "print unit test code"; + "-xml", Arg.Set xml_specs, None, "export specs into XML files file1.xml ... filen.xml"; + "-test_filtering", Arg.Set test_filtering, None, + "list all the files Infer can report on (should be call at the root of the procject, where .inferconfig lives)."; - "-analyzer", Arg.String (fun s -> analyzer := Some (Utils.analyzer_of_string s)), Some "analyzer", - "setup the analyzer for the path filtering"; - "-inferconfig_home", Arg.String (fun s -> Inferconfig.inferconfig_home := Some s), Some "dir", - "Path to the .inferconfig file"; + "-analyzer", Arg.String (fun s -> analyzer := Some (Utils.analyzer_of_string s)), Some "analyzer", + "setup the analyzer for the path filtering"; + "-inferconfig_home", Arg.String (fun s -> Inferconfig.inferconfig_home := Some s), Some "dir", + "Path to the .inferconfig file"; ] in Arg2.create_options_desc false "Options" desc in let reserved_arg = let desc = [ - "-latex", Arg.String (fun s -> latex := create_outfile s), Some "file.tex", "print latex report to file.tex"; - "-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps"; - "-precondition_stats", Arg.Set precondition_stats, None, "print stats about preconditions to standard output"; - "-report", Arg.String (fun s -> report := create_outfile s), Some "report_file", "create file report_file containing a report of the analysis results"; - "-source_file_copy", Arg.String (fun s -> source_file_copy := Some (DB.abs_source_file_from_path s)), Some "source_file", "print the path of the copy of source_file in the results directory"; - "-svg", Arg.Set svg, None, "generate .dot and .svg"; - "-whole_seconds", Arg.Set whole_seconds, None, "print whole seconds only"; + "-latex", Arg.String (fun s -> latex := create_outfile s), Some "file.tex", "print latex report to file.tex"; + "-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps"; + "-precondition_stats", Arg.Set precondition_stats, None, "print stats about preconditions to standard output"; + "-report", Arg.String (fun s -> report := create_outfile s), Some "report_file", "create file report_file containing a report of the analysis results"; + "-source_file_copy", Arg.String (fun s -> source_file_copy := Some (DB.abs_source_file_from_path s)), Some "source_file", "print the path of the copy of source_file in the results directory"; + "-svg", Arg.Set svg, None, "generate .dot and .svg"; + "-whole_seconds", Arg.Set whole_seconds, None, "print whole seconds only"; ] in Arg2.create_options_desc false "Reserved Options" desc in base_arg @ reserved_arg @@ -196,7 +196,7 @@ let loc_trace_to_jsonbug_record trace_list ekind = match ekind with | Exceptions.Kinfo -> [] | _ -> - (* writes a trace as a record for atdgen conversion *) + (* writes a trace as a record for atdgen conversion *) let node_tags_to_records tags_list = list_map (fun tag -> { tag = fst tag; value = snd tag }) tags_list in let trace_item_to_record trace_item = @@ -251,7 +251,7 @@ let summary_values top_proc_set summary = list_iter do_spec specs; let visited_lines = ref IntSet.empty in Specs.Visitedset.iter (fun (n, ls) -> - list_iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls) + list_iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls) !visited; Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in let proof_trace = @@ -337,26 +337,26 @@ module ProcsXml = struct let attributes = [("id", string_of_int !xml_procs_id) ] in let forest = [ - subtree Io_infer.Xml.tag_name (Escape.escape_xml sv.vname); - subtree Io_infer.Xml.tag_name_id (Escape.escape_xml sv.vname_id); - subtree Io_infer.Xml.tag_specs (string_of_int sv.vspecs); - subtree Io_infer.Xml.tag_time sv.vtime; - subtree Io_infer.Xml.tag_to sv.vto; - subtree Io_infer.Xml.tag_symop (string_of_int sv.vsymop); - subtree Io_infer.Xml.tag_err (string_of_int sv.verr); - subtree Io_infer.Xml.tag_file sv.vfile; - subtree Io_infer.Xml.tag_line (string_of_int sv.vline); - subtree Io_infer.Xml.tag_loc (string_of_int sv.vloc); - subtree Io_infer.Xml.tag_top sv.vtop; - subtree Io_infer.Xml.tag_signature (Escape.escape_xml sv.vsignature); - subtree Io_infer.Xml.tag_weight (string_of_int sv.vweight); - subtree Io_infer.Xml.tag_proof_coverage sv.vproof_coverage; - subtree Io_infer.Xml.tag_rank sv.vrank; - subtree Io_infer.Xml.tag_in_calls (string_of_int sv.vin_calls); - subtree Io_infer.Xml.tag_out_calls (string_of_int sv.vin_calls); - subtree Io_infer.Xml.tag_proof_trace sv.vproof_trace; - subtree Io_infer.Xml.tag_cyclomatic (string_of_int sv.vcyclomatic); - subtree Io_infer.Xml.tag_flags (string_of_int (Hashtbl.length sv.vflags)); + subtree Io_infer.Xml.tag_name (Escape.escape_xml sv.vname); + subtree Io_infer.Xml.tag_name_id (Escape.escape_xml sv.vname_id); + subtree Io_infer.Xml.tag_specs (string_of_int sv.vspecs); + subtree Io_infer.Xml.tag_time sv.vtime; + subtree Io_infer.Xml.tag_to sv.vto; + subtree Io_infer.Xml.tag_symop (string_of_int sv.vsymop); + subtree Io_infer.Xml.tag_err (string_of_int sv.verr); + subtree Io_infer.Xml.tag_file sv.vfile; + subtree Io_infer.Xml.tag_line (string_of_int sv.vline); + subtree Io_infer.Xml.tag_loc (string_of_int sv.vloc); + subtree Io_infer.Xml.tag_top sv.vtop; + subtree Io_infer.Xml.tag_signature (Escape.escape_xml sv.vsignature); + subtree Io_infer.Xml.tag_weight (string_of_int sv.vweight); + subtree Io_infer.Xml.tag_proof_coverage sv.vproof_coverage; + subtree Io_infer.Xml.tag_rank sv.vrank; + subtree Io_infer.Xml.tag_in_calls (string_of_int sv.vin_calls); + subtree Io_infer.Xml.tag_out_calls (string_of_int sv.vin_calls); + subtree Io_infer.Xml.tag_proof_trace sv.vproof_trace; + subtree Io_infer.Xml.tag_cyclomatic (string_of_int sv.vcyclomatic); + subtree Io_infer.Xml.tag_flags (string_of_int (Hashtbl.length sv.vflags)); ] in Io_infer.Xml.create_tree "procedure" attributes forest in Io_infer.Xml.pp_inner_node fmt tree @@ -506,11 +506,11 @@ module BugsXml = struct | None -> "" in Io_infer.Xml.create_tree Io_infer.Xml.tag_loc [("num", string_of_int !num)] [(level_to_xml lt.Errlog.lt_level); - (file_to_xml (DB.source_file_to_string loc.Sil.file)); - (line_to_xml loc.Sil.line); - (code_to_xml code); - (description_to_xml lt.Errlog.lt_description); - (node_tags_to_xml lt.Errlog.lt_node_tags)] in + (file_to_xml (DB.source_file_to_string loc.Sil.file)); + (line_to_xml loc.Sil.line); + (code_to_xml code); + (description_to_xml lt.Errlog.lt_description); + (node_tags_to_xml lt.Errlog.lt_node_tags)] in list_rev (list_rev_map loc_to_xml ltr) (** print bugs from summary in xml *) @@ -539,19 +539,19 @@ module BugsXml = struct let bug_hash = get_bug_hash kind type_str procedure_id filename node_key error_desc in let forest = [ - subtree Io_infer.Xml.tag_class error_class; - subtree Io_infer.Xml.tag_kind kind; - subtree Io_infer.Xml.tag_type type_str; - subtree Io_infer.Xml.tag_qualifier err_desc_string; - subtree Io_infer.Xml.tag_severity severity; - subtree Io_infer.Xml.tag_line error_line; - subtree Io_infer.Xml.tag_procedure (Escape.escape_xml procedure_name); - subtree Io_infer.Xml.tag_procedure_id (Escape.escape_xml procedure_id); - subtree Io_infer.Xml.tag_file filename; - Io_infer.Xml.create_tree Io_infer.Xml.tag_trace [] (loc_trace_to_xml linereader ltr); - subtree Io_infer.Xml.tag_key (string_of_int node_key); - Io_infer.Xml.create_tree Io_infer.Xml.tag_qualifier_tags [] (error_desc_to_xml_tags error_desc); - subtree Io_infer.Xml.tag_hash (string_of_int bug_hash) + subtree Io_infer.Xml.tag_class error_class; + subtree Io_infer.Xml.tag_kind kind; + subtree Io_infer.Xml.tag_type type_str; + subtree Io_infer.Xml.tag_qualifier err_desc_string; + subtree Io_infer.Xml.tag_severity severity; + subtree Io_infer.Xml.tag_line error_line; + subtree Io_infer.Xml.tag_procedure (Escape.escape_xml procedure_name); + subtree Io_infer.Xml.tag_procedure_id (Escape.escape_xml procedure_id); + subtree Io_infer.Xml.tag_file filename; + Io_infer.Xml.create_tree Io_infer.Xml.tag_trace [] (loc_trace_to_xml linereader ltr); + subtree Io_infer.Xml.tag_key (string_of_int node_key); + Io_infer.Xml.create_tree Io_infer.Xml.tag_qualifier_tags [] (error_desc_to_xml_tags error_desc); + subtree Io_infer.Xml.tag_hash (string_of_int bug_hash) ] @ (if include_precondition_tree then precondition_tree () else []) in @@ -614,7 +614,7 @@ module UnitTest = struct end (** Module to compute the top procedures. -A procedure is top if it has specs and any procedure calling it has no specs *) + A procedure is top if it has specs and any procedure calling it has no specs *) module TopProcedures : sig type t val create : unit -> t @@ -675,8 +675,8 @@ module Stats = struct let process_loc loc stats = try Hashtbl.find stats.files loc.Sil.file with Not_found -> - stats.nLOC <- stats.nLOC + loc.Sil.nLOC; - Hashtbl.add stats.files loc.Sil.file () + stats.nLOC <- stats.nLOC + loc.Sil.nLOC; + Hashtbl.add stats.files loc.Sil.file () let loc_trace_to_string_list linereader indent_num ltr = let res = ref [] in @@ -810,7 +810,7 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna let always_report () = Localise.error_desc_extract_tag_value error_desc "always_report" = "true" in (filters.Inferconfig.path_filter summary.Specs.loc.Sil.file - || always_report ()) && + || always_report ()) && filters.Inferconfig.error_filter error_name in do_outf procs_csv (fun outf -> F.fprintf outf.fmt "%a" (ProcsCsv.pp_summary fname top_proc_set) summary); do_outf calls_csv (fun outf -> F.fprintf outf.fmt "%a" (CallsCsv.pp_calls fname) summary); @@ -829,11 +829,11 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna let dot_file = DB.filename_add_suffix base ".dot" in let svg_file = DB.filename_add_suffix base ".svg" in if not (DB.file_exists dot_file) - || DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time dot_file + || DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time dot_file then Dotty.pp_speclist_dotty_file base specs; if not (DB.file_exists svg_file) - || DB.file_modified_time dot_file > DB.file_modified_time svg_file + || DB.file_modified_time dot_file > DB.file_modified_time svg_file then ignore (Sys.command ("dot -Tsvg \"" ^ (DB.filename_to_string dot_file) ^ "\" >\"" ^ (DB.filename_to_string svg_file) ^"\"")) end; @@ -841,13 +841,13 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna let xml_file = DB.filename_add_suffix base ".xml" in let specs = Specs.get_specs_from_payload summary in if not (DB.file_exists xml_file) - || DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time xml_file + || DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time xml_file then begin let xml_out = ref (create_outfile (DB.filename_to_string xml_file)) in do_outf xml_out (fun outf -> - Dotty.print_specs_xml (Specs.get_signature summary) specs summary.Specs.loc outf.fmt; - close_outf outf) + Dotty.print_specs_xml (Specs.get_signature summary) specs summary.Specs.loc outf.fmt; + close_outf outf) end end (* ignore (Sys.command ("open " ^ base ^ ".svg")) *) @@ -868,11 +868,11 @@ module AnalysisResults = struct exit(0) end; list_append (if !args = ["."] then begin - let arr = Sys.readdir "." in - let all_files = Array.to_list arr in - list_filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files - end - else !args) (results_dir_specsfiles ()) + let arr = Sys.readdir "." in + let all_files = Array.to_list arr in + list_filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files + end + else !args) (results_dir_specsfiles ()) (** apply [f] to [arg] with the gc compaction disabled during the execution *) let apply_without_gc f arg = @@ -925,7 +925,7 @@ module AnalysisResults = struct Serialization.to_file analysis_results_serializer filename analysis_results (** Return an iterator over all the summaries. - If options - load_results or - save_results are used, all the summaries are loaded in memory *) + If options - load_results or - save_results are used, all the summaries are loaded in memory *) let get_summary_iterator () = let iterator_of_summary_list r = fun f -> list_iter f r in @@ -987,10 +987,10 @@ let () = do_outf bugs_txt close_outf; do_outf bugs_xml (fun outf -> BugsXml.pp_bugs_close outf.fmt (); close_outf outf); do_outf latex (fun outf -> - Latex.pp_end outf.fmt (); - close_outf outf; - pdflatex outf.fname; - let pdf_name = (Filename.chop_extension outf.fname) ^ ".pdf" in - ignore (Sys.command ("open " ^ pdf_name))); + Latex.pp_end outf.fmt (); + close_outf outf; + pdflatex outf.fname; + let pdf_name = (Filename.chop_extension outf.fname) ^ ".pdf" in + ignore (Sys.command ("open " ^ pdf_name))); do_outf report (fun outf -> F.fprintf outf.fmt "%a@?" Report.pp_stats stats; close_outf outf); if !precondition_stats then PreconditionStats.pp_stats () diff --git a/infer/src/backend/interproc.ml b/infer/src/backend/interproc.ml index 966f669bc..fb9fdfd7f 100644 --- a/infer/src/backend/interproc.ml +++ b/infer/src/backend/interproc.ml @@ -67,9 +67,9 @@ module Worklist = struct map := NodeMap.add min.node (min.visits + 1) !map; (* increase the visits *) min.node with Not_found -> begin - L.out "@\n...Work list is empty! Impossible to remove edge...@\n"; - assert false - end + L.out "@\n...Work list is empty! Impossible to remove edge...@\n"; + assert false + end end (* =============== END of module Worklist =============== *) @@ -100,8 +100,8 @@ let htable_retrieve (htable : (int, Paths.PathSet.t) Hashtbl.t) (key : int) : Pa try Hashtbl.find htable key with Not_found -> - Hashtbl.replace htable key Paths.PathSet.empty; - Paths.PathSet.empty + Hashtbl.replace htable key Paths.PathSet.empty; + Paths.PathSet.empty let path_set_get_visited (sid: int) : Paths.PathSet.t = htable_retrieve path_set_visited sid @@ -130,8 +130,8 @@ let path_set_checkout_todo (node: Cfg.node) : Paths.PathSet.t = Hashtbl.replace path_set_visited sid new_visited; todo with Not_found -> - L.out "@.@.ERROR: could not find todo for node %a@.@." Cfg.Node.pp node; - assert false + L.out "@.@.ERROR: could not find todo for node %a@.@." Cfg.Node.pp node; + assert false (* =============== END of the edge_set object =============== *) @@ -166,11 +166,11 @@ let pp_path_dotty f path = let pp_complete_path_dotty_file = let counter = ref 0 in fun path -> - incr counter; - let outc = open_out ("error_path" ^ string_of_int !counter ^ ".dot") in - let fmt = F.formatter_of_out_channel outc in - F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_path_dotty path; - close_out outc + incr counter; + let outc = open_out ("error_path" ^ string_of_int !counter ^ ".dot") in + let fmt = F.formatter_of_out_channel outc in + F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_path_dotty path; + close_out outc (* =============== END: Print a complete path in a dotty file =============== *) @@ -306,10 +306,10 @@ let do_symexec_join pname tenv curr_node (edgeset_todo : Paths.PathSet.t) = let old_dset', new_dset' = Dom.pathset_join curr_pname tenv old_dset new_dset in Join_table.put curr_id (Paths.PathSet.union old_dset' new_dset'); list_iter (fun node -> - Paths.PathSet.iter (fun prop path -> - State.set_path path None; - propagate pname false (Paths.PathSet.from_renamed_list [(prop, path)]) node) - new_dset') succ_nodes + Paths.PathSet.iter (fun prop path -> + State.set_path path None; + propagate pname false (Paths.PathSet.from_renamed_list [(prop, path)]) node) + new_dset') succ_nodes let prop_max_size = ref (0, Prop.prop_emp) let prop_max_chain_size = ref (0, Prop.prop_emp) @@ -319,9 +319,9 @@ let check_prop_size p path = let size = Prop.Metrics.prop_size p in if size > fst !prop_max_size then (prop_max_size := (size, p); - L.d_strln ("Prop with new max size " ^ string_of_int size ^ ":"); - Prop.d_prop p; - L.d_ln ()) + L.d_strln ("Prop with new max size " ^ string_of_int size ^ ":"); + Prop.d_prop p; + L.d_ln ()) (* Check prop size and filter out possible unabstracted lists *) let check_prop_size edgeset_todo = @@ -342,8 +342,8 @@ let d_path (path, pos_opt) = incr step; (* Propset.pp_proplist_dotty_file ("path" ^ (string_of_int !count) ^ ".dot") plist; *) L.d_strln ("Path Step #" ^ string_of_int !step ^ - " node " ^ string_of_int (Cfg.Node.get_id curr_node) ^ - " session " ^ string_of_int session ^ ":"); + " node " ^ string_of_int (Cfg.Node.get_id curr_node) ^ + " session " ^ string_of_int session ^ ":"); Propset.d !prop_last_step (Propset.from_proplist plist); L.d_ln (); Cfg.Node.d_instrs true None curr_node; L.d_ln (); L.d_ln (); prop_last_step := (match plist with | [prop] -> prop | _ -> Prop.prop_emp) in @@ -435,13 +435,13 @@ let check_assignement_guard node = let succs_loc = list_map (fun n -> Cfg.Node.get_loc n) succs in let succs_are_all_prune_nodes () = list_for_all (fun n -> match Cfg.Node.get_kind n with - | Cfg.Node.Prune_node(_) -> true - | _ -> false) succs in + | Cfg.Node.Prune_node(_) -> true + | _ -> false) succs in let succs_same_loc_as_node () = if verbose then (L.d_str ("LOCATION NODE: line: "^(string_of_int l_node.Sil.line)^" nLOC: "^(string_of_int l_node.Sil.nLOC)); L.d_strln " "); list_for_all (fun l -> - if verbose then (L.d_str ("LOCATION l: line: "^(string_of_int l.Sil.line)^" nLOC: "^(string_of_int l.Sil.nLOC)); L.d_strln " "); - Sil.loc_equal l l_node) succs_loc in + if verbose then (L.d_str ("LOCATION l: line: "^(string_of_int l.Sil.line)^" nLOC: "^(string_of_int l.Sil.nLOC)); L.d_strln " "); + Sil.loc_equal l l_node) succs_loc in let succs_have_simple_guards () = (* check that the guards of the succs are a var or its negation *) let check_instr = function | Sil.Prune (Sil.Var _, _, _, _) -> true @@ -453,20 +453,20 @@ let check_assignement_guard node = list_for_all check_guard succs in if !Sil.curr_language = Sil.C_CPP && succs_are_all_prune_nodes () && succs_same_loc_as_node () && succs_have_simple_guards () then (let instr = Cfg.Node.get_instrs node in - match succs_loc with - | loc_succ:: _ -> (* at this point all successors are at the same location, so we can take the first*) - let set_instr_at_succs_loc = list_filter (fun i -> (Sil.loc_equal (Sil.instr_get_loc i) loc_succ) && is_set_instr i) instr in - (match set_instr_at_succs_loc with - | [Sil.Set(e, _, _, _)] -> (* we now check if e is the same expression used to prune*) - if (is_prune_exp e) && not ((node_contains_call node) && (is_cil_tmp e)) && not (is_edg_tmp e) then ( - let desc = Errdesc.explain_condition_is_assignment l_node in - let exn = Exceptions.Condition_is_assignment (desc, try assert false with Assert_failure x -> x) in - let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in - Reporting.log_warning pname ~loc: (Some l_node) ~pre: pre_opt exn - ) - else () - | _ -> ()) - | _ -> if verbose then L.d_strln "NOT FOUND loc_succ" + match succs_loc with + | loc_succ:: _ -> (* at this point all successors are at the same location, so we can take the first*) + let set_instr_at_succs_loc = list_filter (fun i -> (Sil.loc_equal (Sil.instr_get_loc i) loc_succ) && is_set_instr i) instr in + (match set_instr_at_succs_loc with + | [Sil.Set(e, _, _, _)] -> (* we now check if e is the same expression used to prune*) + if (is_prune_exp e) && not ((node_contains_call node) && (is_cil_tmp e)) && not (is_edg_tmp e) then ( + let desc = Errdesc.explain_condition_is_assignment l_node in + let exn = Exceptions.Condition_is_assignment (desc, try assert false with Assert_failure x -> x) in + let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in + Reporting.log_warning pname ~loc: (Some l_node) ~pre: pre_opt exn + ) + else () + | _ -> ()) + | _ -> if verbose then L.d_strln "NOT FOUND loc_succ" ) else () (** Perform symbolic execution for a node starting from an initial prop *) @@ -503,9 +503,9 @@ let forward_tabulate cfg tenv = let pre_opt = (* precondition leading to error, if any *) State.get_normalized_pre (Abs.abstract_no_symop curr_pname) in (match pre_opt with - | Some pre -> - L.d_strln "Precondition:"; Prop.d_prop pre; L.d_ln () - | None -> ()); + | Some pre -> + L.d_strln "Precondition:"; Prop.d_prop pre; L.d_ln () + | None -> ()); L.d_strln "SIL INSTR:"; Cfg.Node.d_instrs ~sub_instrs: true (State.get_instr ()) curr_node; L.d_ln (); Reporting.log_error ~pre: pre_opt curr_pname exn; @@ -544,10 +544,10 @@ let forward_tabulate cfg tenv = handled_some_exception := false; check_prop_size pathset_todo; L.d_strln ("**** " ^ (log_string proc_name) ^ " " ^ - "Node: " ^ string_of_int sid_curr_node ^ ", " ^ - "Procedure: " ^ Procname.to_string proc_name ^ ", " ^ - "Session: " ^ string_of_int session ^ ", " ^ - "Todo: " ^ string_of_int (Paths.PathSet.size pathset_todo) ^ " ****"); + "Node: " ^ string_of_int sid_curr_node ^ ", " ^ + "Procedure: " ^ Procname.to_string proc_name ^ ", " ^ + "Session: " ^ string_of_int session ^ ", " ^ + "Todo: " ^ string_of_int (Paths.PathSet.size pathset_todo) ^ " ****"); L.d_increase_indent 1; Propset.d Prop.prop_emp (Paths.PathSet.to_propset pathset_todo); L.d_strln ".... Instructions: .... "; @@ -563,24 +563,24 @@ let forward_tabulate cfg tenv = | Cfg.Node.Start_node _ -> exe_iter (fun prop path cnt num_paths -> - try - L.d_strln ("Processing prop " ^ string_of_int cnt ^ "/" ^ string_of_int num_paths); - L.d_increase_indent 1; - State.reset_diverging_states_goto_node (); - let pset = - do_symbolic_execution (handle_exn curr_node) cfg tenv curr_node prop path in - L.d_decrease_indent 1; L.d_ln(); - propagate_nodes_divergence tenv proc_desc pset path kind_curr_node succ_nodes exn_nodes; - with exn when Exceptions.handle_exception exn && !Config.footprint -> - handle_exn curr_node exn; - if !Config.nonstop then propagate_nodes_divergence tenv proc_desc (Paths.PathSet.from_renamed_list [(prop, path)]) path kind_curr_node succ_nodes exn_nodes; - L.d_decrease_indent 1; L.d_ln ()) + try + L.d_strln ("Processing prop " ^ string_of_int cnt ^ "/" ^ string_of_int num_paths); + L.d_increase_indent 1; + State.reset_diverging_states_goto_node (); + let pset = + do_symbolic_execution (handle_exn curr_node) cfg tenv curr_node prop path in + L.d_decrease_indent 1; L.d_ln(); + propagate_nodes_divergence tenv proc_desc pset path kind_curr_node succ_nodes exn_nodes; + with exn when Exceptions.handle_exception exn && !Config.footprint -> + handle_exn curr_node exn; + if !Config.nonstop then propagate_nodes_divergence tenv proc_desc (Paths.PathSet.from_renamed_list [(prop, path)]) path kind_curr_node succ_nodes exn_nodes; + L.d_decrease_indent 1; L.d_ln ()) pathset_todo in try begin - doit(); - if !handled_some_exception then Printer.force_delayed_prints (); - do_after_node curr_node - end + doit(); + if !handled_some_exception then Printer.force_delayed_prints (); + do_after_node curr_node + end with | exn when Exceptions.handle_exception exn -> handle_exn curr_node exn; @@ -709,9 +709,9 @@ let create_seed_vars sigma = list_fold_left hpred_add_seed [] sigma (** Initialize proposition for execution given formal and global -parameters. The footprint is initialized according to the -execution mode. The prop is not necessarily emp, so it -should be incorporated when the footprint is constructed. *) + parameters. The footprint is initialized according to the + execution mode. The prop is not necessarily emp, so it + should be incorporated when the footprint is constructed. *) let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Prop.t = let sigma_new_formals = let do_formal (pv, typ) = @@ -726,17 +726,17 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr let new_pi = let pi = Prop.get_pi prop in pi - (* inactive until it becomes necessary, as it pollutes props - let fav_ids = Sil.fav_to_list (Prop.sigma_fav sigma_locals) in - let mk_undef_atom id = Prop.mk_neq (Sil.Var id) (Sil.Const (Sil.Cattribute (Sil.Aundef "UNINITIALIZED"))) in - let pi_undef = list_map mk_undef_atom fav_ids in - pi_undef @ pi *) in + (* inactive until it becomes necessary, as it pollutes props + let fav_ids = Sil.fav_to_list (Prop.sigma_fav sigma_locals) in + let mk_undef_atom id = Prop.mk_neq (Sil.Var id) (Sil.Const (Sil.Cattribute (Sil.Aundef "UNINITIALIZED"))) in + let pi_undef = list_map mk_undef_atom fav_ids in + pi_undef @ pi *) in let prop' = Prop.replace_pi new_pi (Prop.prop_sigma_star prop sigma) in Prop.replace_sigma_footprint (Prop.get_sigma_footprint prop' @ sigma_new_formals) prop' (** Construct an initial prop by extending [prop] with locals, and formals if [add_formals] is true -as well as seed variables *) + as well as seed variables *) let initial_prop tenv (curr_f: Cfg.Procdesc.t) (prop : 'a Prop.t) add_formals : Prop.normal Prop.t = let construct_decl (x, typ) = (Sil.mk_pvar (Mangled.from_string x) (Cfg.Procdesc.get_proc_name curr_f), typ) in @@ -766,7 +766,7 @@ let initial_prop_from_pre tenv curr_f pre = (** Re-execute one precondition and return some spec if there was no re-execution error. *) let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Specs.Jprop.t) -: Prop.normal Specs.spec option = + : Prop.normal Specs.spec option = let proc_name = Cfg.Procdesc.get_proc_name pdesc in do_before_node 0 init_node; L.d_strln ("#### Start: RE-execution for " ^ Procname.to_string proc_name ^ " ####"); @@ -800,16 +800,16 @@ let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Spe do_after_node init_node; Some spec with RE_EXE_ERROR -> - do_before_node 0 init_node; - Printer.force_delayed_prints (); - L.d_strln_color Red ("#### [FUNCTION " ^ Procname.to_string proc_name ^ "] ...ERROR"); - L.d_increase_indent 1; - L.d_strln "when starting from pre:"; - Prop.d_prop (Specs.Jprop.to_prop precondition); - L.d_strln "This precondition is filtered out."; - L.d_decrease_indent 1; - do_after_node init_node; - None + do_before_node 0 init_node; + Printer.force_delayed_prints (); + L.d_strln_color Red ("#### [FUNCTION " ^ Procname.to_string proc_name ^ "] ...ERROR"); + L.d_increase_indent 1; + L.d_strln "when starting from pre:"; + Prop.d_prop (Specs.Jprop.to_prop precondition); + L.d_strln "This precondition is filtered out."; + L.d_decrease_indent 1; + do_after_node init_node; + None (** get all the nodes in the current call graph with their defined children *) let get_procs_and_defined_children call_graph = @@ -822,12 +822,12 @@ let pp_intra_stats cfg proc_desc fmt proc_name = F.fprintf fmt "(%d nodes containing %d states)" (list_length nodes) !nstates (** Return functions to perform one phase of the analysis for a procedure. -Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase -and [get_results ()] returns the results computed. -This function is architected so that [get_results ()] can be called even after -[go ()] was interrupted by and exception. *) + Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase + and [get_results ()] returns the results computed. + This function is architected so that [get_results ()] can be called even after + [go ()] was interrupted by and exception. *) let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t) -: (unit -> unit) * (unit -> Prop.normal Specs.spec list) = + : (unit -> unit) * (unit -> Prop.normal Specs.spec list) = let start_node = Cfg.Procdesc.get_start_node pdesc in let check_recursion_level () = @@ -878,7 +878,7 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t | Exceptions.Leak _ -> let exn = Exceptions.Internal_error - (Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint") in + (Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint") in let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in Reporting.log_error pname ~pre: pre_opt exn; [] (* retuning no specs *) in @@ -975,7 +975,7 @@ let remove_this_not_null prop = | hpred -> (var_option, hpred:: hpreds) in let collect_atom var atoms = function | Sil.Aneq (Sil.Var v, e) - when Ident.equal v var && Sil.exp_equal e Sil.exp_null -> atoms + when Ident.equal v var && Sil.exp_equal e Sil.exp_null -> atoms | a -> a:: atoms in match list_fold_left collect_hpred (None, []) (Prop.get_sigma prop) with | None, _ -> prop @@ -988,8 +988,8 @@ let remove_this_not_null prop = (** Detects if there are specs of the form {precondition} proc {runtime exception} and report -an error in that case, generating the trace that lead to the runtime exception if the method is -called in the context { precondition } *) + an error in that case, generating the trace that lead to the runtime exception if the method is + called in the context { precondition } *) let report_runtime_exceptions tenv cfg pdesc summary = let pname = Specs.get_proc_name summary in let is_public_method = @@ -1043,8 +1043,8 @@ let update_summary prev_summary specs proc_name elapsed res = (** Analyze [proc_name] and return the updated summary. Use module -[Timeout] to call [perform_analysis_phase] with a time limit, and -then return the updated summary. Executed as a child process. *) + [Timeout] to call [perform_analysis_phase] with a time limit, and + then return the updated summary. Executed as a child process. *) let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary = if !Config.trace_anal then L.err "===analyze_proc@."; let init_time = Unix.gettimeofday () in @@ -1067,7 +1067,7 @@ let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary = updated_summary (** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for -the procedures enabled after the analysis of [proc_name] *) + the procedures enabled after the analysis of [proc_name] *) let perform_transition exe_env cg proc_name = let proc_names = Fork.should_perform_transition cg proc_name in let transition pname = @@ -1090,19 +1090,19 @@ let perform_transition exe_env cg proc_name = apply_start_node do_after_node; res with exn when exn_not_timeout exn -> - apply_start_node do_after_node; - Config.allowleak := allowleak; - L.err "Error in collect_preconditions for %a@." Procname.pp proc_name; - let err_name, _, mloco, _, _, _, _ = Exceptions.recognize_exception exn in - let err_str = "exception raised " ^ (Localise.to_string err_name) in - L.err "Error: %s %a@." err_str pp_ml_location_opt mloco; - [] in + apply_start_node do_after_node; + Config.allowleak := allowleak; + L.err "Error in collect_preconditions for %a@." Procname.pp proc_name; + let err_name, _, mloco, _, _, _, _ = Exceptions.recognize_exception exn in + let err_str = "exception raised " ^ (Localise.to_string err_name) in + L.err "Error: %s %a@." err_str pp_ml_location_opt mloco; + [] in Fork.transition_footprint_re_exe pname joined_pres in list_iter transition proc_names (** Process the result of the analysis of [proc_name]: update the -returned summary and add it to the spec table. Executed in the -parent process as soon as a child process returns a result. *) + returned summary and add it to the spec table. Executed in the + parent process as soon as a child process returns a result. *) let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary) : unit = if !Config.trace_anal then L.err "===process_result@."; Ident.reset_name_generator (); (* for consistency with multi-core mode *) @@ -1112,14 +1112,14 @@ let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary perform_transition exe_env call_graph proc_name; if !Config.only_footprint || summ.Specs.phase != Specs.FOOTPRINT then (try Specs.store_summary proc_name summ with - Sys_error s -> - L.err "@.### System Error while writing summary of procedure %a to disk: %s@." Procname.pp proc_name s); + Sys_error s -> + L.err "@.### System Error while writing summary of procedure %a to disk: %s@." Procname.pp proc_name s); let procs_done = Fork.procs_become_done call_graph proc_name in Fork.post_process_procs exe_env procs_done (** Return true if the analysis of [proc_name] should be -skipped. Called by the parent process before attempting to analyze a -proc. *) + skipped. Called by the parent process before attempting to analyze a + proc. *) let filter_out (call_graph: Cg.t) (proc_name: Procname.t) : bool = if !Config.trace_anal then L.err "===filter_out@."; let slice_out = (* filter out if slicing is active and [proc_name] not in slice *) @@ -1192,16 +1192,16 @@ let do_analysis exe_env = Callbacks.proc_inline_synthetic_methods cfg pdesc; Specs.init_summary (pname, ret_type, formals, dep, loc, nodes, proc_flags, - static_err_log, calls, cyclomatic, None, attributes) in + static_err_log, calls, cyclomatic, None, attributes) in let filter = if !Config.only_skips then (filter_skipped_procs cg procs_and_defined_children) else if !Config.only_nospecs then filter_nospecs else (fun _ -> true) in list_iter (fun x -> if filter x then init_proc x) procs_and_defined_children; (try Fork.parallel_iter_nodes exe_env analyze_proc process_result filter_out with - exe when do_parallel -> - L.out "@.@. ERROR exception raised in parallel execution@."; - raise exe) + exe when do_parallel -> + L.out "@.@. ERROR exception raised in parallel execution@."; + raise exe) let visited_and_total_nodes cfg = let all_nodes = @@ -1218,7 +1218,7 @@ let visited_and_total_nodes cfg = Cfg.NodeSet.elements visited_nodes_re, Cfg.NodeSet.elements counted_nodes (** Print the stats for the given cfg; consider every defined proc unless a proc with the same name -was defined in another module, and was the one which was analyzed *) + was defined in another module, and was the one which was analyzed *) let print_stats_cfg proc_shadowed proc_is_active cfg = let err_table = Errlog.create_err_table () in let active_procs = list_filter proc_is_active (Cfg.get_defined_procs cfg) in @@ -1248,9 +1248,9 @@ let print_stats_cfg proc_shadowed proc_is_active cfg = tot_specs := (list_length specs) + !tot_specs; let () = match specs, - Errlog.size - (fun ekind in_footprint -> ekind = Exceptions.Kerror && in_footprint) - stats.Specs.err_log with + Errlog.size + (fun ekind in_footprint -> ekind = Exceptions.Kerror && in_footprint) + stats.Specs.err_log with | [], 0 -> incr num_nospec_noerror_proc | _, 0 -> incr num_spec_noerror_proc | [], _ -> incr num_nospec_error_proc @@ -1264,7 +1264,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg = let num_infos = Errlog.err_table_size_footprint Exceptions.Kinfo err_table in let num_ok_proc = !num_spec_noerror_proc + !num_spec_error_proc in (* F.fprintf fmt "VISITED: %a@\n" (pp_seq pp_node) nodes_visited; - F.fprintf fmt "TOTAL: %a@\n" (pp_seq pp_node) nodes_total; *) + F.fprintf fmt "TOTAL: %a@\n" (pp_seq pp_node) nodes_total; *) F.fprintf fmt "@\n++++++++++++++++++++++++++++++++++++++++++++++++++@\n"; F.fprintf fmt "+ FILE: %s LOC: %n VISITED: %d/%d SYMOPS: %d@\n" (DB.source_file_to_string !DB.current_source) !Config.nLOC (list_length nodes_visited) (list_length nodes_total) !tot_symops; F.fprintf fmt "+ num_procs: %d (%d ok, %d timeouts, %d errors, %d warnings, %d infos)@\n" !num_proc num_ok_proc !num_timeout num_errors num_warnings num_infos; @@ -1297,8 +1297,8 @@ let print_stats exe_env = let proc_is_active proc_desc = Exe_env.proc_is_active exe_env (Cfg.Procdesc.get_proc_name proc_desc) in Exe_env.iter_files (fun fname tenv cfg -> - let proc_shadowed proc_desc = - (** return true if a proc with the same name in another module was analyzed instead *) - let proc_name = Cfg.Procdesc.get_proc_name proc_desc in - Exe_env.get_source exe_env proc_name <> fname in - print_stats_cfg proc_shadowed proc_is_active cfg) exe_env + let proc_shadowed proc_desc = + (** return true if a proc with the same name in another module was analyzed instead *) + let proc_name = Cfg.Procdesc.get_proc_name proc_desc in + Exe_env.get_source exe_env proc_name <> fname in + print_stats_cfg proc_shadowed proc_is_active cfg) exe_env diff --git a/infer/src/backend/io_infer.ml b/infer/src/backend/io_infer.ml index 4023ebb6b..b83de078d 100644 --- a/infer/src/backend/io_infer.ml +++ b/infer/src/backend/io_infer.ml @@ -22,13 +22,13 @@ module Html : sig val pp_line_link : ?with_name: bool -> ?text: (string option) -> DB.Results_dir.path -> Format.formatter -> int -> unit (** Print an html link to the given line number of the current source file *) val pp_hline : Format.formatter -> unit -> unit (** Print a horizontal line *) val pp_end_color : Format.formatter -> unit -> unit (** Print end color *) - + (** [pp_node_link path_to_root description isvisited isproof fmt id] prints an html link to the given node. - [path_to_root] is the path to the dir for the procedure in the spec db. - [description] is a string description. - [is_visited] indicates whether the node should be active or greyed out. - [is_proof] indicates whether the node is part of a proof and should be green. - [id] is the node identifier. *) + [path_to_root] is the path to the dir for the procedure in the spec db. + [description] is a string description. + [is_visited] indicates whether the node should be active or greyed out. + [is_proof] indicates whether the node is part of a proof and should be green. + [id] is the node identifier. *) val pp_node_link : DB.Results_dir.path -> string -> int list -> int list -> int list -> bool -> bool -> Format.formatter -> int -> unit val pp_proc_link : DB.Results_dir.path -> Procname.t -> Format.formatter -> string -> unit (** Print an html link to the given proc *) val pp_session_link : ?with_name: bool -> string list -> Format.formatter -> int * int * int -> unit (** Print an html link given node id and session *) @@ -45,98 +45,98 @@ end = struct let s = "" ++ "\n\n" ^ fname ^ "" ++ - "" ++ - "" ++ - "" ++ - "" in + "" ++ + "" ++ + "" ++ + "" in F.fprintf fmt "%s" s; (fd, fmt) - + (** get the full html filename from a path *) let get_full_fname path = let fname, dir_path = match list_rev path with | fname:: dir_path -> fname, dir_path | [] -> raise (Failure "Html.open_out") in DB.Results_dir.path_to_filename DB.Results_dir.Abs_source_dir (list_rev ((fname ^ ".html") :: dir_path)) - + let open_out path = let full_fname = get_full_fname path in let fd = Unix.openfile (DB.filename_to_string full_fname) [Unix.O_WRONLY; Unix.O_APPEND] 0o777 in let outc = Unix.out_channel_of_descr fd in let fmt = F.formatter_of_out_channel outc in (fd, fmt) - + let modified_during_analysis path = let fname = get_full_fname path in if DB.file_exists fname then DB.file_modified_time fname >= initial_analysis_time else false - + let close (fd, fmt) = F.fprintf fmt "@\n@."; Unix.close fd - + (** Print a horizontal line *) let pp_hline fmt () = F.fprintf fmt "
@\n" - + (** Print start color *) let pp_start_color fmt color = F.fprintf fmt "%s" ("") - + (** Print end color *) let pp_end_color fmt () = F.fprintf fmt "%s" "" - + let pp_link ?(name = None) ?(pos = None) path fmt text = let pos_str = match pos with | None -> "" @@ -147,7 +147,7 @@ end = struct | Some n -> "name=\"" ^ n ^ "\"" in let pr_str = "" ^ text ^ "" in F.fprintf fmt " %s" pr_str - + (** [pp_node_link path_to_root description isvisited isproof fmt id] prints an html link to the given node. *) let pp_node_link path_to_root description preds succs exn isvisited isproof fmt id = let display_name = @@ -163,11 +163,11 @@ end = struct pp_to_string pp () in if not isvisited then F.fprintf fmt " %s" node_text else pp_link (path_to_root @ ["nodes"; node_name]) fmt node_text - + (** Print an html link to the given proc *) let pp_proc_link path_to_root proc_name fmt text = pp_link (path_to_root @ [Procname.to_filename proc_name]) fmt text - + (** Print an html link to the given line number of the current source file *) let pp_line_link ?(with_name = false) ?(text = None) path_to_root fmt linenum = let fname = DB.source_file_encoding !DB.current_source in @@ -175,7 +175,7 @@ end = struct let name = "LINE" ^ linenum_str in pp_link ~name: (if with_name then Some name else None) (path_to_root @ [".."; fname]) ~pos: (Some name) fmt (match text with Some s -> s | None -> linenum_str) - + (** Print an html link given node id and session *) let pp_session_link ?(with_name = false) path_to_root fmt (node_id, session, linenum) = let node_name = "node" ^ (string_of_int node_id) in @@ -231,23 +231,23 @@ module Xml = struct let tag_trace = "trace" let tag_type = "type" let tag_weight = "weight" - + type tree = { name: string; attributes: (string * string) list; forest: node list } and node = | Tree of tree | String of string - + let pp = F.fprintf - + let create_tree name attributes forest = Tree { name = name; attributes = attributes; forest = forest } - + let pp_attribute fmt (name, value) = pp fmt "%s=\"%s\"" name value - + let pp_attributes fmt l = pp_seq pp_attribute fmt l - + (** print an xml node *) let rec pp_node newline indent fmt = function | Tree { name = name; attributes = attributes; forest = forest } -> @@ -262,19 +262,19 @@ module Xml = struct F.fprintf fmt "%s%s%s" indent s newline and pp_forest newline indent fmt forest = list_iter (pp_node newline indent fmt) forest - + let pp_prelude fmt = pp fmt "%s" "\n" - + let pp_open fmt name = pp_prelude fmt; pp fmt "<%s>@\n" name - + let pp_close fmt name = pp fmt "@." name - + let pp_inner_node fmt node = pp_node "\n" "" fmt node - + (** print an xml document, if the first parameter is false on a single line without preamble *) let pp_document on_several_lines fmt node = let newline = if on_several_lines then "\n" else "" in diff --git a/infer/src/backend/localise.ml b/infer/src/backend/localise.ml index 7471162d6..109145532 100644 --- a/infer/src/backend/localise.ml +++ b/infer/src/backend/localise.ml @@ -142,7 +142,7 @@ module BucketLevel = struct end (** takes in input a tag to extract from the given error_desc -and returns its value *) + and returns its value *) let error_desc_extract_tag_value (_, _, tags) tag_to_extract = let find_value tag v = match v with @@ -286,7 +286,7 @@ let deref_str_undef (proc_name, loc) = value_pre = Some (pointer_or_object ()); value_post = None; problem_str = "could be assigned by a call to skip function " ^ proc_name_str ^ - at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed"; } + at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed"; } (** dereference strings for a freed pointer dereference *) let deref_str_freed ra = @@ -403,8 +403,8 @@ let dereference_string deref_str value_str access_opt loc = let problem_str = match Tags.get !tags Tags.nullable_src with | Some nullable_src -> - if nullable_src = value_str then "is annotated with @Nullable and is dereferenced without a null check" - else "is indirectly marked @Nullable (source: " ^ nullable_src ^ ") and is dereferenced without a null check" + if nullable_src = value_str then "is annotated with @Nullable and is dereferenced without a null check" + else "is indirectly marked @Nullable (source: " ^ nullable_src ^ ") and is dereferenced without a null check" | None -> deref_str.problem_str in [(problem_str ^ " " ^ at_line tags loc)] in value_desc:: access_desc @ problem_desc, None, !tags diff --git a/infer/src/backend/logging.ml b/infer/src/backend/logging.ml index 473d2f167..c18c86969 100644 --- a/infer/src/backend/logging.ml +++ b/infer/src/backend/logging.ml @@ -181,7 +181,7 @@ let stdout fmt_string = do_print F.std_formatter fmt_string (** print a warning with information of the position in the ml source where it oririnated. -use as: warning_position "description" (try assert false with Assert_failure x -> x); *) + use as: warning_position "description" (try assert false with Assert_failure x -> x); *) let warning_position (s: string) (mloc: ml_location) = err "WARNING: %s in %a@." s pp_ml_location_opt (Some mloc) diff --git a/infer/src/backend/mangled.ml b/infer/src/backend/mangled.ml index 8cff125f9..3f2869bcd 100644 --- a/infer/src/backend/mangled.ml +++ b/infer/src/backend/mangled.ml @@ -66,7 +66,7 @@ let pp f pn = type mangled_t = t module MangledSet = Set.Make - (struct - type t = mangled_t - let compare = compare - end) + (struct + type t = mangled_t + let compare = compare + end) diff --git a/infer/src/backend/match.ml b/infer/src/backend/match.ml index 317ed228d..03e8165c4 100644 --- a/infer/src/backend/match.ml +++ b/infer/src/backend/match.ml @@ -18,8 +18,8 @@ let mem_idlist i l = list_exists (Ident.equal i) l (** Type for a hpred pattern. flag=false means that the implication -between hpreds is not considered, and flag = true means that it is -considered during pattern matching *) + between hpreds is not considered, and flag = true means that it is + considered during pattern matching *) type hpred_pat = { hpred : Sil.hpred; flag : bool } let pp_hpat pe f hpat = @@ -33,7 +33,7 @@ let rec pp_hpat_list pe f = function F.fprintf f "%a * %a" (pp_hpat pe) hpat (pp_hpat_list pe) hpats (** Checks e1 = e2[sub ++ sub'] for some sub' with dom(sub') subseteq vars. -Returns (sub ++ sub', vars - dom(sub')). *) + Returns (sub ++ sub', vars - dom(sub')). *) let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option = let check_equal sub vars e1 e2 = let e2_inst = Sil.exp_sub sub e2 @@ -63,8 +63,8 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option = None (* Naive *) | Sil.BinOp(b1, e1', e1''), Sil.BinOp(b2, e2', e2'') when Sil.binop_equal b1 b2 -> (match exp_match e1' sub vars e2' with - | None -> None - | Some (sub', vars') -> exp_match e1'' sub' vars' e2'') + | None -> None + | Some (sub', vars') -> exp_match e1'' sub' vars' e2'') | Sil.BinOp _, _ | _, Sil.BinOp _ -> None (* Naive *) | Sil.Lvar _, _ | _, Sil.Lvar _ -> @@ -75,8 +75,8 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option = None | Sil.Lindex(base1, idx1), Sil.Lindex(base2, idx2) -> (match exp_match base1 sub vars base2 with - | None -> None - | Some (sub', vars') -> exp_match idx1 sub' vars' idx2) + | None -> None + | Some (sub', vars') -> exp_match idx1 sub' vars' idx2) let exp_list_match es1 sub vars es2 = let f res_acc (e1, e2) = match res_acc with @@ -87,9 +87,9 @@ let exp_list_match es1 sub vars es2 = in es_match_res (** Checks sexp1 = sexp2[sub ++ sub'] for some sub' with -dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). -WARNING: This function does not consider the fact that the analyzer -sometimes forgets fields of hpred. It can possibly cause a problem. *) + dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). + WARNING: This function does not consider the fact that the analyzer + sometimes forgets fields of hpred. It can possibly cause a problem. *) let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option = match sexp1, sexp2 with | Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) -> @@ -102,12 +102,12 @@ let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option = None | Sil.Earray (size1, isel1, _), Sil.Earray (size2, isel2, _) -> (match exp_match size1 sub vars size2 with - | Some (sub', vars') -> isel_match isel1 sub' vars' isel2 - | None -> None) + | Some (sub', vars') -> isel_match isel1 sub' vars' isel2 + | None -> None) (** Checks fsel1 = fsel2[sub ++ sub'] for some sub' with -dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) + dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) and fsel_match fsel1 sub vars fsel2 = match fsel1, fsel2 with | [], [] -> Some (sub, vars) @@ -124,11 +124,11 @@ and fsel_match fsel1 sub vars fsel2 = end else if (n < 0 && !Config.abs_struct > 0) then fsel_match fsel1' sub vars fsel2 - (* This can lead to great information loss *) + (* This can lead to great information loss *) else None (** Checks isel1 = isel2[sub ++ sub'] for some sub' with -dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) + dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) and isel_match isel1 sub vars isel2 = match isel1, isel2 with | [], [] -> Some (sub, vars) @@ -203,8 +203,8 @@ let rec instantiate_to_emp p condition sub vars = function instantiate_to_emp p condition sub_new vars_leftover hpats (* This function has to be changed in order to -* implement the idea "All lsegs outside are NE, and all lsegs inside -* are PE" *) + * implement the idea "All lsegs outside are NE, and all lsegs inside + * are PE" *) let rec iter_match_with_impl iter condition sub vars hpat hpats = (* @@ -243,8 +243,8 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats = let gen_filter_pointsto lexp2 strexp2 te2 = function | Sil.Hpointsto (lexp1, strexp1, te1) when Sil.exp_equal te1 te2 -> (match (exp_match lexp1 sub vars lexp2) with - | None -> None - | Some (sub', vars_leftover) -> strexp_match strexp1 sub' vars_leftover strexp2) + | None -> None + | Some (sub', vars_leftover) -> strexp_match strexp1 sub' vars_leftover strexp2) | _ -> None in let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function @@ -328,19 +328,19 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats = | Some _ -> None in begin match ((Prop.prop_iter_find iter filter), hpats) with | (None, _) when not hpat.flag -> - (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) + (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) None | (None, _) when Sil.lseg_kind_equal k2 Sil.Lseg_NE -> - (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) + (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) do_para_lseg () | (None, _) -> - (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) + (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) execute_with_backtracking [do_emp_lseg; do_para_lseg] | (Some iter_cur, []) -> - (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) + (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) do_empty_hpats iter_cur () | (Some iter_cur, _) -> - (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) + (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] end | Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> @@ -460,10 +460,10 @@ and hpara_dll_match_with_impl impl_ok para1 para2 : bool = (** [prop_match_with_impl p condition vars hpat hpats] -returns [(subst, p_leftover)] such that -1) [dom(subst) = vars] -2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover]. -Using the flag [field], we can control the strength of |-. *) + returns [(subst, p_leftover)] such that + 1) [dom(subst) = vars] + 2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover]. + Using the flag [field], we can control the strength of |-. *) let prop_match_with_impl p condition vars hpat hpats = prop_match_with_impl_sub p condition Sil.sub_empty vars hpat hpats @@ -571,10 +571,10 @@ let hpara_dll_iso para1 para2 = (** [generic_find_partial_iso] finds isomorphic subsigmas of [sigma_todo]. -The function [update] is used to get rid of hpred pairs from [sigma_todo]. -[sigma_corres] records the isormophic copies discovered so far. The first -parameter determines how much flexibility we will allow during this partial -isomorphism finding. *) + The function [update] is used to get rid of hpred pairs from [sigma_todo]. + [sigma_corres] records the isormophic copies discovered so far. The first + parameter determines how much flexibility we will allow during this partial + isomorphism finding. *) let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_todo = match todos with | [] -> @@ -599,10 +599,10 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod | None, _ | _, None -> None | Some (Sil.Hpointsto (_, _, te1)), Some (Sil.Hpointsto (_, _, te2)) - when not (Sil.exp_equal te1 te2) -> + when not (Sil.exp_equal te1 te2) -> None | Some (Sil.Hpointsto (_, se1, _) as hpred1), - Some (Sil.Hpointsto (_, se2, _) as hpred2) -> + Some (Sil.Hpointsto (_, se2, _) as hpred2) -> begin match generate_todos_from_strexp mode [] se1 se2 with | None -> None @@ -620,51 +620,51 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod end | Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1), - Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) -> + Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) -> if k1 <> k2 || not (hpara_iso para1 para2) then None else (try - let new_corres = match corres_extend_front e1 e2 corres with - | None -> assert false - | Some new_corres -> new_corres in - let new_sigma_corres = - let sigma1, sigma2 = sigma_corres in - let new_sigma1 = hpred1 :: sigma1 in - let new_sigma2 = hpred2 :: sigma2 in - (new_sigma1, new_sigma2) in - let new_todos = - let shared12 = list_combine shared1 shared2 in - (root1, root2) :: (next1, next2) :: shared12 @ todos' in - generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo - with Invalid_argument _ -> None) + let new_corres = match corres_extend_front e1 e2 corres with + | None -> assert false + | Some new_corres -> new_corres in + let new_sigma_corres = + let sigma1, sigma2 = sigma_corres in + let new_sigma1 = hpred1 :: sigma1 in + let new_sigma2 = hpred2 :: sigma2 in + (new_sigma1, new_sigma2) in + let new_todos = + let shared12 = list_combine shared1 shared2 in + (root1, root2) :: (next1, next2) :: shared12 @ todos' in + generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo + with Invalid_argument _ -> None) | Some (Sil.Hdllseg(k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1), - Some (Sil.Hdllseg(k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) -> + Some (Sil.Hdllseg(k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) -> if k1 <> k2 || not (hpara_dll_iso para1 para2) then None else (try - let new_corres = match corres_extend_front e1 e2 corres with - | None -> assert false - | Some new_corres -> new_corres in - let new_sigma_corres = - let sigma1, sigma2 = sigma_corres in - let new_sigma1 = hpred1 :: sigma1 in - let new_sigma2 = hpred2 :: sigma2 in - (new_sigma1, new_sigma2) in - let new_todos = - let shared12 = list_combine shared1 shared2 in - (iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in - generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo - with Invalid_argument _ -> None) + let new_corres = match corres_extend_front e1 e2 corres with + | None -> assert false + | Some new_corres -> new_corres in + let new_sigma_corres = + let sigma1, sigma2 = sigma_corres in + let new_sigma1 = hpred1 :: sigma1 in + let new_sigma2 = hpred2 :: sigma2 in + (new_sigma1, new_sigma2) in + let new_todos = + let shared12 = list_combine shared1 shared2 in + (iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in + generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo + with Invalid_argument _ -> None) | _ -> None end | _ -> None (** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma. -The function returns a partial iso and three sigmas. The first sigma is the first -copy of the two isomorphic sigmas, so it uses expressions in the domain of -the returned isomorphism. The second is the second copy of the two isomorphic sigmas, -and it uses expressions in the range of the isomorphism. The third is the unused -part of the input sigma. *) + The function returns a partial iso and three sigmas. The first sigma is the first + copy of the two isomorphic sigmas, so it uses expressions in the domain of + the returned isomorphism. The second is the second copy of the two isomorphic sigmas, + and it uses expressions in the range of the isomorphism. The third is the unused + part of the input sigma. *) let find_partial_iso eq corres todos sigma = let update e1 e2 sigma0 = let (hpredo1, sigma0_no_e1) = sigma_remove_hpred eq sigma0 e1 in @@ -675,11 +675,11 @@ let find_partial_iso eq corres todos sigma = generic_find_partial_iso Exact update corres init_sigma_corres todos init_sigma_todo (** [find_partial_iso_from_two_sigmas] finds isomorphic sub-sigmas inside two -given sigmas. The function returns a partial iso and four sigmas. The first -sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of -the returned isomorphism. The second is the second copy of the two isomorphic sigmas, -and it uses expressions in the range of the isomorphism. The third and fourth -are the unused parts of the two input sigmas. *) + given sigmas. The function returns a partial iso and four sigmas. The first + sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of + the returned isomorphism. The second is the second copy of the two isomorphic sigmas, + and it uses expressions in the range of the isomorphism. The third and fourth + are the unused parts of the two input sigmas. *) let find_partial_iso_from_two_sigmas mode eq corres todos sigma1 sigma2 = let update e1 e2 sigma_todo = let sigma_todo1, sigma_todo2 = sigma_todo in @@ -703,12 +703,12 @@ let sigma_lift_to_pe sigma = list_map hpred_lift_to_pe sigma (** [generic_para_create] takes a correspondence, and a sigma -and a list of expressions for the first part of this -correspondence. Then, it creates a renaming of expressions -in the domain of the given correspondence, and applies this -renaming to the given sigma. The result is a tuple of the renaming, -the renamed sigma, ids for existentially quantified expressions, -ids for shared expressions, and shared expressions. *) + and a list of expressions for the first part of this + correspondence. Then, it creates a renaming of expressions + in the domain of the given correspondence, and applies this + renaming to the given sigma. The result is a tuple of the renaming, + the renamed sigma, ids for existentially quantified expressions, + ids for shared expressions, and shared expressions. *) let generic_para_create corres sigma1 elist1 = let corres_ids = let not_same_consts = function @@ -732,9 +732,9 @@ let generic_para_create corres sigma1 elist1 = (renaming, body, ids_exists, ids_shared, es_shared) (** [hpara_create] takes a correspondence, and a sigma, a root -and a next for the first part of this correspondence. Then, it creates a -hpara and discovers a list of shared expressions that are -passed as arguments to hpara. Both of them are returned as a result. *) + and a next for the first part of this correspondence. Then, it creates a + hpara and discovers a list of shared expressions that are + passed as arguments to hpara. Both of them are returned as a result. *) let hpara_create corres sigma1 root1 next1 = let renaming, body, ids_exists, ids_shared, es_shared = generic_para_create corres sigma1 [root1; next1] in @@ -755,9 +755,9 @@ let hpara_create corres sigma1 root1 next1 = (hpara, es_shared) (** [hpara_dll_create] takes a correspondence, and a sigma, a root, -a blink and a flink for the first part of this correspondence. Then, it creates a -hpara_dll and discovers a list of shared expressions that are -passed as arguments to hpara. Both of them are returned as a result. *) + a blink and a flink for the first part of this correspondence. Then, it creates a + hpara_dll and discovers a list of shared expressions that are + passed as arguments to hpara. Both of them are returned as a result. *) let hpara_dll_create corres sigma1 root1 blink1 flink1 = let renaming, body, ids_exists, ids_shared, es_shared = generic_para_create corres sigma1 [root1; blink1; flink1] in diff --git a/infer/src/backend/objc_models.ml b/infer/src/backend/objc_models.ml index b0b50596a..d658bacf5 100644 --- a/infer/src/backend/objc_models.ml +++ b/infer/src/backend/objc_models.ml @@ -12,7 +12,7 @@ open Utils (** This module models special c struct types from the Apple's Core Foundation libraries -for which there are particular rules for memory management. *) + for which there are particular rules for memory management. *) module Core_foundation_model = struct @@ -57,7 +57,7 @@ struct "__CFTree"; "__CFURLEnumerator"; "__CFUUID" - ] + ] let cf_network = [ "_CFHTTPAuthentication"; @@ -67,7 +67,7 @@ struct "__CFNetService"; "__CFNetServiceMonitor"; "__CFNetServiceBrowser" - ] + ] let core_media = [ "OpaqueCMBlockBuffer"; @@ -79,7 +79,7 @@ struct "opaqueCMSimpleQueue"; "OpaqueCMClock"; "OpaqueCMTimebase" - ] + ] let core_text = [ "__CTFont"; @@ -95,21 +95,21 @@ struct "__CTRunDelegate"; "__CTTextTab"; "__CTTypesetter" - ] + ] let core_video = [ "__CVBuffer"; "__CVMetalTextureCache"; "__CVOpenGLESTextureCache"; "__CVPixelBufferPool" - ] + ] let image_io = [ "CGImageDestination"; "CGImageMetadata"; "CGImageMetadataTag"; "CGImageSource" - ] + ] let security = [ "__SecCertificate"; @@ -121,7 +121,7 @@ struct "__SecCode"; "__SecTrust"; "__SecRequirement" - ] + ] let system_configuration = [ "__SCDynamicStore"; @@ -133,7 +133,7 @@ struct "__SCNetworkConnection"; "__SCNetworkReachability"; "__SCPreferences" - ] + ] let core_graphics_types = [ "CGAffineTransform"; @@ -165,7 +165,7 @@ struct "CGPDFStream"; "CGPDFString"; "CGShading" - ] + ] let core_foundation_types = core_foundation @ @@ -227,7 +227,7 @@ struct let is_core_lib_create typ funct = is_core_lib_type typ && ((string_contains create funct) || - (string_contains copy funct )) + (string_contains copy funct )) let function_arg_is_cftype typ = (string_contains cf_type typ) diff --git a/infer/src/backend/objc_preanal.ml b/infer/src/backend/objc_preanal.ml index b90c27c74..ed86c08d4 100644 --- a/infer/src/backend/objc_preanal.ml +++ b/infer/src/backend/objc_preanal.ml @@ -17,7 +17,7 @@ type procedure_type = let print_map procname_map = Procname.Hash.iter (fun pname redefined -> - print_endline ((Procname.to_string pname)^" "^(string_of_bool redefined))) + print_endline ((Procname.to_string pname)^" "^(string_of_bool redefined))) procname_map let process_all_cfgs process_function default_value = @@ -86,13 +86,13 @@ let update_cfgs generated_proc_map = with Not_found -> assert false in if is_redefined then (Cfg.Procdesc.remove cfg pname true; - Cg.node_set_defined cg pname false; - true) + Cg.node_set_defined cg pname false; + true) else need_updating in let need_updating = list_fold_right update_cfg_procdesc generated_procs false in if need_updating then (Cfg.store_cfg_to_file cfg_name false cfg; - Cg.store_to_file cg_name cg) in + Cg.store_to_file cg_name cg) in process_all_cfgs update_cfg () let do_objc_preanalysis () = diff --git a/infer/src/backend/paths.ml b/infer/src/backend/paths.ml index 42d3086a5..97f0e76c1 100644 --- a/infer/src/backend/paths.ml +++ b/infer/src/backend/paths.ml @@ -17,7 +17,7 @@ open Utils (* =============== START of the Path module ===============*) module Path : sig -(** type for paths *) + (** type for paths *) type t type session = int @@ -58,8 +58,8 @@ module Path : sig val iter_all_nodes_nocalls : (Cfg.node -> unit) -> t -> unit (** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given. - Do not iterate past the given position. - [f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] *) + Do not iterate past the given position. + [f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] *) val iter_longest_sequence : (int -> t -> int -> Mangled.t option -> unit) -> Sil.path_pos option -> t -> unit (** join two paths *) @@ -164,100 +164,100 @@ end = struct else p module Invariant = (** functions in this module either do not assume, or do not re-establish, the invariant on dummy stats *) - struct - (** check whether a stats is the dummy stats *) - let stats_is_dummy stats = - stats.max_length == - 1 - - (** return the stats of the path *) - (** assumes that the stats are computed *) - let get_stats = function - | Pstart (_, stats) -> stats - | Pnode (_, _, _, _, stats, _) -> stats - | Pjoin (_, _, stats) -> stats - | Pcall (_, _, _, stats) -> stats - - (** restore the invariant that all the stats are dummy, so the path is ready for another traversal *) - (** assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *) - let rec reset_stats = function - | Pstart (node, stats) -> - if not (stats_is_dummy stats) then set_dummy_stats stats - | Pnode (node, exn_opt, session, path, stats, _) -> - if not (stats_is_dummy stats) then - begin - reset_stats path; - set_dummy_stats stats - end - | Pjoin (path1, path2, stats) -> - if not (stats_is_dummy stats) then - begin - reset_stats path1; - reset_stats path2; - set_dummy_stats stats - end - | Pcall (path1, pname, path2, stats) -> - if not (stats_is_dummy stats) then - begin - reset_stats path1; - reset_stats path2; - set_dummy_stats stats - end - - (** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *) - (** Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats - is the length of a longest sequence of nodes in the path where [f] returned [true] on at least one node. - max_length is 0 if the path was visited but no node satisfying [f] was found. *) - (** Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *) - (** Since this breaks the invariant, it must be followed by reset_stats. *) - let rec compute_stats do_calls (f : Cfg.Node.t -> bool) = - let nodes_found stats = stats.max_length > 0 in - function - | Pstart (node, stats) -> - if stats_is_dummy stats then - begin - let found = f node in - stats.max_length <- if found then 1 else 0; - stats.linear_num <- 1.0; - end - | Pnode (node, exn_opt, session, path, stats, _) -> - if stats_is_dummy stats then - begin - compute_stats do_calls f path; - let stats1 = get_stats path in - let found = f node || nodes_found stats1 (* the order is important as f has side-effects *) in - stats.max_length <- if found then 1 + stats1.max_length else 0; - stats.linear_num <- stats1.linear_num; - end - | Pjoin (path1, path2, stats) -> - if stats_is_dummy stats then - begin - compute_stats do_calls f path1; - compute_stats do_calls f path2; - let stats1, stats2 = get_stats path1, get_stats path2 in - stats.max_length <- max stats1.max_length stats2.max_length; - stats.linear_num <- stats1.linear_num +. stats2.linear_num - end - | Pcall (path1, pname, path2, stats) -> - if stats_is_dummy stats then - begin - let stats2 = match do_calls with - | true -> - compute_stats do_calls f path2; - get_stats path2 - | false -> - { max_length = 0; - linear_num = 0.0 } in - let stats1 = - let f' = - if nodes_found stats2 - then fun _ -> true (* already found in call, no need to search before the call *) - else f in - 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; - end - end (* End of module Invariant *) + struct + (** check whether a stats is the dummy stats *) + let stats_is_dummy stats = + stats.max_length == - 1 + + (** return the stats of the path *) + (** assumes that the stats are computed *) + let get_stats = function + | Pstart (_, stats) -> stats + | Pnode (_, _, _, _, stats, _) -> stats + | Pjoin (_, _, stats) -> stats + | Pcall (_, _, _, stats) -> stats + + (** restore the invariant that all the stats are dummy, so the path is ready for another traversal *) + (** assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *) + let rec reset_stats = function + | Pstart (node, stats) -> + if not (stats_is_dummy stats) then set_dummy_stats stats + | Pnode (node, exn_opt, session, path, stats, _) -> + if not (stats_is_dummy stats) then + begin + reset_stats path; + set_dummy_stats stats + end + | Pjoin (path1, path2, stats) -> + if not (stats_is_dummy stats) then + begin + reset_stats path1; + reset_stats path2; + set_dummy_stats stats + end + | Pcall (path1, pname, path2, stats) -> + if not (stats_is_dummy stats) then + begin + reset_stats path1; + reset_stats path2; + set_dummy_stats stats + end + + (** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *) + (** Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats + is the length of a longest sequence of nodes in the path where [f] returned [true] on at least one node. + max_length is 0 if the path was visited but no node satisfying [f] was found. *) + (** Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *) + (** Since this breaks the invariant, it must be followed by reset_stats. *) + let rec compute_stats do_calls (f : Cfg.Node.t -> bool) = + let nodes_found stats = stats.max_length > 0 in + function + | Pstart (node, stats) -> + if stats_is_dummy stats then + begin + let found = f node in + stats.max_length <- if found then 1 else 0; + stats.linear_num <- 1.0; + end + | Pnode (node, exn_opt, session, path, stats, _) -> + if stats_is_dummy stats then + begin + compute_stats do_calls f path; + let stats1 = get_stats path in + let found = f node || nodes_found stats1 (* the order is important as f has side-effects *) in + stats.max_length <- if found then 1 + stats1.max_length else 0; + stats.linear_num <- stats1.linear_num; + end + | Pjoin (path1, path2, stats) -> + if stats_is_dummy stats then + begin + compute_stats do_calls f path1; + compute_stats do_calls f path2; + let stats1, stats2 = get_stats path1, get_stats path2 in + stats.max_length <- max stats1.max_length stats2.max_length; + stats.linear_num <- stats1.linear_num +. stats2.linear_num + end + | Pcall (path1, pname, path2, stats) -> + if stats_is_dummy stats then + begin + let stats2 = match do_calls with + | true -> + compute_stats do_calls f path2; + get_stats path2 + | false -> + { max_length = 0; + linear_num = 0.0 } in + let stats1 = + let f' = + if nodes_found stats2 + then fun _ -> true (* already found in call, no need to search before the call *) + else f in + 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; + end + end (* End of module Invariant *) (** iterate over each node in the path, excluding calls, once *) let iter_all_nodes_nocalls f path = @@ -279,7 +279,7 @@ end = struct !found (** iterate over the longest sequence belonging to the path, restricting to those where [filter] holds of some element. - if a node is reached via an exception, pass the exception information to [f] on the previous node *) + if a node is reached via an exception, pass the exception information to [f] on the previous node *) let iter_longest_sequence_filter (f : int -> t -> int -> Mangled.t option -> unit) (filter: Cfg.Node.t -> bool) (path: t) : unit = let rec doit level session path prev_exn_opt = match path with | Pstart _ -> f level path session prev_exn_opt @@ -298,8 +298,8 @@ end = struct Invariant.reset_stats path (** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given. - Do not iterate past the last occurrence of the given position. - [f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *) + Do not iterate past the last occurrence of the given position. + [f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *) let iter_longest_sequence (f : int -> t -> int -> Mangled.t option -> unit) (pos_opt : Sil.path_pos option) (path: t) : unit = let filter node = match pos_opt with | None -> true @@ -338,7 +338,7 @@ end = struct let n = NodeMap.find node !map in map := NodeMap.add node (n + 1) !map with Not_found -> - map := NodeMap.add node 1 !map in + map := NodeMap.add node 1 !map in iter_longest_sequence (fun level p s exn_opt -> add_node (curr_node p)) None path; let max_rep_node = ref (Cfg.Node.dummy ()) in let max_rep_num = ref 0 in @@ -372,8 +372,8 @@ end = struct let delayed = ref PathMap.empty in let add_path p = try ignore (PathMap.find p !delayed) with Not_found -> - incr delayed_num; - delayed := PathMap.add p !delayed_num !delayed in + incr delayed_num; + delayed := PathMap.add p !delayed_num !delayed in let path_seen p = (* path seen before *) PathMap.mem p !delayed in let rec add_delayed path = @@ -392,11 +392,11 @@ end = struct let num = PathMap.find path !delayed in F.fprintf fmt "P%d" num with Not_found -> - match path with - | Pstart (node, _) -> F.fprintf fmt "n%a" Cfg.Node.pp node - | Pnode (node, exn_top, session, path, _, _) -> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path session Cfg.Node.pp node - | Pjoin (path1, path2, _) -> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2 - | Pcall (path1, _, path2, _) -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 in + match path with + | Pstart (node, _) -> F.fprintf fmt "n%a" Cfg.Node.pp node + | Pnode (node, exn_top, session, path, _, _) -> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path session Cfg.Node.pp node + | Pjoin (path1, path2, _) -> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2 + | Pcall (path1, _, path2, _) -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 in let print_delayed () = if not (PathMap.is_empty !delayed) then begin let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in @@ -474,7 +474,7 @@ end = struct if n <> 0 then n else Sil.loc_compare lt1.Errlog.lt_loc lt2.Errlog.lt_loc in let relevant lt = lt.Errlog.lt_node_tags <> [] in list_remove_irrelevant_duplicates compare relevant (list_rev !trace) - (* list_remove_duplicates compare (list_sort compare !trace) *) + (* list_remove_duplicates compare (list_sort compare !trace) *) end (* =============== END of the Path module ===============*) @@ -610,7 +610,7 @@ end = struct if path_nodes_subset path path_old (* do not propagate new path if it has no new nodes *) then res := PropMap.remove p !res with Not_found -> - res := PropMap.remove p !res in + res := PropMap.remove p !res in PropMap.iter rem ps2; !res diff --git a/infer/src/backend/preanal.ml b/infer/src/backend/preanal.ml index e9c98b05f..6cfa983fa 100644 --- a/infer/src/backend/preanal.ml +++ b/infer/src/backend/preanal.ml @@ -30,7 +30,7 @@ module AllPreds = struct let preds' = Cfg.NodeSet.add nfrom preds in NodeHash.replace preds_table nto preds' with Not_found -> - NodeHash.add preds_table nto (Cfg.NodeSet.singleton nfrom) in + NodeHash.add preds_table nto (Cfg.NodeSet.singleton nfrom) in let do_node n = list_iter (add_edge false n) (Cfg.Node.get_succs n); list_iter (add_edge true n) (Cfg.Node.get_exn n) in @@ -44,7 +44,7 @@ module AllPreds = struct let preds = NodeHash.find preds_table n in Cfg.NodeSet.elements preds with Not_found -> - Cfg.Node.get_preds n + Cfg.Node.get_preds n end module Vset = Set.Make (struct @@ -69,21 +69,21 @@ let rec use_exp cfg pdesc (exp: Sil.exp) acc = match exp with | Sil.Var _ | Sil.Sizeof _ -> acc | Sil.Const (Sil.Ctuple((Sil.Const (Sil.Cfun pname)):: _)) -> - (* for tuples representing the assignment of a block we take the block name *) - (* look for its procdesc and add its captured vars to the set of captured vars. *) + (* for tuples representing the assignment of a block we take the block name *) + (* look for its procdesc and add its captured vars to the set of captured vars. *) let found_pd = ref None in Cfg.iter_proc_desc cfg (fun pn pd -> if Procname.equal pn pname then found_pd:= Some pd); let defining_proc = Cfg.Procdesc.get_proc_name pdesc in (match !found_pd with - | Some pd -> - list_iter (fun (x, _) -> - captured_var:= Vset.add (Sil.mk_pvar x defining_proc) !captured_var - ) (Cfg.Procdesc.get_captured pd) - | _ -> ()); + | Some pd -> + list_iter (fun (x, _) -> + captured_var:= Vset.add (Sil.mk_pvar x defining_proc) !captured_var + ) (Cfg.Procdesc.get_captured pd) + | _ -> ()); acc | Sil.Const _ -> acc | Sil.Lvar x -> - (* If x is a captured var in the current procdesc don't add it to acc *) + (* If x is a captured var in the current procdesc don't add it to acc *) if is_captured_pvar pdesc x then acc else Vset.add x acc | Sil.Cast (_, e) | Sil.UnOp (_, e, _) | Sil.Lfield (e, _, _) -> use_exp cfg pdesc e acc | Sil.BinOp (_, e1, e2) | Sil.Lindex (e1, e2) -> use_exp cfg pdesc e1 (use_exp cfg pdesc e2 acc) @@ -193,7 +193,7 @@ end = struct replace node newset; if not (Vset.equal oldset newset) then Worklist.add node with Not_found -> - replace node set; Worklist.add node in + replace node set; Worklist.add node in list_iter do_node preds let iter init f = @@ -298,7 +298,7 @@ let node_assigns_no_variables cfg node = Vset.is_empty assign_set (** Set the dead variables of a node, by default as dead_after. -If the node is a prune or a join node, propagate as dead_before in the successors *) + If the node is a prune or a join node, propagate as dead_before in the successors *) let add_dead_pvars_after_conditionals_join cfg n dead_pvars = (* L.out " node %d: %a@." (Cfg.Node.get_id n) (Sil.pp_pvar_list pe_text) dead_pvars; *) let seen = ref Cfg.NodeSet.empty in @@ -316,7 +316,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars = | _ -> false in match Cfg.Node.get_kind node with | Cfg.Node.Prune_node _ | Cfg.Node.Join_node when node_assigns_no_variables cfg node && not (next_is_exit node) -> - (* cannot push nullify instructions after an assignment, as they could nullify the same variable *) + (* cannot push nullify instructions after an assignment, as they could nullify the same variable *) let succs = Cfg.Node.get_succs node in list_iter (add_after_prune_join false) succs | _ -> @@ -329,7 +329,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars = add_after_prune_join true n (** Find the set of dead variables for the procedure pname and add nullify instructions. -The variables that are possibly aliased are only considered just before the exit node. *) + The variables that are possibly aliased are only considered just before the exit node. *) let analyze_and_annotate_proc cfg tenv pname pdesc = let exit_node = Cfg.Procdesc.get_exit_node pdesc in let exit_node_is_succ node = @@ -341,7 +341,7 @@ let analyze_and_annotate_proc cfg tenv pname pdesc = captured_var:= Vset.empty; analyze_proc cfg tenv pdesc cand; (* as side effect it coputes the set aliased_var *) (* print_aliased_var "@.@.Aliased variable computed: " !aliased_var; - L.out " PROCEDURE %s@." (Procname.to_string pname); *) + L.out " PROCEDURE %s@." (Procname.to_string pname); *) let dead_pvars_added = ref 0 in let dead_pvars_limit = 100000 in let incr_dead_pvars_added pvars = @@ -350,26 +350,26 @@ let analyze_and_annotate_proc cfg tenv pname pdesc = if !dead_pvars_added > dead_pvars_limit && !dead_pvars_added - num <= dead_pvars_limit then L.err "WARNING: liveness: more than %d dead pvars added in procedure %a, stopping@." dead_pvars_limit Procname.pp pname in Table.iter cand (fun n live_at_predecessors live_current -> (* set dead variables on nodes *) - let nonnull_pvars = Vset.inter (def_node cfg n live_at_predecessors) cand in (* live before, or assigned to *) - let dead_pvars = Vset.diff nonnull_pvars live_current in (* only nullify when variable become live *) - (* L.out " Node %s " (string_of_int (Cfg.Node.get_id n)); *) - let dead_pvars_no_captured = Vset.diff dead_pvars !captured_var in - (* print_aliased_var "@.@.Non-nullable variable computed: " nonnull_pvars; - print_aliased_var "@.Dead variable computed: " dead_pvars; - print_aliased_var "@.Captured variable computed: " !captured_var; - print_aliased_var "@.Dead variable excluding captured computed: " dead_pvars_no_captured; *) - let dead_pvars_no_alias = get_sorted_cand (Vset.diff dead_pvars_no_captured !aliased_var) in - (* print_aliased_var_l "@. Final Dead variable computed: " dead_pvars_no_alias; *) - let dead_pvars_to_add = - if exit_node_is_succ n (* add dead aliased vars just before the exit node *) - then dead_pvars_no_alias @ (get_sorted_cand (Vset.inter cand !aliased_var)) - else dead_pvars_no_alias in - incr_dead_pvars_added dead_pvars_to_add; - if !dead_pvars_added < dead_pvars_limit then add_dead_pvars_after_conditionals_join cfg n dead_pvars_to_add); + let nonnull_pvars = Vset.inter (def_node cfg n live_at_predecessors) cand in (* live before, or assigned to *) + let dead_pvars = Vset.diff nonnull_pvars live_current in (* only nullify when variable become live *) + (* L.out " Node %s " (string_of_int (Cfg.Node.get_id n)); *) + let dead_pvars_no_captured = Vset.diff dead_pvars !captured_var in + (* print_aliased_var "@.@.Non-nullable variable computed: " nonnull_pvars; + print_aliased_var "@.Dead variable computed: " dead_pvars; + print_aliased_var "@.Captured variable computed: " !captured_var; + print_aliased_var "@.Dead variable excluding captured computed: " dead_pvars_no_captured; *) + let dead_pvars_no_alias = get_sorted_cand (Vset.diff dead_pvars_no_captured !aliased_var) in + (* print_aliased_var_l "@. Final Dead variable computed: " dead_pvars_no_alias; *) + let dead_pvars_to_add = + if exit_node_is_succ n (* add dead aliased vars just before the exit node *) + then dead_pvars_no_alias @ (get_sorted_cand (Vset.inter cand !aliased_var)) + else dead_pvars_no_alias in + incr_dead_pvars_added dead_pvars_to_add; + if !dead_pvars_added < dead_pvars_limit then add_dead_pvars_after_conditionals_join cfg n dead_pvars_to_add); list_iter (fun n -> (* generate nullify instructions *) - let dead_pvs_after = Cfg.Node.get_dead_pvars n true in - let dead_pvs_before = Cfg.Node.get_dead_pvars n false in - node_add_nullify_instrs n dead_pvs_after dead_pvs_before) + let dead_pvs_after = Cfg.Node.get_dead_pvars n true in + let dead_pvs_before = Cfg.Node.get_dead_pvars n false in + node_add_nullify_instrs n dead_pvs_after dead_pvs_before) (Cfg.Procdesc.get_nodes pdesc); Table.reset () diff --git a/infer/src/backend/printer.ml b/infer/src/backend/printer.ml index cb0ff60bc..f008aa12e 100644 --- a/infer/src/backend/printer.ml +++ b/infer/src/backend/printer.ml @@ -57,16 +57,16 @@ end = struct Hashtbl.replace log_files (node_fname, !DB.current_source) fd; if needs_initialization then (F.fprintf fmt "

Cfg Node %a

" (Io_infer.Html.pp_line_link ~text: (Some (string_of_int nodeid)) [".."]) loc.Sil.line; - F.fprintf fmt "PROC: %a LINE:%a\n" (Io_infer.Html.pp_proc_link [".."] proc_name) (Escape.escape_xml (Procname.to_string proc_name)) (Io_infer.Html.pp_line_link [".."]) loc.Sil.line; - F.fprintf fmt "
PREDS:@\n"; - list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) preds; - F.fprintf fmt "
SUCCS: @\n"; - list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) succs; - F.fprintf fmt "
EXN: @\n"; - list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) exn; - F.fprintf fmt "
@\n"; - F.pp_print_flush fmt (); - true + F.fprintf fmt "PROC: %a LINE:%a\n" (Io_infer.Html.pp_proc_link [".."] proc_name) (Escape.escape_xml (Procname.to_string proc_name)) (Io_infer.Html.pp_line_link [".."]) loc.Sil.line; + F.fprintf fmt "
PREDS:@\n"; + list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) preds; + F.fprintf fmt "
SUCCS: @\n"; + list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) succs; + F.fprintf fmt "
EXN: @\n"; + list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) exn; + F.fprintf fmt "
@\n"; + F.pp_print_flush fmt (); + true ) else false @@ -220,7 +220,7 @@ let force_delayed_prints () = let _start_session node (loc: Sil.location) proc_name session = let node_id = Cfg.Node.get_id node in (if Log_nodes.start_node node_id loc proc_name (Cfg.Node.get_preds node) (Cfg.Node.get_succs node) (Cfg.Node.get_exn node) - then F.fprintf !html_formatter "%a@[%a@]%a" Io_infer.Html.pp_start_color Green (Cfg.Node.pp_instr (pe_html Green) None ~sub_instrs: true) node Io_infer.Html.pp_end_color ()); + then F.fprintf !html_formatter "%a@[%a@]%a" Io_infer.Html.pp_start_color Green (Cfg.Node.pp_instr (pe_html Green) None ~sub_instrs: true) node Io_infer.Html.pp_end_color ()); F.fprintf !html_formatter "%a%a" Io_infer.Html.pp_hline () (Io_infer.Html.pp_session_link ~with_name: true [".."]) (node_id, session, loc.Sil.line); F.fprintf !html_formatter "%a" Io_infer.Html.pp_start_color Black @@ -249,17 +249,17 @@ let _proc_write_log whole_seconds cfg pname = linenum; list_iter (fun n -> Io_infer.Html.pp_node_link [] - (Cfg.Node.get_description (pe_html Black) n) - (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) - (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) - (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) - (is_visited n) false fmt (Cfg.Node.get_id n)) + (Cfg.Node.get_description (pe_html Black) n) + (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) + (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) + (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) + (is_visited n) false fmt (Cfg.Node.get_id n)) nodes; (match Specs.get_summary pname with - | None -> () - | Some summary -> - Specs.pp_summary (pe_html Black) whole_seconds fmt summary; - Io_infer.Html.close (fd, fmt)) + | None -> () + | Some summary -> + Specs.pp_summary (pe_html Black) whole_seconds fmt summary; + Io_infer.Html.close (fd, fmt)) | None -> () let proc_write_log whole_seconds cfg pname = @@ -275,7 +275,7 @@ let create_errors_per_line err_log = let set = Hashtbl.find err_per_line loc.Sil.line in Hashtbl.replace err_per_line loc.Sil.line (StringSet.add err_str set) with Not_found -> - Hashtbl.add err_per_line loc.Sil.line (StringSet.singleton err_str) in + Hashtbl.add err_per_line loc.Sil.line (StringSet.singleton err_str) in Errlog.iter add_err err_log; err_per_line @@ -284,7 +284,7 @@ let create_err_message err_string = "\n
" ^ err_string ^ "
" (** Module to read specific lines from files. -The data from any file will stay in memory until the handle is collected by the gc *) + The data from any file will stay in memory until the handle is collected by the gc *) module LineReader : sig type t @@ -322,18 +322,18 @@ end = struct done; assert false (* execution never reaches here *) with End_of_file -> - (close_in cin; - Array.of_list (list_rev !lines)) + (close_in cin; + Array.of_list (list_rev !lines)) let file_data (hash: t) fname = try Some (Hashtbl.find hash fname) with Not_found -> - try - let lines_arr = read_file (DB.source_file_to_string fname) in - Hashtbl.add hash fname lines_arr; - Some lines_arr - with exn when exn_not_timeout exn -> None + try + let lines_arr = read_file (DB.source_file_to_string fname) in + Hashtbl.add hash fname lines_arr; + Some lines_arr + with exn when exn_not_timeout exn -> None let from_file_linenum_original hash fname linenum = match file_data hash fname with @@ -382,8 +382,8 @@ let c_file_write_html proc_is_active linereader fname tenv cfg = let err_per_line = create_errors_per_line global_err_log in try (let s = "

File " ^ (DB.source_file_to_string !DB.current_source) ^ "

\n" ^ - "\n" in - F.fprintf fmt "%s" s); + "
\n" in + F.fprintf fmt "%s" s); let linenum = ref 0 in while true do incr linenum; @@ -404,22 +404,22 @@ let c_file_write_html proc_is_active linereader fname tenv cfg = "\n" done with End_of_file -> - (F.fprintf fmt "%s" "
" ^ linenum_str ^ "" ^ line_html in F.fprintf fmt "%s" str; list_iter (fun n -> - let isproof = Specs.Visitedset.mem (Cfg.Node.get_id n, []) !proof_cover in - Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum; + let isproof = Specs.Visitedset.mem (Cfg.Node.get_id n, []) !proof_cover in + Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum; list_iter (fun n -> match Cfg.Node.get_kind n with - | Cfg.Node.Start_node proc_desc -> - let proc_name = Cfg.Procdesc.get_proc_name proc_desc in - let num_specs = list_length (Specs.get_specs proc_name) in - let label = (Escape.escape_xml (Procname.to_string proc_name)) ^ ": " ^ (string_of_int num_specs) ^ " specs" in - Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label - | _ -> ()) nodes_at_linenum; + | Cfg.Node.Start_node proc_desc -> + let proc_name = Cfg.Procdesc.get_proc_name proc_desc in + let num_specs = list_length (Specs.get_specs proc_name) in + let label = (Escape.escape_xml (Procname.to_string proc_name)) ^ ": " ^ (string_of_int num_specs) ^ " specs" in + Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label + | _ -> ()) nodes_at_linenum; list_iter (fun err_string -> F.fprintf fmt "%s" (create_err_message err_string)) errors_at_linenum; F.fprintf fmt "%s" "
\n"; - Errlog.pp_html [fname_encoding] fmt global_err_log; - Io_infer.Html.close (fd, fmt)) + (F.fprintf fmt "%s" "\n"; + Errlog.pp_html [fname_encoding] fmt global_err_log; + Io_infer.Html.close (fd, fmt)) let c_files_write_html linereader exe_env = let proc_is_active = Exe_env.proc_is_active exe_env in diff --git a/infer/src/backend/procname.ml b/infer/src/backend/procname.ml index 2dc3fbd1a..55b375d9b 100644 --- a/infer/src/backend/procname.ml +++ b/infer/src/backend/procname.ml @@ -238,9 +238,9 @@ let java_is_static = function let java_to_string ?withclass: (wc = false) j verbosity = match verbosity with | VERBOSE | NON_VERBOSE -> - (* if verbose, then package.class.method(params): rtype, - else rtype package.class.method(params) - verbose is used for example to create unique filenames, non_verbose to create reports *) + (* if verbose, then package.class.method(params): rtype, + else rtype package.class.method(params) + verbose is used for example to create unique filenames, non_verbose to create reports *) let return_type = java_return_type_to_string j verbosity in let params = java_param_list_to_string j.parameters verbosity in let classname = java_type_to_string j.classname verbosity in @@ -279,16 +279,16 @@ let java_is_anonymous_inner_class = function | _ -> false (** Check if the last parameter is a hidden inner class, and remove it if present. -This is used in private constructors, where a proxy constructor is generated -with an extra parameter and calls the normal constructor. *) + This is used in private constructors, where a proxy constructor is generated + with an extra parameter and calls the normal constructor. *) let java_remove_hidden_inner_class_parameter = function | JAVA js -> (match list_rev js.parameters with - | (so, s) :: par' -> - if is_anonymous_inner_class_name s - then Some (JAVA { js with parameters = list_rev par'}) - else None - | [] -> None) + | (so, s) :: par' -> + if is_anonymous_inner_class_name s + then Some (JAVA { js with parameters = list_rev par'}) + else None + | [] -> None) | _ -> None (** Check if the procedure name is an anonymous inner class constructor. *) @@ -299,19 +299,19 @@ let java_is_anonymous_inner_class_constructor = function | _ -> false (** Check if the procedure name is an acess method (e.g. access$100 used to -access private members from a nested class. *) + access private members from a nested class. *) let java_is_access_method = function | JAVA js -> (match string_split_character js.methodname '$' with - | Some "access", s -> - let is_int = - try ignore (int_of_string s); true with Failure _ -> false in - is_int - | _ -> false) + | Some "access", s -> + let is_int = + try ignore (int_of_string s); true with Failure _ -> false in + is_int + | _ -> false) | _ -> false (** Check if the proc name has the type of a java vararg. -Note: currently only checks that the last argument has type Object[]. *) + Note: currently only checks that the last argument has type Object[]. *) let java_is_vararg = function | JAVA js -> begin @@ -342,7 +342,7 @@ let is_infer_undefined pn = match pn with let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in Str.string_match regexp (java_get_class pn) 0 | _ -> - (* TODO: add cases for obj-c, c, c++ *) + (* TODO: add cases for obj-c, c, c++ *) false (** to_string for C_FUNCTION and STATIC types *) diff --git a/infer/src/backend/prop.ml b/infer/src/backend/prop.ml index 1d0bd4d86..518ccf3d6 100644 --- a/infer/src/backend/prop.ml +++ b/infer/src/backend/prop.ml @@ -15,8 +15,8 @@ module F = Format open Utils (** type to describe different strategies for initializing fields of a structure. [No_init] does not -initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh -variables (C) or default values (Java). *) + initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh + variables (C) or default values (Java). *) type struct_init_mode = | No_init | Fld_init @@ -31,12 +31,12 @@ type normal = Normal (** kind for normal props, i.e. normalized *) type exposed = Exposed (** kind for exposed props *) (** A proposition. The following invariants are mantained. [sub] is of -the form id1 = e1 ... idn = en where: the id's are distinct and do not -occur in the e's nor in [pi] or [sigma]; the id's are in sorted -order; the id's are not existentials; if idn = yn (for yn not -existential) then idn < yn in the order on ident's. [pi] is sorted -and normalized, and does not contain x = e. [sigma] is sorted and -normalized. *) + the form id1 = e1 ... idn = en where: the id's are distinct and do not + occur in the e's nor in [pi] or [sigma]; the id's are in sorted + order; the id's are not existentials; if idn = yn (for yn not + existential) then idn < yn in the order on ident's. [pi] is sorted + and normalized, and does not contain x = e. [sigma] is sorted and + normalized. *) type 'a t = { sigma: Sil.hpred list; sub: Sil.subst; @@ -127,10 +127,10 @@ let pp_hpred_stackvar pe0 env f hpred = { pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *) | _ -> pe in (match pe'.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a = %a:%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te - | PP_LATEX -> - F.fprintf f "%a{=}%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se) + | PP_TEXT | PP_HTML -> + F.fprintf f "%a = %a:%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te + | PP_LATEX -> + F.fprintf f "%a{=}%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se) | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> assert false (* should not happen *) end; Sil.color_post_wrapper changed pe0 f @@ -173,7 +173,7 @@ let pp_sigma pe = pp_semicolon_seq pe (Sil.pp_hpred pe) (** Split sigma into stack and nonstack parts. -The boolean indicates whether the stack should only include local variales. *) + The boolean indicates whether the stack should only include local variales. *) let sigma_get_stack_nonstack only_local_vars sigma = let hpred_is_stack_var = function | Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not only_local_vars || Sil.pvar_is_local pvar @@ -188,8 +188,8 @@ let pp_sigma_simple pe env fmt sigma = if sg != [] then Format.fprintf fmt "%a" (pp_semicolon_seq pe (pp_hpred_stackvar pe env)) sg in let pp_nl fmt doit = if doit then (match pe.pe_kind with - | PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n" - | PP_LATEX -> Format.fprintf fmt " ; \\\\@\n") in + | PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n" + | PP_LATEX -> Format.fprintf fmt " ; \\\\@\n") in let pp_nonstack fmt = pp_semicolon_seq pe (Sil.pp_hpred_env pe (Some env)) fmt in if sigma_stack != [] || sigma_nonstack != [] then Format.fprintf fmt "%a%a%a" pp_stack sigma_stack pp_nl (sigma_stack != [] && sigma_nonstack != []) pp_nonstack sigma_nonstack @@ -312,7 +312,7 @@ let pp_prop pe0 f prop = else F.fprintf f "%a%a%a" pp_pure () (pp_sigma pe) prop.sigma (pp_footprint pe) prop in if !Config.forcing_delayed_prints then (** print in html mode *) - F.fprintf f "%a%a%a" Io_infer.Html.pp_start_color Blue do_print () Io_infer.Html.pp_end_color () + F.fprintf f "%a%a%a" Io_infer.Html.pp_start_color Blue do_print () Io_infer.Html.pp_end_color () else do_print f () (** print in text mode *) @@ -590,20 +590,20 @@ let sym_eval abs e = let e' = Sil.BinOp (Sil.PlusA, e1, e2) in eval (Sil.Lindex (ep, e')) | Sil.BinOp (Sil.PlusPI, (Sil.BinOp (Sil.PlusPI, e11, e12)), e2) -> (* take care of pattern ((ptr + off1) + off2) *) - (* progress: convert inner +I to +A *) + (* progress: convert inner +I to +A *) let e2' = Sil.BinOp (Sil.PlusA, e12, e2) in eval (Sil.BinOp (Sil.PlusPI, e11, e2')) | Sil.BinOp (Sil.PlusA, (Sil.Sizeof (Sil.Tstruct (ftal, sftal, csu, name_opt, supers, def_mthds, iann), st) as e1), e2) -> (* pattern for extensible structs - given a struct declatead as struct s { ... t arr[n] ... }, allocation pattern malloc(sizeof(struct s) + k * siezof(t)) - turn it into struct s { ... t arr[n + k] ... } *) + given a struct declatead as struct s { ... t arr[n] ... }, allocation pattern malloc(sizeof(struct s) + k * siezof(t)) + turn it into struct s { ... t arr[n + k] ... } *) let e1' = eval e1 in let e2' = eval e2 in (match list_rev ftal, e2' with - (fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp -> - let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in - let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in - Sil.Sizeof(Sil.Tstruct (list_rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st) - | _ -> Sil.BinOp(Sil.PlusA, e1', e2')) + (fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp -> + let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in + let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in + Sil.Sizeof(Sil.Tstruct (list_rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st) + | _ -> Sil.BinOp(Sil.PlusA, e1', e2')) | Sil.BinOp (Sil.PlusA as oplus, e1, e2) | Sil.BinOp (Sil.PlusPI as oplus, e1, e2) -> let e1' = eval e1 in @@ -638,7 +638,7 @@ let sym_eval abs e = | Sil.Const (Sil.Cint n2), Sil.BinOp (Sil.MinusA, Sil.Const (Sil.Cint n1), e) -> Sil.exp_int (n1 ++ n2) --- e | Sil.BinOp (Sil.MinusA, e1, e2), e3 -> (* (e1-e2)+e3 --> e1 + (e3-e2) *) - (* progress: brings + to the outside *) + (* progress: brings + to the outside *) eval (e1 +++ (e3 --- e2)) | _, Sil.Const _ -> e1' +++ e2' @@ -732,7 +732,7 @@ let sym_eval abs e = | Sil.Const (Sil.Cfloat v), Sil.Const (Sil.Cfloat w) -> Sil.exp_float (v /.w) | Sil.Sizeof(Sil.Tarray(typ, size), _), Sil.Sizeof(_typ, _) (* pattern: sizeof(arr) / sizeof(arr[0]) = size of arr *) - when Sil.typ_equal _typ typ -> + when Sil.typ_equal _typ typ -> size | _ -> if abs then Sil.exp_get_undefined false else Sil.BinOp (Sil.Div, e1', e2') @@ -884,57 +884,57 @@ let atom_const_lt_exp = function let mk_inequality e = match e with | Sil.BinOp (Sil.Le, base, Sil.Const (Sil.Cint n)) -> - (* base <= n case *) + (* base <= n case *) let nbase = exp_normalize_noabs Sil.sub_empty base in (match nbase with - | Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) -> - let new_offset = Sil.exp_int (n -- n') in - let new_e = Sil.BinOp (Sil.Le, base', new_offset) in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') -> - let new_offset = Sil.exp_int (n -- n') in - let new_e = Sil.BinOp (Sil.Le, base', new_offset) in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) -> - let new_offset = Sil.exp_int (n ++ n') in - let new_e = Sil.BinOp (Sil.Le, base', new_offset) in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') -> - let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in - let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.UnOp(Sil.Neg, new_base, _) -> - (* In this case, base = -new_base. Construct -n-1 < new_base. *) - let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in - let new_e = Sil.BinOp (Sil.Lt, new_offset, new_base) in - Sil.Aeq (new_e, Sil.exp_one) - | _ -> Sil.Aeq (e, Sil.exp_one)) + | Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) -> + let new_offset = Sil.exp_int (n -- n') in + let new_e = Sil.BinOp (Sil.Le, base', new_offset) in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') -> + let new_offset = Sil.exp_int (n -- n') in + let new_e = Sil.BinOp (Sil.Le, base', new_offset) in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) -> + let new_offset = Sil.exp_int (n ++ n') in + let new_e = Sil.BinOp (Sil.Le, base', new_offset) in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') -> + let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in + let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.UnOp(Sil.Neg, new_base, _) -> + (* In this case, base = -new_base. Construct -n-1 < new_base. *) + let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in + let new_e = Sil.BinOp (Sil.Lt, new_offset, new_base) in + Sil.Aeq (new_e, Sil.exp_one) + | _ -> Sil.Aeq (e, Sil.exp_one)) | Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n), base) -> - (* n < base case *) + (* n < base case *) let nbase = exp_normalize_noabs Sil.sub_empty base in (match nbase with - | Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) -> - let new_offset = Sil.exp_int (n -- n') in - let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') -> - let new_offset = Sil.exp_int (n -- n') in - let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) -> - let new_offset = Sil.exp_int (n ++ n') in - let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') -> - let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in - let new_e = Sil.BinOp (Sil.Le, base', new_offset) in - Sil.Aeq (new_e, Sil.exp_one) - | Sil.UnOp(Sil.Neg, new_base, _) -> - (* In this case, base = -new_base. Construct new_base <= -n-1 *) - let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in - let new_e = Sil.BinOp (Sil.Le, new_base, new_offset) in - Sil.Aeq (new_e, Sil.exp_one) - | _ -> Sil.Aeq (e, Sil.exp_one)) + | Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) -> + let new_offset = Sil.exp_int (n -- n') in + let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') -> + let new_offset = Sil.exp_int (n -- n') in + let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) -> + let new_offset = Sil.exp_int (n ++ n') in + let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') -> + let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in + let new_e = Sil.BinOp (Sil.Le, base', new_offset) in + Sil.Aeq (new_e, Sil.exp_one) + | Sil.UnOp(Sil.Neg, new_base, _) -> + (* In this case, base = -new_base. Construct new_base <= -n-1 *) + let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in + let new_e = Sil.BinOp (Sil.Le, new_base, new_offset) in + Sil.Aeq (new_e, Sil.exp_one) + | _ -> Sil.Aeq (e, Sil.exp_one)) | _ -> Sil.Aeq (e, Sil.exp_one) (** Normalize an inequality *) @@ -962,9 +962,9 @@ let inequality_normalize a = let rec combine pacc nacc = function | x:: ps, y:: ng -> (match Sil.exp_compare x y with - | n when n < 0 -> combine (x:: pacc) nacc (ps, y :: ng) - | 0 -> combine pacc nacc (ps, ng) - | _ -> combine pacc (y:: nacc) (x :: ps, ng)) + | n when n < 0 -> combine (x:: pacc) nacc (ps, y :: ng) + | 0 -> combine pacc nacc (ps, ng) + | _ -> combine pacc (y:: nacc) (x :: ps, ng)) | ps, ng -> (list_rev pacc) @ ps, (list_rev nacc) @ ng in let pos'', neg'' = combine [] [] (pos', neg') in (pos'', neg'', off) in @@ -997,8 +997,8 @@ let inequality_normalize a = let exp_reorder e1 e2 = if Sil.exp_compare e1 e2 <= 0 then (e1, e2) else (e2, e1) (** Normalize an atom. -We keep the convention that inequalities with constants -are only of the form [e <= n] and [n < e]. *) + We keep the convention that inequalities with constants + are only of the form [e <= n] and [n < e]. *) let atom_normalize sub a0 = let a = Sil.atom_sub sub a0 in let rec normalize_eq eq = match eq with @@ -1072,7 +1072,7 @@ let rec strexp_normalize sub se = | _ -> let fld_cnts' = list_map (fun (fld, cnt) -> - fld, strexp_normalize sub cnt) fld_cnts in + fld, strexp_normalize sub cnt) fld_cnts in let fld_cnts'' = list_sort Sil.fld_strexp_compare fld_cnts' in Sil.Estruct (fld_cnts'', inst) end @@ -1085,8 +1085,8 @@ let rec strexp_normalize sub se = | _ -> let idx_cnts' = list_map (fun (idx, cnt) -> - let idx' = exp_normalize sub idx in - idx', strexp_normalize sub cnt) idx_cnts in + let idx' = exp_normalize sub idx in + idx', strexp_normalize sub cnt) idx_cnts in let idx_cnts'' = list_sort Sil.exp_strexp_compare idx_cnts' in Sil.Earray (size', idx_cnts'', inst) @@ -1144,7 +1144,7 @@ let mk_ptsto lexp sexp te = Sil.Hpointsto(lexp, nsexp, te) (** Construct a points-to predicate for an expression using either the provided expression [name] as -base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *) + base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *) let mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred = let default_strexp () = match te with | Sil.Sizeof (typ, st) -> @@ -1177,12 +1177,12 @@ let rec hpred_normalize sub hpred = let normalized_te = texp_normalize sub te in begin match normalized_cnt, normalized_te with | Sil.Earray (Sil.Sizeof (t, st1), [], inst), Sil.Sizeof (Sil.Tarray _, st2) -> - (* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *) + (* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *) let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (t, st1), None) inst in replace_hpred hpred' | Sil.Earray (Sil.BinOp(Sil.Mult, Sil.Sizeof (t, st1), x), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) | Sil.Earray (Sil.BinOp(Sil.Mult, x, Sil.Sizeof (t, st1)), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) -> - (* check for an array whose size expression is n * (Sizeof type), and turn the array into a strexp of the given type *) + (* check for an array whose size expression is n * (Sizeof type), and turn the array into a strexp of the given type *) let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (Sil.Tarray(t, x), st1), None) inst in replace_hpred (replace_array_contents hpred' esel) | _ -> Sil.Hpointsto (normalized_root, normalized_cnt, normalized_te) @@ -1269,12 +1269,12 @@ let pi_tighten_ineq pi = (** remove duplicate atoms and redundant inequalities from a sorted pi *) let rec pi_sorted_remove_redundant = function | (Sil.Aeq(Sil.BinOp (Sil.Le, e1, Sil.Const (Sil.Cint n1)), Sil.Const (Sil.Cint i1)) as a1) :: - Sil.Aeq(Sil.BinOp (Sil.Le, e2, Sil.Const (Sil.Cint n2)), Sil.Const (Sil.Cint i2)) :: rest - when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* second inequality redundant *) + Sil.Aeq(Sil.BinOp (Sil.Le, e2, Sil.Const (Sil.Cint n2)), Sil.Const (Sil.Cint i2)) :: rest + when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* second inequality redundant *) pi_sorted_remove_redundant (a1 :: rest) | Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n1), e1), Sil.Const (Sil.Cint i1)) :: - (Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n2), e2), Sil.Const (Sil.Cint i2)) as a2) :: rest - when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* first inequality redundant *) + (Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n2), e2), Sil.Const (Sil.Cint i2)) as a2) :: rest + when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* first inequality redundant *) pi_sorted_remove_redundant (a2 :: rest) | a1:: a2:: rest -> if Sil.atom_equal a1 a2 then pi_sorted_remove_redundant (a2 :: rest) @@ -1293,19 +1293,19 @@ let sigma_get_unsigned_exps sigma = !uexps (** Normalization of pi. -The normalization filters out obviously - true disequalities, such as e <> e + 1. *) + The normalization filters out obviously - true disequalities, such as e <> e + 1. *) let pi_normalize sub sigma pi0 = let pi = list_map (atom_normalize sub) pi0 in let ineq_list, nonineq_list = pi_tighten_ineq pi in let syntactically_different = function | Sil.BinOp(op1, e1, Sil.Const(c1)), Sil.BinOp(op2, e2, Sil.Const(c2)) - when Sil.exp_equal e1 e2 -> + when Sil.exp_equal e1 e2 -> Sil.binop_equal op1 op2 && Sil.binop_injective op1 && not (Sil.const_equal c1 c2) | e1, Sil.BinOp(op2, e2, Sil.Const(c2)) - when Sil.exp_equal e1 e2 -> + when Sil.exp_equal e1 e2 -> Sil.binop_injective op2 && Sil.binop_is_zero_runit op2 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c2) | Sil.BinOp(op1, e1, Sil.Const(c1)), e2 - when Sil.exp_equal e1 e2 -> + when Sil.exp_equal e1 e2 -> Sil.binop_injective op1 && Sil.binop_is_zero_runit op1 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c1) | _ -> false in let filter_useful_atom = @@ -1347,13 +1347,13 @@ let footprint_normalize prop = let npi', nsigma' = if Sil.fav_is_empty fp_vars then npi, nsigma else (* replace primed vars by fresh footprint vars *) - let ids_primed = Sil.fav_to_list fp_vars in - let ids_footprint = - list_map (fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in - let ren_sub = Sil.sub_of_list (list_map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_footprint) in - let nsigma' = sigma_normalize Sil.sub_empty (sigma_sub ren_sub nsigma) in - let npi' = pi_normalize Sil.sub_empty nsigma' (pi_sub ren_sub npi) in - (npi', nsigma') in + let ids_primed = Sil.fav_to_list fp_vars in + let ids_footprint = + list_map (fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in + let ren_sub = Sil.sub_of_list (list_map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_footprint) in + let nsigma' = sigma_normalize Sil.sub_empty (sigma_sub ren_sub nsigma) in + let npi' = pi_normalize Sil.sub_empty nsigma' (pi_sub ren_sub npi) in + (npi', nsigma') in { prop with foot_pi = npi'; foot_sigma = nsigma' } let exp_normalize_prop prop exp = @@ -1366,14 +1366,14 @@ let lexp_normalize_prop p lexp = let nroot = exp_normalize_prop p root in let noffsets = list_map (fun n -> match n with - | Sil.Off_fld _ -> n - | Sil.Off_index e -> Sil.Off_index (exp_normalize_prop p e) + | Sil.Off_fld _ -> n + | Sil.Off_index e -> Sil.Off_index (exp_normalize_prop p e) ) offsets in Sil.exp_add_offsets nroot noffsets (** Collapse consecutive indices that should be added. For instance, -this function reduces x[1][1] to x[2]. The [typ] argument is used -to ensure the soundness of this collapsing. *) + this function reduces x[1][1] to x[2]. The [typ] argument is used + to ensure the soundness of this collapsing. *) let exp_collapse_consecutive_indices_prop p typ exp = let typ_is_base = function | Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true @@ -1464,24 +1464,24 @@ let prop_replace_sub sub p = let mk_neq e1 e2 = run_with_abs_val_eq_zero (fun () -> - let ne1 = exp_normalize Sil.sub_empty e1 in - let ne2 = exp_normalize Sil.sub_empty e2 in - atom_normalize Sil.sub_empty (Sil.Aneq (ne1, ne2))) + let ne1 = exp_normalize Sil.sub_empty e1 in + let ne2 = exp_normalize Sil.sub_empty e2 in + atom_normalize Sil.sub_empty (Sil.Aneq (ne1, ne2))) (** Sil.Construct an equality. *) let mk_eq e1 e2 = run_with_abs_val_eq_zero (fun () -> - let ne1 = exp_normalize Sil.sub_empty e1 in - let ne2 = exp_normalize Sil.sub_empty e2 in - atom_normalize Sil.sub_empty (Sil.Aeq (ne1, ne2))) + let ne1 = exp_normalize Sil.sub_empty e1 in + let ne2 = exp_normalize Sil.sub_empty e2 in + atom_normalize Sil.sub_empty (Sil.Aeq (ne1, ne2))) let unstructured_type = function | Sil.Tstruct _ | Sil.Tarray _ -> false | _ -> true (** Construct a points-to predicate for a single program variable. -If [expand_structs] is true, initialize the fields of structs with fresh variables. *) + If [expand_structs] is true, initialize the fields of structs with fresh variables. *) let mk_ptsto_lvar tenv expand_structs inst ((pvar: Sil.pvar), texp, expo) : Sil.hpred = mk_ptsto_exp tenv expand_structs (Sil.Lvar pvar, texp, expo) inst @@ -1518,12 +1518,12 @@ let prop_sigma_star (p : 'a t) (sigma : Sil.hpred list) : exposed t = { p with sigma = sigma' } (** Eliminates all empty lsegs from sigma, and collect equalities -The empty lsegs include -(a) "lseg_pe para 0 e elist", -(b) "dllseg_pe para iF oB oF iB elist" with iF = 0 or iB = 0, -(c) "lseg_pe para e1 e2 elist" and the rest of sigma contains the "cell" e1, -(d) "dllseg_pe para iF oB oF iB elist" and the rest of sigma contains -cell iF or iB. *) + The empty lsegs include + (a) "lseg_pe para 0 e elist", + (b) "dllseg_pe para iF oB oF iB elist" with iF = 0 or iB = 0, + (c) "lseg_pe para e1 e2 elist" and the rest of sigma contains the "cell" e1, + (d) "dllseg_pe para iF oB oF iB elist" and the rest of sigma contains + cell iF or iB. *) let sigma_remove_emptylseg sigma = let alloc_set = let rec f_alloc set = function @@ -1543,13 +1543,13 @@ let sigma_remove_emptylseg sigma = | Sil.Hpointsto _ as hpred :: sigma' -> f eqs_zero (hpred :: sigma_passed) sigma' | Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) :: sigma' - when (Sil.exp_equal e1 Sil.exp_zero) || (Sil.ExpSet.mem e1 alloc_set) -> + when (Sil.exp_equal e1 Sil.exp_zero) || (Sil.ExpSet.mem e1 alloc_set) -> f (Sil.Aeq(e1, e2) :: eqs_zero) sigma_passed sigma' | Sil.Hlseg _ as hpred :: sigma' -> f eqs_zero (hpred :: sigma_passed) sigma' | Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) :: sigma' - when (Sil.exp_equal iF Sil.exp_zero) || (Sil.ExpSet.mem iF alloc_set) - || (Sil.exp_equal iB Sil.exp_zero) || (Sil.ExpSet.mem iB alloc_set) -> + when (Sil.exp_equal iF Sil.exp_zero) || (Sil.ExpSet.mem iF alloc_set) + || (Sil.exp_equal iB Sil.exp_zero) || (Sil.ExpSet.mem iB alloc_set) -> f (Sil.Aeq(iF, oF):: Sil.Aeq(iB, oB):: eqs_zero) sigma_passed sigma' | Sil.Hdllseg _ as hpred :: sigma' -> f eqs_zero (hpred :: sigma_passed) sigma' @@ -1563,16 +1563,16 @@ let sigma_intro_nonemptylseg e1 e2 sigma = | Sil.Hpointsto _ as hpred :: sigma' -> f (hpred :: sigma_passed) sigma' | Sil.Hlseg (Sil.Lseg_PE, para, f1, f2, shared) :: sigma' - when (Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2) - || (Sil.exp_equal e2 f1 && Sil.exp_equal e1 f2) -> + when (Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2) + || (Sil.exp_equal e2 f1 && Sil.exp_equal e1 f2) -> f (Sil.Hlseg (Sil.Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma' | Sil.Hlseg _ as hpred :: sigma' -> f (hpred :: sigma_passed) sigma' | Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared) :: sigma' - when (Sil.exp_equal e1 iF && Sil.exp_equal e2 oF) - || (Sil.exp_equal e2 iF && Sil.exp_equal e1 oF) - || (Sil.exp_equal e1 iB && Sil.exp_equal e2 oB) - || (Sil.exp_equal e2 iB && Sil.exp_equal e1 oB) -> + when (Sil.exp_equal e1 iF && Sil.exp_equal e2 oF) + || (Sil.exp_equal e2 iF && Sil.exp_equal e1 oF) + || (Sil.exp_equal e1 iB && Sil.exp_equal e2 oB) + || (Sil.exp_equal e2 iB && Sil.exp_equal e1 oB) -> f (Sil.Hdllseg (Sil.Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' | Sil.Hdllseg _ as hpred :: sigma' -> f (hpred :: sigma_passed) sigma' @@ -1708,10 +1708,10 @@ let attributes_in_same_category attr1 attr2 = let get_attribute prop exp category = let atts = get_exp_attributes prop exp in try Some (list_find - (fun att -> - Sil.attribute_category_equal - (Sil.attribute_to_category att) category) - atts) + (fun att -> + Sil.attribute_category_equal + (Sil.attribute_to_category att) category) + atts) with Not_found -> None let get_resource_undef_attribute prop exp = @@ -1875,12 +1875,12 @@ let find_arithmetic_problem proc_node_session prop exp = walk exp; try Some (Div0 (list_find check_zero !exps_divided)), !res with Not_found -> - (match !uminus_unsigned with - | (e, t):: _ -> Some (UminusUnsigned (e, t)), !res - | _ -> None, !res) + (match !uminus_unsigned with + | (e, t):: _ -> Some (UminusUnsigned (e, t)), !res + | _ -> None, !res) (** Deallocate the stack variables in [pvars], and replace them by normal variables. -Return the list of stack variables whose address was still present after deallocation. *) + Return the list of stack variables whose address was still present after deallocation. *) let deallocate_stack_vars p pvars = let filter = function | Sil.Hpointsto (Sil.Lvar v, _, _) -> @@ -1890,11 +1890,11 @@ let deallocate_stack_vars p pvars = let fresh_address_vars = ref [] in (* fresh vars substituted for the address of stack vars *) let stack_vars_address_in_post = ref [] in (* stack vars whose address is still present *) let exp_replace = list_map (function - | Sil.Hpointsto (Sil.Lvar v, _, _) -> - let freshv = Ident.create_fresh Ident.kprimed in - fresh_address_vars := (v, freshv) :: !fresh_address_vars; - (Sil.Lvar v, Sil.Var freshv) - | _ -> assert false) sigma_stack in + | Sil.Hpointsto (Sil.Lvar v, _, _) -> + let freshv = Ident.create_fresh Ident.kprimed in + fresh_address_vars := (v, freshv) :: !fresh_address_vars; + (Sil.Lvar v, Sil.Var freshv) + | _ -> assert false) sigma_stack in let pi1 = list_map (fun (id, e) -> Sil.Aeq (Sil.Var id, e)) (Sil.sub_to_list p.sub) in let pi = list_map (Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in let p' = { p with sub = Sil.sub_empty; pi = []; sigma = sigma_replace_exp exp_replace sigma_other } in @@ -1903,11 +1903,11 @@ let deallocate_stack_vars p pvars = let p'_fav = prop_fav p' in let do_var (v, freshv) = if Sil.fav_mem p'_fav freshv then (* the address of a de-allocated stack var in in the post *) - begin - stack_vars_address_in_post := v :: !stack_vars_address_in_post; - let check_attribute_change att_old att_new = () in - res := add_or_replace_exp_attribute check_attribute_change !res (Sil.Var freshv) (Sil.Adangling Sil.DAaddr_stack_var) - end in + begin + stack_vars_address_in_post := v :: !stack_vars_address_in_post; + let check_attribute_change att_old att_new = () in + res := add_or_replace_exp_attribute check_attribute_change !res (Sil.Var freshv) (Sil.Adangling Sil.DAaddr_stack_var) + end in list_iter do_var !fresh_address_vars; !res in !stack_vars_address_in_post, list_fold_left prop_atom_and p'' pi @@ -1916,8 +1916,8 @@ let deallocate_stack_vars p pvars = (** {1 Functions for transforming footprints into propositions.} *) (** The ones used for abstraction add/remove local stacks in order to -stop the firing of some abstraction rules. The other usual -transforation functions do not use this hack. *) + stop the firing of some abstraction rules. The other usual + transforation functions do not use this hack. *) (** Extract the footprint and return it as a prop *) let extract_footprint p = @@ -1986,7 +1986,7 @@ let sigma_dfs_sort sigma = list_iter ExpStack.push (next:: shared); (hpred:: visited, list_rev_append cur seen) | Sil.Hdllseg (_, _, iF, oB, oF, iB, shared) - when Sil.exp_equal e iF || Sil.exp_equal e iB -> + when Sil.exp_equal e iF || Sil.exp_equal e iB -> list_iter ExpStack.push (oB:: oF:: shared); (hpred:: visited, list_rev_append cur seen) | _ -> @@ -2095,7 +2095,7 @@ let prop_rename_array_indices prop = let not_same_base_lt_offsets e1 e2 = match e1, e2 with | Sil.BinOp(Sil.PlusA, e1', Sil.Const (Sil.Cint n1')), - Sil.BinOp(Sil.PlusA, e2', Sil.Const (Sil.Cint n2')) -> + Sil.BinOp(Sil.PlusA, e2', Sil.Const (Sil.Cint n2')) -> not (Sil.exp_equal e1' e2' && Sil.Int.lt n1' n2') | _ -> true in let rec select_minimal_indices indices_seen = function @@ -2272,7 +2272,7 @@ let prop_rename_primed_footprint_vars p = let sub_for_normalize = Sil.sub_empty in (* It is fine to use the empty substituion during normalization - because the renaming maintains that a substitution is normalized *) + because the renaming maintains that a substitution is normalized *) let nsub' = sub_normalize sub' in let nsigma' = sigma_normalize sub_for_normalize sigma' in let npi' = pi_normalize sub_for_normalize nsigma' pi' in @@ -2318,7 +2318,7 @@ let prop_ren_sub (ren_sub: Sil.subst) (prop: normal t) : normal t = normalize (prop_sub ren_sub prop) (** Existentially quantify the [ids] in [prop]. -[ids] should not contain any primed variables. *) + [ids] should not contain any primed variables. *) let exist_quantify fav prop = let ids = Sil.fav_to_list fav in if list_exists Ident.is_primed ids then assert false; (* sanity check *) @@ -2412,15 +2412,15 @@ type 'a prop_iter = let prop_iter_create prop = match prop.sigma with | hpred:: sigma' -> Some - { pit_sub = prop.sub; - pit_pi = prop.pi; - pit_newpi = []; - pit_old = []; - pit_curr = hpred; - pit_state = (); - pit_new = sigma'; - pit_foot_pi = prop.foot_pi; - pit_foot_sigma = prop.foot_sigma } + { pit_sub = prop.sub; + pit_pi = prop.pi; + pit_newpi = []; + pit_old = []; + pit_curr = hpred; + pit_state = (); + pit_new = sigma'; + pit_foot_pi = prop.foot_pi; + pit_foot_sigma = prop.foot_sigma } | _ -> None (** Return the prop associated to the iterator. *) @@ -2434,13 +2434,13 @@ let prop_iter_to_prop iter = prop iter.pit_newpi (** Add an atom to the pi part of prop iter. The -first parameter records whether it is done -during footprint or during re - execution. *) + first parameter records whether it is done + during footprint or during re - execution. *) let prop_iter_add_atom footprint iter atom = { iter with pit_newpi = (footprint, atom):: iter.pit_newpi } (** Remove the current element of the iterator, and return the prop -associated to the resulting iterator *) + associated to the resulting iterator *) let prop_iter_remove_curr_then_to_prop iter = let sigma = list_rev_append iter.pit_old iter.pit_new in let normalized_sigma = sigma_normalize iter.pit_sub sigma in @@ -2477,21 +2477,21 @@ let prop_iter_next iter = match iter.pit_new with | [] -> None | hpred':: new' -> Some - { iter with - pit_old = iter.pit_curr:: iter.pit_old; - pit_curr = hpred'; - pit_state = (); - pit_new = new'} + { iter with + pit_old = iter.pit_curr:: iter.pit_old; + pit_curr = hpred'; + pit_state = (); + pit_new = new'} let prop_iter_remove_curr_then_next iter = match iter.pit_new with | [] -> None | hpred':: new' -> Some - { iter with - pit_old = iter.pit_old; - pit_curr = hpred'; - pit_state = (); - pit_new = new'} + { iter with + pit_old = iter.pit_old; + pit_curr = hpred'; + pit_state = (); + pit_new = new'} (** Insert before the current element of the iterator. *) let prop_iter_prev_then_insert iter hpred = @@ -2505,8 +2505,8 @@ let rec prop_iter_find iter filter = | Some st -> Some { iter with pit_state = st } | None -> (match prop_iter_next iter with - | None -> None - | Some iter' -> prop_iter_find iter' filter) + | None -> None + | Some iter' -> prop_iter_find iter' filter) (** Set the state of the iterator *) let prop_iter_set_state iter state = @@ -2627,10 +2627,10 @@ let hpred_gc_fields (fav: Sil.fav) hpred = match hpred with Sil.exp_fav_add fav e; Sil.exp_fav_add fav te; (match strexp_gc_fields fav se with - | None -> hpred - | Some se' -> - if Sil.strexp_compare se se' = 0 then hpred - else Sil.Hpointsto (e, se', te)) + | None -> hpred + | Some se' -> + if Sil.strexp_compare se se' = 0 then hpred + else Sil.Hpointsto (e, se', te)) | Sil.Hlseg _ | Sil.Hdllseg _ -> hpred @@ -2697,38 +2697,38 @@ let trans_land_lor op ((idl1, stml1), e1) ((idl2, stml2), e2) loc = end (** Input of this mehtod is an exp in a prop. Output is a formal variable or path from a -formal variable that is equal to the expression, or the OBJC_NULL attribute of the expression. *) + formal variable that is equal to the expression, or the OBJC_NULL attribute of the expression. *) let find_equal_formal_path e prop = let rec find_in_sigma e seen_hpreds = list_fold_right ( - fun hpred res -> - if list_mem Sil.hpred_equal hpred seen_hpreds then None - else - let seen_hpreds = hpred :: seen_hpreds in - match res with - | Some _ -> res - | None -> - match hpred with - | Sil.Hpointsto (Sil.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal(_, _) ), _) - when Sil.exp_equal exp2 e && (Sil.pvar_is_local pvar1 || Sil.pvar_is_seed pvar1) -> - Some (Sil.Lvar pvar1) - | Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) -> - list_fold_right (fun (field, strexp) res -> - match res with - | Some _ -> res - | None -> - match strexp with - | Sil.Eexp (exp2, _) when Sil.exp_equal exp2 e -> - (match find_in_sigma exp1 seen_hpreds with - | Some exp' -> Some (Sil.Lfield (exp', field, Sil.Tvoid)) - | None -> None) - | _ -> None) fields None - | _ -> None) (get_sigma prop) None in + fun hpred res -> + if list_mem Sil.hpred_equal hpred seen_hpreds then None + else + let seen_hpreds = hpred :: seen_hpreds in + match res with + | Some _ -> res + | None -> + match hpred with + | Sil.Hpointsto (Sil.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal(_, _) ), _) + when Sil.exp_equal exp2 e && (Sil.pvar_is_local pvar1 || Sil.pvar_is_seed pvar1) -> + Some (Sil.Lvar pvar1) + | Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) -> + list_fold_right (fun (field, strexp) res -> + match res with + | Some _ -> res + | None -> + match strexp with + | Sil.Eexp (exp2, _) when Sil.exp_equal exp2 e -> + (match find_in_sigma exp1 seen_hpreds with + | Some exp' -> Some (Sil.Lfield (exp', field, Sil.Tvoid)) + | None -> None) + | _ -> None) fields None + | _ -> None) (get_sigma prop) None in match find_in_sigma e [] with | Some res -> Some res | None -> match get_objc_null_attribute prop e with - | Some (Sil.Aobjc_null exp) -> Some exp - | _ -> None + | Some (Sil.Aobjc_null exp) -> Some exp + | _ -> None (** translate an if-then-else expression *) let trans_if_then_else ((idl1, stml1), e1) ((idl2, stml2), e2) ((idl3, stml3), e3) loc = @@ -2772,8 +2772,8 @@ end = struct (** Approximate the size of the longest chain by counting the max - number of |-> with the same type and whose lhs is primed or - footprint *) + number of |-> with the same type and whose lhs is primed or + footprint *) let sigma_chain_size sigma = let tbl = ref Sil.ExpMap.empty in let add t = @@ -2786,8 +2786,8 @@ end = struct let process_hpred = function | Sil.Hpointsto (e, _, te) -> (match e with - | Sil.Var id when Ident.is_primed id || Ident.is_footprint id -> add te - | _ -> ()) + | Sil.Var id when Ident.is_primed id || Ident.is_footprint id -> add te + | _ -> ()) | Sil.Hlseg _ | Sil.Hdllseg _ -> () in list_iter process_hpred sigma; let size = ref 0 in @@ -2795,15 +2795,15 @@ end = struct !size (** Compute a size value for the prop, which indicates its - complexity *) + complexity *) let prop_size p = let size_current = sigma_size p.sigma in let size_footprint = sigma_size p.foot_sigma in max size_current size_footprint (** Approximate the size of the longest chain by counting the max - number of |-> with the same type and whose lhs is primed or - footprint *) + number of |-> with the same type and whose lhs is primed or + footprint *) let prop_chain_size p = let fp_size = pi_size p.foot_pi + sigma_size p.foot_sigma in pi_size p.pi + sigma_size p.sigma + fp_size diff --git a/infer/src/backend/propgraph.ml b/infer/src/backend/propgraph.ml index f2d50d6f4..f7c599737 100644 --- a/infer/src/backend/propgraph.ml +++ b/infer/src/backend/propgraph.ml @@ -67,7 +67,7 @@ let get_subl footprint_part g = if footprint_part then [] else Sil.sub_to_list (Prop.get_sub g) (** [edge_from_source g n footprint_part is_hpred] finds and edge with the given source [n] in prop [g]. -[footprint_part] indicates whether to search the edge in the footprint part, and [is_pred] whether it is an hpred edge. *) + [footprint_part] indicates whether to search the edge in the footprint part, and [is_pred] whether it is an hpred edge. *) let edge_from_source g n footprint_part is_hpred = let edges = if is_hpred @@ -78,7 +78,7 @@ let edge_from_source g n footprint_part is_hpred = | edge:: _ -> Some edge (** [get_succs g n footprint_part is_hpred] returns the successor nodes of [n] in [g]. -[footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *) + [footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *) let get_succs g n footprint_part is_hpred = match edge_from_source g n footprint_part is_hpred with | None -> [] @@ -98,13 +98,13 @@ let edge_equal e1 e2 = match e1, e2 with | _ -> false (** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e], -searching the footprint part if [footprint_part] is true. *) + searching the footprint part if [footprint_part] is true. *) let contains_edge (footprint_part: bool) (g: t) (e: edge) = try ignore (list_find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true with Not_found -> false (** [iter_edges footprint_part f g] iterates function [f] on the edges in [g] in the same order as returned by [get_edges]; -if [footprint_part] is true the edges are taken from the footprint part. *) + if [footprint_part] is true the edges are taken from the footprint part. *) let iter_edges footprint_part f g = list_iter f (get_edges footprint_part g) (* For now simple iterator; later might use a specific traversal *) @@ -133,9 +133,9 @@ let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list = mat and compute_fsel_diff fsel1 fsel2 : Obj.t list = match fsel1, fsel2 with | ((f1, se1):: fsel1'), (((f2, se2) as x):: fsel2') -> (match Sil.fld_compare f1 f2 with - | n when n < 0 -> compute_fsel_diff fsel1' fsel2 - | 0 -> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2' - | _ -> (Obj.repr x) :: compute_fsel_diff fsel1 fsel2') + | n when n < 0 -> compute_fsel_diff fsel1' fsel2 + | 0 -> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2' + | _ -> (Obj.repr x) :: compute_fsel_diff fsel1 fsel2') | _, [] -> [] | [], x:: fsel2' -> (Obj.repr x) :: compute_fsel_diff [] fsel2' @@ -143,9 +143,9 @@ and compute_fsel_diff fsel1 fsel2 : Obj.t list = match fsel1, fsel2 with and compute_esel_diff esel1 esel2 : Obj.t list = match esel1, esel2 with | ((e1, se1):: esel1'), (((e2, se2) as x):: esel2') -> (match Sil.exp_compare e1 e2 with - | n when n < 0 -> compute_esel_diff esel1' esel2 - | 0 -> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2' - | _ -> (Obj.repr x) :: compute_esel_diff esel1 esel2') + | n when n < 0 -> compute_esel_diff esel1' esel2 + | 0 -> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2' + | _ -> (Obj.repr x) :: compute_esel_diff esel1 esel2') | _, [] -> [] | [], x:: esel2' -> (Obj.repr x) :: compute_esel_diff [] esel2' @@ -192,13 +192,13 @@ let compute_diff default_color oldgraph newgraph : diff = diff_cmap_foot = colormap_foot } (** [diff_get_colormap footprint_part diff] returns the colormap of a computed diff, -selecting the footprint colormap if [footprint_part] is true. *) + selecting the footprint colormap if [footprint_part] is true. *) let diff_get_colormap footprint_part diff = if footprint_part then diff.diff_cmap_foot else diff.diff_cmap_norm (** Print a list of propositions, prepending each one with the given string. -If !Config.pring_using_diff is true, print the diff w.r.t. the given prop, -extracting its local stack vars if the boolean is true. *) + If !Config.pring_using_diff is true, print the diff w.r.t. the given prop, + extracting its local stack vars if the boolean is true. *) let pp_proplist pe0 s (base_prop, extract_stack) f plist = let num = list_length plist in let base_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma base_prop)) in @@ -218,16 +218,16 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist = let pe = update_pe_diff _x in let x = add_base_stack _x in (match pe.pe_kind with - | PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x - | PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x - | PP_LATEX -> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x) + | PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x + | PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x + | PP_LATEX -> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x) | _x:: l -> let pe = update_pe_diff _x in let x = add_base_stack _x in (match pe.pe_kind with - | PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l - | PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l - | PP_LATEX -> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l) + | PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l + | PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l + | PP_LATEX -> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l) in pp_seq_newline 1 f plist (** dump a propset *) diff --git a/infer/src/backend/propset.ml b/infer/src/backend/propset.ml index 25bbd6e44..71f2fb5cf 100644 --- a/infer/src/backend/propset.ml +++ b/infer/src/backend/propset.ml @@ -25,7 +25,7 @@ module PropSet = let compare = PropSet.compare (** Sets of propositions. -The invariant is maintaned that Prop.prop_rename_primed_footprint_vars is called on any prop added to the set. *) + The invariant is maintaned that Prop.prop_rename_primed_footprint_vars is called on any prop added to the set. *) type t = PropSet.t let add p pset = @@ -78,13 +78,13 @@ let map f pset = from_proplist (list_map f (to_proplist pset)) (** [fold f pset a] computes [f (... (f (f a p1) p2) ...) pn] -where [p1 ... pN] are the elements of pset, in increasing order. *) + where [p1 ... pN] are the elements of pset, in increasing order. *) let fold f a pset = let l = to_proplist pset in list_fold_left f a l (** [iter f pset] computes (f p1;f p2;..;f pN) -where [p1 ... pN] are the elements of pset, in increasing order. *) + where [p1 ... pN] are the elements of pset, in increasing order. *) let iter = PropSet.iter diff --git a/infer/src/backend/prover.ml b/infer/src/backend/prover.ml index db924d37e..1e4d1eb7b 100644 --- a/infer/src/backend/prover.ml +++ b/infer/src/backend/prover.ml @@ -74,21 +74,21 @@ end = struct let from_leq acc (e1, e2) = match e1, e2 with | Sil.BinOp(Sil.MinusA, (Sil.Var id11 as e11), (Sil.Var id12 as e12)), Sil.Const (Sil.Cint n) - when not (Ident.equal id11 id12) -> + when not (Ident.equal id11 id12) -> (match Sil.Int.to_signed n with - | None -> acc (* ignore: constraint algorithm only terminates on signed integers *) - | Some n' -> - (e11, e12, n') :: acc) + | None -> acc (* ignore: constraint algorithm only terminates on signed integers *) + | Some n' -> + (e11, e12, n') :: acc) | _ -> acc let from_lt acc (e1, e2) = match e1, e2 with | Sil.Const (Sil.Cint n), Sil.BinOp(Sil.MinusA, (Sil.Var id21 as e21), (Sil.Var id22 as e22)) - when not (Ident.equal id21 id22) -> + when not (Ident.equal id21 id22) -> (match Sil.Int.to_signed n with - | None -> acc (* ignore: constraint algorithm only terminates on signed integers *) - | Some n' -> - let m = Sil.Int.zero -- n' -- Sil.Int.one in - (e22, e21, m) :: acc) + | None -> acc (* ignore: constraint algorithm only terminates on signed integers *) + | Some n' -> + let m = Sil.Int.zero -- n' -- Sil.Int.one in + (e22, e21, m) :: acc) | _ -> acc let rec generate ((e1, e2, n) as constr) acc = function @@ -191,7 +191,7 @@ let check_type_size_lt t1 t2 = match type_size_compare t1 t2 with (** Reasoning about inequalities *) module Inequalities : sig -(** type for inequalities (and implied disequalities) *) + (** type for inequalities (and implied disequalities) *) type t (** Extract inequalities and disequalities from [pi] *) @@ -310,7 +310,7 @@ end = struct let new_umap = umap_add umap e1 new_upper1 in umap_improve_by_difference_constraints new_umap constrs_rest with Not_found -> - umap_improve_by_difference_constraints umap constrs_rest in + umap_improve_by_difference_constraints umap constrs_rest in let rec lmap_improve_by_difference_constraints lmap = function | [] -> lmap | constr:: constrs_rest -> (* e2 - e1 > -n-1 *) @@ -321,7 +321,7 @@ end = struct let new_lmap = lmap_add lmap e2 new_lower2 in lmap_improve_by_difference_constraints new_lmap constrs_rest with Not_found -> - lmap_improve_by_difference_constraints lmap constrs_rest in + lmap_improve_by_difference_constraints lmap constrs_rest in let leqs_res = let umap = umap_create_from_leqs Sil.ExpMap.empty leqs in let umap' = umap_improve_by_difference_constraints umap diff_constraints2 in @@ -375,8 +375,8 @@ end = struct | Sil.Earray (size, isel, _) -> add_lt_minus1_e size; list_iter (fun (idx, se) -> - add_lt_minus1_e idx; - strexp_extract se) isel in + add_lt_minus1_e idx; + strexp_extract se) isel in let hpred_extract = function | Sil.Hpointsto(_, se, texp) -> if texp_is_unsigned texp then strexp_lt_minus1 se; @@ -408,7 +408,7 @@ end = struct match e1, e2 with | Sil.Const (Sil.Cint n1), Sil.Const (Sil.Cint n2) -> Sil.Int.leq n1 n2 | Sil.BinOp (Sil.MinusA, Sil.Sizeof (t1, _), Sil.Sizeof (t2, _)), Sil.Const(Sil.Cint n2) - when Sil.Int.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *) + when Sil.Int.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *) check_type_size_lt t1 t2 | e, Sil.Const (Sil.Cint n) -> (* [e <= n' <= n |- e <= n] *) list_exists (function @@ -533,9 +533,9 @@ let check_zero e = check_equal Prop.prop_emp e Sil.exp_zero (** [is_root prop base_exp exp] checks whether [base_exp = -exp.offlist] for some list of offsets [offlist]. If so, it returns -[Some(offlist)]. Otherwise, it returns [None]. Assumes that -[base_exp] points to the beginning of a structure, not the middle. + exp.offlist] for some list of offsets [offlist]. If so, it returns + [Some(offlist)]. Otherwise, it returns [None]. Assumes that + [base_exp] points to the beginning of a structure, not the middle. *) let is_root prop base_exp exp = let rec f offlist_past e = match e with @@ -599,27 +599,27 @@ let check_disequal prop e1 e2 = | [] -> None | Sil.Hpointsto (base, _, _) as hpred :: sigma_rest -> (match is_root prop base e with - | None -> - let sigma_irrelevant' = hpred :: sigma_irrelevant - in f sigma_irrelevant' e sigma_rest - | Some _ -> - let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest - in Some (true, sigma_irrelevant')) + | None -> + let sigma_irrelevant' = hpred :: sigma_irrelevant + in f sigma_irrelevant' e sigma_rest + | Some _ -> + let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest + in Some (true, sigma_irrelevant')) | Sil.Hlseg (k, _, e1, e2, _) as hpred :: sigma_rest -> (match is_root prop e1 e with - | None -> - let sigma_irrelevant' = hpred :: sigma_irrelevant - in f sigma_irrelevant' e sigma_rest - | Some _ -> - if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then - let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest - in Some (true, sigma_irrelevant') - else if (Sil.exp_equal e2 Sil.exp_zero) then - let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest - in Some (false, sigma_irrelevant') - else - let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest - in f [] e2 sigma_rest') + | None -> + let sigma_irrelevant' = hpred :: sigma_irrelevant + in f sigma_irrelevant' e sigma_rest + | Some _ -> + if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then + let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest + in Some (true, sigma_irrelevant') + else if (Sil.exp_equal e2 Sil.exp_zero) then + let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest + in Some (false, sigma_irrelevant') + else + let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest + in f [] e2 sigma_rest') | Sil.Hdllseg (Sil.Lseg_NE, _, iF, oB, oF, iB, _) :: sigma_rest -> if is_root prop iF e != None || is_root prop iB e != None then let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest @@ -629,19 +629,19 @@ let check_disequal prop e1 e2 = in Some (false, sigma_irrelevant') | Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) as hpred :: sigma_rest -> (match is_root prop iF e with - | None -> - let sigma_irrelevant' = hpred :: sigma_irrelevant - in f sigma_irrelevant' e sigma_rest - | Some _ -> - if (check_pi_implies_disequal iF oF) then - let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest - in Some (true, sigma_irrelevant') - else if (Sil.exp_equal oF Sil.exp_zero) then - let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest - in Some (false, sigma_irrelevant') - else - let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest - in f [] oF sigma_rest') in + | None -> + let sigma_irrelevant' = hpred :: sigma_irrelevant + in f sigma_irrelevant' e sigma_rest + | Some _ -> + if (check_pi_implies_disequal iF oF) then + let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest + in Some (true, sigma_irrelevant') + else if (Sil.exp_equal oF Sil.exp_zero) then + let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest + in Some (false, sigma_irrelevant') + else + let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest + in f [] oF sigma_rest') in let f_null_check sigma_irrelevant e sigma_rest = if not (Sil.exp_equal e Sil.exp_zero) then f sigma_irrelevant e sigma_rest else @@ -651,8 +651,8 @@ let check_disequal prop e1 e2 = | None -> false | Some (e1_allocated, spatial_part_leftover) -> (match f_null_check [] n_e2 spatial_part_leftover with - | None -> false - | Some ((e2_allocated : bool), _) -> e1_allocated || e2_allocated) in + | None -> false + | Some ((e2_allocated : bool), _) -> e1_allocated || e2_allocated) in let neq_pure_part () = check_pi_implies_disequal n_e1 n_e2 in check_disequal_const () || neq_pure_part () || neq_spatial_part () @@ -841,12 +841,12 @@ let check_inconsistency_base prop = let inconsistent_atom = function | Sil.Aeq (e1, e2) -> (match e1, e2 with - | Sil.Const c1, Sil.Const c2 -> not (Sil.const_equal c1 c2) - | _ -> check_disequal prop e1 e2) + | Sil.Const c1, Sil.Const c2 -> not (Sil.const_equal c1 c2) + | _ -> check_disequal prop e1 e2) | Sil.Aneq (e1, e2) -> (match e1, e2 with - | Sil.Const c1, Sil.Const c2 -> Sil.const_equal c1 c2 - | _ -> (Sil.exp_compare e1 e2 = 0)) in + | Sil.Const c1, Sil.Const c2 -> Sil.const_equal c1 c2 + | _ -> (Sil.exp_compare e1 e2 = 0)) in let inconsistent_inequalities () = let ineq = Inequalities.from_prop prop in (* @@ -1097,8 +1097,8 @@ let extend_sub sub v e = Sil.sub_join new_sub (Sil.sub_range_map (Sil.exp_sub new_sub) sub) (** Extend [sub1] and [sub2] to witnesses that each instance of -[e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not -possible. *) + [e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not + possible. *) let exp_imply calc_missing subs e1_in e2_in : subst2 = let e1 = Prop.exp_normalize_noabs (fst subs) e1_in in let e2 = Prop.exp_normalize_noabs (snd subs) e2_in in @@ -1128,7 +1128,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 = | e1, Sil.Var v2 -> let occurs_check v e = (* check whether [v] occurs in normalized [e] *) if Sil.fav_mem (Sil.exp_fav e) v - && Sil.fav_mem (Sil.exp_fav (Prop.exp_normalize_prop Prop.prop_emp e)) v + && Sil.fav_mem (Sil.exp_fav (Prop.exp_normalize_prop Prop.prop_emp e)) v then raise (IMPL_EXC ("occurs check", subs, (EXC_FALSE_EXPS (e1, e2)))) in if Ident.is_primed v2 then let () = occurs_check v2 e1 in @@ -1177,9 +1177,9 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 = do_imply subs e1 e2 (** Convert a path (from lhs of a |-> to a field name present only in -the rhs) into an id. If the lhs was a footprint var, the id is a -new footprint var. Othewise it is a var with the path in the name -and stamp - 1 *) + the rhs) into an id. If the lhs was a footprint var, the id is a + new footprint var. Othewise it is a var with the path in the name + and stamp - 1 *) let path_to_id path = let rec f = function | Sil.Var id -> @@ -1187,12 +1187,12 @@ let path_to_id path = else Some (Ident.name_to_string (Ident.get_name id) ^ (string_of_int (Ident.get_stamp id))) | Sil.Lfield (e, fld, t) -> (match f e with - | None -> None - | Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld))) + | None -> None + | Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld))) | Sil.Lindex (e, ind) -> (match f e with - | None -> None - | Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind))) + | None -> None + | Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind))) | Sil.Lvar pv -> Some (Sil.exp_to_string path) | Sil.Const (Sil.Cstr s) -> @@ -1216,15 +1216,15 @@ let array_size_imply calc_missing subs size1 size2 indices2 = | _, Sil.BinOp (Sil.PlusA, _, Sil.Var _) | Sil.BinOp (Sil.Mult, _, _), _ -> (try exp_imply calc_missing subs size1 size2 with - | IMPL_EXC (s, subs', x) -> - raise (IMPL_EXC ("array size:" ^ s, subs', x))) + | IMPL_EXC (s, subs', x) -> + raise (IMPL_EXC ("array size:" ^ s, subs', x))) | _ -> ProverState.add_bounds_check (ProverState.BCsize_imply (size1, size2, indices2)); subs (** Extend [sub1] and [sub2] to witnesses that each instance of -[se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not -possible. *) + [se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not + possible. *) let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subst2 * (Sil.strexp option) * (Sil.strexp option) = (* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_str " : "; Sil.d_typ_full typ2; L.d_ln(); *) match se1, se2 with @@ -1309,8 +1309,8 @@ and struct_imply source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Ident.fi subs'', fld_frame, (f2, se2):: fld_missing and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2 -: subst2 * ((Sil.exp * Sil.strexp) list) * ((Sil.exp * Sil.strexp) list) -= + : subst2 * ((Sil.exp * Sil.strexp) list) * ((Sil.exp * Sil.strexp) list) + = let typ_elem = Sil.array_typ_elem (Some Sil.Tvoid) typ2 in match esel1, esel2 with | _,[] -> subs, esel1, [] @@ -1321,8 +1321,8 @@ and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2 if n < 0 then array_imply source calc_index_frame calc_missing subs esel1' esel2 typ2 else if n > 0 then array_imply source calc_index_frame calc_missing subs esel1 esel2' typ2 else (* n=0 *) - let subs', _, _ = sexp_imply (Sil.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in - array_imply source calc_index_frame calc_missing subs' esel1' esel2' typ2 + let subs', _, _ = sexp_imply (Sil.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in + array_imply source calc_index_frame calc_missing subs' esel1' esel2' typ2 | [], (e2, se2) :: esel2' -> let subs' = sexp_imply_nolhs (Sil.Lindex (source, e2)) calc_missing subs se2 typ_elem in let subs'', index_frame, index_missing = array_imply source calc_index_frame calc_missing subs' [] esel2' typ2 in @@ -1415,7 +1415,7 @@ let move_primed_lhs_from_front subs sigma = match sigma with let name_n = Ident.string_to_name "n" (** [expand_hpred_pointer calc_index_frame hpred] expands [hpred] if it is a |-> whose lhs is a Lfield or Lindex or ptr+off. -Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *) + Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *) let expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred = let rec expand changed calc_index_frame hpred = match hpred with | Sil.Hpointsto (Sil.Lfield (e, fld, typ_fld), se, t) -> @@ -1509,7 +1509,7 @@ let rec case_analysis_type tenv (t1, st1) (t2, st2) = | Sil.Tstruct (_, _, Sil.Class, Some c1, _, _, _), Sil.Tarray _ -> if ((Mangled.equal c1 serializable_type) || (Mangled.equal c1 cloneable_type) || (Mangled.equal c1 object_type)) && - (st1 <> Sil.Subtype.exact) then (Some st1, None) + (st1 <> Sil.Subtype.exact) then (Some st1, None) else (None, Some st1) | _ -> if (check_subtype_basic_type t1 t2) then (Some st1, None) @@ -1565,27 +1565,27 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing = not (texp_equal_modulo_subtype_flag texp1' texp1) | None -> false in if (calc_missing) then (* footprint *) - begin - match pos_type_opt with - | None -> cast_exception tenv texp1 texp2 e1 subs - | Some texp1' -> - if has_changed then None, pos_type_opt (* missing *) - else pos_type_opt, None (* frame *) - end + begin + match pos_type_opt with + | None -> cast_exception tenv texp1 texp2 e1 subs + | Some texp1' -> + if has_changed then None, pos_type_opt (* missing *) + else pos_type_opt, None (* frame *) + end else (* re-execution *) - begin - match neg_type_opt with - | Some _ -> cast_exception tenv texp1 texp2 e1 subs - | None -> - if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *) - else pos_type_opt, None (* frame *) - end + begin + match neg_type_opt with + | Some _ -> cast_exception tenv texp1 texp2 e1 subs + | None -> + if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *) + else pos_type_opt, None (* frame *) + end end else None, None (** pre-process implication between a non-array and an array: the non-array is turned into an array of size given by its type -only active in type_size mode *) + only active in type_size mode *) let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with | Sil.Eexp (e1, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size -> let se1' = Sil.Earray (texp1, [(Sil.exp_zero, se1)], inst) in @@ -1594,7 +1594,7 @@ let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with | _ -> se1 (** handle parameter subtype for java: when the type of a callee variable in the caller is a strict subtype -of the one in the callee, add a type frame and type missing *) + of the one in the callee, add a type frame and type missing *) let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) = let is_callee = match e1 with | Sil.Lvar pv -> Sil.pvar_is_callee pv @@ -1639,84 +1639,84 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 | Sil.Lvar p -> () | Sil.Var v -> if Ident.is_primed v then (d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2)); - raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) + raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) | _ -> () in (match Prop.prop_iter_create prop1 with - | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) - | Some iter1 -> - (match Prop.prop_iter_find iter1 (filter_ne_lhs (fst subs) e2) with - | None -> raise (IMPL_EXC ("lhs does not have e|->", subs, (EXC_FALSE_HPRED hpred2))) - | Some iter1' -> - (match Prop.prop_iter_current iter1' with - | Sil.Hpointsto (e1, se1, texp1), _ -> - (try - let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) texp2 in - let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in - let se1' = sexp_imply_preprocess se1 texp1 se2 in - let subs', fld_frame, fld_missing = sexp_imply e1 calc_index_frame calc_missing subs se1' se2 typ2 in - if calc_missing then - begin - handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2); - (match fld_missing with - | Some fld_missing -> - ProverState.add_missing_fld (Sil.Hpointsto(_e2, fld_missing, texp1)) - | None -> ()); - (match fld_frame with - | Some fld_frame -> - ProverState.add_frame_fld (Sil.Hpointsto(e1, fld_frame, texp1)) - | None -> ()); - (match typing_missing with - | Some t_missing -> - ProverState.add_missing_typ (_e2, t_missing) - | None -> ()); - (match typing_frame with - | Some t_frame -> - ProverState.add_frame_typ (e1, t_frame) - | None -> ()) - end; - let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' - in (subs', prop1') - with - | IMPL_EXC (s, _, body) when calc_missing -> - raise (MISSING_EXC s)) - | Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (** Unroll lseg *) - let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in - let (_, para_inst1) = Sil.hpara_instantiate para1 e1 n' elist1 in - let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para1 n' f1 elist1] in - let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in - L.d_decrease_indent 1; - res - | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ - when Sil.exp_equal (Sil.exp_sub (fst subs) iF1) e2 -> (** Unroll dllseg forward *) - let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in - let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in - let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 n' iF1 oF1 iB1 elist1] in - let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in - L.d_decrease_indent 1; - res - | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ - when Sil.exp_equal (Sil.exp_sub (fst subs) iB1) e2 -> (** Unroll dllseg backward *) - let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in - let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in - let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 iF1 oB1 iB1 n' elist1] in - let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in - L.d_decrease_indent 1; - res - | _ -> assert false - ) - ) + | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) + | Some iter1 -> + (match Prop.prop_iter_find iter1 (filter_ne_lhs (fst subs) e2) with + | None -> raise (IMPL_EXC ("lhs does not have e|->", subs, (EXC_FALSE_HPRED hpred2))) + | Some iter1' -> + (match Prop.prop_iter_current iter1' with + | Sil.Hpointsto (e1, se1, texp1), _ -> + (try + let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) texp2 in + let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in + let se1' = sexp_imply_preprocess se1 texp1 se2 in + let subs', fld_frame, fld_missing = sexp_imply e1 calc_index_frame calc_missing subs se1' se2 typ2 in + if calc_missing then + begin + handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2); + (match fld_missing with + | Some fld_missing -> + ProverState.add_missing_fld (Sil.Hpointsto(_e2, fld_missing, texp1)) + | None -> ()); + (match fld_frame with + | Some fld_frame -> + ProverState.add_frame_fld (Sil.Hpointsto(e1, fld_frame, texp1)) + | None -> ()); + (match typing_missing with + | Some t_missing -> + ProverState.add_missing_typ (_e2, t_missing) + | None -> ()); + (match typing_frame with + | Some t_frame -> + ProverState.add_frame_typ (e1, t_frame) + | None -> ()) + end; + let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' + in (subs', prop1') + with + | IMPL_EXC (s, _, body) when calc_missing -> + raise (MISSING_EXC s)) + | Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (** Unroll lseg *) + let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in + let (_, para_inst1) = Sil.hpara_instantiate para1 e1 n' elist1 in + let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para1 n' f1 elist1] in + let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in + L.d_decrease_indent 1; + res + | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ + when Sil.exp_equal (Sil.exp_sub (fst subs) iF1) e2 -> (** Unroll dllseg forward *) + let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in + let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in + let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 n' iF1 oF1 iB1 elist1] in + let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in + L.d_decrease_indent 1; + res + | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ + when Sil.exp_equal (Sil.exp_sub (fst subs) iB1) e2 -> (** Unroll dllseg backward *) + let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in + let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in + let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 iF1 oB1 iB1 n' elist1] in + let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in + L.d_decrease_indent 1; + res + | _ -> assert false + ) + ) ) | Sil.Hlseg (k, para2, _e2, _f2, _elist2) -> (* for now ignore implications between PE and NE *) let e2, f2 = Sil.exp_sub (snd subs) _e2, Sil.exp_sub (snd subs) _f2 in @@ -1724,58 +1724,58 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 | Sil.Lvar p -> () | Sil.Var v -> if Ident.is_primed v then (d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2)); - raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) + raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) | _ -> () in if Sil.exp_equal e2 f2 && k == Sil.Lseg_PE then (subs, prop1) else (match Prop.prop_iter_create prop1 with - | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) - | Some iter1 -> - (match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with - | None -> - let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in - let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in - (* calc_missing is false as we're checking an instantiation of the original list *) - L.d_decrease_indent 1; - res - | Some iter1' -> - let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in - let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in (* force instantiation of existentials *) - let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in - let hpred1 = match Prop.prop_iter_current iter1' with - | hpred1, b -> - if b then ProverState.add_missing_pi (Sil.Aneq(_e2, _f2)); (* for PE |- NE *) - hpred1 - in match hpred1 with - | Sil.Hlseg _ -> (subs', prop1') - | Sil.Hpointsto _ -> (* unroll rhs list and try again *) - let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in - let (_, para_inst2) = Sil.hpara_instantiate para2 _e2 n' elist2 in - let hpred_list2 = para_inst2@[Prop.mk_lseg Sil.Lseg_PE para2 n' _f2 _elist2] in - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> - try sigma_imply tenv calc_index_frame calc_missing subs prop1 hpred_list2 - with exn when exn_not_timeout exn -> - begin - (L.d_strln_color Red) "backtracking lseg: trying rhs of length exactly 1"; - let (_, para_inst3) = Sil.hpara_instantiate para2 _e2 _f2 elist2 in - sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3 - end) in - L.d_decrease_indent 1; - res - | Sil.Hdllseg _ -> assert false - ) + | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) + | Some iter1 -> + (match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with + | None -> + let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in + let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in + (* calc_missing is false as we're checking an instantiation of the original list *) + L.d_decrease_indent 1; + res + | Some iter1' -> + let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in + let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in (* force instantiation of existentials *) + let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in + let hpred1 = match Prop.prop_iter_current iter1' with + | hpred1, b -> + if b then ProverState.add_missing_pi (Sil.Aneq(_e2, _f2)); (* for PE |- NE *) + hpred1 + in match hpred1 with + | Sil.Hlseg _ -> (subs', prop1') + | Sil.Hpointsto _ -> (* unroll rhs list and try again *) + let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in + let (_, para_inst2) = Sil.hpara_instantiate para2 _e2 n' elist2 in + let hpred_list2 = para_inst2@[Prop.mk_lseg Sil.Lseg_PE para2 n' _f2 _elist2] in + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> + try sigma_imply tenv calc_index_frame calc_missing subs prop1 hpred_list2 + with exn when exn_not_timeout exn -> + begin + (L.d_strln_color Red) "backtracking lseg: trying rhs of length exactly 1"; + let (_, para_inst3) = Sil.hpara_instantiate para2 _e2 _f2 elist2 in + sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3 + end) in + L.d_decrease_indent 1; + res + | Sil.Hdllseg _ -> assert false + ) ) | Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) -> (d_impl_err ("rhs dllsegPE not implemented", subs, (EXC_FALSE_HPRED hpred2)); - raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) + raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) | Sil.Hdllseg (k, para2, iF2, oB2, oF2, iB2, elist2) -> (* for now ignore implications between PE and NE *) let iF2, oF2 = Sil.exp_sub (snd subs) iF2, Sil.exp_sub (snd subs) oF2 in let iB2, oB2 = Sil.exp_sub (snd subs) iB2, Sil.exp_sub (snd subs) oB2 in @@ -1783,53 +1783,53 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 | Sil.Lvar p -> () | Sil.Var v -> if Ident.is_primed v then (d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2)); - raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) + raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) | _ -> () in let _ = match oB2 with | Sil.Lvar p -> () | Sil.Var v -> if Ident.is_primed v then (d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2)); - raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) + raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))) | _ -> () in (match Prop.prop_iter_create prop1 with - | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) - | Some iter1 -> - (match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with - | None -> - let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in - let _, para_inst2 = - if Sil.exp_equal iF2 iB2 then - Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2 - else assert false in (** Only base case of rhs list considered for now *) - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in - (* calc_missing is false as we're checking an instantiation of the original list *) - L.d_decrease_indent 1; - res - | Some iter1' -> (** Only consider implications between identical listsegs for now *) - let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in - let subs' = exp_list_imply calc_missing subs (iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in (* force instantiation of existentials *) - let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' - in (subs', prop1') - ) + | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) + | Some iter1 -> + (match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with + | None -> + let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in + let _, para_inst2 = + if Sil.exp_equal iF2 iB2 then + Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2 + else assert false in (** Only base case of rhs list considered for now *) + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in + (* calc_missing is false as we're checking an instantiation of the original list *) + L.d_decrease_indent 1; + res + | Some iter1' -> (** Only consider implications between identical listsegs for now *) + let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in + let subs' = exp_list_imply calc_missing subs (iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in (* force instantiation of existentials *) + let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' + in (subs', prop1') + ) ) (** Check that [sigma1] implies [sigma2] and return two substitution -instantiations for the primed variables of [sigma1] and [sigma2] -and a frame. Raise IMPL_FALSE if the implication cannot be -proven. *) + instantiations for the primed variables of [sigma1] and [sigma2] + and a frame. Raise IMPL_FALSE if the implication cannot be + proven. *) and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * Prop.normal Prop.t) = let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *) | Sil.Hpointsto (_e2, _, _) -> let e2 = Sil.exp_sub (snd subs) _e2 in (match e2 with - | Sil.Const (Sil.Cstr s) -> Some (s, true) - | Sil.Const (Sil.Cclass c) -> Some (Ident.name_to_string c, false) - | _ -> None) + | Sil.Const (Sil.Cstr s) -> Some (s, true) + | Sil.Const (Sil.Cclass c) -> Some (Ident.name_to_string c, false) + | _ -> None) | _ -> None in let mk_constant_string_hpred s = (* create an hpred from a constant string *) let size = Sil.exp_int (Sil.Int.of_int (1 + String.length s)) in @@ -1869,60 +1869,60 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * Sil.Hpointsto (root, sexp, class_texp) in try (match move_primed_lhs_from_front subs sigma2 with - | [] -> - L.d_strln "Final Implication"; - d_impl subs (prop1, Prop.prop_emp); - (subs, prop1) - | hpred2 :: sigma2' -> - L.d_strln "Current Implication"; - d_impl subs (prop1, Prop.normalize (Prop.from_sigma (hpred2 :: sigma2'))); - L.d_ln (); - L.d_ln (); - let normal_case hpred2' = - let (subs', prop1') = - try - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2') in - L.d_decrease_indent 1; - res - with IMPL_EXC _ when calc_missing -> - begin - match is_constant_string_class subs hpred2' with - | Some (s, is_string) -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *) - let hpred1' = if is_string then mk_constant_string_hpred s else mk_constant_class_hpred s in - let prop1' = Prop.normalize (Prop.replace_sigma (hpred1' :: Prop.get_sigma prop1) prop1) in - let subs', frame_prop = hpred_imply tenv calc_index_frame calc_missing subs prop1' sigma2 hpred2' in - (* ProverState.add_missing_sigma [hpred1']; *) - subs', frame_prop - | None -> - let subs' = match hpred2' with - | Sil.Hpointsto (e2, se2, te2) -> - let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) te2 in - sexp_imply_nolhs e2 calc_missing subs se2 typ2 - | _ -> subs in - ProverState.add_missing_sigma [hpred2']; - subs', prop1 - end in - L.d_increase_indent 1; - let res = - decrease_indent_when_exception - (fun () -> sigma_imply tenv calc_index_frame calc_missing subs' prop1' sigma2') in - L.d_decrease_indent 1; - res in - (match hpred2 with - | Sil.Hpointsto(_e2, se2, t) -> - let changed, calc_index_frame', hpred2' = expand_hpred_pointer calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs (snd subs) _e2, se2, t)) in - if changed - then sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') (* calc_index_frame=true *) - else normal_case hpred2' - | _ -> normal_case hpred2) + | [] -> + L.d_strln "Final Implication"; + d_impl subs (prop1, Prop.prop_emp); + (subs, prop1) + | hpred2 :: sigma2' -> + L.d_strln "Current Implication"; + d_impl subs (prop1, Prop.normalize (Prop.from_sigma (hpred2 :: sigma2'))); + L.d_ln (); + L.d_ln (); + let normal_case hpred2' = + let (subs', prop1') = + try + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2') in + L.d_decrease_indent 1; + res + with IMPL_EXC _ when calc_missing -> + begin + match is_constant_string_class subs hpred2' with + | Some (s, is_string) -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *) + let hpred1' = if is_string then mk_constant_string_hpred s else mk_constant_class_hpred s in + let prop1' = Prop.normalize (Prop.replace_sigma (hpred1' :: Prop.get_sigma prop1) prop1) in + let subs', frame_prop = hpred_imply tenv calc_index_frame calc_missing subs prop1' sigma2 hpred2' in + (* ProverState.add_missing_sigma [hpred1']; *) + subs', frame_prop + | None -> + let subs' = match hpred2' with + | Sil.Hpointsto (e2, se2, te2) -> + let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) te2 in + sexp_imply_nolhs e2 calc_missing subs se2 typ2 + | _ -> subs in + ProverState.add_missing_sigma [hpred2']; + subs', prop1 + end in + L.d_increase_indent 1; + let res = + decrease_indent_when_exception + (fun () -> sigma_imply tenv calc_index_frame calc_missing subs' prop1' sigma2') in + L.d_decrease_indent 1; + res in + (match hpred2 with + | Sil.Hpointsto(_e2, se2, t) -> + let changed, calc_index_frame', hpred2' = expand_hpred_pointer calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs (snd subs) _e2, se2, t)) in + if changed + then sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') (* calc_index_frame=true *) + else normal_case hpred2' + | _ -> normal_case hpred2) ) with IMPL_EXC (s, _, _) when calc_missing -> - L.d_strln ("Adding rhs as missing: " ^ s); - ProverState.add_missing_sigma sigma2; - subs, prop1 + L.d_strln ("Adding rhs as missing: " ^ s); + ProverState.add_missing_sigma sigma2; + subs, prop1 let prepare_prop_for_implication (sub1, sub2) pi1 sigma1 = let pi1' = (Prop.pi_sub sub2 (ProverState.get_missing_pi ())) @ pi1 in @@ -1946,8 +1946,8 @@ let imply_atom calc_missing (sub1, sub2) prop a = imply_pi calc_missing (sub1, sub2) prop [a] (** Check pure implications before looking at the spatial part. Add -necessary instantiations for equalities and check that instantiations -are possible for disequalities. *) + necessary instantiations for equalities and check that instantiations + are possible for disequalities. *) let rec pre_check_pure_implication calc_missing subs pi1 pi2 = match pi2 with | [] -> subs @@ -1956,21 +1956,21 @@ let rec pre_check_pure_implication calc_missing subs pi1 pi2 = if Sil.exp_equal e2 f2 then pre_check_pure_implication calc_missing subs pi1 pi2' else (match e2, f2 with - | Sil.Var v2, f2 - when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> - (* The commented-out condition should always hold. *) - let sub2' = extend_sub (snd subs) v2 f2 in - pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2' - | e2, Sil.Var v2 - when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> - (* The commented-out condition should always hold. *) - let sub2' = extend_sub (snd subs) v2 e2 in - pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2' - | e2, f2 -> - let pi1' = Prop.pi_sub (fst subs) pi1 in - let prop_for_impl = prepare_prop_for_implication subs pi1' [] in - imply_atom calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in)); - pre_check_pure_implication calc_missing subs pi1 pi2' + | Sil.Var v2, f2 + when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> + (* The commented-out condition should always hold. *) + let sub2' = extend_sub (snd subs) v2 f2 in + pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2' + | e2, Sil.Var v2 + when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> + (* The commented-out condition should always hold. *) + let sub2' = extend_sub (snd subs) v2 e2 in + pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2' + | e2, f2 -> + let pi1' = Prop.pi_sub (fst subs) pi1 in + let prop_for_impl = prepare_prop_for_implication subs pi1' [] in + imply_atom calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in)); + pre_check_pure_implication calc_missing subs pi1 pi2' ) | Sil.Aeq (e1, e2) :: pi2' -> (* must be an inequality *) pre_check_pure_implication calc_missing subs pi1 pi2' @@ -1983,8 +1983,8 @@ let rec pre_check_pure_implication calc_missing subs pi1 pi2 = else raise (IMPL_EXC ("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE)) (** Perform the array bound checks delayed (to instantiate variables) by the prover. -If there is a provable violation of the array bounds, set the prover status to Bounds_check -and make the proof fail. *) + If there is a provable violation of the array bounds, set the prover status to Bounds_check + and make the proof fail. *) let check_array_bounds (sub1, sub2) prop = let check_failed atom = ProverState.checks := Bounds_check :: !ProverState.checks; @@ -2008,7 +2008,7 @@ let check_array_bounds (sub1, sub2) prop = list_iter check_bound (ProverState.get_bounds_checks ()) (** [check_implication_base] returns true if [prop1|-prop2], -ignoring the footprint part of the props *) + ignoring the footprint part of the props *) let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 = try ProverState.reset prop1 prop2; @@ -2063,9 +2063,9 @@ type implication_result = | ImplFail of check list (** [check_implication_for_footprint p1 p2] returns -[Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)] -where [sub] is a substitution which instantiates the -primed vars of [p1] and [p2], which are assumed to be disjoint. *) + [Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)] + where [sub] is a substitution which instantiates the + primed vars of [p1] and [p2], which are assumed to be disjoint. *) let check_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) = let check_frame_empty = false in let calc_missing = true in diff --git a/infer/src/backend/rearrange.ml b/infer/src/backend/rearrange.ml index 22d52b73b..6be3503e1 100644 --- a/infer/src/backend/rearrange.ml +++ b/infer/src/backend/rearrange.ml @@ -30,13 +30,13 @@ let rec list_rev_and_concat l1 l2 = let pp_off fmt off = list_iter (fun n -> match n with - | Sil.Off_fld (f, t) -> F.fprintf fmt "%a " Ident.pp_fieldname f - | Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off + | Sil.Off_fld (f, t) -> F.fprintf fmt "%a " Ident.pp_fieldname f + | Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off (** Check whether the index is out of bounds. -If the size is - 1, no check is performed. -If the index is provably out of bound, a bound error is given. -If the size is a constant and the index is not provably in bound, a warning is given. + If the size is - 1, no check is performed. + If the index is provably out of bound, a bound error is given. + If the size is a constant and the index is not provably in bound, a warning is given. *) let check_bad_index pname tenv p size index loc = let size_is_constant = match size with @@ -145,7 +145,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp | Sil.Tint _, [Sil.Off_index e] | Sil.Tfloat _, [Sil.Off_index e] | Sil.Tvoid, [Sil.Off_index e] | Sil.Tfun _, [Sil.Off_index e] | Sil.Tptr _, [Sil.Off_index e] -> - (* In this case, we lift t to the t array. *) + (* In this case, we lift t to the t array. *) let t' = match t with | Sil.Tptr(t', _) -> t' | _ -> t in @@ -177,10 +177,10 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp res (** Extend the strexp by populating the path indicated by [off]. -This means that it will add missing flds and do the case - analysis -for array accesses. This does not catch the array - bounds errors. -If we want to implement the checks for array bounds errors, -we need to change this function. *) + This means that it will add missing flds and do the case - analysis + for array accesses. This does not catch the array - bounds errors. + If we want to implement the checks for array bounds errors, + we need to change this function. *) let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se typ (off : Sil.offset list) inst = @@ -215,13 +215,13 @@ let rec _strexp_extend_values (res_atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann)) :: acc in list_fold_left replace [] atoms_se_typ_list' with Not_found -> - let atoms', se', res_typ' = - create_struct_values - pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in - let res_fsel' = list_sort Sil.fld_strexp_compare ((f, se'):: fsel) in - let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in - let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in - [(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))] + let atoms', se', res_typ' = + create_struct_values + pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in + let res_fsel' = list_sort Sil.fld_strexp_compare ((f, se'):: fsel) in + let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in + let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in + [(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))] end | (Sil.Off_fld (f, _)):: off', _, _ -> raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) @@ -232,7 +232,7 @@ let rec _strexp_extend_values | (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tfun _ | (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tptr _ | (Sil.Off_index _):: _, Sil.Estruct _, Sil.Tstruct _ -> - (* L.d_strln_color Orange "turn into an array"; *) + (* L.d_strln_color Orange "turn into an array"; *) let size = match se with | Sil.Eexp (_, Sil.Ialloc) -> Sil.exp_one (* if allocated explicitly, we know size is 1 *) | _ -> @@ -259,11 +259,11 @@ let rec _strexp_extend_values else raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in list_fold_left replace [] atoms_se_typ_list' with Not_found -> - array_case_analysis_index pname tenv orig_prop - footprint_part kind max_stamp - size esel - size_for_typ' typ' - e off' inst_arr inst + array_case_analysis_index pname tenv orig_prop + footprint_part kind max_stamp + size esel + size_for_typ' typ' + e off' inst_arr inst end | _, _, _ -> raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) @@ -273,7 +273,7 @@ and array_case_analysis_index pname tenv orig_prop array_size array_cont typ_array_size typ_cont index off inst_arr inst -= + = let check_sound t' = if not (Sil.typ_equal typ_cont t' || array_cont == []) then raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in @@ -319,12 +319,12 @@ and array_case_analysis_index pname tenv orig_prop pname tenv orig_prop footprint_part kind max_stamp se typ_cont off inst in let atoms_se_typ_list' = list_fold_left (fun acc' (atoms', se', typ') -> - check_sound typ'; - let atoms_new = Sil.Aeq(index, i) :: atoms' in - let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in - let array_new = Sil.Earray(array_size, isel_new, inst_arr) in - let typ_new = Sil.Tarray(typ', typ_array_size) in - (atoms_new, array_new, typ_new):: acc' + check_sound typ'; + let atoms_new = Sil.Aeq(index, i) :: atoms' in + let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in + let array_new = Sil.Earray(array_size, isel_new, inst_arr) in + let typ_new = Sil.Tarray(typ', typ_array_size) in + (atoms_new, array_new, typ_new):: acc' ) [] atoms_se_typ_list in let acc_new = atoms_se_typ_list' :: acc in let isel_seen_rev_new = ise :: isel_seen_rev in @@ -370,7 +370,7 @@ let strexp_extend_values off', list_map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs else off, [] in if !Config.trace_rearrange then (L.d_str "entering strexp_extend_values se: "; Sil.d_sexp se; L.d_str " typ: "; - Sil.d_typ_full typ; L.d_str " off': "; Sil.d_offset_list off'; L.d_strln (if footprint_part then " FP" else " RE")); + Sil.d_typ_full typ; L.d_str " off': "; Sil.d_offset_list off'; L.d_strln (if footprint_part then " FP" else " RE")); let atoms_se_typ_list = _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se typ off' inst in @@ -397,7 +397,7 @@ let mk_ptsto_exp_footprint if not (exp_has_only_footprint_ids root) then begin (* in angelic mode, purposely ignore dangling pointer warnings during the footprint phase -- we - * will fix them during the re - execution phase *) + * will fix them during the re - execution phase *) if not (!Config.angelic_execution && !Config.footprint) then begin if !Config.developer_mode then @@ -407,7 +407,7 @@ let mk_ptsto_exp_footprint Errdesc.explain_dereference deref_str orig_prop (State.get_loc ()) in raise (Exceptions.Dangling_pointer_dereference - (None, err_desc, try assert false with Assert_failure x -> x)) + (None, err_desc, try assert false with Assert_failure x -> x)) end end; let off_foot, eqs = laundry_offset_for_footprint max_stamp off in @@ -436,7 +436,7 @@ let mk_ptsto_exp_footprint (ptsto, ptsto_foot, atoms @ atoms') (** Check if the path in exp exists already in the current ptsto predicate. -If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *) + If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *) let prop_iter_check_fields_ptsto_shallow iter lexp = let offset = Sil.exp_get_offsets lexp in let (e, se, t) = @@ -447,12 +447,12 @@ let prop_iter_check_fields_ptsto_shallow iter lexp = | [] -> None | (Sil.Off_fld (fld, _)):: off' -> (match se with - | Sil.Estruct (fsel, _) -> - (try + | Sil.Estruct (fsel, _) -> + (try let _, se' = list_find (fun (fld', _) -> Sil.fld_equal fld fld') fsel in check_offset se' off' with Not_found -> Some fld) - | _ -> Some fld) + | _ -> Some fld) | (Sil.Off_index e):: off' -> None in check_offset se offset @@ -463,9 +463,9 @@ let fav_max_stamp fav = max_stamp (** [prop_iter_extend_ptsto iter lexp] extends the current psto -predicate in [iter] with enough fields to follow the path in -[lexp] -- field splitting model. It also materializes all -indices accessed in lexp. *) + predicate in [iter] with enough fields to follow the path in + [lexp] -- field splitting model. It also materializes all + indices accessed in lexp. *) let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = if !Config.trace_rearrange then (L.d_str "entering prop_iter_extend_ptsto lexp: "; Sil.d_exp lexp; L.d_ln ()); let offset = Sil.exp_get_offsets lexp in @@ -515,29 +515,29 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = if Ident.kind_equal extend_kind Ident.kprimed then iter_list (* normal part already extended: nothing to do *) else (* extend footprint part *) - let atoms_fp_sigma_list = - let footprint_sigma = Prop.prop_iter_get_footprint_sigma iter in - let sigma_pto, sigma_rest = - list_partition (function - | Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e' - | Sil.Hlseg (_, _, e1, e2, _) -> Sil.exp_equal e e1 - | Sil.Hdllseg (_, _, e_iF, e_oB, e_oF, e_iB, _) -> Sil.exp_equal e e_iF || Sil.exp_equal e e_iB - ) footprint_sigma in - let atoms_sigma_list = - match sigma_pto with - | [hpred] -> - let atoms_hpred_list = extend_footprint_pred hpred in - list_map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list - | _ -> - L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln(); - [([], footprint_sigma)] in - list_map (fun (atoms, sigma') -> (atoms, list_stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in - let iter_atoms_fp_sigma_list = - list_product iter_list atoms_fp_sigma_list in - list_map (fun (iter, (atoms, fp_sigma)) -> - let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in - Prop.prop_iter_replace_footprint_sigma iter' fp_sigma - ) iter_atoms_fp_sigma_list in + let atoms_fp_sigma_list = + let footprint_sigma = Prop.prop_iter_get_footprint_sigma iter in + let sigma_pto, sigma_rest = + list_partition (function + | Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e' + | Sil.Hlseg (_, _, e1, e2, _) -> Sil.exp_equal e e1 + | Sil.Hdllseg (_, _, e_iF, e_oB, e_oF, e_iB, _) -> Sil.exp_equal e e_iF || Sil.exp_equal e e_iB + ) footprint_sigma in + let atoms_sigma_list = + match sigma_pto with + | [hpred] -> + let atoms_hpred_list = extend_footprint_pred hpred in + list_map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list + | _ -> + L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln(); + [([], footprint_sigma)] in + list_map (fun (atoms, sigma') -> (atoms, list_stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in + let iter_atoms_fp_sigma_list = + list_product iter_list atoms_fp_sigma_list in + list_map (fun (iter, (atoms, fp_sigma)) -> + let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in + Prop.prop_iter_replace_footprint_sigma iter' fp_sigma + ) iter_atoms_fp_sigma_list in let res_prop_list = list_map Prop.prop_iter_to_prop res_iter_list in begin @@ -558,10 +558,10 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = end (** Add a pointsto for [root(lexp): typ] to the sigma and footprint of a -prop, if it's compatible with the allowed footprint -variables. Then, change it into a iterator. This function ensures -that [root(lexp): typ] is the current hpred of the iterator. typ -is the type of the root of lexp. *) + prop, if it's compatible with the allowed footprint + variables. Then, change it into a iterator. This function ensures + that [root(lexp): typ] is the current hpred of the iterator. typ + is the type of the root of lexp. *) let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst = let max_stamp = fav_max_stamp (Prop.prop_footprint_fav prop) in let ptsto, ptsto_foot, atoms = @@ -587,9 +587,9 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst = Prop.prop_iter_set_state iter offsets_default (** Add a pointsto for [root(lexp): typ] to the iterator and to the -footprint, if it's compatible with the allowed footprint -variables. This function ensures that [root(lexp): typ] is the -current hpred of the iterator. typ is the type of the root of lexp. *) + footprint, if it's compatible with the allowed footprint + variables. This function ensures that [root(lexp): typ] is the + current hpred of the iterator. typ is the type of the root of lexp. *) let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst = let max_stamp = fav_max_stamp (Prop.prop_iter_footprint_fav iter) in let ptsto, ptsto_foot, atoms = @@ -794,11 +794,11 @@ let type_at_offset texp off = | [], _ -> Some typ | (Sil.Off_fld (f, _)):: off', Sil.Tstruct (ftal, sftal, _, _, _, _, _) -> (try - let typ' = - (fun (x, y, z) -> y) - (list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in - strip_offset off' typ' - with Not_found -> None) + let typ' = + (fun (x, y, z) -> y) + (list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in + strip_offset off' typ' + with Not_found -> None) | (Sil.Off_index _):: off', Sil.Tarray (typ', _) -> strip_offset off' typ' | _ -> None in @@ -808,7 +808,7 @@ let type_at_offset texp off = | _ -> None (** Check that the size of a type coming from an instruction does not exceed the size of the type from the pointsto predicate -For example, that a pointer to int is not used to assign to a char *) + For example, that a pointer to int is not used to assign to a char *) let check_type_size pname prop texp off typ_from_instr = L.d_strln_color Orange "check_type_size"; L.d_str "off: "; Sil.d_offset_list off; L.d_ln (); @@ -831,14 +831,14 @@ let check_type_size pname prop texp off typ_from_instr = L.d_str "texp: "; Sil.d_texp_full texp; L.d_ln () (** Exposes lexp |->- from iter. In case that it is not possible to -* expose lexp |->-, this function prints an error message and -* faults. There are four things to note. First, typ is the type of the -* root of lexp. Second, prop should mean the same as iter. Third, the -* result [] means that the given input iter is inconsistent. This -* happens when the theorem prover can prove the inconsistency of prop, -* only after unrolling some predicates in prop. This function ensures -* that the theorem prover cannot prove the inconsistency of any of the -* new iters in the result. *) + * expose lexp |->-, this function prints an error message and + * faults. There are four things to note. First, typ is the type of the + * root of lexp. Second, prop should mean the same as iter. Third, the + * result [] means that the given input iter is inconsistent. This + * happens when the theorem prover can prove the inconsistency of prop, + * only after unrolling some predicates in prop. This function ensures + * that the theorem prover cannot prove the inconsistency of any of the + * new iters in the result. *) let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst: (Sil.offset list) Prop.prop_iter list = @@ -938,24 +938,24 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc = let ann_sig = Models.get_annotated_signature pdesc (Cfg.Procdesc.get_proc_name pdesc) in list_exists (fun hpred -> - match hpred with - | Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (exp, _), _) - when Sil.exp_equal exp deref_exp && Annotations.param_is_nullable pvar ann_sig -> - nullable_obj_str := Sil.pvar_to_string pvar; - true - | Sil.Hpointsto (_, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) -> - let is_nullable fld = - match Annotations.get_field_type_and_annotation fld typ with - | Some (_, annot) -> Annotations.ia_is_nullable annot - | _ -> false in - let is_strexp_pt_by_nullable_fld (fld, strexp) = - match strexp with - | Sil.Eexp (exp, _) when Sil.exp_equal exp deref_exp && is_nullable fld -> - nullable_obj_str := Ident.fieldname_to_string fld; - true - | _ -> false in - list_exists is_strexp_pt_by_nullable_fld flds - | _ -> false) + match hpred with + | Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (exp, _), _) + when Sil.exp_equal exp deref_exp && Annotations.param_is_nullable pvar ann_sig -> + nullable_obj_str := Sil.pvar_to_string pvar; + true + | Sil.Hpointsto (_, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) -> + let is_nullable fld = + match Annotations.get_field_type_and_annotation fld typ with + | Some (_, annot) -> Annotations.ia_is_nullable annot + | _ -> false in + let is_strexp_pt_by_nullable_fld (fld, strexp) = + match strexp with + | Sil.Eexp (exp, _) when Sil.exp_equal exp deref_exp && is_nullable fld -> + nullable_obj_str := Ident.fieldname_to_string fld; + true + | _ -> false in + list_exists is_strexp_pt_by_nullable_fld flds + | _ -> false) (Prop.get_sigma prop) in let root = Sil.root_of_lexp lexp in let is_deref_of_nullable = @@ -970,8 +970,8 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc = let rec fold_getters = function | [] -> None | getter:: tl -> match getter prop exp with - | Some _ as some_attr -> some_attr - | None -> fold_getters tl in + | Some _ as some_attr -> some_attr + | None -> fold_getters tl in fold_getters relevant_attributes_getters in let attribute_opt = match get_relevant_attributes root with | Some att -> Some att @@ -1024,8 +1024,8 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc = match e with | Sil.Var id -> (match (Errdesc.find_ident_assignment (State.get_node ()) id) with - | Some (_, e') -> e' - | None -> e) + | Some (_, e') -> e' + | None -> e) | _ -> e in let get_exp_called () = (* Exp called in the block's function call*) match State.get_instr () with @@ -1069,8 +1069,8 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc = end (** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. -It returns an iterator with [lexp |-> strexp: typ] as current predicate -and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) + It returns an iterator with [lexp |-> strexp: typ] as current predicate + and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) let rearrange pdesc tenv lexp typ prop loc : (Sil.offset list) Prop.prop_iter list = let nlexp = match Prop.exp_normalize_prop prop lexp with | Sil.BinOp(Sil.PlusPI, ep, e) -> (* array access with pointer arithmetic *) diff --git a/infer/src/backend/sil.ml b/infer/src/backend/sil.ml index c1bfc6925..a7ca5f921 100644 --- a/infer/src/backend/sil.ml +++ b/infer/src/backend/sil.ml @@ -304,9 +304,9 @@ module Subtype = struct try SubtypesMap.find (c1, c2) !subtMap with Not_found -> - let is_subt = f c1 c2 in - subtMap := (SubtypesMap.add (c1, c2) is_subt !subtMap); - is_subt + let is_subt = f c1 c2 in + subtMap := (SubtypesMap.add (c1, c2) is_subt !subtMap); + is_subt let flag_to_string flag = match flag with @@ -385,12 +385,12 @@ module Subtype = struct match st_opt with | Some st -> (match st with - | Exact, flag -> - let new_flag = update_flag c1 c2 flag flag' in - Some (Exact, new_flag) - | Subtypes t, flag -> - let new_flag = update_flag c1 c2 flag flag' in - Some (Subtypes t, new_flag)) + | Exact, flag -> + let new_flag = update_flag c1 c2 flag flag' in + Some (Exact, new_flag) + | Subtypes t, flag -> + let new_flag = update_flag c1 c2 flag flag' in + Some (Subtypes t, new_flag)) | None -> None let normalize_subtypes t_opt c1 c2 flag1 flag2 = @@ -398,9 +398,9 @@ module Subtype = struct match t_opt with | Some t -> (match t with - | Exact -> Some (t, new_flag) - | Subtypes l -> - Some (Subtypes (list_sort Mangled.compare l), new_flag)) + | Exact -> Some (t, new_flag) + | Subtypes l -> + Some (Subtypes (list_sort Mangled.compare l), new_flag)) | None -> None let subtypes_to_string t = @@ -417,9 +417,9 @@ module Subtype = struct f c1 c2 && not (Mangled.equal c1 c2) (* checks for redundancies when adding c to l - Xi in A - { X1,..., Xn } is redundant in two cases: - 1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A - 2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj *) + Xi in A - { X1,..., Xn } is redundant in two cases: + 1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A + 2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj *) let check_redundancies f c l = let aux (l, add) ci = let l, should_add = @@ -437,7 +437,7 @@ module Subtype = struct else (updates_head f c rest) (* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur - A - { X1,..., Xn } is inconsistent if A <: Xi for some i *) + A - { X1,..., Xn } is inconsistent if A <: Xi for some i *) let rec add_not_subtype f c1 l1 l2 = match l2 with | [] -> l1 @@ -494,10 +494,10 @@ module Subtype = struct (change_flag pos_st c1 c2 flag2), (change_flag neg_st c1 c2 flag2) (** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] according to [st1] and [st2] - where f c1 c2 is true if c1 is a subtype of c2. - get_subtypes returning a pair: - - whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1] - - whether [st1] and [st2] admit [not(c1 <: c2)], and in case return the updated subtype [st1] *) + where f c1 c2 is true if c1 is a subtype of c2. + get_subtypes returning a pair: + - whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1] + - whether [st1] and [st2] admit [not(c1 <: c2)], and in case return the updated subtype [st1] *) let case_analysis (c1, st1) (c2, st2) f is_interface = let f = check_subtype f in if (!Config.subtype_multirange) then @@ -651,7 +651,7 @@ type dexp = | Dretcall of dexp * dexp list * location * call_flags (** Value paths: identify an occurrence of a value in a symbolic heap -each expression represents a path, with Dpvar being the simplest one *) + each expression represents a path, with Dpvar being the simplest one *) and vpath = dexp option @@ -708,9 +708,9 @@ and typ = | Tptr of typ * ptr_kind (** pointer type *) | Tstruct of struct_fields * struct_fields * csu * Mangled.t option * (csu * Mangled.t) list * Procname.t list * item_annotation (** structure type with class/struct/union flag and name and list of superclasses *) (** Structure type with nonstatic and static fields, class/struct/union flag, name, list of superclasses, - methods defined, and annotations. - The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts - of C structs. *) + methods defined, and annotations. + The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts + of C structs. *) | Tarray of typ * exp (** array type with fixed size *) | Tenum of (Mangled.t * const) list @@ -753,7 +753,7 @@ type instr = | Prune of exp * location * bool * if_kind (** prune the state based on [exp=1], the boolean indicates whether true branch *) | Call of Ident.t list * exp * (exp * typ) list * location * call_flags (** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions - [ret_id1..ret_idn = e_fun(arg_ts);] where n = 0 for void return and n > 1 for struct return *) + [ret_id1..ret_idn = e_fun(arg_ts);] where n = 0 for void return and n > 1 for struct return *) | Nullify of pvar * location * bool (** nullify stack variable, the bool parameter indicates whether to deallocate the variable *) | Abstract of location (** apply abstraction *) | Remove_temps of Ident.t list * location (** remove temporaries *) @@ -810,31 +810,31 @@ type strexp = | Estruct of (Ident.fieldname * strexp) list * inst (** C structure *) | Earray of exp * (exp * strexp) list * inst (** Array of given size. *) (** There are two conditions imposed / used in the array case. -First, if some index and value pair appears inside an array -in a strexp, then the index is less than the size of the array. -For instance, x |->[10 | e1: v1] implies that e1 <= 9. -Second, if two indices appear in an array, they should be different. -For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) + First, if some index and value pair appears inside an array + in a strexp, then the index is less than the size of the array. + For instance, x |->[10 | e1: v1] implies that e1 <= 9. + Second, if two indices appear in an array, they should be different. + For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) (** an atomic heap predicate *) and hpred = | Hpointsto of exp * strexp * exp (** represents [exp|->strexp:typexp] where [typexp] - is an expression representing a type, e.h. [sizeof(t)]. *) + is an expression representing a type, e.h. [sizeof(t)]. *) | Hlseg of lseg_kind * hpara * exp * exp * exp list (** higher - order predicate for singly - linked lists. - Should ensure that exp1!= exp2 implies that exp1 is allocated. - This assumption is used in the rearrangement. The last [exp list] parameter - is used to denote the shared links by all the nodes in the list. *) + Should ensure that exp1!= exp2 implies that exp1 is allocated. + This assumption is used in the rearrangement. The last [exp list] parameter + is used to denote the shared links by all the nodes in the list. *) | Hdllseg of lseg_kind * hpara_dll * exp * exp * exp * exp * exp list -(** higher-order predicate for doubly-linked lists. *) + (** higher-order predicate for doubly-linked lists. *) (** parameter for the higher-order singly-linked list predicate. -Means "lambda (root,next,svars). Exists evars. body". -Assume that root, next, svars, evars are disjoint sets of -primed identifiers, and include all the free primed identifiers in body. -body should not contain any non - primed identifiers or program -variables (i.e. pvars). *) + Means "lambda (root,next,svars). Exists evars. body". + Assume that root, next, svars, evars are disjoint sets of + primed identifiers, and include all the free primed identifiers in body. + body should not contain any non - primed identifiers or program + variables (i.e. pvars). *) and hpara = { root: Ident.t; next: Ident.t; @@ -843,8 +843,8 @@ and hpara = body: hpred list } (** parameter for the higher-order doubly-linked list predicates. -Assume that all the free identifiers in body_dll should belong to -cell, blink, flink, svars_dll, evars_dll. *) + Assume that all the free identifiers in body_dll should belong to + cell, blink, flink, svars_dll, evars_dll. *) and hpara_dll = { cell: Ident.t; (** address cell *) blink: Ident.t; (** backward link *) @@ -892,8 +892,8 @@ let pvar_get_simplified_name pv = match string_split_character s '.' with | Some s1, s2 -> (match string_split_character s1 '.' with - | Some s3, s4 -> s4 ^ "." ^ s2 - | _ -> s) + | Some s3, s4 -> s4 ^ "." ^ s2 + | _ -> s) | _ -> s (** Check if the pvar is an abucted return var or param passed by ref *) @@ -1087,8 +1087,8 @@ let binop_compare o1 o2 = match o1, o2 with let binop_equal o1 o2 = binop_compare o1 o2 = 0 (** This function returns true if the operation is injective -wrt. each argument: op(e,-) and op(-, e) is injective for all e. -The return value false means "don't know". *) + wrt. each argument: op(e,-) and op(-, e) is injective for all e. + The return value false means "don't know". *) let binop_injective = function | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | _ -> false @@ -1099,9 +1099,9 @@ let binop_invertible = function | _ -> false (** This function inverts an injective binary operator -with respect to the first argument. It returns an expression [e'] such that -BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible, -the function raises an exception by calling "assert false". *) + with respect to the first argument. It returns an expression [e'] such that + BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible, + the function raises an exception by calling "assert false". *) let binop_invert bop e1 e2 = let inverted_bop = match bop with | PlusA -> MinusA @@ -1112,7 +1112,7 @@ let binop_invert bop e1 e2 = BinOp(inverted_bop, e2, e1) (** This function returns true if 0 is the right unit of [binop]. -The return value false means "don't know". *) + The return value false means "don't know". *) let binop_is_zero_runit = function | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | _ -> false @@ -1373,7 +1373,7 @@ and typ_compare t1 t2 = | Tarray _, _ -> -1 | _, Tarray _ -> 1 | Tenum l1, Tenum l2 -> - (* Here we take as result the first non-zero result when comparing their (constant,value) pair.*) + (* Here we take as result the first non-zero result when comparing their (constant,value) pair.*) let compare_pair (n1, e1) (n2, e2) = let n = Mangled.compare n1 n2 in if n <> 0 then n else const_compare e1 e2 in @@ -1661,10 +1661,10 @@ module TypMap = Map.Make(struct (** {2 Sets of expressions} *) module ExpSet = Set.Make - (struct - type t = exp - let compare = exp_compare - end) + (struct + type t = exp + let compare = exp_compare + end) module ExpMap = Map.Make(struct type t = exp @@ -1678,10 +1678,10 @@ let elist_to_eset es = (** {2 Sets of heap predicates} *) module HpredSet = Set.Make - (struct - type t = hpred - let compare = hpred_compare - end) + (struct + type t = hpred + let compare = hpred_compare + end) (** {2 Pretty Printing} *) @@ -2015,8 +2015,8 @@ and pp_const pe f = function | Cint i -> Int.pp f i | Cfun fn -> (match pe.pe_kind with - | PP_HTML -> F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn)) - | _ -> F.fprintf f "_fun_%s" (Procname.to_string fn)) + | PP_HTML -> F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn)) + | _ -> F.fprintf f "_fun_%s" (Procname.to_string fn)) | Cstr s -> F.fprintf f "\"%s\"" (String.escaped s) | Cfloat v -> F.fprintf f "%f" v | Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att) @@ -2030,8 +2030,8 @@ and pp_typ pe f te = if !Config.print_types then pp_typ_full pe f te else () (** Pretty print a type declaration. -pp_base prints the variable for a declaration, or can be skip to print only the type -pp_size prints the expression for the array size *) + pp_base prints the variable for a declaration, or can be skip to print only the type + pp_size prints the expression for the array size *) and pp_type_decl pe pp_base pp_size f = function | Tvar tname -> F.fprintf f "%s %a" (typename_to_string tname) pp_base () | Tint ik -> F.fprintf f "%s %a" (ikind_to_string ik) pp_base () @@ -2048,7 +2048,7 @@ and pp_type_decl pe pp_base pp_size f = function | Tstruct (ftal, sftal, csu, Some name, _, _, _) when false -> (* remove "when false" to print the details of struct *) F.fprintf f "%s %a {%a} %a" (csu_name csu) Mangled.pp name (pp_seq (fun f (fld, t, ann) -> - F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) + F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) ftal pp_base () | Tstruct (ftal, sftal, csu, Some name, _, _, _) -> F.fprintf f "%s %a %a" (csu_name csu) Mangled.pp name pp_base () @@ -2072,32 +2072,32 @@ and _pp_exp pe0 pp_t f e0 = | Some sub -> Obj.obj (sub (Obj.repr e0)) (* apply object substitution to expression *) | None -> e0 in (if not (exp_equal e0 e) - then - match e with - | Lvar pvar -> pp_pvar_value pe f pvar - | _ -> assert false - else - let pp_exp = _pp_exp pe pp_t in - let print_binop_stm_output e1 op e2 = - match op with - | Eq | Ne | PlusA | Mult -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1 - | Lt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1 - | Gt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1 - | Le -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1 - | Ge -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1 - | _ -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 in - begin match e with - | Var id -> (Ident.pp pe) f id - | Const c -> F.fprintf f "%a" (pp_const pe) c - | Cast (typ, e) -> F.fprintf f "(%a)%a" pp_t typ pp_exp e - | UnOp (op, e, _) -> F.fprintf f "%s%a" (str_unop op) pp_exp e - | BinOp (op, Const c, e2) when !Config.smt_output -> print_binop_stm_output (Const c) op e2 - | BinOp (op, e1, e2) -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 - | Lvar pv -> pp_pvar pe f pv - | Lfield (e, fld, typ) -> F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld - | Lindex (e1, e2) -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 - | Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s - end); + then + match e with + | Lvar pvar -> pp_pvar_value pe f pvar + | _ -> assert false + else + let pp_exp = _pp_exp pe pp_t in + let print_binop_stm_output e1 op e2 = + match op with + | Eq | Ne | PlusA | Mult -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1 + | Lt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1 + | Gt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1 + | Le -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1 + | Ge -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1 + | _ -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 in + begin match e with + | Var id -> (Ident.pp pe) f id + | Const c -> F.fprintf f "%a" (pp_const pe) c + | Cast (typ, e) -> F.fprintf f "(%a)%a" pp_t typ pp_exp e + | UnOp (op, e, _) -> F.fprintf f "%s%a" (str_unop op) pp_exp e + | BinOp (op, Const c, e2) when !Config.smt_output -> print_binop_stm_output (Const c) op e2 + | BinOp (op, e1, e2) -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 + | Lvar pv -> pp_pvar pe f pv + | Lfield (e, fld, typ) -> F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld + | Lindex (e1, e2) -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 + | Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s + end); color_post_wrapper changed pe0 f and pp_exp pe f e = @@ -2209,33 +2209,33 @@ let pp_call_flags f cf = let rec pp_instr pe0 f instr = let pe, changed = color_pre_wrapper pe0 f instr in (match instr with - | Letderef (id, e, t, loc) -> F.fprintf f "%a=*%a:%a %a" (Ident.pp pe) id (pp_exp pe) e (pp_typ pe) t pp_loc loc - | Set (e1, t, e2, loc) -> F.fprintf f "*%a:%a=%a %a" (pp_exp pe) e1 (pp_typ pe) t (pp_exp pe) e2 pp_loc loc - | Prune (cond, loc, true_branch, ik) -> - F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch pp_loc loc - | Call (ret_ids, e, arg_ts, loc, cf) -> - (match ret_ids with - | [] -> () - | _ -> F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids); - F.fprintf f "%a(%a)%a %a" (pp_exp pe) e (pp_comma_seq (pp_exp_typ pe)) (arg_ts) pp_call_flags cf pp_loc loc - | Nullify (pvar, loc, deallocate) -> - F.fprintf f "NULLIFY(%a,%b); %a" (pp_pvar pe) pvar deallocate pp_loc loc - | Abstract loc -> - F.fprintf f "APPLY_ABSTRACTION; %a" pp_loc loc - | Remove_temps (temps, loc) -> - F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps pp_loc loc - | Stackop (stackop, loc) -> - let s = match stackop with - | Push -> "Push" - | Swap -> "Swap" - | Pop -> "Pop" in - F.fprintf f "STACKOP.%s; %a" s pp_loc loc - | Declare_locals (ptl, loc) -> - (* let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a:%a" (pp_pvar pe) pvar (pp_typ_full pe) typ in *) - let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a" (pp_pvar pe) pvar in - F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl pp_loc loc - | Goto_node (e, loc) -> - F.fprintf f "Goto_node %a %a" (pp_exp pe) e pp_loc loc + | Letderef (id, e, t, loc) -> F.fprintf f "%a=*%a:%a %a" (Ident.pp pe) id (pp_exp pe) e (pp_typ pe) t pp_loc loc + | Set (e1, t, e2, loc) -> F.fprintf f "*%a:%a=%a %a" (pp_exp pe) e1 (pp_typ pe) t (pp_exp pe) e2 pp_loc loc + | Prune (cond, loc, true_branch, ik) -> + F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch pp_loc loc + | Call (ret_ids, e, arg_ts, loc, cf) -> + (match ret_ids with + | [] -> () + | _ -> F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids); + F.fprintf f "%a(%a)%a %a" (pp_exp pe) e (pp_comma_seq (pp_exp_typ pe)) (arg_ts) pp_call_flags cf pp_loc loc + | Nullify (pvar, loc, deallocate) -> + F.fprintf f "NULLIFY(%a,%b); %a" (pp_pvar pe) pvar deallocate pp_loc loc + | Abstract loc -> + F.fprintf f "APPLY_ABSTRACTION; %a" pp_loc loc + | Remove_temps (temps, loc) -> + F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps pp_loc loc + | Stackop (stackop, loc) -> + let s = match stackop with + | Push -> "Push" + | Swap -> "Swap" + | Pop -> "Pop" in + F.fprintf f "STACKOP.%s; %a" s pp_loc loc + | Declare_locals (ptl, loc) -> + (* let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a:%a" (pp_pvar pe) pvar (pp_typ_full pe) typ in *) + let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a" (pp_pvar pe) pvar in + F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl pp_loc loc + | Goto_node (e, loc) -> + F.fprintf f "Goto_node %a %a" (pp_exp pe) e pp_loc loc ); color_post_wrapper changed pe0 f @@ -2288,8 +2288,8 @@ and exp_iter_types f e = | UnOp (op, e1, typo) -> exp_iter_types f e1; (match typo with - | Some t -> typ_iter_types f t - | None -> ()) + | Some t -> typ_iter_types f t + | None -> ()) | BinOp (op, e1, e2) -> exp_iter_types f e1; exp_iter_types f e2 @@ -2346,26 +2346,26 @@ let pp_atom pe0 f a = begin match a with | Aeq (BinOp(op, e1, e2), Const (Cint i)) when Int.isone i -> (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) - | PP_LATEX -> - F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) + | PP_TEXT | PP_HTML -> + F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) + | PP_LATEX -> + F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) ) | Aeq (e1, e2) -> (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2 - | PP_LATEX -> - F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2) + | PP_TEXT | PP_HTML -> + F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2 + | PP_LATEX -> + F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2) | Aneq ((Const (Cattribute a) as ea), e) | Aneq (e, (Const (Cattribute a) as ea)) -> F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e | Aneq (e1, e2) -> (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2 - | PP_LATEX -> - F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2) + | PP_TEXT | PP_HTML -> + F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2 + | PP_LATEX -> + F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2) end; color_post_wrapper changed pe0 f @@ -2384,9 +2384,9 @@ let rec pp_star_seq pp f = function (********* START OF MODULE Predicates **********) (** Module Predicates records the occurrences of predicates as parameters -of (doubly -)linked lists and Epara. Provides unique numbering for predicates and an iterator. *) + of (doubly -)linked lists and Epara. Provides unique numbering for predicates and an iterator. *) module Predicates : sig -(** predicate environment *) + (** predicate environment *) type env (** create an empty predicate environment *) val empty_env : unit -> env @@ -2397,7 +2397,7 @@ module Predicates : sig (** return the id of the hpara_dll *) val get_hpara_dll_id : env -> hpara_dll -> int (** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, - passing the unique id to the functions. The iterator can only be used once. *) + passing the unique id to the functions. The iterator can only be used once. *) val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit (** Process one hpred, updating the predicate environment *) val process_hpred : env -> hpred -> unit @@ -2418,7 +2418,7 @@ end = struct end) (** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted, - also keep a list of hparas still to be emitted. Same for hpara_dll. *) + also keep a list of hparas still to be emitted. Same for hpara_dll. *) type env = { mutable num: int; @@ -2443,16 +2443,16 @@ end = struct let process_hpara env hpara = if not (HparaHash.mem env.hash hpara) then (HparaHash.add env.hash hpara (env.num, false); - env.num <- env.num + 1; - env.todo <- env.todo @ [hpara]) + env.num <- env.num + 1; + env.todo <- env.todo @ [hpara]) (** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *) let process_hpara_dll env hpara_dll = if not (HparaDllHash.mem env.hash_dll hpara_dll) then (HparaDllHash.add env.hash_dll hpara_dll (env.num, false); - env.num <- env.num + 1; - env.todo_dll <- env.todo_dll @ [hpara_dll]) + env.num <- env.num + 1; + env.todo_dll <- env.todo_dll @ [hpara_dll]) (** Process a sexp, updating env *) let rec process_sexp env = function @@ -2484,8 +2484,8 @@ end = struct } (** iterator for predicates which are marked as todo in env, unless they have been visited already. - This can in turn extend the todo list for the nested predicates, which are then visited as well. - Can be applied only once, as it destroys the todo list *) + This can in turn extend the todo list for the nested predicates, which are then visited as well. + Can be applied only once, as it destroys the todo list *) let iter (env: env) f f_dll = while env.todo != [] || env.todo_dll != [] do if env.todo != [] then @@ -2683,26 +2683,26 @@ and pp_hpred_env pe0 envo f hpred = { pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *) | _ -> pe in (match pe'.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a|->%a:%a" (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te - | PP_LATEX -> - F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se) + | PP_TEXT | PP_HTML -> + F.fprintf f "%a|->%a:%a" (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te + | PP_LATEX -> + F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se) | Hlseg (k, hpara, e1, e2, elist) -> (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "lseg%a(%a,%a,[%a],%a)" - pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara - | PP_LATEX -> - F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)" - pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara) + | PP_TEXT | PP_HTML -> + F.fprintf f "lseg%a(%a,%a,[%a],%a)" + pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara + | PP_LATEX -> + F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)" + pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara) | Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) -> (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" - pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll - | PP_LATEX -> - F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)" - pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll) + | PP_TEXT | PP_HTML -> + F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" + pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll + | PP_LATEX -> + F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)" + pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll) end; color_post_wrapper changed pe0 f @@ -2868,24 +2868,24 @@ let unsome_typ s = function assert false (** Turn an expression representing a type into the type it represents -If not a sizeof, return the default type if given, otherwise raise an exception *) + If not a sizeof, return the default type if given, otherwise raise an exception *) let texp_to_typ default_opt = function | Sizeof (t, _) -> t | t -> unsome_typ "texp_to_typ" default_opt (** If a struct type with field f, return the type of f. -If not, return the default type if given, otherwise raise an exception *) + If not, return the default type if given, otherwise raise an exception *) let struct_typ_fld default_opt f = let def () = unsome_typ "struct_typ_fld" default_opt in function | Tstruct (ftal, sftal, _, _, _, _, _) -> (try (fun (x, y, z) -> y) (list_find (fun (_f, t, ann) -> Ident.fieldname_equal _f f) ftal) - with Not_found -> def ()) + with Not_found -> def ()) | _ -> def () (** If an array type, return the type of the element. -If not, return the default type if given, otherwise raise an exception *) + If not, return the default type if given, otherwise raise an exception *) let array_typ_elem default_opt = function | Tarray (t_el, _) -> t_el | t -> @@ -2903,7 +2903,7 @@ let rec root_of_lexp lexp = match lexp with | Sizeof _ -> lexp (** Checks whether an expression denotes a location by pointer arithmetic. -Currently, catches array - indexing expressions such as a[i] only. *) + Currently, catches array - indexing expressions such as a[i] only. *) let rec exp_pointer_arith = function | Lfield (e, _, _) -> exp_pointer_arith e | Lindex _ -> true @@ -2999,9 +2999,9 @@ and hpred_fpv = function @ fpvars_in_elist (** hpara should not contain any program variables. -This is because it might cause problems when we do interprocedural -analysis. In interprocedural analysis, we should consider the issue -of scopes of program variables. *) + This is because it might cause problems when we do interprocedural + analysis. In interprocedural analysis, we should consider the issue + of scopes of program variables. *) and hpara_fpv para = let fpvars_in_body = list_flatten (list_map hpred_fpv para.body) in match fpvars_in_body with @@ -3009,9 +3009,9 @@ and hpara_fpv para = | _ -> assert false (** hpara_dll should not contain any program variables. -This is because it might cause problems when we do interprocedural -analysis. In interprocedural analysis, we should consider the issue -of scopes of program variables. *) + This is because it might cause problems when we do interprocedural + analysis. In interprocedural analysis, we should consider the issue + of scopes of program variables. *) and hpara_dll_fpv para = let fpvars_in_body = list_flatten (list_map hpred_fpv para.body_dll) in match fpvars_in_body with @@ -3069,7 +3069,7 @@ let rec remove_duplicates_from_sorted special_equal = function else x:: (remove_duplicates_from_sorted special_equal (y:: l)) (** Convert a [fav] to a list of identifiers while preserving the order -that the identifiers were added to [fav]. *) + that the identifiers were added to [fav]. *) let fav_to_list fav = list_rev !fav @@ -3107,7 +3107,7 @@ let rec ident_sorted_list_subset l1 l2 = else false (** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] -is in [fav2].*) + is in [fav2].*) let fav_subset_ident fav1 fav2 = ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2) @@ -3173,16 +3173,16 @@ let hpred_fav = fav_imperative_to_functional hpred_fav_add (** This function should be used before adding a new -index to Earray. The [exp] is the newly created -index. This function "cleans" [exp] according to whether it is the footprint or current part of the prop. -The function faults in the re - execution mode, as an internal check of the tool. *) + index to Earray. The [exp] is the newly created + index. This function "cleans" [exp] according to whether it is the footprint or current part of the prop. + The function faults in the re - execution mode, as an internal check of the tool. *) let array_clean_new_index footprint_part new_idx = if footprint_part && not !Config.footprint then assert false; let fav = exp_fav new_idx in if footprint_part && fav_exists fav (fun id -> not (Ident.is_footprint id)) then begin L.d_warning ("Array index " ^ (exp_to_string new_idx) ^ - " has non-footprint vars: replaced by fresh footprint var"); + " has non-footprint vars: replaced by fresh footprint var"); L.d_ln (); let id = Ident.create_fresh Ident.kfootprint in Var id @@ -3288,8 +3288,8 @@ let sub_check_inv sub = (sub_check_sortedness sub) && not (sub_check_duplicated_ids sub) (** Create a substitution from a list of pairs. -For all (id1, e1), (id2, e2) in the input list, -if id1 = id2, then e1 = e2. *) + For all (id1, e1), (id2, e2) in the input list, + if id1 = id2, then e1 = e2. *) let sub_of_list sub = let sub' = list_sort ident_exp_compare sub in let sub'' = remove_duplicates_from_sorted ident_exp_equal sub' in @@ -3315,7 +3315,7 @@ let sub_to_list sub = let sub_empty = sub_of_list [] (** Join two substitutions into one. -For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *) + For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *) let sub_join sub1 sub2 = let sub = sorted_list_merge ident_exp_compare sub1 sub2 in let sub' = remove_duplicates_from_sorted ident_exp_equal sub in @@ -3323,9 +3323,9 @@ let sub_join sub1 sub2 = sub (** Compute the common id-exp part of two inputs [subst1] and [subst2]. -The first component of the output is this common part. -The second and third components are the remainder of [subst1] -and [subst2], respectively. *) + The first component of the output is this common part. + The second and third components are the remainder of [subst1] + and [subst2], respectively. *) let sub_symmetric_difference sub1_in sub2_in = let rec diff sub_common sub1_only sub2_only sub1 sub2 = match sub1, sub2 with @@ -3353,21 +3353,21 @@ let sub_find filter (sub: subst) = snd (list_find (fun (i, _) -> filter i) sub) (** [sub_filter filter sub] restricts the domain of [sub] to the -identifiers satisfying [filter]. *) + identifiers satisfying [filter]. *) let sub_filter filter (sub: subst) = list_filter (fun (i, _) -> filter i) sub (** [sub_filter_pair filter sub] restricts the domain of [sub] to the -identifiers satisfying [filter(id, sub(id))]. *) + identifiers satisfying [filter(id, sub(id))]. *) let sub_filter_pair = list_filter (** [sub_range_partition filter sub] partitions [sub] according to -whether range expressions satisfy [filter]. *) + whether range expressions satisfy [filter]. *) let sub_range_partition filter (sub: subst) = list_partition (fun (_, e) -> filter e) sub (** [sub_domain_partition filter sub] partitions [sub] according to -whether domain identifiers satisfy [filter]. *) + whether domain identifiers satisfy [filter]. *) let sub_domain_partition filter (sub: subst) = list_partition (fun (i, _) -> filter i) sub @@ -3384,7 +3384,7 @@ let sub_range_map f sub = sub_of_list (list_map (fun (i, e) -> (i, f e)) sub) (** [sub_map f g sub] applies the renaming [f] to identifiers in the domain -of [sub] and the substitution [g] to the expressions in the range of [sub]. *) + of [sub] and the substitution [g] to the expressions in the range of [sub]. *) let sub_map f g sub = sub_of_list (list_map (fun (i, e) -> (f i, g e)) sub) @@ -3398,7 +3398,7 @@ let extend_sub sub id exp : subst option = else Some (sorted_list_merge compare sub [(id, exp)]) (** Free auxilary variables in the domain and range of the -substitution. *) + substitution. *) let sub_fav_add fav (sub: subst) = list_iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub @@ -3765,8 +3765,8 @@ let tenv_fold f tenv = let pp_tenv f (tenv : tenv) = TypenameHash.iter (fun name typ -> - Format.fprintf f "@[<6>NAME: %s@." (typename_to_string name); - Format.fprintf f "@[<6>TYPE: %a@." (pp_typ_full pe_text) typ) + Format.fprintf f "@[<6>NAME: %s@." (typename_to_string name); + Format.fprintf f "@[<6>TYPE: %a@." (pp_typ_full pe_text) typ) tenv (** {2 Functions for constructing or destructing entities in this module} *) @@ -3840,9 +3840,9 @@ let sigma_to_sigma_ne sigma : (atom list * hpred list) list = [([], sigma)] (** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], -[e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], -then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] -for some fresh [_zs'].*) + [e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], + then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] + for some fresh [_zs'].*) let hpara_instantiate para e1 e2 elist = let subst_for_svars = let g id e = (id, e) in @@ -3859,9 +3859,9 @@ let hpara_instantiate para e1 e2 elist = (ids_evars, list_map (hpred_sub subst) para.body) (** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], -[blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], -then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] -for some fresh [_zs'].*) + [blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], + then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] + for some fresh [_zs'].*) let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist = let subst_for_svars = let g id e = (id, e) in @@ -3882,7 +3882,7 @@ let rec strexp_get_target_exps = function | Eexp (e, inst) -> [e] | Estruct (fsel, inst) -> list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) fsel) | Earray (_, esel, _) -> - (* We ignore size and indices since they are not quite outgoing arrows. *) + (* We ignore size and indices since they are not quite outgoing arrows. *) list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) esel) let global_error = diff --git a/infer/src/backend/specs.ml b/infer/src/backend/specs.ml index 2dc8adae6..fb93a67f0 100644 --- a/infer/src/backend/specs.ml +++ b/infer/src/backend/specs.ml @@ -120,15 +120,15 @@ module Jprop = struct | [] -> acc | (Prop (_, p) as jp) :: jpl -> (match f jp with - | Some x -> - do_filter (x:: acc) jpl - | None -> do_filter acc jpl) + | Some x -> + do_filter (x:: acc) jpl + | None -> do_filter acc jpl) | (Joined (_, p, jp1, jp2) as jp) :: jpl -> (match f jp with - | Some x -> - do_filter (x:: acc) jpl - | None -> - do_filter acc (jpl @ [jp1; jp2])) in + | Some x -> + do_filter (x:: acc) jpl + | None -> + do_filter acc (jpl @ [jp1; jp2])) in do_filter [] jpl let rec map (f : 'a Prop.t -> 'b Prop.t) = function @@ -148,20 +148,20 @@ let visited_str vis = let lines = ref IntSet.empty in let do_one (node, ns) = (* if list_length ns > 1 then - begin - let ss = ref "" in - list_iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns; - L.err "Node %d has lines %s@." node !ss - end; *) + begin + let ss = ref "" in + list_iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns; + L.err "Node %d has lines %s@." node !ss + end; *) list_iter (fun n -> lines := IntSet.add n !lines) ns in Visitedset.iter do_one vis; IntSet.iter (fun n -> s := !s ^ " " ^ string_of_int n) !lines; !s (** A spec consists of: -pre: a joined prop -post: a list of props with path -visited: a list of pairs (node_id, line) for the visited nodes *) + pre: a joined prop + post: a list of props with path + visited: a list of pairs (node_id, line) for the visited nodes *) type 'a spec = { pre: 'a Jprop.t; posts: ('a Prop.t * Paths.Path.t) list; visited : Visitedset.t } module NormSpec : sig (* encapsulate type for normalized specs *) @@ -407,10 +407,10 @@ let describe_phase summary = let get_signature summary = let s = ref "" in list_iter (fun (p, typ) -> - let pp_name f () = F.fprintf f "%s" p in - let pp f () = Sil.pp_type_decl pe_text pp_name Sil.pp_exp f typ in - let decl = pp_to_string pp () in - s := if !s = "" then decl else !s ^ ", " ^ decl) summary.formals; + let pp_name f () = F.fprintf f "%s" p in + let pp f () = Sil.pp_type_decl pe_text pp_name Sil.pp_exp f typ in + let decl = pp_to_string pp () in + s := if !s = "" then decl else !s ^ ", " ^ decl) summary.formals; let pp_procname f () = F.fprintf f "%a" Procname.pp summary.proc_name in let pp f () = Sil.pp_type_decl pe_text pp_procname Sil.pp_exp f summary.ret_type in let decl = pp_to_string pp () in @@ -462,8 +462,8 @@ let empty_stats err_log calls cyclomatic in_out_calls_opt = stats_timeout = false; stats_calls = (match in_out_calls_opt with - | Some in_out_calls -> in_out_calls - | None -> { Cg.in_calls = 0; Cg.out_calls = 0 }); + | Some in_out_calls -> in_out_calls + | None -> { Cg.in_calls = 0; Cg.out_calls = 0 }); symops = 0; err_log = err_log; nodes_visited_fp = IntSet.empty; @@ -570,9 +570,9 @@ let load_summary_to_spec_table proc_name = | [] -> false | spec_path :: spec_paths -> (match load_summary spec_path with - | None -> load_summary_libs spec_paths - | Some summ -> - add summ Spec_lib) in + | None -> load_summary_libs spec_paths + | Some summ -> + add summ Spec_lib) in let rec load_summary_ziplibs zip_libraries = (* try to load the summary from a list of zip libraries *) let zip_specs_filename = specs_filename proc_name in let zip_specs_path = @@ -591,7 +591,7 @@ let load_summary_to_spec_table proc_name = let default_spec_dir = res_dir_specs_filename proc_name in match load_summary default_spec_dir with | None -> - (* search on models, libzips, and libs *) + (* search on models, libzips, and libs *) if load_summary_models (specs_models_filename proc_name) then true else if load_summary_ziplibs !Config.zip_libraries then true else load_summary_libs (specs_library_filenames proc_name) @@ -603,9 +603,9 @@ let rec get_summary_origin proc_name = try Some (Procname.Hash.find spec_tbl proc_name) with Not_found -> - if load_summary_to_spec_table proc_name then - get_summary_origin proc_name - else None + if load_summary_to_spec_table proc_name then + get_summary_origin proc_name + else None let get_summary proc_name = match get_summary_origin proc_name with @@ -619,7 +619,7 @@ let get_summary_unsafe proc_name = | Some summary -> summary (** Check if the procedure is from a library: -It's not defined in the current proc desc, and there is no spec file for it. *) + It's not defined in the current proc desc, and there is no spec file for it. *) let proc_is_library proc_name proc_desc = let defined = Cfg.Procdesc.is_defined proc_desc in if not defined then @@ -688,7 +688,7 @@ let get_flag proc_name key = with Not_found -> None (** Get the iterations associated to the procedure if any, or the default timeout from the -command line *) + command line *) let get_iterations proc_name = match get_summary proc_name with | None -> @@ -735,7 +735,7 @@ let re_initialize_dependency_map dependency_map = Procname.Map.map (fun dep_proc -> - 1) dependency_map (** Update the dependency map of [proc_name] with the current -timestamps of the dependents *) + timestamps of the dependents *) let update_dependency_map proc_name = match get_summary_origin proc_name with | None -> @@ -749,12 +749,12 @@ let update_dependency_map proc_name = set_summary_origin proc_name { summary with dependency_map = current_dependency_map } origin (** [init_summary loc (proc_name, ret_type, formals, depend_list, loc, nodes, -proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, proc_attributes)] -initializes the summary for [proc_name] given dependent procs in list [depend_list]. *) + proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, proc_attributes)] + initializes the summary for [proc_name] given dependent procs in list [depend_list]. *) let init_summary (proc_name, ret_type, formals, depend_list, loc, - nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, - proc_attributes) = + nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, + proc_attributes) = let dependency_map = mk_initial_dependency_map depend_list in let summary = { @@ -790,19 +790,19 @@ let reset_summary call_graph proc_name loc = Sil.is_generated = false; } in init_summary ( - proc_name, - Sil.Tvoid, - [], - Procname.Set.elements - dependents, - loc, - [], - proc_flags_empty (), - Errlog.empty (), - [], - 0, - Some (Cg.get_calls call_graph proc_name), - proc_attributes - ) + proc_name, + Sil.Tvoid, + [], + Procname.Set.elements + dependents, + loc, + [], + proc_flags_empty (), + Errlog.empty (), + [], + 0, + Some (Cg.get_calls call_graph proc_name), + proc_attributes + ) (* =============== END of support for spec tables =============== *) diff --git a/infer/src/backend/state.ml b/infer/src/backend/state.ml index 39476f25d..15ce5ec27 100644 --- a/infer/src/backend/state.ml +++ b/infer/src/backend/state.ml @@ -51,8 +51,8 @@ type failure_stats = { mutable node_fail: int; (* number of node failures (i.e. at least one instruction failure) *) mutable node_ok: int; (* number of node successes (i.e. no instruction failures) *) mutable first_failure : - (Sil.location * (int * int) * int * Errlog.loc_trace * - (Prop.normal Prop.t) option * exn) option (* exception at the first failure *) + (Sil.location * (int * int) * int * Errlog.loc_trace * + (Prop.normal Prop.t) option * exn) option (* exception at the first failure *) } module NodeHash = Cfg.NodeHash @@ -63,9 +63,9 @@ let failure_map : failure_stats NodeHash.t = NodeHash.create 1 let get_failure_stats node = try NodeHash.find failure_map node with Not_found -> - let fs = { instr_fail = 0; instr_ok = 0; node_fail = 0; node_ok = 0; first_failure = None } in - NodeHash.add failure_map node fs; - fs + let fs = { instr_fail = 0; instr_ok = 0; node_fail = 0; node_ok = 0; first_failure = None } in + NodeHash.add failure_map node fs; + fs let add_diverging_states pset = diverging_states_proc := Paths.PathSet.union pset !diverging_states_proc; @@ -137,8 +137,8 @@ let instrs_normalize instrs = list_map (Sil.instr_sub subst) instrs (** Create a function to find duplicate nodes. -A node is a duplicate of another one if they have the same kind and location -and normalized (w.r.t. renaming of let - bound ids) list of instructions. *) + A node is a duplicate of another one if they have the same kind and location + and normalized (w.r.t. renaming of let - bound ids) list of instructions. *) let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) = let module M = (* map from (loc,kind) *) Map.Make(struct @@ -182,7 +182,7 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) = list_iter do_node nodes; !m with E.Threshold -> - M.empty in + M.empty in let find_duplicate_nodes node = try @@ -238,7 +238,7 @@ let extract_pre p tenv pdesc abstract_fun = Prop.normalize (Prop.prop_sub sub pre') (** return the normalized precondition extracted form the last prop seen, if any -the abstraction function is a parameter to get around module dependencies *) + the abstraction function is a parameter to get around module dependencies *) let get_normalized_pre (abstract_fun : Sil.tenv -> Prop.normal Prop.t -> Prop.normal Prop.t) : Prop.normal Prop.t option = match get_prop_tenv_pdesc () with | None -> None diff --git a/infer/src/backend/symExec.ml b/infer/src/backend/symExec.ml index 12169771d..124ea6ae6 100644 --- a/infer/src/backend/symExec.ml +++ b/infer/src/backend/symExec.ml @@ -46,10 +46,10 @@ let rec unroll_type tenv typ off = begin try fldlist_assoc fld ftal with Not_found -> - L.d_strln ".... Invalid Field Access ...."; - L.d_strln ("Fld : " ^ Ident.fieldname_to_string fld); - L.d_str "Type : "; Sil.d_typ_full typ; L.d_ln (); - raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) + L.d_strln ".... Invalid Field Access ...."; + L.d_strln ("Fld : " ^ Ident.fieldname_to_string fld); + L.d_str "Type : "; Sil.d_typ_full typ; L.d_ln (); + raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) end | Sil.Tarray (typ', _), Sil.Off_index _ -> typ' @@ -73,8 +73,8 @@ let list_split equal x xys = (* Given a node, returns a list of pvar of blocks that have been nullified in the block *) let get_nullified_block node = let null_blocks = list_flatten(list_map (fun i -> match i with - | Sil.Nullify(pvar, _, true) when Sil.is_block_pvar pvar -> [pvar] - | _ -> []) (Cfg.Node.get_instrs node)) in + | Sil.Nullify(pvar, _, true) when Sil.is_block_pvar pvar -> [pvar] + | _ -> []) (Cfg.Node.get_instrs node)) in null_blocks (* Given a proposition and an objc block checks whether by existentially quantifying *) @@ -90,19 +90,19 @@ let check_block_retain_cycle cfg tenv pname _prop block_nullified = () (** Apply function [f] to the expression at position [offlist] in [strexp]. -If not found, expand [strexp] and apply [f] to [None]. -The routine should maintain the invariant that strexp and typ correspond to -each other exactly, without involving any re - interpretation of some type t -as the t array. The [fp_root] parameter indicates whether the kind of the -root expression of the corresponding pointsto predicate is a footprint identifier. -The function can expand a list of higher - order [hpara_psto] predicates, if -the list is stored at [offlist] in [strexp] initially. The expanded list -is returned as a part of the result. All these happen under [p], so that it -is sound to call the prover with [p]. Finally, before running this function, -the tool should run strexp_extend_value in rearrange.ml for the same strexp -and offlist, so that all the necessary extensions of strexp are done before -this function. If the tool follows this protocol, it will never hit the assert -false cases for field and array accesses. *) + If not found, expand [strexp] and apply [f] to [None]. + The routine should maintain the invariant that strexp and typ correspond to + each other exactly, without involving any re - interpretation of some type t + as the t array. The [fp_root] parameter indicates whether the kind of the + root expression of the corresponding pointsto predicate is a footprint identifier. + The function can expand a list of higher - order [hpara_psto] predicates, if + the list is stored at [offlist] in [strexp] initially. The expanded list + is returned as a part of the result. All these happen under [p], so that it + is sound to call the prover with [p]. Finally, before running this function, + the tool should run strexp_extend_value in rearrange.ml for the same strexp + and offlist, so that all the necessary extensions of strexp are done before + this function. If the tool follows this protocol, it will never hit the assert + false cases for field and array accesses. *) let rec apply_offlist footprint_part pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist (f: Sil.exp option -> Sil.exp) inst lookup_inst = @@ -177,10 +177,10 @@ let rec apply_offlist let res_t = Sil.Tstruct (list_map replace_fta ftal, sftal, csu, nameo, supers, def_mthds, iann) in (res_e', res_se, res_t, res_pred_insts_op') with Not_found -> - pp_error(); - assert false - (* This case should not happen. The rearrangement should - have materialized all the accessed cells. *) + pp_error(); + assert false + (* This case should not happen. The rearrangement should + have materialized all the accessed cells. *) end | (Sil.Off_fld _):: _, _ -> pp_error(); @@ -202,28 +202,28 @@ let rec apply_offlist let res_t = Sil.Tarray(res_t', size') in (res_e', res_se, res_t, res_pred_insts_op') with Not_found -> (* return a nondeterministic value if the index is not found after rearrangement *) - L.d_str "apply_offlist: index "; Sil.d_exp idx; L.d_strln " not materialized -- returning nondeterministic value"; - let res_e' = Sil.Var (Ident.create_fresh Ident.kprimed) in - (res_e', strexp, typ, None) + L.d_str "apply_offlist: index "; Sil.d_exp idx; L.d_strln " not materialized -- returning nondeterministic value"; + let res_e' = Sil.Var (Ident.create_fresh Ident.kprimed) in + (res_e', strexp, typ, None) end | (Sil.Off_index idx):: offlist', _ -> pp_error(); raise (Exceptions.Internal_error (Localise.verbatim_desc "Array out of bounds in Symexec")) (* This case should not happen. The rearrangement should -have materialized all the accessed cells. *) + have materialized all the accessed cells. *) (** Given [lexp |-> se: typ], if the location [offlist] exists in [se], -function [ptsto_lookup p (lexp, se, typ) offlist id] returns a tuple. -The first component of the tuple is an expression at position [offlist] in [se]. -The second component is an expansion of the predicate [lexp |-> se: typ], -where the entity at [offlist] in [se] is expanded if the entity is a list of -higher - order parameters [hpara_psto]. If this expansion happens, -the last component of the tuple is a list of pi - sigma pairs obtained -by instantiating the [hpara_psto] list. Otherwise, the last component is None. -All these steps happen under [p]. So, we can call a prover with [p]. -Finally, before running this function, the tool should run strexp_extend_value -in rearrange.ml for the same se and offlist, so that all the necessary -extensions of se are done before this function. *) + function [ptsto_lookup p (lexp, se, typ) offlist id] returns a tuple. + The first component of the tuple is an expression at position [offlist] in [se]. + The second component is an expansion of the predicate [lexp |-> se: typ], + where the entity at [offlist] in [se] is expanded if the entity is a list of + higher - order parameters [hpara_psto]. If this expansion happens, + the last component of the tuple is a list of pi - sigma pairs obtained + by instantiating the [hpara_psto] list. Otherwise, the last component is None. + All these steps happen under [p]. So, we can call a prover with [p]. + Finally, before running this function, the tool should run strexp_extend_value + in rearrange.ml for the same se and offlist, so that all the necessary + extensions of se are done before this function. *) let ptsto_lookup footprint_part pdesc tenv p (lexp, se, typ, st) offlist id = let f = function Some exp -> exp | None -> Sil.Var id in @@ -242,16 +242,16 @@ let ptsto_lookup footprint_part pdesc tenv p (lexp, se, typ, st) offlist id = (e', ptsto', pred_insts_op', lookup_uninitialized) (** [ptsto_update p (lexp,se,typ) offlist exp] takes -[lexp |-> se: typ], and updates [se] by replacing the -expression at [offlist] with [exp]. Then, it returns -the updated pointsto predicate. If [lexp |-> se: typ] gets -expanded during this update, the generated pi - sigma list from -the expansion gets returned, and otherwise, None is returned. -All these happen under the proposition [p], so it is ok call -prover with [p]. Finally, before running this function, -the tool should run strexp_extend_value in rearrange.ml for the same -se and offlist, so that all the necessary extensions of se are done -before this function. *) + [lexp |-> se: typ], and updates [se] by replacing the + expression at [offlist] with [exp]. Then, it returns + the updated pointsto predicate. If [lexp |-> se: typ] gets + expanded during this update, the generated pi - sigma list from + the expansion gets returned, and otherwise, None is returned. + All these happen under the proposition [p], so it is ok call + prover with [p]. Finally, before running this function, + the tool should run strexp_extend_value in rearrange.ml for the same + se and offlist, so that all the necessary extensions of se are done + before this function. *) let ptsto_update footprint_part pdesc tenv p (lexp, se, typ, st) offlist exp = let f _ = exp in let fp_root = @@ -298,9 +298,9 @@ let execute_letderef pdesc tenv id rhs_exp acc_in iter = Errdesc.warning_err (State.get_loc ()) "no offset access in execute_letderef -- treating as skip@."; (Prop.prop_iter_to_prop iter_ren) :: acc_in (* The implementation of this case means that we - ignore this dereferencing operator. When the analyzer treats - numerical information and arrays more precisely later, we - should change the implementation here. *) + ignore this dereferencing operator. When the analyzer treats + numerical information and arrays more precisely later, we + should change the implementation here. *) | _ -> assert false @@ -343,8 +343,8 @@ module Builtin = struct let get_sym_exe_builtin name : sym_exe_builtin = try Procname.Hash.find builtin_functions name with Not_found -> - try Hashtbl.find builtin_plain_functions (Procname.to_string name) - with Not_found -> assert false + try Hashtbl.find builtin_plain_functions (Procname.to_string name) + with Not_found -> assert false (* register a builtin function name and symbolic execution handler *) let register proc_name_str (sym_exe_fun: sym_exe_builtin) = @@ -386,7 +386,7 @@ let print_builtins () = let function_is_builtin = Builtin.is_registered (** Precondition: se should not include hpara_psto -that could mean nonempty heaps. *) + that could mean nonempty heaps. *) let rec execute_nullify_se = function | Sil.Eexp _ -> Sil.Eexp (Sil.exp_zero, Sil.inst_nullify) @@ -398,7 +398,7 @@ let rec execute_nullify_se = function Sil.Earray (size, esel', Sil.inst_nullify) (** Do pruning for conditional [if (e1 != e2) ] if [positive] is true -and [(if (e1 == e2)] if [positive] is false *) + and [(if (e1 == e2)] if [positive] is false *) let prune_ne tenv positive e1 e2 prop = let is_inconsistent = if positive then Prover.check_equal prop e1 e2 @@ -436,7 +436,7 @@ let rec prune_polarity tenv positive (condition : Sil.exp) (prop : Prop.normal P | Sil.BinOp (Sil.Ne, e1, e2) -> prune_ne tenv positive e1 e2 prop | Sil.BinOp (Sil.Ge, e2, e1) | Sil.BinOp (Sil.Le, e1, e2) -> - (* e1<=e2 Case. Encode it as (e1<=e2)=1 *) + (* e1<=e2 Case. Encode it as (e1<=e2)=1 *) if Sil.exp_equal e1 e2 then if positive then Propset.singleton prop else Propset.empty else @@ -456,7 +456,7 @@ let rec prune_polarity tenv positive (condition : Sil.exp) (prop : Prop.normal P (Prop.conjoin_eq ~footprint: (!Config.footprint) e2_lt_e1 Sil.exp_one prop) end | Sil.BinOp (Sil.Gt, e2, e1) | Sil.BinOp (Sil.Lt, e1, e2) -> - (* e1 < e2 Case. Encode it as (e1 Sil.exp_equal e lhs - | _ -> false) (Prop.get_sigma prop)) + | Sil.Hpointsto (e, _, _) -> Sil.exp_equal e lhs + | _ -> false) (Prop.get_sigma prop)) with Not_found -> None in let rec is_check_zero = function | Sil.Var id -> @@ -598,11 +598,11 @@ let check_already_dereferenced pname cond prop = let dereferenced_line = match is_check_zero cond with | Some id -> (match find_hpred (Prop.exp_normalize_prop prop (Sil.Var id)) with - | Some (Sil.Hpointsto (_, se, _)) -> - (match Tabulation.find_dereference_without_null_check_in_sexp se with - | Some n -> Some (id, n) - | None -> None) - | _ -> None) + | Some (Sil.Hpointsto (_, se, _)) -> + (match Tabulation.find_dereference_without_null_check_in_sexp se with + | Some n -> Some (id, n) + | None -> None) + | _ -> None) | None -> None in match dereferenced_line with @@ -642,26 +642,26 @@ let proc_desc_copy cfg pdesc pname pname' = if (Procname.equal pname pname') then pdesc else (match Cfg.Procdesc.find_from_name cfg pname' with - | Some pdesc' -> pdesc' - | None -> - let open Cfg.Procdesc in - create { - cfg = cfg; - name = pname'; - proc_attributes = Sil.copy_proc_attributes (get_attributes pdesc); - is_defined = is_defined pdesc; - ret_type = get_ret_type pdesc; - formals = get_formals pdesc; - locals = get_locals pdesc; - captured = get_captured pdesc; - loc = get_loc pdesc; - }) + | Some pdesc' -> pdesc' + | None -> + let open Cfg.Procdesc in + create { + cfg = cfg; + name = pname'; + proc_attributes = Sil.copy_proc_attributes (get_attributes pdesc); + is_defined = is_defined pdesc; + ret_type = get_ret_type pdesc; + formals = get_formals pdesc; + locals = get_locals pdesc; + captured = get_captured pdesc; + loc = get_loc pdesc; + }) let method_exists right_proc_name methods = if !Sil.curr_language = Sil.Java then list_exists (fun meth_name -> Procname.equal right_proc_name meth_name) methods else (* ObjC case *) - Specs.summary_exists right_proc_name + Specs.summary_exists right_proc_name let resolve_method tenv class_name proc_name = @@ -680,11 +680,11 @@ let resolve_method tenv class_name proc_name = Some right_proc_name else (match super_classes with - | (Sil.Class, super_class):: interfaces -> - if not (Mangled.MangledSet.mem super_class !visited) - then resolve super_class - else None - | _ -> None) + | (Sil.Class, super_class):: interfaces -> + if not (Mangled.MangledSet.mem super_class !visited) + then resolve super_class + else None + | _ -> None) | _ -> None in resolve class_name in match found_class with @@ -709,7 +709,7 @@ let resolve_typename prop arg = (** If the dynamic type of the object calling a method is known, the method from the dynamic type -is called *) + is called *) let resolve_virtual_pname cfg tenv prop args pname : Procname.t = match args with | [] -> failwith "Expecting the first parameter to be the object expression" @@ -776,16 +776,16 @@ let call_constructor_url_update_args tenv cfg pname actual_params = let url_pname = Procname.mangled_java ((Some "java.net"), "URL") None "" [(Some "java.lang"), "String"] Procname.Non_Static in if (Procname.equal url_pname pname) then (match actual_params with - | [this; (Sil.Const (Sil.Cstr s), atype)] -> - let parts = Str.split (Str.regexp_string "://") s in - (match parts with - | frst:: parts -> - if (frst = "http") || (frst = "ftp") || (frst = "https") || (frst = "mailto") || (frst = "jar") then - [this; (Sil.Const (Sil.Cstr frst), atype)] - else actual_params - | _ -> actual_params) - | [this; _, atype] -> [this; (Sil.Const (Sil.Cstr "file"), atype)] - | _ -> actual_params) + | [this; (Sil.Const (Sil.Cstr s), atype)] -> + let parts = Str.split (Str.regexp_string "://") s in + (match parts with + | frst:: parts -> + if (frst = "http") || (frst = "ftp") || (frst = "https") || (frst = "mailto") || (frst = "jar") then + [this; (Sil.Const (Sil.Cstr frst), atype)] + else actual_params + | _ -> actual_params) + | [this; _, atype] -> [this; (Sil.Const (Sil.Cstr "file"), atype)] + | _ -> actual_params) else actual_params (** Handles certain method calls in a special way *) @@ -799,16 +799,16 @@ let handle_special_cases_call tenv cfg pname actual_params = let handle_objc_method_call actual_pars actual_params pre tenv cfg ret_ids pdesc callee_pname loc path = let receiver_self receiver prop = list_exists (fun hpred -> - match hpred with - | Sil.Hpointsto (Sil.Lvar pv, Sil.Eexp (e, _), _) -> - Sil.exp_equal e receiver && Sil.pvar_is_seed pv && - Sil.pvar_get_name pv = Mangled.from_string "self" - | _ -> false) (Prop.get_sigma prop) in + match hpred with + | Sil.Hpointsto (Sil.Lvar pv, Sil.Eexp (e, _), _) -> + Sil.exp_equal e receiver && Sil.pvar_is_seed pv && + Sil.pvar_get_name pv = Mangled.from_string "self" + | _ -> false) (Prop.get_sigma prop) in let path_description = "Message "^(Procname.to_simplified_string callee_pname)^" with receiver nil returns nil." in let receiver = (match actual_pars with | (e, _):: _ -> e | _ -> raise (Exceptions.Internal_error - (Localise.verbatim_desc "In Objective-C instance method call there should be a receiver."))) in + (Localise.verbatim_desc "In Objective-C instance method call there should be a receiver."))) in let is_receiver_null = match actual_pars with | (e, _):: _ when Sil.exp_equal e Sil.exp_zero || Option.is_some (Prop.get_objc_null_attribute pre e) -> true @@ -821,17 +821,17 @@ let handle_objc_method_call actual_pars actual_params pre tenv cfg ret_ids pdesc match ret_ids with | [ret_id] -> (match Prop.find_equal_formal_path receiver prop with - | Some info -> - Prop.add_or_replace_exp_attribute (fun a1 a2 -> ()) prop (Sil.Var ret_id) - (Sil.Aobjc_null info) - | None -> Prop.conjoin_eq (Sil.Var ret_id) Sil.exp_zero prop) + | Some info -> + Prop.add_or_replace_exp_attribute (fun a1 a2 -> ()) prop (Sil.Var ret_id) + (Sil.Aobjc_null info) + | None -> Prop.conjoin_eq (Sil.Var ret_id) Sil.exp_zero prop) | _ -> prop in 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 ("Object-C method " ^ Procname.to_string callee_pname^ " called with nil receiver. Returning 0/nil"); - (* We wish to nullify the result. However, in some cases, 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)] + let path = Paths.Path.add_description path path_description in + L.d_strln ("Object-C method " ^ Procname.to_string callee_pname^ " called with nil receiver. Returning 0/nil"); + (* We wish to nullify the result. However, in some cases, 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)] else let res = Tabulation.exe_function_call tenv cfg ret_ids pdesc callee_pname loc actual_params pre path in let is_undef = match Prop.get_resource_undef_attribute pre receiver with @@ -863,7 +863,7 @@ let normalize_params pdesc prop actual_params = (** Execute [instr] with a symbolic heap [prop].*) let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path -: (Prop.normal Prop.t * Paths.Path.t) list = + : (Prop.normal Prop.t * Paths.Path.t) list = let pname = Cfg.Procdesc.get_proc_name pdesc in State.set_instr _instr; (* mark instruction last seen *) State.set_prop_tenv_pdesc _prop tenv pdesc; (* mark prop,tenv,pdesc last seen *) @@ -943,7 +943,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path let sym_exe_builtin = Builtin.get_sym_exe_builtin fn in sym_exe_builtin cfg pdesc instr tenv _prop path ret_ids args fn loc | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), actual_params, loc, call_flags) -> - (** Generic fun call with known name *) + (** Generic fun call with known name *) let (prop_r, _n_actual_params) = normalize_params pdesc _prop actual_params in let fn, n_actual_params = handle_special_cases_call tenv cfg callee_pname _n_actual_params in let resolved_pname = @@ -959,13 +959,13 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path Reporting.log_info pname exn; L.d_strln ("Undefined function " ^ Procname.to_string callee_pname - ^ ", returning undefined value."); + ^ ", returning undefined value."); (match Specs.get_summary pname with - | None -> () - | Some summary -> - Specs.CallStats.trace - summary.Specs.stats.Specs.call_stats callee_pname loc - (Specs.CallStats.CR_skip) !Config.footprint); + | None -> () + | Some summary -> + Specs.CallStats.trace + summary.Specs.stats.Specs.call_stats callee_pname loc + (Specs.CallStats.CR_skip) !Config.footprint); call_unknown_or_scan false cfg pdesc tenv prop path ret_ids ret_typ_opt n_actual_params resolved_pname loc in @@ -1000,9 +1000,9 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path begin let eprop = Prop.expose _prop in match list_partition - (function - | Sil.Hpointsto (Sil.Lvar pvar', _, _) -> Sil.pvar_equal pvar pvar' - | _ -> false) (Prop.get_sigma eprop) with + (function + | Sil.Hpointsto (Sil.Lvar pvar', _, _) -> Sil.pvar_equal pvar pvar' + | _ -> false) (Prop.get_sigma eprop) with | [Sil.Hpointsto(e, se, typ)], sigma' -> let sigma'' = match deallocate with | false -> @@ -1022,7 +1022,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path ret_old_path [] else ret_old_path [Abs.remove_redundant_array_elements pname tenv - (Abs.abstract pname tenv _prop)] + (Abs.abstract pname tenv _prop)] | Sil.Remove_temps (temps, loc) -> ret_old_path [Prop.exist_quantify (Sil.fav_from_list temps) _prop] | Sil.Declare_locals (ptl, loc) -> @@ -1057,18 +1057,18 @@ and execute_diverge prop path = [] (** Like sym_exec but for generated instructions. -If errors occur and [mask_errors] is false, just treat as skip.*) + If errors occur and [mask_errors] is false, just treat as skip.*) and sym_exec_generated mask_errors cfg tenv pdesc instrs ppl = let exe_instr instr (p, path) = L.d_str "Executing Generated Instruction "; Sil.d_instr instr; L.d_ln (); try sym_exec cfg tenv pdesc instr p path with exn when exn_not_timeout exn && mask_errors -> - let err_name, _, ml_source, _ , _, _, _ = Exceptions.recognize_exception exn in - let loc = (match ml_source with - | Some (src, l, c) -> "at "^(src^" "^(string_of_int l)) - | None -> "") in - L.d_warning ("Generated Instruction Failed with: " ^ (Localise.to_string err_name)^loc ); L.d_ln(); - [(p, path)] in + let err_name, _, ml_source, _ , _, _, _ = Exceptions.recognize_exception exn in + let loc = (match ml_source with + | Some (src, l, c) -> "at "^(src^" "^(string_of_int l)) + | None -> "") in + L.d_warning ("Generated Instruction Failed with: " ^ (Localise.to_string err_name)^loc ); L.d_ln(); + [(p, path)] in let f plist instr = list_flatten (list_map (exe_instr instr) plist) in list_fold_left f ppl instrs @@ -1086,7 +1086,7 @@ and add_constraints_on_retval pdesc prop ret_ids ret_type_option callee_pname = else match ret_ids, ret_type_option with | [ret_id], Some ret_typ -> - (* To avoid obvious false positives, assume skip functions do not return null pointers *) + (* To avoid obvious false positives, assume skip functions do not return null pointers *) let add_ret_non_null ret_id ret_typ prop = match ret_typ with | Sil.Tptr _ -> Prop.conjoin_neq (Sil.Var ret_id) Sil.exp_zero prop @@ -1099,8 +1099,8 @@ and add_constraints_on_retval pdesc prop ret_ids ret_type_option callee_pname = let already_has_abducted_retval p = list_exists (fun hpred -> match hpred with - | Sil.Hpointsto (Sil.Lvar pv, _, _) -> Sil.pvar_equal pv abducted_ret_pv - | _ -> false) + | Sil.Hpointsto (Sil.Lvar pv, _, _) -> Sil.pvar_equal pv abducted_ret_pv + | _ -> false) (Prop.get_sigma_footprint p) in (* prevent introducing multiple abducted retvals for a single call site in a loop *) if already_has_abducted_retval prop then prop @@ -1114,7 +1114,7 @@ and add_constraints_on_retval pdesc prop ret_ids ret_type_option callee_pname = let bind_exp_to_abducted_val exp_to_bind abducted_pvar prop = let bind_exp prop = function | Sil.Hpointsto (Sil.Lvar pv, Sil.Eexp (rhs, _), _) - when Sil.pvar_equal pv abducted_pvar -> + when Sil.pvar_equal pv abducted_pvar -> Prop.conjoin_eq exp_to_bind rhs prop | _ -> prop in list_fold_left bind_exp prop (Prop.get_sigma prop) in @@ -1137,14 +1137,14 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname = let add_actual_by_ref_to_footprint prop (actual, actual_typ) = match actual with | Sil.Lvar actual_pv -> - (* introduce a fresh program variable to allow abduction on the return value *) + (* introduce a fresh program variable to allow abduction on the return value *) let abducted_ref_pv = Sil.mk_pvar_abducted_ref_param callee_pname actual_pv (State.get_loc ()) in let already_has_abducted_retval p = list_exists (fun hpred -> match hpred with - | Sil.Hpointsto (Sil.Lvar pv, _, _) -> Sil.pvar_equal pv abducted_ref_pv - | _ -> false) + | Sil.Hpointsto (Sil.Lvar pv, _, _) -> Sil.pvar_equal pv abducted_ref_pv + | _ -> false) (Prop.get_sigma_footprint p) in (* prevent introducing multiple abducted retvals for a single call site in a loop *) if already_has_abducted_retval prop then prop @@ -1174,11 +1174,11 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname = Prop.normalize (Prop.replace_sigma filtered_sigma prop) in list_fold_left (fun p hpred -> - match hpred with - | Sil.Hpointsto (Sil.Lvar pv, rhs, texp) when Sil.pvar_equal pv abducted_ref_pv -> - let new_hpred = Sil.Hpointsto (actual, rhs, texp) in - Prop.normalize (Prop.replace_sigma (new_hpred :: (Prop.get_sigma prop')) p) - | _ -> p) + match hpred with + | Sil.Hpointsto (Sil.Lvar pv, rhs, texp) when Sil.pvar_equal pv abducted_ref_pv -> + let new_hpred = Sil.Hpointsto (actual, rhs, texp) in + Prop.normalize (Prop.replace_sigma (new_hpred :: (Prop.get_sigma prop')) p) + | _ -> p) prop' (Prop.get_sigma prop') | _ -> assert false in @@ -1200,7 +1200,7 @@ and call_unknown_or_scan is_scan cfg pdesc tenv pre path let do_exp p (e, t) = let do_attribute q = function | Sil.Aresource res_action as res - when res_action.Sil.ra_res = Sil.Rfile -> + when res_action.Sil.ra_res = Sil.Rfile -> Prop.remove_attribute res q | _ -> q in list_fold_left do_attribute p (Prop.get_exp_attributes p e) in @@ -1248,15 +1248,15 @@ and sym_exe_check_variadic_sentinel ?(fails_on_nil=false) cfg pdesc tenv prop pa try sym_exec_generated false cfg tenv pdesc [letderef] result with e when exn_not_timeout e -> - if not fails_on_nil then - let deref_str = Localise.deref_str_nil_argument_in_variadic_method callee_pname nargs i in - let err_desc = - Errdesc.explain_dereference ~use_buckets: true ~is_premature_nil: true - deref_str prop loc in - raise (Exceptions.Premature_nil_termination - (err_desc, try assert false with Assert_failure x -> x)) - else - raise e in + if not fails_on_nil then + let deref_str = Localise.deref_str_nil_argument_in_variadic_method callee_pname nargs i in + let err_desc = + Errdesc.explain_dereference ~use_buckets: true ~is_premature_nil: true + deref_str prop loc in + raise (Exceptions.Premature_nil_termination + (err_desc, try assert false with Assert_failure x -> x)) + else + raise e in (* list_fold_left reverses the arguments back so that we report an *) (* error on the first premature nil argument *) list_fold_left check_allocated [(prop, path)] non_terminal_argsi @@ -1282,14 +1282,14 @@ and sym_exec_call cfg pdesc tenv pre path ret_ids actual_pars summary loc = let is_ignored = match ret_typ, ret_ids with | Sil.Tvoid, _ -> false | Sil.Tint _, _ when not (is_defined cfg callee_pname) -> - (* if the proc returns Tint and is not defined, *) - (* don't report ignored return value *) + (* if the proc returns Tint and is not defined, *) + (* don't report ignored return value *) false | _, [] -> true | _, [id] -> Errdesc.id_is_assigned_then_dead (State.get_node ()) id | _ -> false in if is_ignored - && Specs.get_flag callee_pname proc_flag_ignore_return = None then + && Specs.get_flag callee_pname proc_flag_ignore_return = None then let err_desc = Localise.desc_return_value_ignored callee_pname loc in let exn = (Exceptions.Return_value_ignored (err_desc, try assert false with Assert_failure x -> x)) in let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop caller_pname) in @@ -1316,22 +1316,22 @@ and sym_exec_call cfg pdesc tenv pre path ret_ids actual_pars summary loc = raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in let actual_params = comb actual_pars formal_types in (* Actual parameters are associated to their formal - parameter type if there are enough formal parameters, and - to their actual type otherwise. The latter case happens - with variable - arguments functions *) + parameter type if there are enough formal parameters, and + to their actual type otherwise. The latter case happens + with variable - arguments functions *) check_return_value_ignored (); (* In case we call an objc instance method we add and extra spec *) (* were the receiver is null and the semantics of the call is nop*) if (!Sil.curr_language <> Sil.Java) && !Config.objc_method_call_semantics && - (Specs.get_attributes summary).Sil.is_objc_instance_method then + (Specs.get_attributes summary).Sil.is_objc_instance_method then handle_objc_method_call actual_pars actual_params pre tenv cfg ret_ids pdesc callee_pname loc path else (* non-objective-c method call. Standard tabulation *) - Tabulation.exe_function_call tenv cfg ret_ids pdesc callee_pname loc actual_params pre path + Tabulation.exe_function_call tenv cfg ret_ids pdesc callee_pname loc actual_params pre path end (** perform symbolic execution for a single prop, and check for junk *) and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t), path) -: Paths.PathSet.t = + : Paths.PathSet.t = let pname = Cfg.Procdesc.get_proc_name pdesc in let prop_primed_to_normal p = (** Rename primed vars with fresh normal vars, and return them *) let fav = Prop.prop_fav p in @@ -1369,7 +1369,7 @@ and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t) let curr_node = State.get_node () in match Cfg.Node.get_kind curr_node with | Cfg.Node.Prune_node _ when not (node_has_abstraction curr_node) -> - (* don't check for leaks in prune nodes, unless there is abstraction anyway, but force them into either branch *) + (* don't check for leaks in prune nodes, unless there is abstraction anyway, but force them into either branch *) p' | _ -> check_deallocate_static_memory (Abs.abstract_junk ~original_prop: p pname tenv p') in @@ -1377,7 +1377,7 @@ and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t) let prop', fav_normal = pre_process_prop prop in let res_list = run_with_abs_val_eq_zero (* no exp abstraction during sym exe *) (fun () -> - sym_exec cfg tenv pdesc instr prop' path) in + sym_exec cfg tenv pdesc instr prop' path) in let res_list_nojunk = list_map (fun (p, path) -> (post_process_result fav_normal p path, path)) res_list in let results = list_map (fun (p, path) -> (Prop.prop_rename_primed_footprint_vars p, path)) res_list_nojunk in L.d_strln "Instruction Returns"; @@ -1385,22 +1385,22 @@ and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t) State.mark_instr_ok (); Paths.PathSet.from_renamed_list results with exn when Exceptions.handle_exception exn && !Config.footprint -> - handle_exn exn; (* calls State.mark_instr_fail *) - if !Config.nonstop - then (Paths.PathSet.from_renamed_list [(prop, path)]) (* in nonstop mode treat the instruction as skip *) - else Paths.PathSet.empty + handle_exn exn; (* calls State.mark_instr_fail *) + if !Config.nonstop + then (Paths.PathSet.from_renamed_list [(prop, path)]) (* in nonstop mode treat the instruction as skip *) + else Paths.PathSet.empty (** {2 Lifted Abstract Transfer Functions} *) let lifted_sym_exec handle_exn cfg tenv pdesc (pset : Paths.PathSet.t) node (instrs : Sil.instr list) -: Paths.PathSet.t = + : Paths.PathSet.t = let pname = Cfg.Procdesc.get_proc_name pdesc in let exe_instr_prop instr p tr (pset1: Paths.PathSet.t) = let pset2 = if Tabulation.prop_is_exn pname p && not (Sil.instr_is_auxiliary instr) - && Cfg.Node.get_kind node <> Cfg.Node.exn_handler_kind - (* skip normal instructions if an exception was thrown, unless this is an exception handler node *) + && Cfg.Node.get_kind node <> Cfg.Node.exn_handler_kind + (* skip normal instructions if an exception was thrown, unless this is an exception handler node *) then begin L.d_str "Skipping instr "; Sil.d_instr instr; L.d_strln " due to exception"; @@ -1443,7 +1443,7 @@ module ModelBuiltins = struct (** model va_arg as always returning 0 *) let execute___builtin_va_arg cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp1, typ1); (lexp2, typ2); (lexp3, typ3)], _ -> let instr' = Sil.Set (lexp3, typ3, Sil.exp_zero, loc) in @@ -1471,7 +1471,7 @@ module ModelBuiltins = struct | _ -> prop let execute___get_array_size cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp, typ)] when list_length ret_ids <= 1 -> let return_result_for_array_size e prop ret_ids = return_result e prop ret_ids in @@ -1479,31 +1479,31 @@ module ModelBuiltins = struct begin try let hpred = list_find (function - | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp - | _ -> false) (Prop.get_sigma prop) in + | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp + | _ -> false) (Prop.get_sigma prop) in match hpred with | Sil.Hpointsto(e, Sil.Earray(size, _, _), _) -> [(return_result_for_array_size size prop ret_ids, path)] | _ -> [] with Not_found -> - let otyp' = (extract_array_type typ) in - match otyp' with - | Some typ' -> - let size = Sil.Var(Ident.create_fresh Ident.kfootprint) in - let s = mk_empty_array size in - let hpred = Prop.mk_ptsto n_lexp s (Sil.Sizeof(Sil.Tarray(typ', size), Sil.Subtype.exact)) in - let sigma = Prop.get_sigma prop in - let sigma_fp = Prop.get_sigma_footprint prop in - let prop'= Prop.replace_sigma (hpred:: sigma) prop in - let prop''= Prop.replace_sigma_footprint (hpred:: sigma_fp) prop' in - let prop''= Prop.normalize prop'' in - [(return_result_for_array_size size prop'' ret_ids, path)] - | _ -> [] + let otyp' = (extract_array_type typ) in + match otyp' with + | Some typ' -> + let size = Sil.Var(Ident.create_fresh Ident.kfootprint) in + let s = mk_empty_array size in + let hpred = Prop.mk_ptsto n_lexp s (Sil.Sizeof(Sil.Tarray(typ', size), Sil.Subtype.exact)) in + let sigma = Prop.get_sigma prop in + let sigma_fp = Prop.get_sigma_footprint prop in + let prop'= Prop.replace_sigma (hpred:: sigma) prop in + let prop''= Prop.replace_sigma_footprint (hpred:: sigma_fp) prop' in + let prop''= Prop.normalize prop'' in + [(return_result_for_array_size size prop'' ret_ids, path)] + | _ -> [] end | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute___set_array_size cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp, typ); (size, _)], [] -> let n_lexp, _prop' = exp_norm_check_arith pdesc _prop lexp in @@ -1511,8 +1511,8 @@ module ModelBuiltins = struct begin try let hpred, sigma' = list_partition (function - | Sil.Hpointsto(e, _, t) -> Sil.exp_equal e n_lexp - | _ -> false) (Prop.get_sigma prop) in + | Sil.Hpointsto(e, _, t) -> Sil.exp_equal e n_lexp + | _ -> false) (Prop.get_sigma prop) in match hpred with | [Sil.Hpointsto(e, Sil.Earray(_, esel, inst), t)] -> let hpred' = Sil.Hpointsto (e, Sil.Earray (n_size, esel, inst), t) in @@ -1520,25 +1520,25 @@ module ModelBuiltins = struct [(Prop.normalize prop', path)] | _ -> raise Not_found with Not_found -> - match typ with - | Sil.Tptr (typ', _) -> - let size_fp = Sil.Var(Ident.create_fresh Ident.kfootprint) in - let se = mk_empty_array n_size in - let se_fp = mk_empty_array size_fp in - let hpred = Prop.mk_ptsto n_lexp se (Sil.Sizeof(Sil.Tarray(typ', size), Sil.Subtype.exact)) in - let hpred_fp = Prop.mk_ptsto n_lexp se_fp (Sil.Sizeof(Sil.Tarray(typ', size_fp), Sil.Subtype.exact)) in - let sigma = Prop.get_sigma prop in - let sigma_fp = Prop.get_sigma_footprint prop in - let prop'= Prop.replace_sigma (hpred:: sigma) prop in - let prop''= Prop.replace_sigma_footprint (hpred_fp:: sigma_fp) prop' in - let prop''= Prop.normalize prop'' in - [(prop'', path)] - | _ -> [] + match typ with + | Sil.Tptr (typ', _) -> + let size_fp = Sil.Var(Ident.create_fresh Ident.kfootprint) in + let se = mk_empty_array n_size in + let se_fp = mk_empty_array size_fp in + let hpred = Prop.mk_ptsto n_lexp se (Sil.Sizeof(Sil.Tarray(typ', size), Sil.Subtype.exact)) in + let hpred_fp = Prop.mk_ptsto n_lexp se_fp (Sil.Sizeof(Sil.Tarray(typ', size_fp), Sil.Subtype.exact)) in + let sigma = Prop.get_sigma prop in + let sigma_fp = Prop.get_sigma_footprint prop in + let prop'= Prop.replace_sigma (hpred:: sigma) prop in + let prop''= Prop.replace_sigma_footprint (hpred_fp:: sigma_fp) prop' in + let prop''= Prop.normalize prop'' in + [(prop'', path)] + | _ -> [] end | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute___print_value cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = L.err "__print_value: "; let do_arg (lexp, typ) = let n_lexp, _ = exp_norm_check_arith pdesc prop lexp in @@ -1553,44 +1553,44 @@ module ModelBuiltins = struct | _ -> false (** Creates an object in the heap with a given type, when the object is not known to be null or when it doesn't - appear already in the heap. *) + appear already in the heap. *) let create_type tenv n_lexp typ prop = let prop_type = try let _ = list_find (function - | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp - | _ -> false) (Prop.get_sigma prop) in + | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp + | _ -> false) (Prop.get_sigma prop) in prop with Not_found -> - let mhpred = - match typ with - | Sil.Tptr (typ', _) -> - let sexp = Sil.Estruct ([], Sil.inst_none) in - let typ'' = Sil.expand_type tenv typ' in - let texp = Sil.Sizeof (typ'', Sil.Subtype.subtypes) in - let hpred = Prop.mk_ptsto n_lexp sexp texp in - Some hpred - | Sil.Tarray (typ', _) -> - let size = Sil.Var(Ident.create_fresh Ident.kfootprint) in - let sexp = mk_empty_array size in - let texp = Sil.Sizeof (typ, Sil.Subtype.subtypes) in - let hpred = Prop.mk_ptsto n_lexp sexp texp in - Some hpred - | _ -> None in - match mhpred with - | Some hpred -> - let sigma = Prop.get_sigma prop in - let sigma_fp = Prop.get_sigma_footprint prop in - let prop'= Prop.replace_sigma (hpred:: sigma) prop in - let prop''= - let has_normal_variables = - Sil.fav_exists (Sil.exp_fav n_lexp) Ident.is_normal in - if (is_undefined_opt prop n_lexp) || has_normal_variables - then prop' - else Prop.replace_sigma_footprint (hpred:: sigma_fp) prop' in - let prop''= Prop.normalize prop'' in - prop'' - | None -> prop in + let mhpred = + match typ with + | Sil.Tptr (typ', _) -> + let sexp = Sil.Estruct ([], Sil.inst_none) in + let typ'' = Sil.expand_type tenv typ' in + let texp = Sil.Sizeof (typ'', Sil.Subtype.subtypes) in + let hpred = Prop.mk_ptsto n_lexp sexp texp in + Some hpred + | Sil.Tarray (typ', _) -> + let size = Sil.Var(Ident.create_fresh Ident.kfootprint) in + let sexp = mk_empty_array size in + let texp = Sil.Sizeof (typ, Sil.Subtype.subtypes) in + let hpred = Prop.mk_ptsto n_lexp sexp texp in + Some hpred + | _ -> None in + match mhpred with + | Some hpred -> + let sigma = Prop.get_sigma prop in + let sigma_fp = Prop.get_sigma_footprint prop in + let prop'= Prop.replace_sigma (hpred:: sigma) prop in + let prop''= + let has_normal_variables = + Sil.fav_exists (Sil.exp_fav n_lexp) Ident.is_normal in + if (is_undefined_opt prop n_lexp) || has_normal_variables + then prop' + else Prop.replace_sigma_footprint (hpred:: sigma_fp) prop' in + let prop''= Prop.normalize prop'' in + prop'' + | None -> prop in let sil_is_null = Sil.BinOp (Sil.Eq, n_lexp, (Sil.exp_zero)) in let sil_is_nonnull = Sil.UnOp(Sil.LNot, sil_is_null, None) in let null_case = Propset.to_proplist (prune_prop tenv sil_is_null prop) in @@ -1601,7 +1601,7 @@ module ModelBuiltins = struct else null_case@non_null_case let execute___get_type_of cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp, typ)] when list_length ret_ids <= 1 -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1610,8 +1610,8 @@ module ModelBuiltins = struct begin try let hpred = list_find (function - | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp - | _ -> false) (Prop.get_sigma prop) in + | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp + | _ -> false) (Prop.get_sigma prop) in match hpred with | Sil.Hpointsto(e, _, texp) -> (return_result texp prop ret_ids), path @@ -1639,7 +1639,7 @@ module ModelBuiltins = struct let execute___instanceof_cast cfg pdesc instr tenv _prop path ret_ids args callee_pname loc instof - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(_val1, typ1); (_texp2, typ2)] when list_length ret_ids <= 1 -> let val1, __prop = exp_norm_check_arith pdesc _prop _val1 in @@ -1651,8 +1651,8 @@ module ModelBuiltins = struct begin try let hpred = list_find (function - | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1 - | _ -> false) (Prop.get_sigma prop) in + | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1 + | _ -> false) (Prop.get_sigma prop) in match hpred with | Sil.Hpointsto(_, _, texp1) -> let pos_type_opt, neg_type_opt = Prover.subtype_case_analysis tenv texp1 texp2 in @@ -1664,48 +1664,48 @@ module ModelBuiltins = struct else replace_ptsto_texp prop val1 texp1' in [(return_result res_e prop' ret_ids, path)] in if (instof) then (* instanceof *) - begin - let pos_res = mk_res pos_type_opt Sil.exp_one in - let neg_res = mk_res neg_type_opt Sil.exp_zero in - pos_res @ neg_res - end + begin + let pos_res = mk_res pos_type_opt Sil.exp_one in + let neg_res = mk_res neg_type_opt Sil.exp_zero in + pos_res @ neg_res + end else (* cast *) - begin - if (!Config.footprint = true) then - begin - match pos_type_opt with - | None -> - Tabulation.raise_cast_exception - (try assert false with Assert_failure ml_loc -> ml_loc) - None texp1 texp2 val1 - | Some texp1' -> (mk_res pos_type_opt val1) - end - else (* !Config.footprint = false *) begin - match neg_type_opt with - | Some _ -> - if (is_undefined_opt prop val1) then (mk_res pos_type_opt val1) - else - Tabulation.raise_cast_exception - (try assert false with Assert_failure ml_loc -> ml_loc) - None texp1 texp2 val1 - | None -> (mk_res pos_type_opt val1) + if (!Config.footprint = true) then + begin + match pos_type_opt with + | None -> + Tabulation.raise_cast_exception + (try assert false with Assert_failure ml_loc -> ml_loc) + None texp1 texp2 val1 + | Some texp1' -> (mk_res pos_type_opt val1) + end + else (* !Config.footprint = false *) + begin + match neg_type_opt with + | Some _ -> + if (is_undefined_opt prop val1) then (mk_res pos_type_opt val1) + else + Tabulation.raise_cast_exception + (try assert false with Assert_failure ml_loc -> ml_loc) + None texp1 texp2 val1 + | None -> (mk_res pos_type_opt val1) + end end - end | _ -> [] with Not_found -> - [(return_result val1 prop ret_ids, path)] + [(return_result val1 prop ret_ids, path)] end in let props = create_type tenv val1 typ1 prop in list_flatten (list_map exe_one_prop props) | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute___instanceof cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = (execute___instanceof_cast cfg pdesc instr tenv _prop path ret_ids args callee_pname loc true) let execute___cast cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = (execute___instanceof_cast cfg pdesc instr tenv _prop path ret_ids args callee_pname loc false) let set_resource_attribute prop path n_lexp loc ra_res = @@ -1722,7 +1722,7 @@ module ModelBuiltins = struct (** Set the attibute of the value as file *) let execute___set_file_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp, typ)], _ -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1731,7 +1731,7 @@ module ModelBuiltins = struct (** Set the attibute of the value as lock *) let execute___set_lock_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp, typ)], _ -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1741,7 +1741,7 @@ module ModelBuiltins = struct (** Set the resource attribute of the first real argument of method as ignore, the first argument is assumed to be "this" *) let execute___method_set_ignore_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [_ ; (lexp, typ)], _ -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1750,7 +1750,7 @@ module ModelBuiltins = struct (** Set the attibute of the value as memory *) let execute___set_mem_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp, typ)], _ -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1759,7 +1759,7 @@ module ModelBuiltins = struct (** Set the attibute of the value as tainted *) let execute___set_taint_attribute cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp, typ)], _ -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1773,7 +1773,7 @@ module ModelBuiltins = struct (** Set the attibute of the value as untainted *) let execute___set_untaint_attribute cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp, typ)], _ -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1787,7 +1787,7 @@ module ModelBuiltins = struct (** take a pointer to a struct, and return the value of a hidden field in the struct *) let execute___get_hidden_field cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp, typ)] -> let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in @@ -1822,7 +1822,7 @@ module ModelBuiltins = struct (** take a pointer to a struct and a value, and set a hidden field in the struct to the given value *) let execute___set_hidden_field cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp1, typ1); (lexp2, typ2)] -> let n_lexp1, _prop1 = exp_norm_check_arith pdesc _prop lexp1 in @@ -1849,21 +1849,21 @@ module ModelBuiltins = struct | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute___state_untainted cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp, typ)] when list_length ret_ids <= 1 -> (match ret_ids with - | [ret_id] -> - let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in - [(return_result (Sil.BinOp(Sil.Ne, n_lexp, (Sil.Const(Sil.Cattribute((Sil.Auntaint)))))) prop ret_ids, path)] - | _ -> [(_prop, path)]) + | [ret_id] -> + let n_lexp, prop = exp_norm_check_arith pdesc _prop lexp in + [(return_result (Sil.BinOp(Sil.Ne, n_lexp, (Sil.Const(Sil.Cattribute((Sil.Auntaint)))))) prop ret_ids, path)] + | _ -> [(_prop, path)]) | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) (* Update the objective-c hidden counter by applying the operation op and the operand delta.*) (* Eg. op=+/- delta is an integer *) let execute___objc_counter_update suppress_npe_report op delta cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp, typ)] -> let typ' = (match Sil.expand_type tenv typ with @@ -1893,7 +1893,7 @@ module ModelBuiltins = struct | _ -> true, args let execute___objc_retain_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = let suppress_npe_report, args' = get_suppress_npe_flag args in match args' with | [(lexp, typ)] -> @@ -1903,35 +1903,35 @@ module ModelBuiltins = struct | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute___objc_retain cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = if !Config.objc_memory_model_on then execute___objc_retain_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc else execute___no_op _prop path let execute___objc_retain_cf cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = execute___objc_retain_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc let execute___objc_release_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = let suppress_npe_flag, args' = get_suppress_npe_flag args in execute___objc_counter_update suppress_npe_flag (Sil.MinusA) (Sil.Int.one) cfg pdesc instr tenv _prop path ret_ids args' callee_name loc let execute___objc_release cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = if !Config.objc_memory_model_on then execute___objc_release_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc else execute___no_op _prop path let execute___objc_release_cf cfg pdesc instr tenv _prop path ret_ids args callee_name loc - : Builtin.ret_typ = + : Builtin.ret_typ = execute___objc_release_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc (** Set the attibute of the value as objc autoreleased *) let execute___set_autorelease_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args, ret_ids with | [(lexp, typ)], _ -> let prop = return_result lexp _prop ret_ids in @@ -1946,7 +1946,7 @@ module ModelBuiltins = struct (** Release all the objects in the pool *) let execute___release_autorelease_pool cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = if !Config.objc_memory_model_on then let autoreleased_objects = Prop.get_atoms_with_attribute Sil.Aautorelease _prop in let prop = Prop.remove_attribute Sil.Aautorelease _prop in @@ -1954,45 +1954,45 @@ module ModelBuiltins = struct match res with | (prop, path):: _ -> (try - let hpred = list_find (function - | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 exp - | _ -> false) (Prop.get_sigma _prop) in - match hpred with - | Sil.Hpointsto(_, _, Sil.Sizeof (typ, st)) -> - let res1 = - execute___objc_release cfg pdesc instr tenv prop path ret_ids - [(exp, typ)] callee_pname loc in - res1 - | _ -> res - with Not_found -> res) + let hpred = list_find (function + | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 exp + | _ -> false) (Prop.get_sigma _prop) in + match hpred with + | Sil.Hpointsto(_, _, Sil.Sizeof (typ, st)) -> + let res1 = + execute___objc_release cfg pdesc instr tenv prop path ret_ids + [(exp, typ)] callee_pname loc in + res1 + | _ -> res + with Not_found -> res) | [] -> res in list_fold_left call_release [(prop, path)] autoreleased_objects else execute___no_op _prop path let execute___objc_cast cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(_val1, typ1); (_texp2, typ2)] when list_length ret_ids <= 1 -> let val1, __prop = exp_norm_check_arith pdesc _prop _val1 in let texp2, prop = exp_norm_check_arith pdesc __prop _texp2 in (try - let hpred = list_find (function - | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1 - | _ -> false) (Prop.get_sigma prop) in - match hpred, texp2 with - | Sil.Hpointsto(val1, _, texp1), Sil.Sizeof (typ, st) -> - let prop' = replace_ptsto_texp prop val1 texp2 in - [(return_result val1 prop' ret_ids, path)] - | _ -> [(return_result val1 prop ret_ids, path)] - with Not_found -> [(return_result val1 prop ret_ids, path)]) + let hpred = list_find (function + | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1 + | _ -> false) (Prop.get_sigma prop) in + match hpred, texp2 with + | Sil.Hpointsto(val1, _, texp1), Sil.Sizeof (typ, st) -> + let prop' = replace_ptsto_texp prop val1 texp2 in + [(return_result val1 prop' ret_ids, path)] + | _ -> [(return_result val1 prop ret_ids, path)] + with Not_found -> [(return_result val1 prop ret_ids, path)]) | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute_abort cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string callee_pname), try assert false with Assert_failure x -> x)) let execute_exit cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = execute_diverge prop path let _execute_free tenv mk loc acc iter = @@ -2021,16 +2021,16 @@ module ModelBuiltins = struct list_rev prop_list end with Rearrange.ARRAY_ACCESS -> - if (!Config.array_level = 0) then assert false - else begin - L.d_strln ".... Array containing allocated heap cells ...."; - L.d_str " Instr: "; Sil.d_instr instr; L.d_ln (); - L.d_str " PROP: "; Prop.d_prop prop; L.d_ln (); - raise (Exceptions.Array_of_pointsto (try assert false with Assert_failure x -> x)) - end + if (!Config.array_level = 0) then assert false + else begin + L.d_strln ".... Array containing allocated heap cells ...."; + L.d_str " Instr: "; Sil.d_instr instr; L.d_ln (); + L.d_str " PROP: "; Prop.d_prop prop; L.d_ln (); + raise (Exceptions.Array_of_pointsto (try assert false with Assert_failure x -> x)) + end let execute_free mk cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp, typ)] -> begin @@ -2042,14 +2042,14 @@ module ModelBuiltins = struct let plist = prop_zero @ (* model: if 0 then skip else _execute_free_nonzero *) list_flatten (list_map (fun p -> - _execute_free_nonzero mk pdesc tenv instr p path - (Prop.exp_normalize_prop p lexp) typ loc) prop_nonzero) in + _execute_free_nonzero mk pdesc tenv instr p path + (Prop.exp_normalize_prop p lexp) typ loc) prop_nonzero) in list_map (fun p -> (p, path)) plist end | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute_alloc mk can_return_null cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = let rec evaluate_char_sizeof e = match e with | Sil.Var _ -> e | Sil.UnOp (uop, e', typ) -> @@ -2094,26 +2094,26 @@ module ModelBuiltins = struct else [(prop_alloc, path)] let execute_pthread_create cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [thread; attr; start_routine; arg] -> let routine_name = Prop.exp_normalize_prop prop (fst start_routine) in let routine_arg = Prop.exp_normalize_prop prop (fst arg) in (match routine_name, (snd start_routine) with - | Sil.Lvar pvar, _ -> - let fun_name = Sil.pvar_get_name pvar in - let fun_string = Mangled.to_string fun_name in - L.d_strln ("pthread_create: calling function " ^ fun_string); - begin - match Specs.get_summary (Procname.from_string_c_fun fun_string) with - | None -> assert false - | Some callee_summary -> - sym_exec_call - cfg pdesc tenv prop path ret_ids [(routine_arg, snd arg)] callee_summary loc - end - | _ -> - L.d_str "pthread_create: unknown function "; Sil.d_exp routine_name; L.d_strln ", skipping call."; - [(prop, path)]) + | Sil.Lvar pvar, _ -> + let fun_name = Sil.pvar_get_name pvar in + let fun_string = Mangled.to_string fun_name in + L.d_strln ("pthread_create: calling function " ^ fun_string); + begin + match Specs.get_summary (Procname.from_string_c_fun fun_string) with + | None -> assert false + | Some callee_summary -> + sym_exec_call + cfg pdesc tenv prop path ret_ids [(routine_arg, snd arg)] callee_summary loc + end + | _ -> + L.d_str "pthread_create: unknown function "; Sil.d_exp routine_name; L.d_strln ", skipping call."; + [(prop, path)]) | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute_skip cfg pdesc instr tenv prop path ret_ids args callee_pname loc : Builtin.ret_typ = @@ -2121,7 +2121,7 @@ module ModelBuiltins = struct let execute_scan_function skip_n_arguments cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | _ when list_length args >= skip_n_arguments -> let varargs = ref args in @@ -2130,7 +2130,7 @@ module ModelBuiltins = struct | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute__unwrap_exception cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(ret_exn, _)] -> begin @@ -2144,7 +2144,7 @@ module ModelBuiltins = struct | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute_return_first_argument cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | (_arg1, _):: _ -> let arg1, prop = exp_norm_check_arith pdesc _prop _arg1 in @@ -2153,46 +2153,46 @@ module ModelBuiltins = struct | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute___split_get_nth cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp1, _); (lexp2, _); (lexp3, _)] -> let n_lexp1, prop = exp_norm_check_arith pdesc _prop lexp1 in let n_lexp2, prop = exp_norm_check_arith pdesc _prop lexp2 in let n_lexp3, prop = exp_norm_check_arith pdesc _prop lexp3 in (match n_lexp1, n_lexp2, n_lexp3 with - | Sil.Const (Sil.Cstr str1), Sil.Const (Sil.Cstr str2), Sil.Const (Sil.Cint n_sil) -> - (let n = Sil.Int.to_int n_sil in - try - let parts = Str.split (Str.regexp_string str2) str1 in - let n_part = list_nth parts n in - let res = Sil.Const (Sil.Cstr n_part) in - [(return_result res prop ret_ids, path)] - with Not_found -> assert false) - | _ -> [(prop, path)]) + | Sil.Const (Sil.Cstr str1), Sil.Const (Sil.Cstr str2), Sil.Const (Sil.Cint n_sil) -> + (let n = Sil.Int.to_int n_sil in + try + let parts = Str.split (Str.regexp_string str2) str1 in + let n_part = list_nth parts n in + let res = Sil.Const (Sil.Cstr n_part) in + [(return_result res prop ret_ids, path)] + with Not_found -> assert false) + | _ -> [(prop, path)]) | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) let execute___create_tuple cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = let el = list_map fst args in let res = Sil.Const (Sil.Ctuple el) in [(return_result res prop ret_ids, path)] let execute___tuple_get_nth cfg pdesc instr tenv _prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = match args with | [(lexp1, _); (lexp2, _)] -> let n_lexp1, _prop' = exp_norm_check_arith pdesc _prop lexp1 in let n_lexp2, prop = exp_norm_check_arith pdesc _prop' lexp2 in (match n_lexp1, n_lexp2 with - | Sil.Const (Sil.Ctuple el), Sil.Const (Sil.Cint i) -> - let n = Sil.Int.to_int i in - let en = list_nth el n in - [(return_result en prop ret_ids, path)] - | _ -> [(prop, path)]) + | Sil.Const (Sil.Ctuple el), Sil.Const (Sil.Cint i) -> + let n = Sil.Int.to_int i in + let en = list_nth el n in + [(return_result en prop ret_ids, path)] + | _ -> [(prop, path)]) | _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) (* forces the expression passed as parameter to be assumed true at the point where this - builtin is called, blocks if this causes an inconsistency *) + builtin is called, blocks if this causes an inconsistency *) let execute___infer_assume cfg pdesc instr tenv prop path ret_ids args callee_pname loc: Builtin.ret_typ = match args with @@ -2204,7 +2204,7 @@ module ModelBuiltins = struct (* creates a named error state *) let execute___infer_fail cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = let error_str = match args with | [(lexp_msg, _)] -> @@ -2221,7 +2221,7 @@ module ModelBuiltins = struct (* translate builtin assertion failure *) let execute___assert_fail cfg pdesc instr tenv prop path ret_ids args callee_pname loc - : Builtin.ret_typ = + : Builtin.ret_typ = let error_str = match args with | l when list_length l = 4 -> diff --git a/infer/src/backend/tabulation.ml b/infer/src/backend/tabulation.ml index ee5c00063..f3cd0689f 100644 --- a/infer/src/backend/tabulation.ml +++ b/infer/src/backend/tabulation.ml @@ -46,9 +46,9 @@ type valid_res = vr_incons_res : (Prop.normal Prop.t * Paths.Path.t) list; (** inconsistent result props *) } (** Result of (bi)-abduction on a single spec. -A result is invalid if no splitting was found, or if combine failed, or if we are in re - execution mode and the sigma -part of the splitting is not empty. -A valid result contains the missing pi ans sigma, as well as the resulting props. *) + A result is invalid if no splitting was found, or if combine failed, or if we are in re - execution mode and the sigma + part of the splitting is not empty. + A valid result contains the missing pi ans sigma, as well as the resulting props. *) type abduction_res = | Valid_res of valid_res (** valid result for a function cal *) | Invalid_res of invalid_res (** reason for invalid result *) @@ -113,14 +113,14 @@ let spec_find_rename trace_call (proc_name : Procname.t) : (int * Prop.exposed S list_map (fun (x, _) -> Sil.mk_pvar_callee (Mangled.from_string x) proc_name) formals in list_map f specs, formal_parameters with Not_found -> begin - L.d_strln ("ERROR: found no entry for procedure " ^ Procname.to_string proc_name ^ ". Give up..."); - raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x)) - end + L.d_strln ("ERROR: found no entry for procedure " ^ Procname.to_string proc_name ^ ". Give up..."); + raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x)) + end (** Process a splitting coming straight from a call to the prover: -change the instantiating substitution so that it returns primed vars, -except for vars occurring in the missing part, where it returns -footprint vars. *) + change the instantiating substitution so that it returns primed vars, + except for vars occurring in the missing part, where it returns + footprint vars. *) let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld frame_typ missing_typ = (* let check_precondition () = @@ -228,11 +228,11 @@ and find_dereference_without_null_check_in_sexp_list = function | [] -> None | se:: sel -> (match find_dereference_without_null_check_in_sexp se with - | None -> find_dereference_without_null_check_in_sexp_list sel - | Some x -> Some x) + | None -> find_dereference_without_null_check_in_sexp_list sel + | Some x -> Some x) (** Check dereferences implicit in the spec pre. -In case of dereference error, return [Some(deref_error, description)], otherwise [None] *) + In case of dereference error, return [Some(deref_error, description)], otherwise [None] *) let check_dereferences callee_pname actual_pre sub spec_pre formal_params = let check_dereference e sexp = let e_sub = Sil.exp_sub sub e in @@ -253,9 +253,9 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params = else None in if deref_no_null_check_pos != None then (* only report a dereference null error if we know there was a dereference without null check *) - match deref_no_null_check_pos with - | Some pos -> Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname))) - | None -> assert false + match deref_no_null_check_pos with + | Some pos -> Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname))) + | None -> assert false else if Sil.exp_equal e_sub Sil.exp_minus_one then Some (Deref_minusone, desc true (Localise.deref_str_dangling None)) else match Prop.get_resource_undef_attribute actual_pre e_sub with | Some (Sil.Aundef (s, loc, pos)) -> @@ -268,25 +268,25 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params = check_dereference (Sil.root_of_lexp lexp) se | _ -> None in let deref_err_list = list_fold_left (fun deref_errs hpred -> match check_hpred hpred with - | Some reason -> reason :: deref_errs - | None -> deref_errs - ) [] (Prop.get_sigma spec_pre) in + | Some reason -> reason :: deref_errs + | None -> deref_errs + ) [] (Prop.get_sigma spec_pre) in match deref_err_list with | [] -> None | deref_err :: _ -> if !Config.angelic_execution then (* In angelic mode, prefer to report Deref_null over other kinds of deref errors. this - * makes sure we report a NULL_DEREFERENCE instead of a less interesting PRECONDITION_NOT_MET - * whenever possible *) + * makes sure we report a NULL_DEREFERENCE instead of a less interesting PRECONDITION_NOT_MET + * whenever possible *) (* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *) Some - (try - list_find - (fun err -> match err with + (try + list_find + (fun err -> match err with | (Deref_null _, _) -> true | _ -> false ) - deref_err_list - with Not_found -> deref_err) + deref_err_list + with Not_found -> deref_err) else Some deref_err let post_process_sigma (sigma: Sil.hpred list) loc : Sil.hpred list = @@ -313,8 +313,8 @@ let check_path_errors_in_post caller_pname post post_path = list_iter check_attr (Prop.get_all_attributes post) (** Post process the instantiated post after the function call so that -x.f |-> se becomes x |-> \{ f: se \}. -Also, update any Aresource attributes to refer to the caller *) + x.f |-> se becomes x |-> \{ f: se \}. + Also, update any Aresource attributes to refer to the caller *) let post_process_post caller_pname callee_pname loc actual_pre ((post: Prop.exposed Prop.t), post_path) = let actual_pre_has_freed_attribute e = match Prop.get_resource_undef_attribute actual_pre e with @@ -323,7 +323,7 @@ let post_process_post let atom_update_alloc_attribute = function | Sil.Aneq (e , Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra)))) | Sil.Aneq (Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra))), e) - when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *) + when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *) let vpath, _ = Errdesc.vpath_find post e in let ra' = { ra with Sil.ra_pname = callee_pname; Sil.ra_loc = loc; Sil.ra_vpath = vpath } in let c = Sil.Const (Sil.Cattribute (Sil.Aresource ra')) in @@ -360,9 +360,9 @@ let rec fsel_star_fld fsel1 fsel2 = match fsel1, fsel2 with | fsel1,[] -> fsel1 | (f1, se1):: fsel1', (f2, se2):: fsel2' -> (match Ident.fieldname_compare f1 f2 with - | 0 -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2' - | n when n < 0 -> (f1, se1) :: fsel_star_fld fsel1' fsel2 - | _ -> (f2, se2) :: fsel_star_fld fsel1 fsel2') + | 0 -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2' + | n when n < 0 -> (f1, se1) :: fsel_star_fld fsel1' fsel2 + | _ -> (f2, se2) :: fsel_star_fld fsel1 fsel2') and array_content_star se1 se2 = try sexp_star_fld se1 se2 with @@ -374,11 +374,11 @@ and esel_star_fld esel1 esel2 = match esel1, esel2 with | esel1,[] -> esel1 | (e1, se1):: esel1', (e2, se2):: esel2' -> (match Sil.exp_compare e1 e2 with - | 0 -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2' - | n when n < 0 -> (e1, se1) :: esel_star_fld esel1' esel2 - | _ -> - let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *) - (e2, se2') :: esel_star_fld esel1 esel2') + | 0 -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2' + | n when n < 0 -> (e1, se1) :: esel_star_fld esel1' esel2 + | _ -> + let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *) + (e2, se2') :: esel_star_fld esel1 esel2') and sexp_star_fld se1 se2 : Sil.strexp = (* L.d_str "sexp_star_fld "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln (); *) @@ -416,8 +416,8 @@ let texp_star texp1 texp2 = let hpred_star_fld (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred = match hpred1, hpred2 with | Sil.Hpointsto(e1, se1, t1), Sil.Hpointsto(_, se2, t2) -> - (* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2; - L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *) + (* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2; + L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *) Sil.Hpointsto(e1, sexp_star_fld se1 se2, texp_star t1 t2) | _ -> assert false @@ -440,10 +440,10 @@ let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpr in try star sigma1 sigma2 with exn when exn_not_timeout exn -> - L.d_str "cannot star "; - Prop.d_sigma sigma1; L.d_str " and "; Prop.d_sigma sigma2; - L.d_ln (); - raise (Prop.Cannot_star (try assert false with Assert_failure x -> x)) + L.d_str "cannot star "; + Prop.d_sigma sigma1; L.d_str " and "; Prop.d_sigma sigma2; + L.d_ln (); + raise (Prop.Cannot_star (try assert false with Assert_failure x -> x)) let hpred_typing_lhs_compare hpred1 (e2, te2) = match hpred1 with | Sil.Hpointsto(e1, _, _) -> Sil.exp_compare e1 e2 @@ -474,10 +474,10 @@ let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Sil.exp * Sil.exp) lis end in try star sigma1 typings2 with exn when exn_not_timeout exn -> - L.d_str "cannot star "; - Prop.d_sigma sigma1; L.d_str " and "; Prover.d_typings typings2; - L.d_ln (); - raise (Prop.Cannot_star (try assert false with Assert_failure x -> x)) + L.d_str "cannot star "; + Prop.d_sigma sigma1; L.d_str " and "; Prover.d_typings typings2; + L.d_ln (); + raise (Prop.Cannot_star (try assert false with Assert_failure x -> x)) end else sigma1 @@ -489,7 +489,7 @@ let prop_footprint_add_pi_sigma_starfld_sigma (prop : 'a Prop.t) pi_new sigma_ne let fav = Prop.sigma_fav [hpred] in (* TODO (t4893479): make this check less angelic *) if Sil.fav_exists fav - (fun id -> not (Ident.is_footprint id) && not !Config.angelic_execution) + (fun id -> not (Ident.is_footprint id) && not !Config.angelic_execution) then begin L.d_warning "found hpred with non-footprint variable, dropping the spec"; L.d_ln (); Sil.d_hpred hpred; L.d_ln (); None @@ -519,8 +519,8 @@ let prop_footprint_add_pi_sigma_starfld_sigma (prop : 'a Prop.t) pi_new sigma_ne (** Check if the attribute change is a mismatch between a kind of allocation and a different kind of deallocation *) let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with | Sil.Aresource ({ Sil.ra_kind = Sil.Racquire; Sil.ra_res = Sil.Rmemory mk_old } as ra_old), - Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk_new } as ra_new) - when Sil.mem_kind_compare mk_old mk_new <> 0 -> + Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk_new } as ra_new) + when Sil.mem_kind_compare mk_old mk_new <> 0 -> let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in raise (Exceptions.Deallocation_mismatch (desc, try assert false with Assert_failure x -> x)) | _ -> () @@ -573,7 +573,7 @@ let lookup_global_errors prop = let rec search_error = function | [] -> None | Sil.Hpointsto (Sil.Lvar var, Sil.Eexp (Sil.Const (Sil.Cstr str), _), _) :: tl - when Sil.pvar_equal var Sil.global_error -> Some (Mangled.from_string str) + when Sil.pvar_equal var Sil.global_error -> Some (Mangled.from_string str) | _ :: tl -> search_error tl in search_error (Prop.get_sigma prop) @@ -622,22 +622,22 @@ let combine let posts' = if !Config.footprint && posts = [] then (* in case of divergence, produce a prop *) - (* with updated footprint and inconsistent current *) - [(Prop.replace_pi [Sil.Aneq (Sil.exp_zero, Sil.exp_zero)] Prop.prop_emp, path_pre)] + (* with updated footprint and inconsistent current *) + [(Prop.replace_pi [Sil.Aneq (Sil.exp_zero, Sil.exp_zero)] Prop.prop_emp, path_pre)] else list_map (fun (p, path_post) -> - (p, - Paths.Path.add_call - (include_subtrace callee_pname) - path_pre - callee_pname - path_post)) + (p, + Paths.Path.add_call + (include_subtrace callee_pname) + path_pre + callee_pname + path_post)) posts in list_map (fun (p, path) -> - (post_process_post - caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path))) + (post_process_post + caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path))) posts' in L.d_increase_indent 1; L.d_strln "New footprint:"; Prop.d_pi_sigma new_footprint_pi new_footprint_sigma; L.d_ln (); @@ -695,7 +695,7 @@ let combine let p = Prop.prop_iter_remove_curr_then_to_prop iter' in Prop.conjoin_eq e' (Sil.Var (list_hd ret_ids)) p | Sil.Hpointsto (e, Sil.Estruct (ftl, _), t) - when list_length ftl = list_length ret_ids -> + when list_length ftl = list_length ret_ids -> let rec do_ftl_ids p = function | [], [] -> p | (f, Sil.Eexp (e', inst')):: ftl', ret_id:: ret_ids' -> @@ -715,15 +715,15 @@ let combine post_p4 in let _results = list_map (fun (p, path) -> (compute_result p, path)) instantiated_post in if list_exists (fun (x, _) -> x = None) _results then (* at least one combine failed *) - None + None else let results = list_map (function (Some x, path) -> (x, path) | (None, _) -> assert false) _results in print_results actual_pre (list_map fst results); Some results (** Construct the actual precondition: add to the current state a copy -of the (callee's) formal parameters instantiated with the actual -parameters. *) + of the (callee's) formal parameters instantiated with the actual + parameters. *) let mk_actual_precondition prop actual_params formal_params = let formals_actuals = let rec comb fpars apars = match fpars, apars with @@ -731,7 +731,7 @@ let mk_actual_precondition prop actual_params formal_params = | [], _ -> 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 ()); + L.d_warning str; L.d_ln ()); [] | _:: _,[] -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in comb formal_params actual_params in @@ -759,11 +759,11 @@ let rec get_taint_untaint pi = | Sil.Aneq (e1, e2):: pi' -> let p = Prop.replace_pi pi Prop.prop_emp in (match Prop.get_taint_attribute p e1, Prop.get_taint_attribute p e2 with - | Some(Sil.Ataint), _ -> let (t', u') = get_taint_untaint pi' in (e1:: t', u') - | Some(Sil.Auntaint), _ -> let (t', u') = get_taint_untaint pi' in (t', e1:: u') - | _, Some(Sil.Ataint) -> let (t', u') = get_taint_untaint pi' in (e2:: t', u') - | _ , Some(Sil.Auntaint) -> let (t', u') = get_taint_untaint pi' in (t', e2:: u') - | _, _ -> get_taint_untaint pi') + | Some(Sil.Ataint), _ -> let (t', u') = get_taint_untaint pi' in (e1:: t', u') + | Some(Sil.Auntaint), _ -> let (t', u') = get_taint_untaint pi' in (t', e1:: u') + | _, Some(Sil.Ataint) -> let (t', u') = get_taint_untaint pi' in (e2:: t', u') + | _ , Some(Sil.Auntaint) -> let (t', u') = get_taint_untaint pi' in (t', e2:: u') + | _, _ -> get_taint_untaint pi') | _ :: pi' -> get_taint_untaint pi' (* perform the taint analysis check *) @@ -783,16 +783,16 @@ let do_taint_check caller_pname actual_pre missing_pi missing_sigma sub1 sub2 = match intersection_taint_untaint taint2 untaint2 with | None -> L.d_str "^^^^^^NO TAINT ERROR" | Some e -> begin - L.d_str "^^^^^ERROR in TAINT ANALYSIS: "; - let e' = match Errdesc.find_pvar_with_exp sub2_augmented_actual_pre e with - | Some (pv, _) -> Sil.Lvar pv - | None -> e in - let err_desc = Errdesc.explain_tainted_value_reaching_sensitive_function e' (State.get_loc ()) in - let exn = - Exceptions.Tainted_value_reaching_sensitive_function + L.d_str "^^^^^ERROR in TAINT ANALYSIS: "; + let e' = match Errdesc.find_pvar_with_exp sub2_augmented_actual_pre e with + | Some (pv, _) -> Sil.Lvar pv + | None -> e in + let err_desc = Errdesc.explain_tainted_value_reaching_sensitive_function e' (State.get_loc ()) in + let exn = + Exceptions.Tainted_value_reaching_sensitive_function (err_desc, try assert false with Assert_failure x -> x) in - Reporting.log_warning caller_pname exn - end + Reporting.log_warning caller_pname exn + end let class_cast_exn pname_opt texp1 texp2 exp ml_location = let desc = Errdesc.explain_class_cast_exception pname_opt texp1 texp2 exp (State.get_node ()) (State.get_loc ()) in @@ -816,30 +816,30 @@ let exe_spec let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in let posts = match ret_ids with - | [ret_id] when !Config.idempotent_getters && !Sil.curr_language = Sil.Java -> - (* if we have seen a previous call to the same function, only use specs whose return value - is consistent with constraints on the return value of the previous call w.r.t to nullness. - meant to eliminate false NPE warnings from the common "if (get() != null) get().something()" - pattern *) - let last_call_ret_non_null = - list_exists - (fun (exp, attr) -> - match attr with - | Sil.Aretval pname when Procname.equal callee_pname pname -> - Prover.check_disequal prop exp Sil.exp_zero - | _ -> false) - (Prop.get_all_attributes prop) in - if last_call_ret_non_null then - let returns_null prop = + | [ret_id] when !Config.idempotent_getters && !Sil.curr_language = Sil.Java -> + (* if we have seen a previous call to the same function, only use specs whose return value + is consistent with constraints on the return value of the previous call w.r.t to nullness. + meant to eliminate false NPE warnings from the common "if (get() != null) get().something()" + pattern *) + let last_call_ret_non_null = list_exists - (function - | Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (e, _), _) when Sil.pvar_is_return pvar -> - Prover.check_equal (Prop.normalize prop) e Sil.exp_zero - | _ -> false) - (Prop.get_sigma prop) in - list_filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts - else spec.Specs.posts - | _ -> spec.Specs.posts in + (fun (exp, attr) -> + match attr with + | Sil.Aretval pname when Procname.equal callee_pname pname -> + Prover.check_disequal prop exp Sil.exp_zero + | _ -> false) + (Prop.get_all_attributes prop) in + if last_call_ret_non_null then + let returns_null prop = + list_exists + (function + | Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (e, _), _) when Sil.pvar_is_return pvar -> + Prover.check_equal (Prop.normalize prop) e Sil.exp_zero + | _ -> false) + (Prop.get_sigma prop) in + list_filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts + else spec.Specs.posts + | _ -> spec.Specs.posts in let actual_pre = mk_actual_precondition prop actual_params formal_params in let spec_pre = Specs.Jprop.to_prop spec.Specs.pre in L.d_strln ("EXECUTING SPEC " ^ string_of_int n ^ "/" ^ string_of_int nspecs); @@ -862,19 +862,19 @@ let exe_spec (split, norm_missing_pi, norm_missing_sigma) in let report_valid_res split norm_missing_pi norm_missing_sigma = match combine - cfg ret_ids posts - actual_pre path_pre split - caller_pdesc callee_pname loc with + cfg ret_ids posts + actual_pre path_pre split + caller_pdesc callee_pname loc with | None -> Invalid_res Cannot_combine | Some results -> let inconsistent_results, consistent_results = list_partition (fun (p, _) -> Prover.check_inconsistency p) results in let incons_pre_missing = inconsistent_actualpre_missing actual_pre (Some split) in Valid_res { incons_pre_missing = incons_pre_missing; - vr_pi = norm_missing_pi; - vr_sigma = norm_missing_sigma; - vr_cons_res = consistent_results; - vr_incons_res = inconsistent_results } in + vr_pi = norm_missing_pi; + vr_sigma = norm_missing_sigma; + vr_cons_res = consistent_results; + vr_incons_res = inconsistent_results } in begin list_iter log_check_exn checks; if (!Config.taint_analysis && !Config.developer_mode) then @@ -889,8 +889,8 @@ let exe_spec | [] -> None | (_, p):: l -> (match join_paths l with - | None -> Some p - | Some p' -> Some (Paths.Path.join p p')) in + | None -> Some p + | Some p' -> Some (Paths.Path.join p p')) in let pjoin = join_paths posts in (* join the paths from the posts *) Invalid_res (Dereference_error (deref_error, desc, pjoin)) | None -> @@ -925,7 +925,7 @@ let remove_constant_string_class prop = Prop.normalize prop' (** existentially quantify the path identifier generated by the prover to keep track of expansions of lhs paths -and remove pointsto's whose lhs is a constant string *) + and remove pointsto's whose lhs is a constant string *) let quantify_path_idents_remove_constant_strings (prop: Prop.normal Prop.t) : Prop.normal Prop.t = let fav = Prop.prop_fav prop in Sil.fav_filter_ident fav Ident.is_path; @@ -943,7 +943,7 @@ let prop_pure_to_footprint (p: 'a Prop.t) : Prop.normal Prop.t = if new_footprint_atoms == [] then p else (** add pure fact to footprint *) - Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p) + Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p) (** check whether 0|->- occurs in sigma *) let sigma_has_null_pointer sigma = @@ -976,62 +976,62 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r if !Config.footprint then begin if valid_res_cons_pre_missing == [] then (* no valid results where actual pre and missing are consistent *) - begin - if deref_errors <> [] then (* dereference error detected *) - let extend_path path_opt path_pos_opt = match path_opt with - | None -> () - | Some path_post -> - let old_path, _ = State.get_path () in - let new_path = Paths.Path.add_call (include_subtrace callee_pname) old_path callee_pname path_post in - State.set_path new_path path_pos_opt in - match list_hd deref_errors with - | Dereference_error (Deref_minusone, desc, path_opt) -> - trace_call Specs.CallStats.CR_not_met; - extend_path path_opt None; - raise (Exceptions.Dangling_pointer_dereference (Some Sil.DAminusone, desc, try assert false with Assert_failure x -> x)) - | Dereference_error (Deref_null pos, desc, path_opt) -> - trace_call Specs.CallStats.CR_not_met; - extend_path path_opt (Some pos); - if Localise.is_parameter_not_null_checked_desc desc then - raise (Exceptions.Parameter_not_null_checked (desc, try assert false with Assert_failure x -> x)) - else if Localise.is_field_not_null_checked_desc desc then - raise (Exceptions.Field_not_null_checked (desc, try assert false with Assert_failure x -> x)) - else raise (Exceptions.Null_dereference (desc, try assert false with Assert_failure x -> x)) - | Dereference_error (Deref_freed ra, desc, path_opt) -> - trace_call Specs.CallStats.CR_not_met; - extend_path path_opt None; - raise (Exceptions.Use_after_free (desc, try assert false with Assert_failure x -> x)) - | Dereference_error (Deref_undef (s, loc, pos), desc, path_opt) -> + begin + if deref_errors <> [] then (* dereference error detected *) + let extend_path path_opt path_pos_opt = match path_opt with + | None -> () + | Some path_post -> + let old_path, _ = State.get_path () in + let new_path = Paths.Path.add_call (include_subtrace callee_pname) old_path callee_pname path_post in + State.set_path new_path path_pos_opt in + match list_hd deref_errors with + | Dereference_error (Deref_minusone, desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met; + extend_path path_opt None; + raise (Exceptions.Dangling_pointer_dereference (Some Sil.DAminusone, desc, try assert false with Assert_failure x -> x)) + | Dereference_error (Deref_null pos, desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met; + extend_path path_opt (Some pos); + if Localise.is_parameter_not_null_checked_desc desc then + raise (Exceptions.Parameter_not_null_checked (desc, try assert false with Assert_failure x -> x)) + else if Localise.is_field_not_null_checked_desc desc then + raise (Exceptions.Field_not_null_checked (desc, try assert false with Assert_failure x -> x)) + else raise (Exceptions.Null_dereference (desc, try assert false with Assert_failure x -> x)) + | Dereference_error (Deref_freed ra, desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met; + extend_path path_opt None; + raise (Exceptions.Use_after_free (desc, try assert false with Assert_failure x -> x)) + | Dereference_error (Deref_undef (s, loc, pos), desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met; + extend_path path_opt (Some pos); + raise (Exceptions.Skip_pointer_dereference (desc, try assert false with Assert_failure x -> x)) + | Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty -> + trace_call Specs.CallStats.CR_not_met; + assert false + else (* no dereference error detected *) + let desc = + if list_exists (function Cannot_combine -> true | _ -> false) invalid_res then + call_desc (Some Localise.Pnm_dangling) + else if list_exists (function + | Prover_checks (check :: _) -> + trace_call Specs.CallStats.CR_not_met; + let exn = get_check_exn check callee_pname loc (try assert false with Assert_failure x -> x) in + raise exn + | _ -> false) invalid_res then + call_desc (Some Localise.Pnm_bounds) + else call_desc None in trace_call Specs.CallStats.CR_not_met; - extend_path path_opt (Some pos); - raise (Exceptions.Skip_pointer_dereference (desc, try assert false with Assert_failure x -> x)) - | Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty -> - trace_call Specs.CallStats.CR_not_met; - assert false - else (* no dereference error detected *) - let desc = - if list_exists (function Cannot_combine -> true | _ -> false) invalid_res then - call_desc (Some Localise.Pnm_dangling) - else if list_exists (function - | Prover_checks (check :: _) -> - trace_call Specs.CallStats.CR_not_met; - let exn = get_check_exn check callee_pname loc (try assert false with Assert_failure x -> x) in - raise exn - | _ -> false) invalid_res then - call_desc (Some Localise.Pnm_bounds) - else call_desc None in - trace_call Specs.CallStats.CR_not_met; - raise (Exceptions.Precondition_not_met (desc, try assert false with Assert_failure x -> x)) - end + raise (Exceptions.Precondition_not_met (desc, try assert false with Assert_failure x -> x)) + end else (* combine the valid results, and store diverging states *) - let process_valid_res vr = - let save_diverging_states () = - if not vr.incons_pre_missing && vr.vr_cons_res = [] then (* no consistent results on one spec: divergence *) - let incons_res = list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in - State.add_diverging_states (Paths.PathSet.from_renamed_list incons_res) in - save_diverging_states (); - vr.vr_cons_res in - list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) (list_flatten (list_map process_valid_res valid_res)) + let process_valid_res vr = + let save_diverging_states () = + if not vr.incons_pre_missing && vr.vr_cons_res = [] then (* no consistent results on one spec: divergence *) + let incons_res = list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in + State.add_diverging_states (Paths.PathSet.from_renamed_list incons_res) in + save_diverging_states (); + vr.vr_cons_res in + list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) (list_flatten (list_map process_valid_res valid_res)) end else if valid_res_no_miss_pi != [] then list_flatten (list_map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi) @@ -1060,20 +1060,20 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r !Config.idempotent_getters && !Sil.curr_language = Sil.Java && is_likely_getter callee_pname in match ret_ids with | [ret_id] when should_add_ret_attr ()-> - (* add attribute to remember what function call a return id came from *) - let ret_var = Sil.Var ret_id in - let mark_id_as_retval (p, path) = - (* check if the retval already has an important resource that should not be overwritten *) - let has_important_resource_attr = - match Prop.get_resource_undef_attribute p ret_var with - | Some (Sil.Aresource ({ Sil.ra_res = Sil.Rfile; })) -> true - | _ -> false in - if has_important_resource_attr then p, path - else - let check_attr_change att_old att_new = () in - let att_retval = Sil.Aretval callee_pname in - Prop.add_or_replace_exp_attribute check_attr_change p ret_var att_retval, path in - list_map mark_id_as_retval res + (* add attribute to remember what function call a return id came from *) + let ret_var = Sil.Var ret_id in + let mark_id_as_retval (p, path) = + (* check if the retval already has an important resource that should not be overwritten *) + let has_important_resource_attr = + match Prop.get_resource_undef_attribute p ret_var with + | Some (Sil.Aresource ({ Sil.ra_res = Sil.Rfile; })) -> true + | _ -> false in + if has_important_resource_attr then p, path + else + let check_attr_change att_old att_new = () in + let att_retval = Sil.Aretval callee_pname in + Prop.add_or_replace_exp_attribute check_attr_change p ret_var att_retval, path in + list_map mark_id_as_retval res | _ -> res (** Execute the function call and return the list of results with return value *) diff --git a/infer/src/backend/type_prop.ml b/infer/src/backend/type_prop.ml index 47e7e5944..3c43f030d 100644 --- a/infer/src/backend/type_prop.ml +++ b/infer/src/backend/type_prop.ml @@ -29,7 +29,7 @@ sig type context type field_context val collect_items : Exe_env.t -> Cfg.cfg -> Sil.tenv -> t -> map -> - context -> field_context -> context * field_context * map * ret_t list + context -> field_context -> context * field_context * map * ret_t list val to_t : ret_t -> t val save_items_to_set : bool val t_to_string : t -> string @@ -44,7 +44,7 @@ end (* updating the map, add nodes for which the map changed back to TODO. 4. *) (* Until the set is empty. *) module Control_flow = -functor (TM : TODO_MAP) -> + functor (TM : TODO_MAP) -> struct let set_to_string set = @@ -112,8 +112,8 @@ struct | [] -> "" | [s, typ] -> (match string_typ_to_string (s, typ) with - | Some s -> s - | None -> "") + | Some s -> s + | None -> "") | (s, typ):: rest -> match string_typ_to_string (s, typ) with | Some s -> s^", "^(type_signature_to_string rest) @@ -203,9 +203,9 @@ struct let print_stack stack = let aux (typ, var_kind, level) = print_endline ( - (string_of_int level)^":"^ - (Sil.typ_to_string typ)^"-"^ - (var_kind_to_string var_kind)) in + (string_of_int level)^":"^ + (Sil.typ_to_string typ)^"-"^ + (var_kind_to_string var_kind)) in Stack.iter aux stack let print_map_value map_value = @@ -247,11 +247,11 @@ struct let new_map_value = { map_value with type_stack = stack } in Map.add var new_map_value context with Not_found -> - let var_kind = typ_to_var_kind new_typ in - let stack = Stack.create () in - let _ = Stack.push (new_typ, var_kind, curr_level) stack in - let map_value = { var_level = curr_level; type_stack = stack } in - Map.add var map_value context + let var_kind = typ_to_var_kind new_typ in + let stack = Stack.create () in + let _ = Stack.push (new_typ, var_kind, curr_level) stack in + let map_value = { var_level = curr_level; type_stack = stack } in + Map.add var map_value context (* Adds a type to a path starting from a variable. It replaces the top *) (* of the stack if the level if the same as the current level, or it *) @@ -297,10 +297,10 @@ struct with Not_found -> assert false in match Stack.top map_value.type_stack with | (typ, var_kind, level) -> - (* print_string ((key_to_string pvar)^"->"); print_endline ("typ is *) - (* "^(Sil.typ_to_string typ)); print_endline (var_kind_to_string *) - (* var_kind); print_string "the path is "; print_endline *) - (* (Utils.list_to_string Ident.fieldname_to_string path); *) + (* print_string ((key_to_string pvar)^"->"); print_endline ("typ is *) + (* "^(Sil.typ_to_string typ)); print_endline (var_kind_to_string *) + (* var_kind); print_string "the path is "; print_endline *) + (* (Utils.list_to_string Ident.fieldname_to_string path); *) get_type_var_kind tenv typ path var_kind end @@ -317,8 +317,8 @@ let rec super tenv t = | Sil.Tptr (dom_type, p) -> let super_dom_type = super tenv dom_type in (match super_dom_type with - | None -> None - | Some super -> Some (Sil.Tptr (super, p))) + | None -> None + | Some super -> Some (Sil.Tptr (super, p))) | _ -> None let rec lub tenv t1 t2 = @@ -444,20 +444,20 @@ struct match exp with | Sil.Var id -> (match get_id_exptyp id id_context with - | Exp exp -> aux exp - | Typ typ -> typ) + | Exp exp -> aux exp + | Typ typ -> typ) | Sil.UnOp (unop, exp, typ) -> aux exp | Sil.BinOp (binop, exp1, exp2) -> aux exp1 | Sil.Const const -> get_const_type const | Sil.Cast (typ, exp) -> typ | Sil.Lfield (e, fld, typ) -> (try Field_context.Map.find fld field_context - with Not_found -> retrieve_type tenv fld typ) + with Not_found -> retrieve_type tenv fld typ) | Sil.Lindex (Sil.Var id, i) -> (match get_id_exptyp id id_context with - | Exp (Sil.Lvar pvar) -> - Context_map.get_type_content tenv pvar [] context - | _ -> assert false) + | Exp (Sil.Lvar pvar) -> + Context_map.get_type_content tenv pvar [] context + | _ -> assert false) | Sil.Sizeof (typ, sub) -> assert false | Sil.Lvar pvar -> Context_map.get_type pvar context @@ -488,8 +488,8 @@ struct let pred = try list_find (fun p -> not (Set.mem p set)) preds with Not_found -> - try list_hd preds - with Failure "hd" -> Set.min_elt set in + try list_hd preds + with Failure "hd" -> Set.min_elt set in (aux pred) in if (Set.mem old_node set) then backtrack () else @@ -500,8 +500,8 @@ struct node in match el with | Some old_node -> - (* print_endline "choosing an element when old_element is "; *) - (* print_endline (t_to_string old_node); *) + (* print_endline "choosing an element when old_element is "; *) + (* print_endline (t_to_string old_node); *) aux old_node | None -> choose_start_node () @@ -532,23 +532,23 @@ struct let exp_typ = get_type tenv exp id_context context field_context in let context, field_context = (match exp1 with - | Sil.Lvar pvar -> - (* print_endline ("trying to add variable "^(Context_map.key_to_string *) - (* pvar) ); print_endline ("with type "^(Sil.typ_to_string exp_typ)); *) - (* print_endline "Context"; Context_map.print_map context; *) - Context_map.add_type pvar exp_typ 0 context, field_context - | Sil.Lfield (e, fld, typ) -> - context, Field_context.add_type tenv fld exp_typ field_context - | Sil.Lindex (Sil.Var id, _) -> - (match get_id_exptyp id id_context with - | Exp (Sil.Lvar pvar) -> - Context_map.add_type_content pvar [] exp_typ 0 context, field_context - | _ -> assert false) - | _ -> assert false) in + | Sil.Lvar pvar -> + (* print_endline ("trying to add variable "^(Context_map.key_to_string *) + (* pvar) ); print_endline ("with type "^(Sil.typ_to_string exp_typ)); *) + (* print_endline "Context"; Context_map.print_map context; *) + Context_map.add_type pvar exp_typ 0 context, field_context + | Sil.Lfield (e, fld, typ) -> + context, Field_context.add_type tenv fld exp_typ field_context + | Sil.Lindex (Sil.Var id, _) -> + (match get_id_exptyp id id_context with + | Exp (Sil.Lvar pvar) -> + Context_map.add_type_content pvar [] exp_typ 0 context, field_context + | _ -> assert false) + | _ -> assert false) in id_context, context, field_context, map, list | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), actual_params, loc, call_flags) - when not (SymExec.function_is_builtin callee_pname) -> - (* TODO: constraint for virtual calls *) + when not (SymExec.function_is_builtin callee_pname) -> + (* TODO: constraint for virtual calls *) let cfg = if (Procname.Set.mem callee_pname !defined_methods) then Exe_env.get_cfg exe_env callee_pname @@ -573,22 +573,22 @@ struct id_context, context, field_context, map', list else id_context, context, field_context, map, list | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), [(exp, class_type)], loc, call_flags) - when Procname.equal callee_pname SymExec.ModelBuiltins.__new -> + when Procname.equal callee_pname SymExec.ModelBuiltins.__new -> let id_context = set_ids ret_ids class_type id_context in id_context, context, field_context, map, list | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), - [(array_size, array_type)], loc, call_flags) - when Procname.equal callee_pname SymExec.ModelBuiltins.__new_array -> + [(array_size, array_type)], loc, call_flags) + when Procname.equal callee_pname SymExec.ModelBuiltins.__new_array -> let id_context = set_ids ret_ids array_type id_context in id_context, context, field_context, map, list | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), - [(sil_ex, type_of_ex); (Sil.Sizeof (typ, _), Sil.Tvoid)], loc, call_flags) - when Procname.equal callee_pname SymExec.ModelBuiltins.__cast -> + [(sil_ex, type_of_ex); (Sil.Sizeof (typ, _), Sil.Tvoid)], loc, call_flags) + when Procname.equal callee_pname SymExec.ModelBuiltins.__cast -> let id_context = set_ids ret_ids typ id_context in id_context, context, field_context, map, list | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), - [(sil_ex, type_of_ex); (_, Sil.Tvoid)], loc, call_flags) - when Procname.equal callee_pname SymExec.ModelBuiltins.__instanceof -> + [(sil_ex, type_of_ex); (_, Sil.Tvoid)], loc, call_flags) + when Procname.equal callee_pname SymExec.ModelBuiltins.__instanceof -> let id_context = set_ids ret_ids (Sil.Tint Sil.IBool) id_context in id_context, context, field_context, map, list | _ -> id_context, context, field_context, map, list in @@ -710,8 +710,8 @@ let arg_desc = let options_to_keep = ["-results_dir"] in let filter arg_desc = list_filter (fun desc -> - let (option_name, _, _, _) = desc in - list_mem string_equal option_name options_to_keep) + let (option_name, _, _, _) = desc in + list_mem string_equal option_name options_to_keep) arg_desc in let desc = (filter Utils.base_arg_desc) in Utils.Arg2.create_options_desc false "Parsing Options" desc in @@ -771,7 +771,7 @@ let load_cg_files _exe_env (source_dirs : DB.source_dir list) = match Exe_env.add_cg _exe_env source_dir with | None -> () | Some cg -> - (*L.err "loaded %s@." (DB.source_dir_to_string source_dir) *) () in + (*L.err "loaded %s@." (DB.source_dir_to_string source_dir) *) () in list_iter (fun source_dir -> load_cg_file _exe_env source_dir) source_dirs; let exe_env = Exe_env.freeze _exe_env in exe_env diff --git a/infer/src/backend/utils.ml b/infer/src/backend/utils.ml index 6e4c3d6b3..4ced56cf4 100644 --- a/infer/src/backend/utils.ml +++ b/infer/src/backend/utils.ml @@ -96,8 +96,8 @@ let list_split = | [] -> (acc1, acc2) | (x, y):: l -> split (x:: acc1) (y:: acc2) l in fun l -> - let acc1, acc2 = split [] [] l in - list_rev acc1, list_rev acc2 + let acc1, acc2 = split [] [] l in + list_rev acc1, list_rev acc2 (** Like List.mem but without builtin equality *) let list_mem equal x l = list_exists (equal x) l @@ -309,7 +309,7 @@ let pe_extend_colormap pe (x: Obj.t) (c: color) = { pe with pe_cmap_norm = colormap } (** Set the object substitution, which is supposed to preserve the type. -Currently only used for a map from (identifier) expressions to the program var containing them *) + Currently only used for a map from (identifier) expressions to the program var containing them *) let pe_set_obj_sub pe (sub: 'a -> 'a) = let new_obj_sub x = let x' = Obj.repr (sub (Obj.obj x)) in @@ -351,10 +351,10 @@ let rec _pp_semicolon_seq oneline pe pp f = | [x] -> F.fprintf f "%a" pp x | x:: l -> (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a ; %a%a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l - | PP_LATEX -> - F.fprintf f "%a ;\\\\%a %a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l) + | PP_TEXT | PP_HTML -> + F.fprintf f "%a ; %a%a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l + | PP_LATEX -> + F.fprintf f "%a ;\\\\%a %a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l) (** Print a ;-separated sequence with newlines. *) let pp_semicolon_seq pe = _pp_semicolon_seq false pe @@ -368,12 +368,12 @@ let rec pp_or_seq pe pp f = function | [x] -> F.fprintf f "%a" pp x | x:: l -> (match pe.pe_kind with - | PP_TEXT -> - F.fprintf f "%a || %a" pp x (pp_semicolon_seq pe pp) l - | PP_HTML -> - F.fprintf f "%a ∨ %a" pp x (pp_semicolon_seq pe pp) l - | PP_LATEX -> - F.fprintf f "%a \\vee %a" pp x (pp_semicolon_seq pe pp) l) + | PP_TEXT -> + F.fprintf f "%a || %a" pp x (pp_semicolon_seq pe pp) l + | PP_HTML -> + F.fprintf f "%a ∨ %a" pp x (pp_semicolon_seq pe pp) l + | PP_LATEX -> + F.fprintf f "%a \\vee %a" pp x (pp_semicolon_seq pe pp) l) (** Produce a string from a 1-argument pretty printer function *) let pp_to_string pp x = @@ -634,19 +634,19 @@ let copy_file fname_from fname_to = None module FileLOC = (** count lines of code of files and keep processed results in a cache *) - struct - let include_loc_hash = Hashtbl.create 1 - - let reset () = Hashtbl.clear include_loc_hash - - let file_get_loc fname = - try Hashtbl.find include_loc_hash fname with Not_found -> - let loc = match read_file fname with - | None -> 0 - | Some l -> list_length l in - Hashtbl.add include_loc_hash fname loc; - loc - end +struct + let include_loc_hash = Hashtbl.create 1 + + let reset () = Hashtbl.clear include_loc_hash + + let file_get_loc fname = + try Hashtbl.find include_loc_hash fname with Not_found -> + let loc = match read_file fname with + | None -> 0 + | Some l -> list_length l in + Hashtbl.add include_loc_hash fname loc; + loc +end (** type for files used for printing *) type outfile = @@ -661,8 +661,8 @@ let create_outfile fname = let fmt = F.formatter_of_out_channel out_c in Some { fname = fname; out_c = out_c; fmt = fmt } with Sys_error _ -> - F.fprintf F.err_formatter "error: cannot create file %s@." fname; - None + F.fprintf F.err_formatter "error: cannot create file %s@." fname; + None (** operate on an outfile reference if it is not None *) let do_outf outf_ref f = @@ -769,63 +769,63 @@ let filename_to_relative root fname = let base_arg_desc = [ - "-results_dir", - Arg.String (fun s -> Config.results_dir := s), - Some "dir", - "set the project results directory (default dir=" ^ Config.default_results_dir ^ ")"; - "-coverage", - Arg.Unit (fun () -> Config.worklist_mode:= 2), - None, - "analysis mode to maximize coverage (can take longer)"; - "-lib", - Arg.String (fun s -> Config.specs_library := filename_to_absolute s :: !Config.specs_library), - Some "dir", - "add dir to the list of directories to be searched for spec files"; - "-models", - Arg.String (fun s -> Config.add_models (filename_to_absolute s)), - Some "zip file", - "add a zip file containing the models"; - "-ziplib", - Arg.String (fun s -> Config.add_zip_library (filename_to_absolute s)), - Some "zip file", - "add a zip file containing library spec files"; - "-project_root", - Arg.String (fun s -> Config.project_root := Some (filename_to_absolute s)), - Some "dir", - "root directory of the project"; - "-infer_cache", - Arg.String (fun s -> Config.JarCache.infer_cache := Some (filename_to_absolute s)), - Some "dir", - "Select a directory to contain the infer cache"; + "-results_dir", + Arg.String (fun s -> Config.results_dir := s), + Some "dir", + "set the project results directory (default dir=" ^ Config.default_results_dir ^ ")"; + "-coverage", + Arg.Unit (fun () -> Config.worklist_mode:= 2), + None, + "analysis mode to maximize coverage (can take longer)"; + "-lib", + Arg.String (fun s -> Config.specs_library := filename_to_absolute s :: !Config.specs_library), + Some "dir", + "add dir to the list of directories to be searched for spec files"; + "-models", + Arg.String (fun s -> Config.add_models (filename_to_absolute s)), + Some "zip file", + "add a zip file containing the models"; + "-ziplib", + Arg.String (fun s -> Config.add_zip_library (filename_to_absolute s)), + Some "zip file", + "add a zip file containing library spec files"; + "-project_root", + Arg.String (fun s -> Config.project_root := Some (filename_to_absolute s)), + Some "dir", + "root directory of the project"; + "-infer_cache", + Arg.String (fun s -> Config.JarCache.infer_cache := Some (filename_to_absolute s)), + Some "dir", + "Select a directory to contain the infer cache"; ] let reserved_arg_desc = [ - "-absstruct", Arg.Set_int Config.abs_struct, Some "n", "abstraction level for fields of structs (default n = 1)"; - "-absval", Arg.Set_int Config.abs_val, Some "n", "abstraction level for expressions (default n = 2)"; - "-arraylevel", Arg.Set_int Config.array_level, Some "n", "the level of treating the array indexing and pointer arithmetic (default n = 0)"; - "-developer_mode", Arg.Set Config.developer_mode, None, "reserved"; - "-dotty", Arg.Set Config.write_dotty, None, "produce dotty files in the results directory"; - "-exit_node_bias", Arg.Unit (fun () -> Config.worklist_mode:= 1), None, "nodes nearest the exit node are analyzed first"; - "-html", Arg.Set Config.write_html, None, "produce hmtl output in the results directory"; - "-join_cond", Arg.Set_int Config.join_cond, Some "n", "set the strength of the final information-loss check used by the join (default n=1)"; - "-leak", Arg.Set Config.allowleak, None, "forget leaks during abstraction"; - "-max_procs", Arg.Set_int Config.max_num_proc, Some "n", "set the maximum number of processes to be used for parallel execution (default n=0)"; - "-monitor_prop_size", Arg.Set Config.monitor_prop_size, None, "monitor size of props"; - "-nelseg", Arg.Set Config.nelseg, None, "use only nonempty lsegs"; - "-noliveness", Arg.Clear Config.liveness, None, "turn the dead program variable elimination off"; - "-noprintdiff", Arg.Clear Config.print_using_diff, None, "turn off highlighting diff w.r.t. previous prop in printing"; - "-notest", Arg.Clear Config.test, None, "turn test mode off"; - "-num_cores", Arg.Set_int Config.num_cores, Some "n", "set the number of cores used in parallel by the analysis (default n=1)"; - "-only_footprint", Arg.Set Config.only_footprint, None, "skip the re-execution phase"; - "-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps"; - "-set_pp_margin", Arg.Int (fun i -> F.set_margin i), Some "n", "set right margin for the pretty printing functions"; - "-slice_fun", Arg.Set_string Config.slice_fun, None, "analyze only functions recursively called by function given as argument"; - "-spec_abs_level", Arg.Set_int Config.spec_abs_level, Some "n", "set the level of abstracting the postconditions of discovered specs (default n=1)"; - "-trace_error", Arg.Set Config.trace_error, None, "turn on tracing of error explanation"; - "-trace_join", Arg.Set Config.trace_join, None, "turn on tracing of join"; - "-trace_rearrange", Arg.Set Config.trace_rearrange, None, "turn on tracing of rearrangement"; - "-visits_bias", Arg.Unit (fun () -> Config.worklist_mode:= 2), None, "nodes visited fewer times are analyzed first"; + "-absstruct", Arg.Set_int Config.abs_struct, Some "n", "abstraction level for fields of structs (default n = 1)"; + "-absval", Arg.Set_int Config.abs_val, Some "n", "abstraction level for expressions (default n = 2)"; + "-arraylevel", Arg.Set_int Config.array_level, Some "n", "the level of treating the array indexing and pointer arithmetic (default n = 0)"; + "-developer_mode", Arg.Set Config.developer_mode, None, "reserved"; + "-dotty", Arg.Set Config.write_dotty, None, "produce dotty files in the results directory"; + "-exit_node_bias", Arg.Unit (fun () -> Config.worklist_mode:= 1), None, "nodes nearest the exit node are analyzed first"; + "-html", Arg.Set Config.write_html, None, "produce hmtl output in the results directory"; + "-join_cond", Arg.Set_int Config.join_cond, Some "n", "set the strength of the final information-loss check used by the join (default n=1)"; + "-leak", Arg.Set Config.allowleak, None, "forget leaks during abstraction"; + "-max_procs", Arg.Set_int Config.max_num_proc, Some "n", "set the maximum number of processes to be used for parallel execution (default n=0)"; + "-monitor_prop_size", Arg.Set Config.monitor_prop_size, None, "monitor size of props"; + "-nelseg", Arg.Set Config.nelseg, None, "use only nonempty lsegs"; + "-noliveness", Arg.Clear Config.liveness, None, "turn the dead program variable elimination off"; + "-noprintdiff", Arg.Clear Config.print_using_diff, None, "turn off highlighting diff w.r.t. previous prop in printing"; + "-notest", Arg.Clear Config.test, None, "turn test mode off"; + "-num_cores", Arg.Set_int Config.num_cores, Some "n", "set the number of cores used in parallel by the analysis (default n=1)"; + "-only_footprint", Arg.Set Config.only_footprint, None, "skip the re-execution phase"; + "-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps"; + "-set_pp_margin", Arg.Int (fun i -> F.set_margin i), Some "n", "set right margin for the pretty printing functions"; + "-slice_fun", Arg.Set_string Config.slice_fun, None, "analyze only functions recursively called by function given as argument"; + "-spec_abs_level", Arg.Set_int Config.spec_abs_level, Some "n", "set the level of abstracting the postconditions of discovered specs (default n=1)"; + "-trace_error", Arg.Set Config.trace_error, None, "turn on tracing of error explanation"; + "-trace_join", Arg.Set Config.trace_join, None, "turn on tracing of join"; + "-trace_rearrange", Arg.Set Config.trace_rearrange, None, "turn on tracing of rearrangement"; + "-visits_bias", Arg.Unit (fun () -> Config.worklist_mode:= 2), None, "nodes visited fewer times are analyzed first"; ] (**************** START MODULE Arg2 -- modified from Arg in the ocaml distribution ***************) @@ -864,7 +864,7 @@ module Arg2 = struct let print_spec buf (key, spec, doc) = match spec with | Arg.Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) - doc + doc | _ -> let sep = if String.length doc != 0 && String.get doc 0 = '=' then "" else " " in bprintf buf " %s%s%s\n" key sep doc @@ -875,11 +875,11 @@ module Arg2 = struct let add1 = try ignore (assoc3 "-help" speclist); [] with Not_found -> - ["-help", Arg.Unit help_action, " Display this list of options"] + ["-help", Arg.Unit help_action, " Display this list of options"] and add2 = try ignore (assoc3 "--help" speclist); [] with Not_found -> - ["--help", Arg.Unit help_action, " Display this list of options"] + ["--help", Arg.Unit help_action, " Display this list of options"] in speclist @ (add1 @ add2) @@ -926,72 +926,72 @@ module Arg2 = struct with Not_found -> stop (Unknown s) in begin try - let rec treat_action = function - | Arg.Unit f -> f (); - | Arg.Bool f when !current + 1 < l -> - let arg = argv.(!current + 1) in - begin try f (bool_of_string arg) - with Invalid_argument "bool_of_string" -> - raise (Stop (Wrong (s, arg, "a boolean"))) - end; - incr current; - | Arg.Set r -> r := true; - | Arg.Clear r -> r := false; - | Arg.String f when !current + 1 < l -> - f argv.(!current + 1); - incr current; - | Arg.Symbol (symb, f) when !current + 1 < l -> - let arg = argv.(!current + 1) in - if list_mem string_equal arg symb then begin - f argv.(!current + 1); + let rec treat_action = function + | Arg.Unit f -> f (); + | Arg.Bool f when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try f (bool_of_string arg) + with Invalid_argument "bool_of_string" -> + raise (Stop (Wrong (s, arg, "a boolean"))) + end; incr current; - end else begin - raise (Stop (Wrong (s, arg, "one of: " - ^ (make_symlist "" " " "" symb)))) - end - | Arg.Set_string r when !current + 1 < l -> - r := argv.(!current + 1); - incr current; - | Arg.Int f when !current + 1 < l -> - let arg = argv.(!current + 1) in - begin try f (int_of_string arg) - with Failure "int_of_string" -> - raise (Stop (Wrong (s, arg, "an integer"))) - end; - incr current; - | Arg.Set_int r when !current + 1 < l -> - let arg = argv.(!current + 1) in - begin try r := (int_of_string arg) - with Failure "int_of_string" -> - raise (Stop (Wrong (s, arg, "an integer"))) - end; - incr current; - | Arg.Float f when !current + 1 < l -> - let arg = argv.(!current + 1) in - begin try f (float_of_string arg); - with Failure "float_of_string" -> - raise (Stop (Wrong (s, arg, "a float"))) - end; - incr current; - | Arg.Set_float r when !current + 1 < l -> - let arg = argv.(!current + 1) in - begin try r := (float_of_string arg); - with Failure "float_of_string" -> - raise (Stop (Wrong (s, arg, "a float"))) - end; - incr current; - | Arg.Tuple specs -> - list_iter treat_action specs; - | Arg.Rest f -> - while !current < l - 1 do + | Arg.Set r -> r := true; + | Arg.Clear r -> r := false; + | Arg.String f when !current + 1 < l -> f argv.(!current + 1); incr current; - done; - | _ -> raise (Stop (Missing s)) - in - treat_action action - with Bad m -> stop (Message m); - | Stop e -> stop e; + | Arg.Symbol (symb, f) when !current + 1 < l -> + let arg = argv.(!current + 1) in + if list_mem string_equal arg symb then begin + f argv.(!current + 1); + incr current; + end else begin + raise (Stop (Wrong (s, arg, "one of: " + ^ (make_symlist "" " " "" symb)))) + end + | Arg.Set_string r when !current + 1 < l -> + r := argv.(!current + 1); + incr current; + | Arg.Int f when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try f (int_of_string arg) + with Failure "int_of_string" -> + raise (Stop (Wrong (s, arg, "an integer"))) + end; + incr current; + | Arg.Set_int r when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try r := (int_of_string arg) + with Failure "int_of_string" -> + raise (Stop (Wrong (s, arg, "an integer"))) + end; + incr current; + | Arg.Float f when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try f (float_of_string arg); + with Failure "float_of_string" -> + raise (Stop (Wrong (s, arg, "a float"))) + end; + incr current; + | Arg.Set_float r when !current + 1 < l -> + let arg = argv.(!current + 1) in + begin try r := (float_of_string arg); + with Failure "float_of_string" -> + raise (Stop (Wrong (s, arg, "a float"))) + end; + incr current; + | Arg.Tuple specs -> + list_iter treat_action specs; + | Arg.Rest f -> + while !current < l - 1 do + f argv.(!current + 1); + incr current; + done; + | _ -> raise (Stop (Missing s)) + in + treat_action action + with Bad m -> stop (Message m); + | Stop e -> stop e; end; incr current; end else begin @@ -1117,8 +1117,8 @@ let join_strings sep = function let next compare = fun x y n -> - if n <> 0 then n - else compare x y + if n <> 0 then n + else compare x y let directory_fold f init path = @@ -1130,7 +1130,7 @@ let directory_fold f init path = else (f accu full_path, dirs) with Sys_error _ -> - (accu, dirs) in + (accu, dirs) in let rec loop accu dirs = match dirs with | [] -> accu @@ -1153,7 +1153,7 @@ let directory_iter f path = let () = f full_path in dirs with Sys_error _ -> - dirs in + dirs in let rec loop dirs = match dirs with | [] -> () diff --git a/infer/src/checkers/annotations.ml b/infer/src/checkers/annotations.ml index fe6cd9b31..48aec40db 100644 --- a/infer/src/checkers/annotations.ml +++ b/infer/src/checkers/annotations.ml @@ -40,9 +40,9 @@ let get_field_type_and_annotation fn = function | Sil.Tptr (Sil.Tstruct (ftal, sftal, _, _, _, _, _), _) | Sil.Tstruct (ftal, sftal, _, _, _, _, _) -> (try - let (_, t, a) = list_find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in - Some (t, a) - with Not_found -> None) + let (_, t, a) = list_find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in + Some (t, a) + with Not_found -> None) | _ -> None let ia_iter f = @@ -140,7 +140,7 @@ let ia_is ann ia = match ann with type get_method_annotation = Procname.t -> Cfg.Procdesc.t -> Sil.method_annotation (** Get a method signature with annotations from a proc_name and proc_desc, -or search in the .specs file if it is not defined in the proc_desc. *) + or search in the .specs file if it is not defined in the proc_desc. *) let get_annotated_signature get_method_annotation proc_desc proc_name : annotated_signature = let method_annotation = get_method_annotation proc_name proc_desc in let formals = Cfg.Procdesc.get_formals proc_desc in @@ -157,8 +157,8 @@ let get_annotated_signature get_method_annotation proc_desc proc_name : annotate annotated_signature (** Check if the annotated signature is for a wrapper of an anonymous inner class method. -These wrappers have the same name as the original method, every type is Object, and the parameters -are called x0, x1, x2. *) + These wrappers have the same name as the original method, every type is Object, and the parameters + are called x0, x1, x2. *) let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name = let check_ret (ia, t) = Sil.item_annotation_is_empty ia && PatternMatch.type_is_object t in @@ -188,10 +188,10 @@ let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name = (** Check if the given parameter has a Nullable annotation in the given signature *) let param_is_nullable pvar ann_sig = - let pvar_str = Mangled.to_string (Sil.pvar_get_name pvar) in - list_exists - (fun (param_str, annot, _) -> param_str = pvar_str && ia_is_nullable annot) - ann_sig.params + let pvar_str = Mangled.to_string (Sil.pvar_get_name pvar) in + list_exists + (fun (param_str, annot, _) -> param_str = pvar_str && ia_is_nullable annot) + ann_sig.params (** Pretty print a method signature with annotations. *) let pp_annotated_signature proc_name fmt annotated_signature = diff --git a/infer/src/checkers/callbackChecker.ml b/infer/src/checkers/callbackChecker.ml index 1f15acbd3..8f313ce2f 100644 --- a/infer/src/checkers/callbackChecker.ml +++ b/infer/src/checkers/callbackChecker.ml @@ -23,7 +23,7 @@ let get_fields_nullified procdesc = (* walk through the instructions and look for instance fields that are assigned to null *) let collect_nullified_flds (nullified_flds, this_ids) _ = function | Sil.Set (Sil.Lfield (Sil.Var lhs, fld, _), typ, rhs, loc) - when Sil.exp_is_null_literal rhs && IdSet.mem lhs this_ids -> + when Sil.exp_is_null_literal rhs && IdSet.mem lhs this_ids -> (FldSet.add fld nullified_flds, this_ids) | Sil.Letderef (id, rhs, _, _) when Sil.exp_is_this rhs -> (nullified_flds, IdSet.add id this_ids) @@ -44,12 +44,12 @@ let android_lifecycle_typs = ref [] let get_or_create_lifecycle_typs tenv = match !android_lifecycle_typs with | [] -> let lifecycle_typs = list_fold_left (fun typs (pkg, clazz, methods) -> - let qualified_name = Mangled.from_package_class pkg clazz in - match AndroidFramework.get_lifecycle_for_framework_typ_opt + let qualified_name = Mangled.from_package_class pkg clazz in + match AndroidFramework.get_lifecycle_for_framework_typ_opt qualified_name methods tenv with - | Some (framework_typ, _) -> framework_typ :: typs - | None -> typs - ) [] AndroidFramework.get_lifecycles in + | Some (framework_typ, _) -> framework_typ :: typs + | None -> typs + ) [] AndroidFramework.get_lifecycles in android_lifecycle_typs := lifecycle_typs; lifecycle_typs | typs -> typs @@ -64,21 +64,21 @@ let done_checking num_methods = !num_methods_checked = num_methods (** ask Eradicate to check each of the procs in [registered_callback_procs] (and their transitive -* callees) in a context where each of the fields in [fields_nullifed] is marked as @Nullable *) + * callees) in a context where each of the fields in [fields_nullifed] is marked as @Nullable *) let do_eradicate_check all_procs get_procdesc idenv tenv = (* tell Eradicate to treat each of the fields nullified in on_destroy as nullable *) FldSet.iter (fun fld -> Models.Inference.field_add_nullable_annotation fld) !fields_nullified; Procname.Set.iter (fun proc_name -> - match get_procdesc proc_name with - | Some proc_desc -> - do_eradicate_check all_procs get_procdesc idenv tenv proc_name proc_desc - | None -> ()) + match get_procdesc proc_name with + | Some proc_desc -> + do_eradicate_check all_procs get_procdesc idenv tenv proc_name proc_desc + | None -> ()) !registered_callback_procs (** if [procname] belongs to an Android lifecycle type, save the set of callbacks registered in -* [procname]. in addition, if [procname] is a special "destroy" /"cleanup" method, save the set of -* fields that are nullified *) + * [procname]. in addition, if [procname] is a special "destroy" /"cleanup" method, save the set of + * fields that are nullified *) let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc = match Sil.get_typ (Mangled.from_string (Procname.java_get_class proc_name)) None tenv with | Some (Sil.Tstruct(_, _, csu, Some class_name, _, methods, _) as typ) -> @@ -93,15 +93,15 @@ let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc (* find the callbacks registered by this procedure and update the list *) let registered_callback_procs' = list_fold_left (fun callback_procs callback_typ -> - match callback_typ with - | Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) -> - list_fold_left - (fun callback_procs callback_proc -> - if Procname.is_constructor callback_proc then callback_procs - else Procname.Set.add callback_proc callback_procs) - callback_procs - methods - | typ -> callback_procs) + match callback_typ with + | Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) -> + list_fold_left + (fun callback_procs callback_proc -> + if Procname.is_constructor callback_proc then callback_procs + else Procname.Set.add callback_proc callback_procs) + callback_procs + methods + | typ -> callback_procs) !registered_callback_procs registered_callback_typs in registered_callback_procs := registered_callback_procs'; diff --git a/infer/src/checkers/checkers.ml b/infer/src/checkers/checkers.ml index 0887e69fb..990c9d21e 100644 --- a/infer/src/checkers/checkers.ml +++ b/infer/src/checkers/checkers.ml @@ -18,7 +18,7 @@ let verbose = ref true (** Convenience functions for chechers to print information *) module PP = struct (** Print a range of lines of the source file in [loc], including [nbefore] lines before loc - and [nafter] lines after [loc] *) + and [nafter] lines after [loc] *) let pp_loc_range linereader nbefore nafter fmt loc = let printline n = match Printer.LineReader.from_loc linereader { loc with Sil.line = n } with | Some s -> F.fprintf fmt "%s%s@\n" (if n = loc.Sil.line then "-->" else " ") s @@ -56,7 +56,7 @@ module ST = struct let store_summary proc_name = Option.may (fun summary -> - try Specs.store_summary proc_name summary with Sys_error s -> L.err "%s@." s) + try Specs.store_summary proc_name summary with Sys_error s -> L.err "%s@." s) (Specs.get_summary proc_name) let report_error @@ -77,10 +77,10 @@ module ST = struct let exn = exception_kind kind localized_description in (* Errors can be suppressed with annotations. An error of kind CHECKER_ERROR_NAME can be - suppressed with the following annotations: - - @android.annotation.SuppressLint("checker-error-name") - - @some.PrefixErrorName - where the kind matching is case - insensitive and ignores '-' and '_' characters. *) + suppressed with the following annotations: + - @android.annotation.SuppressLint("checker-error-name") + - @some.PrefixErrorName + where the kind matching is case - insensitive and ignores '-' and '_' characters. *) let suppressed = let annotation_matches a = let normalize str = @@ -106,19 +106,19 @@ module ST = struct let is_field_suppressed = match field_name, PatternMatch.get_this_type proc_desc with | Some field_name, Some t -> begin - match (Annotations.get_field_type_and_annotation field_name t) with - | Some (_, ia) -> Annotations.ia_has_annotation_with ia annotation_matches - | None -> false - end + match (Annotations.get_field_type_and_annotation field_name t) with + | Some (_, ia) -> Annotations.ia_has_annotation_with ia annotation_matches + | None -> false + end | _ -> false in let is_class_suppressed = match (PatternMatch.get_this_type proc_desc) with | Some t -> begin - match (PatternMatch.type_get_annotation t) with - | Some ia -> Annotations.ia_has_annotation_with ia annotation_matches - | None -> false - end + match (PatternMatch.type_get_annotation t) with + | Some ia -> Annotations.ia_has_annotation_with ia annotation_matches + | None -> false + end | None -> false in is_method_suppressed || is_field_suppressed || is_class_suppressed in @@ -213,8 +213,8 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name let class_name = Procname.java_get_class proc_name in let method_name = Procname.java_get_method proc_name in (try - class_name = "android.os.Parcel" && (String.sub method_name 0 5 = "write" || String.sub method_name 0 4 = "read") - with Invalid_argument _ -> false) + class_name = "android.os.Parcel" && (String.sub method_name 0 5 = "write" || String.sub method_name 0 4 = "read") + with Invalid_argument _ -> false) | _ -> assert false in let is_inverse rc wc = @@ -256,9 +256,9 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name match parcel_constructors this_type with | x :: xs -> (match get_proc_desc x with - | Some x_proc_desc -> - check x x_proc_desc proc_name proc_desc - | None -> raise Not_found) + | Some x_proc_desc -> + check x x_proc_desc proc_name proc_desc + | None -> raise Not_found) | _ -> L.stdout "No parcel constructor found for %a@." Procname.pp proc_name with Not_found -> if !verbose then L.stdout "Methods not available@." end @@ -270,15 +270,15 @@ let callback_monitor_nullcheck all_procs get_proc_desc idenv tenv proc_name proc let verbose = ref false in let class_formal_names = lazy ( - let formals = Cfg.Procdesc.get_formals proc_desc in - let class_formals = - let is_class_type = function - | "this", Sil.Tptr _ -> false (* no need to null check 'this' *) - | _, Sil.Tstruct _ -> true - | _, Sil.Tptr (Sil.Tstruct _, _) -> true - | _ -> false in - list_filter is_class_type formals in - list_map (fun (s, _) -> Mangled.from_string s) class_formals) in + let formals = Cfg.Procdesc.get_formals proc_desc in + let class_formals = + let is_class_type = function + | "this", Sil.Tptr _ -> false (* no need to null check 'this' *) + | _, Sil.Tstruct _ -> true + | _, Sil.Tptr (Sil.Tstruct _, _) -> true + | _ -> false in + list_filter is_class_type formals in + list_map (fun (s, _) -> Mangled.from_string s) class_formals) in let equal_formal_param exp formal_name = match exp with | Sil.Lvar pvar -> let name = Sil.pvar_get_name pvar in @@ -363,40 +363,40 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name p try ST.pname_find proc_name' ret_const_key with Not_found -> - match get_proc_desc proc_name' with - Some proc_desc' -> - let is_return_instr = function - | Sil.Set (Sil.Lvar p, _, _, _) + match get_proc_desc proc_name' with + Some proc_desc' -> + let is_return_instr = function + | Sil.Set (Sil.Lvar p, _, _, _) when Sil.pvar_equal p (Cfg.Procdesc.get_ret_var proc_desc') -> true - | _ -> false in - (match reverse_find_instr is_return_instr (Cfg.Procdesc.get_exit_node proc_desc') with - | Some (Sil.Set (_, _, Sil.Const (Sil.Cclass n), _)) -> Ident.name_to_string n - | _ -> "<" ^ (Procname.to_string proc_name') ^ ">") - | None -> "?" in + | _ -> false in + (match reverse_find_instr is_return_instr (Cfg.Procdesc.get_exit_node proc_desc') with + | Some (Sil.Set (_, _, Sil.Const (Sil.Cclass n), _)) -> Ident.name_to_string n + | _ -> "<" ^ (Procname.to_string proc_name') ^ ">") + | None -> "?" in let get_actual_arguments node instr = match instr with | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> (try - let find_const exp typ = - let expanded = Idenv.expand_expr idenv exp in - match expanded with - | Sil.Const (Sil.Cclass n) -> Ident.name_to_string n - | Sil.Lvar p -> ( - let is_call_instr set call = match set, call with - | Sil.Set (_, _, Sil.Var (i1), _), Sil.Call (i2::[], _, _, _, _) when Ident.equal i1 i2 -> true - | _ -> false in - let is_set_instr = function - | Sil.Set (e1, t, e2, l) when Sil.exp_equal expanded e1 -> true - | _ -> false in - match reverse_find_instr is_set_instr node with (** Look for ivar := tmp *) - | Some s -> ( - match reverse_find_instr (is_call_instr s) node with (** Look for tmp := foo() *) - | Some (Sil.Call (_, Sil.Const (Sil.Cfun pn), _, l, _)) -> get_return_const pn - | _ -> "?") - | _ -> "?") - | _ -> "?" in - let arg_name (exp, typ) = find_const exp typ in - Some (list_map arg_name args) - with _ -> None) + let find_const exp typ = + let expanded = Idenv.expand_expr idenv exp in + match expanded with + | Sil.Const (Sil.Cclass n) -> Ident.name_to_string n + | Sil.Lvar p -> ( + let is_call_instr set call = match set, call with + | Sil.Set (_, _, Sil.Var (i1), _), Sil.Call (i2::[], _, _, _, _) when Ident.equal i1 i2 -> true + | _ -> false in + let is_set_instr = function + | Sil.Set (e1, t, e2, l) when Sil.exp_equal expanded e1 -> true + | _ -> false in + match reverse_find_instr is_set_instr node with (** Look for ivar := tmp *) + | Some s -> ( + match reverse_find_instr (is_call_instr s) node with (** Look for tmp := foo() *) + | Some (Sil.Call (_, Sil.Const (Sil.Cfun pn), _, l, _)) -> get_return_const pn + | _ -> "?") + | _ -> "?") + | _ -> "?" in + let arg_name (exp, typ) = find_const exp typ in + Some (list_map arg_name args) + with _ -> None) | _ -> None in let process_result instr result = @@ -406,22 +406,22 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name p ); match result with | str when (Str.string_match (Str.regexp "<\\(.*\\)>") str 0) -> ( - let missing_proc_name = Str.matched_group 1 str in - L.stdout "Deserialization of %s requires 2nd phase: " str; - L.stdout "missing: %s@." missing_proc_name) + let missing_proc_name = Str.matched_group 1 str in + L.stdout "Deserialization of %s requires 2nd phase: " str; + L.stdout "missing: %s@." missing_proc_name) | "?" -> L.stdout "Unable to resolve deserialization\n\n@." | _ -> L.stdout "Deserialization of %s\n\n@." result in let do_instr node instr = match PatternMatch.get_java_method_call_formal_signature instr with | Some (_, "readValue", _, _) -> ( - match get_actual_arguments node instr with - | Some [_; cl] -> process_result instr cl - | _ -> process_result instr "?") + match get_actual_arguments node instr with + | Some [_; cl] -> process_result instr cl + | _ -> process_result instr "?") | Some (_, "readValueAs", _, _) -> ( - match get_actual_arguments node instr with - | Some [cl] -> process_result instr cl - | _ -> process_result instr "?") + match get_actual_arguments node instr with + | Some [cl] -> process_result instr cl + | _ -> process_result instr "?") | _ -> () in let store_return () = @@ -478,7 +478,7 @@ let callback_check_field_access all_procs get_proc_desc idenv tenv proc_name pro let callback_print_c_method_calls all_procs get_proc_desc idenv tenv proc_name proc_desc = let do_instr node = function | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (e, t):: args, loc, cf) - when Procname.is_c_method pn -> + when Procname.is_c_method pn -> let receiver = match Errdesc.exp_rv_dexp node e with | Some de -> Sil.dexp_to_string de | None -> "?" in diff --git a/infer/src/checkers/codeQuery.ml b/infer/src/checkers/codeQuery.ml index 3512b2bd0..6dd0e173a 100644 --- a/infer/src/checkers/codeQuery.ml +++ b/infer/src/checkers/codeQuery.ml @@ -47,9 +47,9 @@ module Err = struct } in [(Specs.spec_normalize spec)] in let new_summ = { old_summ with - Specs.loc = Cfg.Procdesc.get_loc proc_desc; - Specs.nodes = nodes; - Specs.payload = Specs.PrePosts specs } in + Specs.loc = Cfg.Procdesc.get_loc proc_desc; + Specs.nodes = nodes; + Specs.payload = Specs.PrePosts specs } in Specs.add_summary proc_name new_summ let add_error_to_spec proc_name s node loc = @@ -84,8 +84,8 @@ module Match = struct let value' = Hashtbl.find env id in value_equal value value' with Not_found -> - Hashtbl.add env id value; - true + Hashtbl.add env id value; + true let pp_env fmt env = let pp_item id value = F.fprintf fmt "%s=%a " id pp_value value in diff --git a/infer/src/checkers/constantPropagation.ml b/infer/src/checkers/constantPropagation.ml index a7e6a93db..b14aca7b6 100644 --- a/infer/src/checkers/constantPropagation.ml +++ b/infer/src/checkers/constantPropagation.ml @@ -41,8 +41,8 @@ module ConstantFlow = Dataflow.MakeDF(struct Format.fprintf fmt "]@." (* Item - wise equality where values are equal iff - - both are None - - both are a constant and equal wrt. Sil.const_equal *) + - both are None + - both are a constant and equal wrt. Sil.const_equal *) let equal m n = ConstantMap.equal (opt_equal Sil.const_equal) m n let join = ConstantMap.merge merge_values @@ -71,32 +71,32 @@ module ConstantFlow = Dataflow.MakeDF(struct (* Handle propagation of string with StringBuilder. Does not handle null case *) | Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var sb, _):: [], _, _) - when Procname.java_get_class pn = "java.lang.StringBuilder" - && Procname.java_get_method pn = "" -> (* StringBuilder. *) + when Procname.java_get_class pn = "java.lang.StringBuilder" + && Procname.java_get_method pn = "" -> (* StringBuilder. *) update (Sil.Var sb) (Some (Sil.Cstr "")) constants | Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: [], _, _) - when Procname.java_get_class pn = "java.lang.StringBuilder" - && Procname.java_get_method pn = "toString" -> (* StringBuilder.toString *) + when Procname.java_get_class pn = "java.lang.StringBuilder" + && Procname.java_get_method pn = "toString" -> (* StringBuilder.toString *) update (Sil.Var i) (ConstantMap.find (Sil.Var i1) constants) constants | Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], _, _) - when Procname.java_get_class pn = "java.lang.StringBuilder" - && Procname.java_get_method pn = "append" -> (* StringBuilder.append *) + when Procname.java_get_class pn = "java.lang.StringBuilder" + && Procname.java_get_method pn = "append" -> (* StringBuilder.append *) (match - ConstantMap.find (Sil.Var i1) constants, - ConstantMap.find (Sil.Var i2) constants with - | Some (Sil.Cstr s1), Some (Sil.Cstr s2) -> - begin - let s = s1 ^ s2 in - let u = - if String.length s < string_widening_limit then - Some (Sil.Cstr s) - else - None in - update (Sil.Var i) u constants - end - | _ -> constants) + ConstantMap.find (Sil.Var i1) constants, + ConstantMap.find (Sil.Var i2) constants with + | Some (Sil.Cstr s1), Some (Sil.Cstr s2) -> + begin + let s = s1 ^ s2 in + let u = + if String.length s < string_widening_limit then + Some (Sil.Cstr s) + else + None in + update (Sil.Var i) u constants + end + | _ -> constants) | _ -> constants with Not_found -> constants in diff --git a/infer/src/checkers/dataflow.ml b/infer/src/checkers/dataflow.ml index 1974c31fd..da0cd8626 100644 --- a/infer/src/checkers/dataflow.ml +++ b/infer/src/checkers/dataflow.ml @@ -49,10 +49,10 @@ let node_throws node (proc_throws : Procname.t -> throws) : throws = Sil.pvar_equal pvar ret_pvar in match instr with | Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar -> - (* assignment to return variable is an artifact of a throw instruction *) + (* assignment to return variable is an artifact of a throw instruction *) Throws | Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), args, loc, _) - when SymExec.function_is_builtin callee_pn -> + when SymExec.function_is_builtin callee_pn -> if Procname.equal callee_pn SymExec.ModelBuiltins.__cast then DontKnow else DoesNotThrow diff --git a/infer/src/checkers/eradicate.ml b/infer/src/checkers/eradicate.ml index 2f9d35ab7..422e741df 100644 --- a/infer/src/checkers/eradicate.ml +++ b/infer/src/checkers/eradicate.ml @@ -32,9 +32,9 @@ type parameters = TypeState.parameters module type CallBackT = sig val callback : - TypeCheck.checks -> Procname.t list -> TypeCheck.get_proc_desc -> - Idenv.t -> Sil.tenv -> Procname.t -> - Cfg.Procdesc.t -> unit + TypeCheck.checks -> Procname.t list -> TypeCheck.get_proc_desc -> + Idenv.t -> Sil.tenv -> Procname.t -> + Cfg.Procdesc.t -> unit end (* CallBackT *) (** Extension to the type checker. *) @@ -47,7 +47,7 @@ end (** Create a module with the toplevel callback. *) module MkCallback (Extension : ExtensionT) -: CallBackT = + : CallBackT = struct (** Update the summary with stats from the checker. *) let update_summary proc_name proc_desc final_typestate_opt = @@ -126,10 +126,10 @@ struct find_canonical_duplicate annotated_signature typestate node linereader in if trace then list_iter (fun typestate_succ -> - L.stdout - "Typestate After Node %a@\n%a@." - Cfg.Node.pp node - (TypeState.pp Extension.ext) typestate_succ) + L.stdout + "Typestate After Node %a@\n%a@." + Cfg.Node.pp node + (TypeState.pp Extension.ext) typestate_succ) typestates_succ; typestates_succ, typestates_exn let proc_throws pn = DontKnow @@ -190,7 +190,7 @@ struct !res in (** Get the initializers recursively called by computing a fixpoint. - Start from the initializers of the current class and the current procedure. *) + Start from the initializers of the current class and the current procedure. *) let initializers_recursive : init list = let initializers_base_case = initializers_current_class in @@ -227,8 +227,8 @@ struct let pname_and_pdescs_with f = list_map (fun n -> match get_proc_desc n with - | Some d -> [(n, d)] - | None -> []) + | Some d -> [(n, d)] + | None -> []) all_procs |> list_flatten |> list_filter f @@ -243,8 +243,8 @@ struct let initializers_current_class = pname_and_pdescs_with (fun (pname, pdesc) -> - is_initializer pdesc pname && - Procname.java_get_class pname = Procname.java_get_class curr_pname) in + is_initializer pdesc pname && + Procname.java_get_class pname = Procname.java_get_class curr_pname) in final_typestates ((curr_pname, curr_pdesc):: initializers_current_class) end @@ -254,8 +254,8 @@ struct let constructors_current_class = pname_and_pdescs_with (fun (n, d) -> - Procname.is_constructor n && - Procname.java_get_class n = Procname.java_get_class curr_pname) in + Procname.is_constructor n && + Procname.java_get_class n = Procname.java_get_class curr_pname) in final_typestates constructors_current_class end @@ -265,8 +265,8 @@ struct let do_typestate typestate = let start_node = Cfg.Procdesc.get_start_node curr_pdesc in if not calls_this && (* if 'this(...)' is called, no need to check initialization *) - check_field_initialization && - checks.TypeCheck.eradicate + check_field_initialization && + checks.TypeCheck.eradicate then begin EradicateChecks.check_constructor_initialization find_canonical_duplicate @@ -305,7 +305,7 @@ struct let filter_special_cases () = if Procname.java_is_access_method proc_name || - (Specs.proc_get_attributes proc_name proc_desc).Sil.is_bridge_method + (Specs.proc_get_attributes proc_name proc_desc).Sil.is_bridge_method then None else begin @@ -313,11 +313,11 @@ struct if (Specs.proc_get_attributes proc_name proc_desc).Sil.is_abstract then begin if Models.infer_library_return && - EradicateChecks.classify_procedure proc_name proc_desc = "L" then + EradicateChecks.classify_procedure proc_name proc_desc = "L" then (let ret_is_nullable = (* get the existing annotation *) - let ia, _ = annotated_signature.Annotations.ret in - Annotations.ia_is_nullable ia in - EradicateChecks.pp_inferred_return_annotation ret_is_nullable proc_name); + let ia, _ = annotated_signature.Annotations.ret in + Annotations.ia_is_nullable ia in + EradicateChecks.pp_inferred_return_annotation ret_is_nullable proc_name); Some annotated_signature end else @@ -342,7 +342,7 @@ end (* MkCallback *) (** Given an extension to the typestate with a check, call the check on each instruction. *) module Build (Extension : ExtensionT) -: CallBackT = + : CallBackT = struct module Callback = MkCallback(Extension) let callback = Callback.callback diff --git a/infer/src/checkers/eradicateChecks.ml b/infer/src/checkers/eradicateChecks.ml index 5153cc011..7a1e43426 100644 --- a/infer/src/checkers/eradicateChecks.ml +++ b/infer/src/checkers/eradicateChecks.ml @@ -42,7 +42,7 @@ let get_field_annotation fn typ = (* TODO (t4968422) eliminate not !Config.eradicate check by marking fields as nullified *) (* outside of Eradicate in some other way *) if (Models.Inference.enabled || not !Config.eradicate) - && Models.Inference.field_is_marked fn + && Models.Inference.field_is_marked fn then Annotations.mk_ia Annotations.Nullable ia else ia in Some (t, ia') @@ -138,7 +138,7 @@ let check_condition case_zero find_canonical_duplicate get_proc_desc curr_pname | _ -> false in let do_instr = function | Sil.Call (_, Sil.Const (Sil.Cfun pn), [_; (Sil.Sizeof(t, _), _)], _, _) when - Procname.equal pn SymExec.ModelBuiltins.__instanceof && typ_is_throwable t -> + Procname.equal pn SymExec.ModelBuiltins.__instanceof && typ_is_throwable t -> throwable_found := true | _ -> () in let do_node n = @@ -264,10 +264,10 @@ let check_constructor_initialization | None -> unknown in list_exists (function pname, typestate -> - let pvar = Sil.mk_pvar - (Mangled.from_string (Ident.fieldname_to_string fn)) - pname in - filter_range_opt (TypeState.lookup_pvar pvar typestate)) + let pvar = Sil.mk_pvar + (Mangled.from_string (Ident.fieldname_to_string fn)) + pname in + filter_range_opt (TypeState.lookup_pvar pvar typestate)) list in let may_be_assigned_in_final_typestate = @@ -299,7 +299,7 @@ let check_constructor_initialization (* Check if field is missing annotation. *) if not (nullable_annotated || nonnull_annotated) && - not may_be_assigned_in_final_typestate then + not may_be_assigned_in_final_typestate then report_error find_canonical_duplicate start_node @@ -310,8 +310,8 @@ let check_constructor_initialization (* Check if field is over-annotated. *) if activate_field_over_annotated && - nullable_annotated && - not (may_be_nullable_in_final_typestate ()) then + nullable_annotated && + not (may_be_nullable_in_final_typestate ()) then report_error find_canonical_duplicate start_node @@ -410,7 +410,7 @@ let check_call_receiver find_canonical_duplicate node (TypeErr.Call_receiver_annotation_inconsistent - (ann, descr, callee_pname, origin_descr)) + (ann, descr, callee_pname, origin_descr)) (Some instr_ref) loc curr_pname end @@ -484,7 +484,7 @@ let check_call_parameters check (list_rev sig_params) (list_rev call_params) (** Checks if the annotations are consistent with the inherited class or with the -implemented interfaces *) + implemented interfaces *) let check_overridden_annotations find_canonical_duplicate get_proc_desc tenv proc_name proc_desc annotated_signature = @@ -512,12 +512,12 @@ let check_overridden_annotations let _, overriden_ia, overriden_type = overriden_param in let () = if not (Annotations.ia_is_nullable current_ia) - && Annotations.ia_is_nullable overriden_ia then + && Annotations.ia_is_nullable overriden_ia then report_error find_canonical_duplicate start_node (TypeErr.Inconsistent_subclass_parameter_annotation - (current_name, pos, proc_name, overriden_proc_name)) + (current_name, pos, proc_name, overriden_proc_name)) None loc proc_name in (pos + 1) in @@ -549,8 +549,8 @@ let check_overridden_annotations not (Procname.is_constructor pname) in list_iter (fun pname -> - if is_override pname - then check pname) + if is_override pname + then check pname) methods | _ -> () in diff --git a/infer/src/checkers/idenv.ml b/infer/src/checkers/idenv.ml index 766e34a9f..fcc22efda 100644 --- a/infer/src/checkers/idenv.ml +++ b/infer/src/checkers/idenv.ml @@ -8,7 +8,7 @@ *) (** Environment for temporary identifiers used in instructions. -Lazy implementation: only created when actually used. *) + Lazy implementation: only created when actually used. *) type t = (Sil.exp Ident.IdentHash.t) Lazy.t * Cfg.cfg @@ -41,8 +41,8 @@ let lookup (_map, _) id = let expand_expr idenv e = match e with | Sil.Var id -> (match lookup idenv id with - | Some e' -> e' - | None -> e) + | Some e' -> e' + | None -> e) | _ -> e let expand_expr_temps idenv node _exp = @@ -50,9 +50,9 @@ let expand_expr_temps idenv node _exp = match exp with | Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar -> (match Errdesc.find_program_variable_assignment node pvar with - | None -> exp - | Some (_, id) -> - expand_expr idenv (Sil.Var id)) + | None -> exp + | Some (_, id) -> + expand_expr idenv (Sil.Var id)) | _ -> exp (** Return true if the expression is a temporary variable introduced by the front-end. *) diff --git a/infer/src/checkers/immutableChecker.ml b/infer/src/checkers/immutableChecker.ml index e7d16c66d..eeb5c9b30 100644 --- a/infer/src/checkers/immutableChecker.ml +++ b/infer/src/checkers/immutableChecker.ml @@ -18,14 +18,14 @@ let check_immutable_cast curr_pname curr_pdesc typ_expected typ_found_opt loc : begin let casts = [ - "java.util.List", "com.google.common.collect.ImmutableList"; - "java.util.Map", "com.google.common.collect.ImmutableMap"; - "java.util.Set", "com.google.common.collect.ImmutableSet" + "java.util.List", "com.google.common.collect.ImmutableList"; + "java.util.Map", "com.google.common.collect.ImmutableMap"; + "java.util.Set", "com.google.common.collect.ImmutableSet" ] in let in_casts expected given = list_exists (fun (x, y) -> Mangled.from_string x = expected && Mangled.from_string y = given) casts in match PatternMatch.type_get_class_name typ_expected, - PatternMatch.type_get_class_name typ_found with + PatternMatch.type_get_class_name typ_found with | Some name_expected, Some name_given -> if in_casts name_expected name_given then begin diff --git a/infer/src/checkers/models.ml b/infer/src/checkers/models.ml index fcda72616..774904ae5 100644 --- a/infer/src/checkers/models.ml +++ b/infer/src/checkers/models.ml @@ -121,69 +121,69 @@ let check_not_null_parameter_list, check_not_null_list = let x = if check_not_null_strict then o else n in let list = [ - 1, (o, [x; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object"; - 1, (o, [x; n; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object"; - 1, (o, [x]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object):java.lang.Object"; - 1, (o, [x; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object"; - 1, (o, [x; n; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object"; - 1, (o, [x]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object):java.lang.Object"; - 1, (o, [x]), "org.junit.Assert.assertNotNull(java.lang.Object):void"; - 2, (o, [n; x]), "org.junit.Assert.assertNotNull(java.lang.String,java.lang.Object):void"; - 1, (o, [n]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object):java.lang.Object"; - 1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object,java.lang.String):java.lang.Object"; - 1, (o, [n]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object):java.lang.Object"; - 1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object"; + 1, (o, [x; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object"; + 1, (o, [x; n; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object"; + 1, (o, [x]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object):java.lang.Object"; + 1, (o, [x; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object"; + 1, (o, [x; n; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object"; + 1, (o, [x]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object):java.lang.Object"; + 1, (o, [x]), "org.junit.Assert.assertNotNull(java.lang.Object):void"; + 2, (o, [n; x]), "org.junit.Assert.assertNotNull(java.lang.String,java.lang.Object):void"; + 1, (o, [n]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object):java.lang.Object"; + 1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object,java.lang.String):java.lang.Object"; + 1, (o, [n]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object):java.lang.Object"; + 1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object"; ] in list_map (fun (x, y, z) -> (x, z)) list, list_map (fun (x, y, z) -> (y, z)) list let check_state_list = [ - (o, [n]), "Preconditions.checkState(boolean):void"; - (o, [n]), "com.facebook.common.internal.Preconditions.checkState(boolean):void"; - (o, [n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.Object):void"; - (o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void"; - (o, [n]), "com.google.common.base.Preconditions.checkState(boolean):void"; - (o, [n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.Object):void"; - (o, [n; n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void"; - (o, [n]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean):void"; - (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean,java.lang.String):void"; - (o, [n]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean):void"; - (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean,java.lang.String):void"; + (o, [n]), "Preconditions.checkState(boolean):void"; + (o, [n]), "com.facebook.common.internal.Preconditions.checkState(boolean):void"; + (o, [n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.Object):void"; + (o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void"; + (o, [n]), "com.google.common.base.Preconditions.checkState(boolean):void"; + (o, [n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.Object):void"; + (o, [n; n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void"; + (o, [n]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean):void"; + (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean,java.lang.String):void"; + (o, [n]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean):void"; + (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean,java.lang.String):void"; ] let check_argument_list = [ - (o, [n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean):void"; - (o, [n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.Object):void"; - (o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void"; - (o, [n]), "com.google.common.base.Preconditions.checkArgument(boolean):void"; - (o, [n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.Object):void"; - (o, [n; n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void"; + (o, [n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean):void"; + (o, [n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.Object):void"; + (o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void"; + (o, [n]), "com.google.common.base.Preconditions.checkArgument(boolean):void"; + (o, [n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.Object):void"; + (o, [n; n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void"; ] let optional_get_list : ((_ * bool list) * _) list = [ - (o, []), "Optional.get():java.lang.Object"; - (o, []), "com.google.common.base.Optional.get():java.lang.Object"; + (o, []), "Optional.get():java.lang.Object"; + (o, []), "com.google.common.base.Optional.get():java.lang.Object"; ] let optional_isPresent_list : ((_ * bool list) * _) list = [ - (o, []), "Optional.isPresent():boolean"; - (o, []), "com.google.common.base.Optional.isPresent():boolean"; + (o, []), "Optional.isPresent():boolean"; + (o, []), "com.google.common.base.Optional.isPresent():boolean"; ] (** Models for Map.containsKey *) let containsKey_list = [ - n1, "com.google.common.collect.ImmutableMap.containsKey(java.lang.Object):boolean"; - n1, "java.util.Map.containsKey(java.lang.Object):boolean"; + n1, "com.google.common.collect.ImmutableMap.containsKey(java.lang.Object):boolean"; + n1, "java.util.Map.containsKey(java.lang.Object):boolean"; ] (** Models for @Strict annotations *) let annotated_list_strict = [ - (n, [o]), "android.content.Context.getSystemService(java.lang.String):java.lang.Object"; + (n, [o]), "android.content.Context.getSystemService(java.lang.String):java.lang.Object"; ] (** Models for @Nullable annotations *) @@ -191,53 +191,53 @@ let annotated_list_nullable = check_not_null_list @ check_state_list @ check_argument_list @ annotated_list_strict @ [ - n1, "android.os.Parcel.writeList(java.util.List):void"; - n2, "android.os.Parcel.writeParcelable(android.os.Parcelable,int):void"; - n1, "android.os.Parcel.writeString(java.lang.String):void"; - (o, [o; o; n; n; n]), "com.android.sdklib.build.ApkBuilder.(java.io.File,java.io.File,java.io.File,java.lang.String,java.io.PrintStream)"; - (o, [n]), "com.android.manifmerger.ManifestMerger.xmlFileAndLine(org.w3c.dom.Node):com.android.manifmerger.IMergerLog$FileAndLine"; - on, "com.android.util.CommandLineParser$Mode.process(com.android.util.CommandLineParser$Arg,java.lang.String):java.lang.Object"; - on, "com.google.common.base.Objects$ToStringHelper.add(java.lang.String,java.lang.Object):com.google.common.base.Objects$ToStringHelper"; - n2, "com.google.common.base.Objects.equal(java.lang.Object,java.lang.Object):boolean"; - n1, "com.google.common.base.Optional.fromNullable(java.lang.Object):com.google.common.base.Optional"; - (n, []), "com.google.common.base.Optional.orNull():java.lang.Object"; - n1, "com.google.common.base.Strings.nullToEmpty(java.lang.String):java.lang.String"; - cg, "com.google.common.collect.ImmutableMap.get(java.lang.Object):java.lang.Object"; (* container get *) - o1, "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder"; - o1, "com.google.common.collect.ImmutableList$Builder.addAll(java.lang.Iterable):com.google.common.collect.ImmutableList$Builder"; - o1, "com.google.common.collect.ImmutableSortedSet$Builder.add(java.lang.Object):com.google.common.collect.ImmutableSortedSet$Builder"; - on, "com.google.common.collect.Iterables.getFirst(java.lang.Iterable,java.lang.Object):java.lang.Object"; - o1, "com.google.common.util.concurrent.SettableFuture.setException(java.lang.Throwable):boolean"; - o1, "java.io.File.(java.lang.String)"; - n1, "java.io.PrintStream.print(java.lang.String):void"; - o1, "java.lang.Class.isAssignableFrom(java.lang.Class):boolean"; - n1, "java.lang.Integer.equals(java.lang.Object):boolean"; - n2, "java.lang.RuntimeException.(java.lang.String,java.lang.Throwable)"; - n1, "java.lang.String.equals(java.lang.Object):boolean"; - n1, "java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder"; - on, "java.net.URLClassLoader.newInstance(java.net.URL[],java.lang.ClassLoader):java.net.URLClassLoader"; - n1, "java.util.AbstractList.equals(java.lang.Object):boolean"; - ca, "java.util.ArrayList.add(java.lang.Object):boolean"; (* container add *) - ca, "java.util.List.add(java.lang.Object):boolean"; (* container add *) - cg, "java.util.Map.get(java.lang.Object):java.lang.Object"; (* container get *) - cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object"; (* container put *) - n3, "javax.tools.JavaCompiler.getStandardFileManager(javax.tools.DiagnosticListener,java.util.Locale,java.nio.charset.Charset):javax.tools.StandardJavaFileManager"; - (n, [o; n; n]), "org.w3c.dom.Document.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object"; - (n, [o; n; n]), "org.w3c.dom.Node.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object"; - - (* References *) - ng, "java.lang.ref.Reference.get():java.lang.Object"; - ng, "java.lang.ref.PhantomReference.get():java.lang.Object"; - ng, "java.lang.ref.SoftReference.get():java.lang.Object"; - ng, "java.lang.ref.WeakReference.get():java.lang.Object"; - ng, "java.util.concurrent.atomic.AtomicReference.get():java.lang.Object"; + n1, "android.os.Parcel.writeList(java.util.List):void"; + n2, "android.os.Parcel.writeParcelable(android.os.Parcelable,int):void"; + n1, "android.os.Parcel.writeString(java.lang.String):void"; + (o, [o; o; n; n; n]), "com.android.sdklib.build.ApkBuilder.(java.io.File,java.io.File,java.io.File,java.lang.String,java.io.PrintStream)"; + (o, [n]), "com.android.manifmerger.ManifestMerger.xmlFileAndLine(org.w3c.dom.Node):com.android.manifmerger.IMergerLog$FileAndLine"; + on, "com.android.util.CommandLineParser$Mode.process(com.android.util.CommandLineParser$Arg,java.lang.String):java.lang.Object"; + on, "com.google.common.base.Objects$ToStringHelper.add(java.lang.String,java.lang.Object):com.google.common.base.Objects$ToStringHelper"; + n2, "com.google.common.base.Objects.equal(java.lang.Object,java.lang.Object):boolean"; + n1, "com.google.common.base.Optional.fromNullable(java.lang.Object):com.google.common.base.Optional"; + (n, []), "com.google.common.base.Optional.orNull():java.lang.Object"; + n1, "com.google.common.base.Strings.nullToEmpty(java.lang.String):java.lang.String"; + cg, "com.google.common.collect.ImmutableMap.get(java.lang.Object):java.lang.Object"; (* container get *) + o1, "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder"; + o1, "com.google.common.collect.ImmutableList$Builder.addAll(java.lang.Iterable):com.google.common.collect.ImmutableList$Builder"; + o1, "com.google.common.collect.ImmutableSortedSet$Builder.add(java.lang.Object):com.google.common.collect.ImmutableSortedSet$Builder"; + on, "com.google.common.collect.Iterables.getFirst(java.lang.Iterable,java.lang.Object):java.lang.Object"; + o1, "com.google.common.util.concurrent.SettableFuture.setException(java.lang.Throwable):boolean"; + o1, "java.io.File.(java.lang.String)"; + n1, "java.io.PrintStream.print(java.lang.String):void"; + o1, "java.lang.Class.isAssignableFrom(java.lang.Class):boolean"; + n1, "java.lang.Integer.equals(java.lang.Object):boolean"; + n2, "java.lang.RuntimeException.(java.lang.String,java.lang.Throwable)"; + n1, "java.lang.String.equals(java.lang.Object):boolean"; + n1, "java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder"; + on, "java.net.URLClassLoader.newInstance(java.net.URL[],java.lang.ClassLoader):java.net.URLClassLoader"; + n1, "java.util.AbstractList.equals(java.lang.Object):boolean"; + ca, "java.util.ArrayList.add(java.lang.Object):boolean"; (* container add *) + ca, "java.util.List.add(java.lang.Object):boolean"; (* container add *) + cg, "java.util.Map.get(java.lang.Object):java.lang.Object"; (* container get *) + cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object"; (* container put *) + n3, "javax.tools.JavaCompiler.getStandardFileManager(javax.tools.DiagnosticListener,java.util.Locale,java.nio.charset.Charset):javax.tools.StandardJavaFileManager"; + (n, [o; n; n]), "org.w3c.dom.Document.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object"; + (n, [o; n; n]), "org.w3c.dom.Node.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object"; + + (* References *) + ng, "java.lang.ref.Reference.get():java.lang.Object"; + ng, "java.lang.ref.PhantomReference.get():java.lang.Object"; + ng, "java.lang.ref.SoftReference.get():java.lang.Object"; + ng, "java.lang.ref.WeakReference.get():java.lang.Object"; + ng, "java.util.concurrent.atomic.AtomicReference.get():java.lang.Object"; ] (** Models for @Present annotations *) let annotated_list_present = [ - (n, [o]), "Optional.of(java.lang.Object):Optional"; - (n, [o]), "com.google.common.base.Optional.of(java.lang.Object):com.google.common.base.Optional"; + (n, [o]), "Optional.of(java.lang.Object):Optional"; + (n, [o]), "com.google.common.base.Optional.of(java.lang.Object):com.google.common.base.Optional"; ] let mk_table list = @@ -304,7 +304,7 @@ let get_annotated_signature callee_pdesc callee_pname = let mark = Hashtbl.find annotated_table_nullable proc_id in Annotations.annotated_signature_mark callee_pname Annotations.Nullable ann_sig mark with Not_found -> - ann_sig + ann_sig else ann_sig in let lookup_models_present ann_sig = if use_models then @@ -312,11 +312,11 @@ let get_annotated_signature callee_pdesc callee_pname = let mark = Hashtbl.find annotated_table_present proc_id in Annotations.annotated_signature_mark callee_pname Annotations.Present ann_sig mark with Not_found -> - ann_sig + ann_sig else ann_sig in let lookup_models_strict ann_sig = if use_models - && Hashtbl.mem annotated_table_strict proc_id + && Hashtbl.mem annotated_table_strict proc_id then Annotations.annotated_signature_mark_return_strict callee_pname ann_sig else diff --git a/infer/src/checkers/patternMatch.ml b/infer/src/checkers/patternMatch.ml index de2fa7f84..7fd11d77e 100644 --- a/infer/src/checkers/patternMatch.ml +++ b/infer/src/checkers/patternMatch.ml @@ -21,9 +21,9 @@ let type_is_object = function let java_proc_name_with_class_method pn class_with_path method_name = (try - Procname.java_get_class pn = class_with_path && - Procname.java_get_method pn = method_name - with _ -> false) + Procname.java_get_class pn = class_with_path && + Procname.java_get_method pn = method_name + with _ -> false) let is_direct_subtype_of this_type super_type_name = match this_type with @@ -135,12 +135,12 @@ let get_field_type_name match typ with | Sil.Tstruct (fields, _, _, _, _, _, _) | Sil.Tptr (Sil.Tstruct (fields, _, _, _, _, _, _), _) -> ( - try - let _, ft, _ = list_find - (function | (fn, _, _) -> Ident.fieldname_equal fn fieldname) - fields in - Some (get_type_name ft) - with Not_found -> None) + try + let _, ft, _ = list_find + (function | (fn, _, _) -> Ident.fieldname_equal fn fieldname) + fields in + Some (get_type_name ft) + with Not_found -> None) | _ -> None let java_get_const_type_name @@ -158,9 +158,9 @@ let get_vararg_type_names let rec initializes_array instrs = match instrs with | Sil.Call ([t1], Sil.Const (Sil.Cfun pn), _, _, _):: - Sil.Set (Sil.Lvar iv, _, Sil.Var t2, _):: is -> + Sil.Set (Sil.Lvar iv, _, Sil.Var t2, _):: is -> (Sil.pvar_equal ivar iv && Ident.equal t1 t2 && - Procname.equal pn (Procname.from_string_c_fun "__new_array")) + Procname.equal pn (Procname.from_string_c_fun "__new_array")) || initializes_array is | i:: is -> initializes_array is | _ -> false in @@ -170,24 +170,24 @@ let get_vararg_type_names let rec nvar_type_name nvar instrs = match instrs with | Sil.Letderef (nv, Sil.Lfield (_, id, t), _, _):: _ - when Ident.equal nv nvar -> get_field_type_name t id + when Ident.equal nv nvar -> get_field_type_name t id | Sil.Letderef (nv, e, t, _):: _ - when Ident.equal nv nvar -> + when Ident.equal nv nvar -> Some (get_type_name t) | i:: is -> nvar_type_name nvar is | _ -> None in let rec added_nvar array_nvar instrs = match instrs with | Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Var nvar, _):: _ - when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node) + when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node) | Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Const c, _):: _ - when Ident.equal iv array_nvar -> Some (java_get_const_type_name c) + when Ident.equal iv array_nvar -> Some (java_get_const_type_name c) | i:: is -> added_nvar array_nvar is | _ -> None in let rec array_nvar instrs = match instrs with | Sil.Letderef (nv, Sil.Lvar iv, _, _):: _ - when Sil.pvar_equal iv ivar -> + when Sil.pvar_equal iv ivar -> added_nvar nv instrs | i:: is -> array_nvar is | _ -> None in @@ -200,8 +200,8 @@ let get_vararg_type_names else match (Cfg.Node.get_preds node) with | [n] -> (match (added_type_name node) with - | Some name -> name:: type_names n - | None -> type_names n) + | Some name -> name:: type_names n + | None -> type_names n) | _ -> raise Not_found in list_rev (type_names call_node) @@ -232,15 +232,15 @@ let get_java_field_access_signature = function | _ -> None (** Returns the formal signature (class name, method name, -argument type names and return type name) *) + argument type names and return type name) *) let get_java_method_call_formal_signature = function | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> (try - let arg_names = list_map (function | e, t -> get_type_name t) args in - let rt_name = Procname.java_get_return_type pn in - let m_name = Procname.java_get_method pn in - Some (get_type_name tt, m_name, arg_names, rt_name) - with _ -> None) + let arg_names = list_map (function | e, t -> get_type_name t) args in + let rt_name = Procname.java_get_return_type pn in + let m_name = Procname.java_get_method pn in + Some (get_type_name tt, m_name, arg_names, rt_name) + with _ -> None) | _ -> None @@ -256,14 +256,14 @@ let initializer_classes = list_map Mangled.from_string [ "android.app.Application"; "android.app.Fragment"; "android.support.v4.app.Fragment"; - ] + ] let initializer_methods = [ "onActivityCreated"; "onAttach"; "onCreate"; "onCreateView"; - ] +] (** Check if the type has in its supertypes from the initializer_classes list. *) let type_has_initializer @@ -291,8 +291,8 @@ let java_get_vararg_values node pvar idenv pdesc = let values = ref [] in let do_instr = function | Sil.Set (Sil.Lindex (array_exp, _), _, content_exp, _) - when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv array_exp) -> - (* Each vararg argument is an assigment to a pvar denoting an array of objects. *) + when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv array_exp) -> + (* Each vararg argument is an assigment to a pvar denoting an array of objects. *) values := content_exp :: !values | _ -> () in let do_node n = diff --git a/infer/src/checkers/printfArgs.ml b/infer/src/checkers/printfArgs.ml index 0db1e8c25..a23aeba87 100644 --- a/infer/src/checkers/printfArgs.ml +++ b/infer/src/checkers/printfArgs.ml @@ -30,22 +30,22 @@ let printf_signature_to_string let printf_like_functions = ref [ - { unique_id = "java.io.PrintStream.printf(java.lang.String,java.lang.Object[]):java.io.PrintStream"; - format_pos = 1; - fixed_pos = []; - vararg_pos = Some 2 }; - { unique_id = "java.io.PrintStream.printf(java.lang.Locale,java.lang.String,java.lang.Object[]):java.io.PrintStream"; - format_pos = 2; - fixed_pos = []; - vararg_pos = Some 3 }; - { unique_id = "java.lang.String(java.lang.String,java.lang.Object[]):java.lang.String"; - format_pos = 1; - fixed_pos = []; - vararg_pos = Some 2 }; - { unique_id = "java.lang.String(java.lang.Locale,java.lang.String,java.lang.Object[]):java.lang.String"; - format_pos = 2; - fixed_pos = []; - vararg_pos = Some 3 }; + { unique_id = "java.io.PrintStream.printf(java.lang.String,java.lang.Object[]):java.io.PrintStream"; + format_pos = 1; + fixed_pos = []; + vararg_pos = Some 2 }; + { unique_id = "java.io.PrintStream.printf(java.lang.Locale,java.lang.String,java.lang.Object[]):java.io.PrintStream"; + format_pos = 2; + fixed_pos = []; + vararg_pos = Some 3 }; + { unique_id = "java.lang.String(java.lang.String,java.lang.Object[]):java.lang.String"; + format_pos = 1; + fixed_pos = []; + vararg_pos = Some 2 }; + { unique_id = "java.lang.String(java.lang.Locale,java.lang.String,java.lang.Object[]):java.lang.String"; + format_pos = 2; + fixed_pos = []; + vararg_pos = Some 3 }; ] let add_printf_like_function plf = @@ -169,18 +169,18 @@ let callback_printf_args let rec array_ivar instrs nvar = match instrs, nvar with | Sil.Letderef (id, Sil.Lvar iv, _, _):: _, Sil.Var nid - when Ident.equal id nid -> iv + when Ident.equal id nid -> iv | i:: is, _ -> array_ivar is nvar | _ -> raise Not_found in let rec fixed_nvar_type_name instrs nvar = match nvar with | Sil.Var nid -> ( - match instrs with - | Sil.Letderef (id, Sil.Lvar iv, t, _):: _ + match instrs with + | Sil.Letderef (id, Sil.Lvar iv, t, _):: _ when Ident.equal id nid -> PatternMatch.get_type_name t - | i:: is -> fixed_nvar_type_name is nvar - | _ -> raise Not_found) + | i:: is -> fixed_nvar_type_name is nvar + | _ -> raise Not_found) | Sil.Const c -> PatternMatch.java_get_const_type_name c | _ -> raise (Failure "Could not resolve fixed type name") in @@ -189,39 +189,39 @@ let callback_printf_args (instr: Sil.instr): unit = match instr with | Sil.Call (_, Sil.Const (Sil.Cfun pn), args, cl, _) -> ( - match printf_like_function pn with - | Some printf -> ( - try - let fmt, fixed_nvars, array_nvar = format_arguments printf args in - let instrs = Cfg.Node.get_instrs node in - let fixed_nvar_type_names = list_map (fixed_nvar_type_name instrs) fixed_nvars in - let vararg_ivar_type_names = match array_nvar with - | Some nvar -> ( - let ivar = array_ivar instrs nvar in - PatternMatch.get_vararg_type_names node ivar) - | None -> [] in - match fmt with - | Some fmt -> - check_type_names - cl - (printf.format_pos + 1) - pn - (format_string_type_names fmt 0) - (fixed_nvar_type_names@ vararg_ivar_type_names) - | None -> - Checkers.ST.report_error - proc_name - proc_desc - printf_args_name - cl - "Format string must be string literal" - with e -> - L.stderr - "%s Exception when analyzing %s: %s@." - printf_args_name - (Procname.to_string proc_name) - (Printexc.to_string e)) - | None -> ()) + match printf_like_function pn with + | Some printf -> ( + try + let fmt, fixed_nvars, array_nvar = format_arguments printf args in + let instrs = Cfg.Node.get_instrs node in + let fixed_nvar_type_names = list_map (fixed_nvar_type_name instrs) fixed_nvars in + let vararg_ivar_type_names = match array_nvar with + | Some nvar -> ( + let ivar = array_ivar instrs nvar in + PatternMatch.get_vararg_type_names node ivar) + | None -> [] in + match fmt with + | Some fmt -> + check_type_names + cl + (printf.format_pos + 1) + pn + (format_string_type_names fmt 0) + (fixed_nvar_type_names@ vararg_ivar_type_names) + | None -> + Checkers.ST.report_error + proc_name + proc_desc + printf_args_name + cl + "Format string must be string literal" + with e -> + L.stderr + "%s Exception when analyzing %s: %s@." + printf_args_name + (Procname.to_string proc_name) + (Printexc.to_string e)) + | None -> ()) | _ -> () in Cfg.Procdesc.iter_instrs do_instr proc_desc diff --git a/infer/src/checkers/registerCheckers.ml b/infer/src/checkers/registerCheckers.ml index 213885230..e9160382c 100644 --- a/infer/src/checkers/registerCheckers.ml +++ b/infer/src/checkers/registerCheckers.ml @@ -20,28 +20,28 @@ let active_procedure_checkers () = let java_checkers = let l = [ - CallbackChecker.callback_checker_main, false; - Checkers.callback_check_access, false; - Checkers.callback_monitor_nullcheck, false; - Checkers.callback_test_state , false; - Checkers.callback_checkVisibleForTesting, false; - Checkers.callback_check_write_to_parcel, false; - Checkers.callback_find_deserialization, false; - Dataflow.callback_test_dataflow, false; - SqlChecker.callback_sql, false; - Eradicate.callback_eradicate, !Config.eradicate; - CodeQuery.code_query_callback, !CodeQuery.query <> None; - Checkers.callback_check_field_access, false; - ImmutableChecker.callback_check_immutable_cast, checkers_enabled; - RepeatedCallsChecker.callback_check_repeated_calls, checkers_enabled; - PrintfArgs.callback_printf_args, checkers_enabled; + CallbackChecker.callback_checker_main, false; + Checkers.callback_check_access, false; + Checkers.callback_monitor_nullcheck, false; + Checkers.callback_test_state , false; + Checkers.callback_checkVisibleForTesting, false; + Checkers.callback_check_write_to_parcel, false; + Checkers.callback_find_deserialization, false; + Dataflow.callback_test_dataflow, false; + SqlChecker.callback_sql, false; + Eradicate.callback_eradicate, !Config.eradicate; + CodeQuery.code_query_callback, !CodeQuery.query <> None; + Checkers.callback_check_field_access, false; + ImmutableChecker.callback_check_immutable_cast, checkers_enabled; + RepeatedCallsChecker.callback_check_repeated_calls, checkers_enabled; + PrintfArgs.callback_printf_args, checkers_enabled; ] in list_map (fun (x, y) -> (x, y, Some Sil.Java)) l in let c_cpp_checkers = let l = [ - Checkers.callback_print_c_method_calls, false; - CheckDeadCode.callback_check_dead_code, checkers_enabled; + Checkers.callback_print_c_method_calls, false; + CheckDeadCode.callback_check_dead_code, checkers_enabled; ] in list_map (fun (x, y) -> (x, y, Some Sil.C_CPP)) l in diff --git a/infer/src/checkers/repeatedCallsChecker.ml b/infer/src/checkers/repeatedCallsChecker.ml index 038e10686..960018866 100644 --- a/infer/src/checkers/repeatedCallsChecker.ml +++ b/infer/src/checkers/repeatedCallsChecker.ml @@ -25,7 +25,7 @@ struct type t = Sil.instr let compare i1 i2 = match i1, i2 with | Sil.Call (ret1, e1, etl1, loc1, cf1), Sil.Call (ret2, e2, etl2, loc2, cf2) -> - (* ignore return ids and call flags *) + (* ignore return ids and call flags *) let n = Sil.exp_compare e1 e2 in if n <> 0 then n else let n = list_compare Sil.exp_typ_compare etl1 etl2 in if n <> 0 then n else Sil.call_flags_compare cf1 cf2 @@ -61,8 +61,8 @@ struct | SomePath (** Check if some path exists *) (** Check if the procedure performs an allocation operation. - If [paths] is AllPaths, check if an allocation happens on all paths. - If [paths] is SomePath, check if a path with an allocation exists. *) + If [paths] is AllPaths, check if an allocation happens on all paths. + If [paths] is SomePath, check if a path with an allocation exists. *) let proc_performs_allocation pdesc paths : Sil.location option = let node_allocates node : Sil.location option = @@ -113,14 +113,14 @@ struct let arguments_not_temp args = let filter_arg (e, t) = match e with | Sil.Lvar pvar -> - (* same temporary variable does not imply same value *) + (* same temporary variable does not imply same value *) not (Errdesc.pvar_is_frontend_tmp pvar) | _ -> true in list_for_all filter_arg args in match instr with | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _, loc, call_flags) - when ret_ids <> [] && arguments_not_temp normalized_etl -> + when ret_ids <> [] && arguments_not_temp normalized_etl -> let instr_normalized_args = Sil.Call ( ret_ids, Sil.Const (Sil.Cfun callee_pname), diff --git a/infer/src/checkers/sqlChecker.ml b/infer/src/checkers/sqlChecker.ml index 92a74d7a6..9c72eee4f 100644 --- a/infer/src/checkers/sqlChecker.ml +++ b/infer/src/checkers/sqlChecker.ml @@ -23,14 +23,14 @@ let callback_sql all_procs get_proc_desc idenv tenv proc_name proc_desc = "insert into.*"; "update .* set.*"; "delete .* from.*"; - ] in + ] in list_map Str.regexp_case_fold _sql_start in (* Check for SQL string concatenations *) let do_instr const_map node = function | Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], l, _) - when Procname.java_get_class pn = "java.lang.StringBuilder" - && Procname.java_get_method pn = "append" -> + when Procname.java_get_class pn = "java.lang.StringBuilder" + && Procname.java_get_method pn = "append" -> let rvar1 = Sil.Var i1 in let rvar2 = Sil.Var i2 in begin diff --git a/infer/src/checkers/typeCheck.ml b/infer/src/checkers/typeCheck.ml index 004446511..9b0c69915 100644 --- a/infer/src/checkers/typeCheck.ml +++ b/infer/src/checkers/typeCheck.ml @@ -22,8 +22,8 @@ let debug = Config.from_env_variable "ERADICATE_DEBUG" (** Module to treat selected complex expressions as constants. *) module ComplexExpressions = struct (** What complex expressions are considered constant, each case includes the previous ones. - Boolean checks (e.g. null check) and assignments on expressions considered constant are - retained across the control flow assuming there are no modifications in between. *) + Boolean checks (e.g. null check) and assignments on expressions considered constant are + retained across the control flow assuming there are no modifications in between. *) type expressions_constant = | FL_NO (* none *) | FL_PARAMETER_STATIC (* parameter.field and static fields *) @@ -82,7 +82,7 @@ module ComplexExpressions = struct dexp_to_string de | Sil.Dfcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual }) | Sil.Dretcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual }) - when functions_idempotent () -> + when functions_idempotent () -> let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in let pp_args fmt des = (pp_comma_seq) pp_arg fmt des in let pp fmt () = @@ -140,12 +140,12 @@ let rec typecheck_expr typestate e tr_default loc : TypeState.range = match e with | Sil.Lvar pvar -> (match TypeState.lookup_pvar pvar typestate with - | Some tr -> TypeState.range_add_locs tr [loc] - | None -> tr_default) + | Some tr -> TypeState.range_add_locs tr [loc] + | None -> tr_default) | Sil.Var id -> (match TypeState.lookup_id id typestate with - | Some tr -> TypeState.range_add_locs tr [loc] - | None -> tr_default) + | Some tr -> TypeState.range_add_locs tr [loc] + | None -> tr_default) | Sil.Const (Sil.Cint i) when Sil.Int.iszero i -> let (typ, _, locs) = tr_default in if PatternMatch.type_is_class typ @@ -223,8 +223,8 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc L.stdout " %a@." (Sil.pp_instr pe_text) instr in (** Handle the case where a field access X.f happens via a temporary variable $Txxx. - This has been observed in assignments this.f = exp when exp contains an ifthenelse. - Reconstuct the original expression knowing: the origin of $Txxx is 'this'. *) + This has been observed in assignments this.f = exp when exp contains an ifthenelse. + Reconstuct the original expression knowing: the origin of $Txxx is 'this'. *) let handle_field_access_via_temporary typestate exp loc = let name_is_temporary name = let prefix = "$T" in @@ -254,7 +254,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc | _ -> exp in (** Convert a complex expressions into a pvar. - When [is_assigment] is true, update the relevant annotations for the pvar. *) + When [is_assigment] is true, update the relevant annotations for the pvar. *) let convert_complex_exp_to_pvar node' is_assignment _exp typestate loc = let exp = handle_field_access_via_temporary @@ -269,21 +269,21 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc | Some _ when not is_assignment -> typestate | _ -> (match EradicateChecks.get_field_annotation fn typ with - | Some (t, ia) -> - let range = - ( - t, - TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (fn, loc)), - [loc] - ) in - TypeState.add_pvar pvar range typestate - | None -> typestate) in + | Some (t, ia) -> + let range = + ( + t, + TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (fn, loc)), + [loc] + ) in + TypeState.add_pvar pvar range typestate + | None -> typestate) in (* Convert a function call to a pvar. *) let handle_function_call call_node id = match Errdesc.find_normal_variable_funcall call_node id with | Some (Sil.Const (Sil.Cfun pn), _, _, _) - when not (ComplexExpressions.procname_used_in_condition pn) -> + when not (ComplexExpressions.procname_used_in_condition pn) -> begin match ComplexExpressions.exp_to_string node' exp with | None -> default @@ -299,12 +299,12 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc match exp with | Sil.Var id when - ComplexExpressions.functions_idempotent () && - Errdesc.find_normal_variable_funcall node' id <> None -> + ComplexExpressions.functions_idempotent () && + Errdesc.find_normal_variable_funcall node' id <> None -> handle_function_call node' id | Sil.Lvar pvar when - ComplexExpressions.functions_idempotent () && - Errdesc.pvar_is_frontend_tmp pvar -> + ComplexExpressions.functions_idempotent () && + Errdesc.pvar_is_frontend_tmp pvar -> let frontend_variable_assignment = Errdesc.find_program_variable_assignment node pvar in begin @@ -339,13 +339,13 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc let typestate' = update_typestate_fld pvar fn typ in (Sil.Lvar pvar, typestate') | Sil.Lfield (_exp', fn', typ') when Ident.java_fieldname_is_outer_instance fn' -> - (** handle double dereference when accessing a field from an outer class *) + (** handle double dereference when accessing a field from an outer class *) let fld_name = Ident.fieldname_to_string fn' ^ "_" ^ Ident.fieldname_to_string fn in let pvar = Sil.mk_pvar (Mangled.from_string fld_name) curr_pname in let typestate' = update_typestate_fld pvar fn typ in (Sil.Lvar pvar, typestate') | Sil.Lvar _ | Sil.Lfield _ when ComplexExpressions.all_nested_fields () -> - (** treat var.field1. ... .fieldn as a constant *) + (** treat var.field1. ... .fieldn as a constant *) begin match ComplexExpressions.exp_to_string node' exp with | Some exp_str -> @@ -395,7 +395,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc (* Drop parameters from the signature which we do not check in a call. *) let drop_unchecked_signature_params pdesc pname annotated_signature = if Procname.is_constructor pname && - (Cfg.Procdesc.get_attributes pdesc).Sil.is_synthetic_method then + (Cfg.Procdesc.get_attributes pdesc).Sil.is_synthetic_method then list_drop_last 1 annotated_signature.Annotations.params else annotated_signature.Annotations.params in @@ -417,7 +417,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc | None -> typestate' | Some (node', id) -> - (* handle the case where pvar is a frontend-generated program variable *) + (* handle the case where pvar is a frontend-generated program variable *) let exp = Idenv.expand_expr idenv (Sil.Var id) in begin match convert_complex_exp_to_pvar node' false exp typestate' loc with @@ -452,7 +452,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc (typecheck_expr_simple typestate' e' typ TypeOrigin.Undef loc) typestate' | Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar -> - (* skip assignment to return variable where it is an artifact of a throw instruction *) + (* skip assignment to return variable where it is an artifact of a throw instruction *) typestate | Sil.Set (e1, typ, e2, loc) -> typecheck_expr_for_errors typestate e1 loc; @@ -481,14 +481,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc check_field_assign (); typestate2 | Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(_, typ)], loc, _) - when Procname.equal pn SymExec.ModelBuiltins.__new || - Procname.equal pn SymExec.ModelBuiltins.__new_array -> + when Procname.equal pn SymExec.ModelBuiltins.__new || + Procname.equal pn SymExec.ModelBuiltins.__new_array -> TypeState.add_id id (typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.New, [loc]) typestate (* new never returns null *) | Sil.Call ([id], Sil.Const (Sil.Cfun pn), (e, typ):: _, loc, _) - when Procname.equal pn SymExec.ModelBuiltins.__cast -> + when Procname.equal pn SymExec.ModelBuiltins.__cast -> typecheck_expr_for_errors typestate e loc; let e', typestate' = convert_complex_exp_to_pvar node false e typestate loc in @@ -497,7 +497,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc (typecheck_expr_simple typestate' e' typ TypeOrigin.ONone loc) typestate' | Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(array_exp, t)], loc, _) - when Procname.equal pn SymExec.ModelBuiltins.__get_array_size -> + when Procname.equal pn SymExec.ModelBuiltins.__get_array_size -> let (_, ta, _) = typecheck_expr find_canonical_duplicate calls_this @@ -531,7 +531,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc | Sil.Call (_, Sil.Const (Sil.Cfun pn), _, _, _) when SymExec.function_is_builtin pn -> typestate (* skip othe builtins *) | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _etl, loc, cflags) - when get_proc_desc callee_pname <> None -> + when get_proc_desc callee_pname <> None -> let callee_pdesc = match get_proc_desc callee_pname with | Some callee_pdesc -> callee_pdesc | None -> assert false in @@ -589,7 +589,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc find_canonical_duplicate node (TypeErr.Condition_redundant - (true, EradicateChecks.explain_expr node cond, false)) + (true, EradicateChecks.explain_expr node cond, false)) (Some instr_ref) loc curr_pname end; @@ -640,7 +640,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc let do_instr = function | Sil.Prune (Sil.BinOp (Sil.Eq, _cond_e, Sil.Const (Sil.Cint i)), _, _, _) | Sil.Prune (Sil.BinOp (Sil.Eq, Sil.Const (Sil.Cint i), _cond_e), _, _, _) - when Sil.Int.iszero i -> + when Sil.Int.iszero i -> let cond_e = Idenv.expand_expr_temps idenv cond_node _cond_e in begin match convert_complex_exp_to_pvar cond_node false cond_e typestate' loc with @@ -657,13 +657,13 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc | _ -> () in match call_params with | ((_, Sil.Lvar pvar), typ):: _ -> - (* temporary variable for the value of the boolean condition *) + (* temporary variable for the value of the boolean condition *) begin let curr_node = TypeErr.InstrRef.get_node instr_ref in let branch = false in match Errdesc.find_boolean_assignment curr_node pvar branch with (* In foo(cond1 && cond2), the node that sets the result to false - has all the negated conditions as parents. *) + has all the negated conditions as parents. *) | Some boolean_assignment_node -> list_iter handle_negated_condition (Cfg.Node.get_preds boolean_assignment_node); !res_typestate @@ -675,7 +675,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc | Some (node', id) -> let () = match Errdesc.find_normal_variable_funcall node' id with | Some (Sil.Const (Sil.Cfun pn), [e], loc, call_flags) - when ComplexExpressions.procname_optional_isPresent pn -> + when ComplexExpressions.procname_optional_isPresent pn -> handle_optional_isPresent node' e | _ -> () in () @@ -740,7 +740,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc typestate2 else if Procname.java_get_method callee_pname = "checkNotNull" - && Procname.java_is_vararg callee_pname + && Procname.java_is_vararg callee_pname then let last_parameter = list_length call_params in do_preconditions_check_not_null @@ -748,7 +748,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc true (* is_vararg *) typestate2 else if Models.is_check_state callee_pname || - Models.is_check_argument callee_pname then + Models.is_check_argument callee_pname then do_preconditions_check_state typestate2 else typestate2 end @@ -765,7 +765,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc begin match Errdesc.find_normal_variable_funcall node' id with | Some (Sil.Const (Sil.Cfun pn), e1:: _, loc, call_flags) when - filter_callee pn -> + filter_callee pn -> Some e1 | _ -> None end @@ -889,14 +889,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc | _ -> typestate in (** Handle assigment fron a temp pvar in a condition. - This recognizes the handling of temp variables in ((x = ...) != null) *) + This recognizes the handling of temp variables in ((x = ...) != null) *) let handle_assignment_in_condition pvar = match Cfg.Node.get_preds node with | [prev_node] -> let found = ref None in let do_instr i = match i with | Sil.Set (e, _, e', _) - when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv e') -> + when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv e') -> found := Some e | _ -> () in list_iter do_instr (Cfg.Node.get_instrs prev_node); @@ -918,11 +918,11 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc else _node, c' | Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar -> (match handle_assignment_in_condition pvar with - | None -> - (match Errdesc.find_program_variable_assignment _node pvar with - | Some (node', id) -> node', Sil.Var id - | None -> _node, _cond) - | Some e2 -> _node, e2) + | None -> + (match Errdesc.find_program_variable_assignment _node pvar with + | Some (node', id) -> node', Sil.Var id + | None -> _node, _cond) + | Some e2 -> _node, e2) | c -> _node, c in let node', ncond = normalize_cond node cond in @@ -943,7 +943,7 @@ let typecheck_node let typestates_exn = ref [] in let handle_exceptions typestate instr = match instr with | Sil.Call (_, Sil.Const (Sil.Cfun callee_pname), _, _, _) -> - (* check if the call might throw an exception *) + (* check if the call might throw an exception *) let exceptions = match get_proc_desc callee_pname with | Some callee_pdesc -> @@ -952,9 +952,9 @@ let typecheck_node if exceptions <> [] then typestates_exn := typestate :: !typestates_exn | Sil.Set (Sil.Lvar pv, _, _, _) when - Sil.pvar_is_return pv && - Cfg.Node.get_kind node = Cfg.Node.throw_kind -> - (* throw instruction *) + Sil.pvar_is_return pv && + Cfg.Node.get_kind node = Cfg.Node.throw_kind -> + (* throw instruction *) typestates_exn := typestate :: !typestates_exn | _ -> () in diff --git a/infer/src/checkers/typeErr.ml b/infer/src/checkers/typeErr.ml index 9c0fee4e1..e3b6087aa 100644 --- a/infer/src/checkers/typeErr.ml +++ b/infer/src/checkers/typeErr.ml @@ -70,7 +70,7 @@ type err_instance = | Field_over_annotated of Ident.fieldname * Procname.t | Null_field_access of string option * Ident.fieldname * origin_descr * bool | Call_receiver_annotation_inconsistent - of Annotations.annotation * string option * Procname.t * origin_descr + of Annotations.annotation * string option * Procname.t * origin_descr | Parameter_annotation_inconsistent of parameter_not_nullable | Return_annotation_inconsistent of Annotations.annotation * Procname.t * origin_descr | Return_over_annotated of Procname.t @@ -110,14 +110,14 @@ module H = Hashtbl.Make(struct | Null_field_access _, _ | _, Null_field_access _ -> false | Call_receiver_annotation_inconsistent (ann1, so1, pn1, od1), - Call_receiver_annotation_inconsistent (ann2, so2, pn2, od2) -> + Call_receiver_annotation_inconsistent (ann2, so2, pn2, od2) -> ann1 = ann2 && (opt_equal string_equal) so1 so2 && Procname.equal pn1 pn2 | Call_receiver_annotation_inconsistent _, _ | _, Call_receiver_annotation_inconsistent _ -> false | Parameter_annotation_inconsistent (ann1, s1, n1, pn1, cl1, od1), - Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, od2) -> + Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, od2) -> ann1 = ann2 && string_equal s1 s2 && int_equal n1 n2 && @@ -126,18 +126,18 @@ module H = Hashtbl.Make(struct | Parameter_annotation_inconsistent _, _ | _, Parameter_annotation_inconsistent _ -> false | Return_annotation_inconsistent (ann1, pn1, od1), - Return_annotation_inconsistent (ann2, pn2, od2) -> + Return_annotation_inconsistent (ann2, pn2, od2) -> ann1 = ann2 && Procname.equal pn1 pn2 | Return_annotation_inconsistent _, _ | _, Return_annotation_inconsistent _ -> false | Return_over_annotated pn1, Return_over_annotated pn2 -> Procname.equal pn1 pn2 | Inconsistent_subclass_return_annotation (pn1, spn1), - Inconsistent_subclass_return_annotation (pn2, spn2) -> + Inconsistent_subclass_return_annotation (pn2, spn2) -> if Procname.equal pn1 pn2 then true else Procname.equal spn1 spn2 | Inconsistent_subclass_parameter_annotation (param_name_1, pos_1, pn_1, overriden_pn_1), - Inconsistent_subclass_parameter_annotation (param_name_2, pos_2, pn_2, overriden_pn_2) -> + Inconsistent_subclass_parameter_annotation (param_name_2, pos_2, pn_2, overriden_pn_2) -> string_equal param_name_1 param_name_2 && int_equal pos_1 pos_2 && Procname.equal pn_1 pn_2 && @@ -201,8 +201,8 @@ let err_tbl : err_state H.t = let reset () = H.reset err_tbl (** Get the forall status of an err_instance. -The forall status indicates that the error should be printed only if it -occurs on every path. *) + The forall status indicates that the error should be printed only if it + occurs on every path. *) let get_forall = function | Condition_redundant _ -> true | Field_not_initialized _ -> false @@ -219,7 +219,7 @@ let get_forall = function (** Reset the always field of the forall erros in the node, so if they are not set again -we know that they don't fire on every path. *) + we know that they don't fire on every path. *) let node_reset_forall node = let iter (err_instance, instr_ref_opt) err_state = match instr_ref_opt, get_forall err_instance with @@ -255,10 +255,10 @@ module Strict = struct let this_type_get_strict signature = match signature.Annotations.params with | ("this", _, this_type):: _ -> begin - match PatternMatch.type_get_annotation this_type with - | Some ia -> Annotations.ia_get_strict ia - | None -> None - end + match PatternMatch.type_get_annotation this_type with + | Some ia -> Annotations.ia_get_strict ia + | None -> None + end | _ -> None let signature_get_strict signature = @@ -283,7 +283,7 @@ module Strict = struct | Null_field_access (_, _, origin_descr, _) -> origin_descr_get_strict origin_descr | Parameter_annotation_inconsistent (Annotations.Nullable, _, _, _, _, origin_descr) - when report_on_method_arguments -> + when report_on_method_arguments -> origin_descr_get_strict origin_descr | _ -> None end (* Strict *) @@ -434,12 +434,12 @@ let report_error_now s origin_desc | Annotations.Present -> "ERADICATE_PARAMETER_VALUE_ABSENT", - P.sprintf - "`%s` needs a present value in parameter %d but argument `%s` can be absent. %s" - (Procname.to_simplified_string pn) - n - s - origin_desc in + P.sprintf + "`%s` needs a present value in parameter %d but argument `%s` can be absent. %s" + (Procname.to_simplified_string pn) + n + s + origin_desc in true, kind_s, description, @@ -518,7 +518,7 @@ let report_error_now (** Report an error unless is has been reported already, or unless it's a forall error -since it requires waiting until the end of the analysis and be printed by flush. *) + since it requires waiting until the end of the analysis and be printed by flush. *) let report_error st_report_error find_canonical_duplicate node err_instance instr_ref_opt loc proc_name = let should_report_now = diff --git a/infer/src/checkers/typeOrigin.ml b/infer/src/checkers/typeOrigin.ml index f24bd9ae7..50c58ba6c 100644 --- a/infer/src/checkers/typeOrigin.ml +++ b/infer/src/checkers/typeOrigin.ml @@ -83,8 +83,8 @@ let get_description origin = | Some ann -> let str = "@Strict" in (match ann.Sil.parameters with - | par1 :: _ -> Printf.sprintf "%s(%s) " str par1 - | [] -> Printf.sprintf "%s " str) + | par1 :: _ -> Printf.sprintf "%s(%s) " str par1 + | [] -> Printf.sprintf "%s " str) | None -> "" in let description = Printf.sprintf "call to %s%s %s" diff --git a/infer/src/checkers/typeState.ml b/infer/src/checkers/typeState.ml index 0615fdbea..789b018b1 100644 --- a/infer/src/checkers/typeState.ml +++ b/infer/src/checkers/typeState.ml @@ -24,8 +24,8 @@ type 'a ext = { empty : 'a; (** empty extension *) check_instr : (** check the extension for an instruction *) - get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t - -> 'a -> Sil.instr -> parameters -> 'a; + get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t + -> 'a -> Sil.instr -> parameters -> 'a; join : 'a -> 'a -> 'a; (** join two extensions *) pp : Format.formatter -> 'a -> unit (** pretty print an extension *) } @@ -99,23 +99,23 @@ let map_join m1 m2 = try let range1 = M.find exp2 m1 in (match range_join range1 range2 with - | None -> () - | Some range' -> tjoined := M.add exp2 range' !tjoined) + | None -> () + | Some range' -> tjoined := M.add exp2 range' !tjoined) with Not_found -> - let (t2, ta2, locs2) = range2 in - let range2' = - let ta2' = TypeAnnotation.with_origin ta2 TypeOrigin.Undef in - (t2, ta2', locs2) in - tjoined := M.add exp2 range2' !tjoined in + let (t2, ta2, locs2) = range2 in + let range2' = + let ta2' = TypeAnnotation.with_origin ta2 TypeOrigin.Undef in + (t2, ta2', locs2) in + tjoined := M.add exp2 range2' !tjoined in let missing_rhs exp1 range1 = (* handle elements missing in the rhs *) try ignore (M.find exp1 m2) with Not_found -> - let (t1, ta1, locs1) = range1 in - let range1' = - let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in - (t1, ta1', locs1) in - tjoined := M.add exp1 range1' !tjoined in + let (t1, ta1, locs1) = range1 in + let range1' = + let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in + (t1, ta1', locs1) in + tjoined := M.add exp1 range1' !tjoined in if m1 == m2 then m1 else try diff --git a/infer/src/clang/ast_expressions.ml b/infer/src/clang/ast_expressions.ml index 5938de9e7..2a20441ce 100644 --- a/infer/src/clang/ast_expressions.ml +++ b/infer/src/clang/ast_expressions.ml @@ -373,7 +373,7 @@ let translate_dispatch_function block_name stmt_info stmt_list ei n = let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} in let block_def = ImplicitCastExpr(stmt_info,[block_expr], bei, cast_info) in let decl_info = { empty_decl_info - with di_pointer = stmt_info.si_pointer; di_source_range = stmt_info.si_source_range } in + with di_pointer = stmt_info.si_pointer; di_source_range = stmt_info.si_source_range } in let var_decl_info = { empty_var_decl with vdi_init_expr = Some block_def } in let block_var_decl = VarDecl(decl_info, block_name_info, ei.ei_qual_type, var_decl_info) in let decl_stmt = DeclStmt(stmt_info,[], [block_var_decl]) in @@ -495,8 +495,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = | ParmVarDecl(di, name, qt, _) -> let qt_fun = create_void_unsigned_long_type () in let parameter = UnaryExprOrTypeTraitExpr((fresh_stmt_info stmt_info), [], - make_expr_info (create_unsigned_long_type ()), - { Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in + make_expr_info (create_unsigned_long_type ()), + { Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in let malloc = create_call (fresh_stmt_info stmt_info) di.di_pointer CFrontend_config.malloc qt_fun [parameter] in let init_exp = create_implicit_cast_expr (fresh_stmt_info stmt_info) [malloc] qt `BitCast in make_DeclStmt (fresh_stmt_info stmt_info) di qt name (Some init_exp) @@ -551,8 +551,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let ei_idx = get_ei_from_cast decl_ref_expr_idx in let ove_idx = build_OpaqueValueExpr (fresh_stmt_info stmt_info) decl_ref_expr_idx ei_idx in let objc_sre = ObjCSubscriptRefExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], - make_expr_info (pseudo_object_qt ()), - { osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in + make_expr_info (pseudo_object_qt ()), + { osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in let obj_c_message_expr_info = { omei_selector = CFrontend_config.object_at_indexed_subscript_m; omei_receiver_kind =`Instance } in let ome = ObjCMessageExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], poe_ei, obj_c_message_expr_info) in let pseudo_obj_expr = PseudoObjectExpr((fresh_stmt_info stmt_info), [objc_sre; ove_array; ove_idx; ome], poe_ei) in @@ -625,8 +625,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let if_stop = build_if_stop stop_cast in let free_stop = free_stop pstop in [ objects_decl; block_decl; decl_stop; assign_stop; - ForStmt(stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr; - CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op + ForStmt(stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr; + CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op | _ -> assert false in match stmt_list with @@ -636,8 +636,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let translated_stmt, op = translate bdi.Clang_ast_t.bdi_parameters s block_decl bei.Clang_ast_t.ei_qual_type in CompoundStmt(stmt_info, translated_stmt), vars_to_register@op@bv | _ -> (* When it is not the method we expect with only one parameter, we don't translate *) - Printing.log_out "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info); - CompoundStmt(stmt_info, stmt_list), [] + Printing.log_out "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info); + CompoundStmt(stmt_info, stmt_list), [] (* We translate the logical negation of an integer with a conditional*) (* !x <=> x?0:1 *) diff --git a/infer/src/clang/cArithmetic_trans.ml b/infer/src/clang/cArithmetic_trans.ml index c3fd62c6e..32ab28b62 100644 --- a/infer/src/clang/cArithmetic_trans.ml +++ b/infer/src/clang/cArithmetic_trans.ml @@ -28,24 +28,24 @@ let assignment_arc_mode context e1 typ e2 loc rhs_owning_method is_e1_decl = Sil.Call([], bi_retain, [(e, t)], loc, Sil.cf_default) in match typ with | Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && not is_e1_decl -> - (* for __strong e1 = e2 the semantics is*) - (* retain(e2); tmp=e1; e1=e2; release(tmp); *) + (* for __strong e1 = e2 the semantics is*) + (* retain(e2); tmp=e1; e1=e2; release(tmp); *) let retain = mk_call retain_pname e2 typ in let id = Ident.create_fresh Ident.knormal in let tmp_assign = Sil.Letderef(id, e1, typ, loc) in let release = mk_call release_pname (Sil.Var id) typ in (e1,[retain; tmp_assign; assign; release ], [id]) | Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && is_e1_decl -> - (* for A __strong *e1 = e2 the semantics is*) - (* retain(e2); e1=e2; *) + (* for A __strong *e1 = e2 the semantics is*) + (* retain(e2); e1=e2; *) let retain = mk_call retain_pname e2 typ in (e1,[retain; assign ], []) | Sil.Tptr (t, Sil.Pk_objc_weak) | Sil.Tptr (t, Sil.Pk_objc_unsafe_unretained) -> (e1, [assign],[]) | Sil.Tptr (t, Sil.Pk_objc_autoreleasing) -> - (* for __autoreleasing e1 = e2 the semantics is*) - (* retain(e2); autorelease(e2); e1=e2; *) + (* for __autoreleasing e1 = e2 the semantics is*) + (* retain(e2); autorelease(e2); e1=e2; *) let retain = mk_call retain_pname e2 typ in let autorelease = mk_call autorelease_pname e2 typ in (e1, [retain; autorelease; assign], []) @@ -167,7 +167,7 @@ let unary_operation_instruction uoi e typ loc = | `Plus -> ([], e, []) | `LNot -> ([], un_exp (Sil.LNot), []) | `Deref -> - (* Actual dereferencing is handled by implicit cast from rvalue to lvalue *) + (* Actual dereferencing is handled by implicit cast from rvalue to lvalue *) ([], e, []) | `AddrOf -> ([], e, []) | `Real | `Imag | `Extension -> diff --git a/infer/src/clang/cAstProcessor.ml b/infer/src/clang/cAstProcessor.ml index 596e7cbea..1a980e7be 100644 --- a/infer/src/clang/cAstProcessor.ml +++ b/infer/src/clang/cAstProcessor.ml @@ -8,8 +8,8 @@ *) (** Module to preprocess location information in the AST. -The original location information is incremental, each location is a delta -w.r.t. the previous one. This module processes the AST and makes locations explicit. *) + The original location information is incremental, each location is a delta + w.r.t. the previous one. This module processes the AST and makes locations explicit. *) open Utils open Clang_ast_j @@ -140,7 +140,7 @@ let pp_ast_decl fmt ast_decl = (** Compose incremental location information and make locations explicit. *) module LocComposer : sig -(** Status of the composer. *) + (** Status of the composer. *) type status (** Create a new composer with the initial status. *) @@ -150,9 +150,9 @@ module LocComposer : sig val compose : status -> source_range -> source_range (** Set the current file if specified in the source_range. - The composer will not descend into file included from the current one. - For locations in included files, it will return instead the last known - location of the current file. *) + The composer will not descend into file included from the current one. + For locations in included files, it will return instead the last known + location of the current file. *) val set_current_file : status -> source_range -> unit end = struct type status = @@ -271,9 +271,9 @@ and decl_process_locs loc_composer decl = (** Process locations in the AST by making them explicit. -Each toplevel declaration determines the current file, -and once diving into the details of the declaration, location -information about other (include) files is ignored. *) + Each toplevel declaration determines the current file, + and once diving into the details of the declaration, location + information about other (include) files is ignored. *) let ast_decl_process_locs loc_composer ast_decl = let toplevel_decl_process_locs decl = diff --git a/infer/src/clang/cContext.ml b/infer/src/clang/cContext.ml index 1dff56eea..7816c9c58 100644 --- a/infer/src/clang/cContext.ml +++ b/infer/src/clang/cContext.ml @@ -103,9 +103,9 @@ struct let print_stack var_name stack = Stack.iter (fun (var_name, typ, level) -> - Printing.log_out "var item %s:" (Mangled.to_string var_name); - Printing.log_out "%s" (Sil.typ_to_string typ); - Printing.log_out "- %s @." (string_of_int level)) stack in + Printing.log_out "var item %s:" (Mangled.to_string var_name); + Printing.log_out "%s" (Sil.typ_to_string typ); + Printing.log_out "- %s @." (string_of_int level)) stack in Printing.log_out "LOCAL VARS:@\n"; StringMap.iter print_stack context.local_vars_stack @@ -125,9 +125,9 @@ struct try StringMap.find pointer context.local_vars_pointer with Not_found -> - (Printing.log_err " ...Variable for pointer %s not found!!\n%!" pointer); - print_pointer_vars context; - assert false + (Printing.log_err " ...Variable for pointer %s not found!!\n%!" pointer); + print_pointer_vars context; + assert false let lookup_var_locals context procname var_name = let stack = lookup_var_map context var_name in @@ -141,37 +141,37 @@ struct try Some (fst (lookup_var_locals context procname var_name)) with Stack.Empty -> - try - Some (fst (lookup_var_globals context procname var_name)) - with Not_found -> - if is_captured_var context var_name then - try (* if it's a captured variable we need to look at the parameters list*) - Some (fst (lookup_var_formals context procname var_name)) - with Not_found -> - Printing.log_err "Variable %s not found!!\n%!" var_name; - print_locals context; - None - else None + try + Some (fst (lookup_var_globals context procname var_name)) + with Not_found -> + if is_captured_var context var_name then + try (* if it's a captured variable we need to look at the parameters list*) + Some (fst (lookup_var_formals context procname var_name)) + with Not_found -> + Printing.log_err "Variable %s not found!!\n%!" var_name; + print_locals context; + None + else None else if (kind = `ParmVar) then try Some (fst (lookup_var_formals context procname var_name)) with Not_found -> - let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in - Printing.log_err "Warning: Parameter %s not found!!\n%!" var_name; - Printing.log_err "Formals of procdesc %s" (Procname.to_string procname); - Printing.log_err " are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc)); - Printing.print_failure_info pointer; - assert false + let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in + Printing.log_err "Warning: Parameter %s not found!!\n%!" var_name; + Printing.log_err "Formals of procdesc %s" (Procname.to_string procname); + Printing.log_err " are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc)); + Printing.print_failure_info pointer; + assert false else if (kind = `Function || kind = `ImplicitParam) then ( (* ImplicitParam are 'self' and '_cmd'. These are never defined but they can be referred to in the code. *) Printing.log_err "Creating a variable for '%s' \n%!" var_name; Some (Sil.mk_pvar (Mangled.from_string var_name) procname)) else if (kind = `EnumConstant) then (Printing.print_failure_info pointer; - assert false) + assert false) else (Printing.log_err "WARNING: In lookup_var kind %s not handled. Giving up!\n%!" (Clang_ast_j.string_of_decl_kind kind); - Printing.print_failure_info pointer; - assert false) + Printing.print_failure_info pointer; + assert false) let get_variable_name name = Mangled.mangled name ((string_of_int(Block.depth ()))) @@ -201,8 +201,8 @@ struct let (top_var, top_typ, top_level) = Stack.top stack in if top_level == (Block.depth ()) then (ignore (Stack.pop stack); - context.local_vars_stack <- - StringMap.add var_name stack context.local_vars_stack) + context.local_vars_stack <- + StringMap.add var_name stack context.local_vars_stack) else () with Stack.Empty -> () in StringMap.iter remove_top context.local_vars_stack @@ -256,7 +256,7 @@ let curr_class_to_string curr_class = match curr_class with | ContextCls (name, superclass, protocols) -> ("class " ^ name ^ ", superclass: " ^ (Option.default "" superclass) ^ - ", protocols: " ^ (Utils.list_to_string (fun x -> x) protocols)) + ", protocols: " ^ (Utils.list_to_string (fun x -> x) protocols)) | ContextCategory (name, cls) -> ("category " ^ name ^ " of class " ^ cls) | ContextProtocol name -> ("protocol " ^ name) | ContextNoCls -> "no class" @@ -297,8 +297,8 @@ let create_curr_class tenv class_name = match Sil.tenv_lookup tenv class_tn_name with | Some Sil.Tstruct(intf_fields, _, _, _, superclasses, methods, annotation) -> (let superclasses_names = list_map (fun (_, name) -> Mangled.to_string name) superclasses in - match superclasses_names with - | superclass:: protocols -> - ContextCls (class_name, Some superclass, protocols) - | [] -> ContextCls (class_name, None, [])) + match superclasses_names with + | superclass:: protocols -> + ContextCls (class_name, Some superclass, protocols) + | [] -> ContextCls (class_name, None, [])) | _ -> assert false diff --git a/infer/src/clang/cEnum_decl.ml b/infer/src/clang/cEnum_decl.ml index 0aca82afc..254c014ef 100644 --- a/infer/src/clang/cEnum_decl.ml +++ b/infer/src/clang/cEnum_decl.ml @@ -30,16 +30,16 @@ let create_empty_procdesc () = Sil.is_generated = false; } in create { - cfg = Cfg.Node.create_cfg (); - name = procname; - is_defined = false; - ret_type = Sil.Tvoid; - formals = []; - locals = []; - captured = []; - loc = Sil.loc_none; - proc_attributes = proc_attributes; - } + cfg = Cfg.Node.create_cfg (); + name = procname; + is_defined = false; + ret_type = Sil.Tvoid; + formals = []; + locals = []; + captured = []; + loc = Sil.loc_none; + proc_attributes = proc_attributes; + } (* We will use global_procdesc for storing global variables. *) (* Globals will be stored as locals in global_procdesc and they are added*) @@ -52,19 +52,19 @@ let rec get_enum_constants context decl_list v = | EnumConstantDecl(decl_info, name_info, qual_type, enum_constant_decl_info) :: decl_list' -> let name = name_info.Clang_ast_t.ni_name in (match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with - | None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v)); - (Mangled.from_string name, Sil.Cint (Sil.Int.of_int v)) - :: get_enum_constants context decl_list' (v + 1) - | Some stmt -> - let e = CGen_trans.CTransImpl.expression_trans context stmt - "WARNING: Expression in Enumeration constant not found\n" in - let const = (match Prop.exp_normalize_prop Prop.prop_emp e with - | Sil.Const c -> c - | _ -> (* This is a hack to avoid failing in some strange definition of Enum *) - Sil.Cint Sil.Int.zero) in - Printing.log_out " ...Defining Enum Constant ('%s', " name; - Printing.log_out "'%s')\n" (Sil.exp_to_string (Sil.Const const)); - (Mangled.from_string name, const) :: get_enum_constants context decl_list' v) + | None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v)); + (Mangled.from_string name, Sil.Cint (Sil.Int.of_int v)) + :: get_enum_constants context decl_list' (v + 1) + | Some stmt -> + let e = CGen_trans.CTransImpl.expression_trans context stmt + "WARNING: Expression in Enumeration constant not found\n" in + let const = (match Prop.exp_normalize_prop Prop.prop_emp e with + | Sil.Const c -> c + | _ -> (* This is a hack to avoid failing in some strange definition of Enum *) + Sil.Cint Sil.Int.zero) in + Printing.log_out " ...Defining Enum Constant ('%s', " name; + Printing.log_out "'%s')\n" (Sil.exp_to_string (Sil.Const const)); + (Mangled.from_string name, const) :: get_enum_constants context decl_list' v) | _ -> assert false let enum_decl name tenv cfg cg namespace decl_list opt_type = diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index 26eb2d898..3bee84a29 100644 --- a/infer/src/clang/cField_decl.ml +++ b/infer/src/clang/cField_decl.ml @@ -32,8 +32,8 @@ let fields_superclass tenv interface_decl_info = match interface_decl_info.Clang_ast_t.otdi_super with | Some dr -> (match dr.Clang_ast_t.dr_name with - | Some sc -> get_fields_super_classes tenv (CTypes.mk_classname sc.Clang_ast_t.ni_name) - | _ -> []) + | Some sc -> get_fields_super_classes tenv (CTypes.mk_classname sc.Clang_ast_t.ni_name) + | _ -> []) | _ -> [] let get_field_www name_field fl = @@ -70,12 +70,12 @@ let ivar_property curr_class ivar = match ObjcProperty_decl.Property.find_property_name_from_ivar curr_class ivar with | Some pname' -> (Printing.log_out "Found property name from ivar: '%s'" pname'; - try - let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in - atts - with Not_found -> - Printing.log_out "Didn't find property for pname '%s'" pname'; - []) + try + let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in + atts + with Not_found -> + Printing.log_out "Didn't find property for pname '%s'" pname'; + []) | None -> Printing.log_out "No property found for ivar '%s'@." ivar; [] @@ -102,7 +102,7 @@ let rec get_fields tenv curr_class decl_list = Printing.log_out " ...Resulting sil field: (%s) with attributes:@." ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ)); list_iter (fun (ia', _) -> - list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia; + list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia; (fname, typ, ia):: fields | ObjCPropertyImplDecl(decl_info, property_impl_decl_info):: decl_list' -> diff --git a/infer/src/clang/cFrontend.ml b/infer/src/clang/cFrontend.ml index 5f9a792b2..910b8d74d 100644 --- a/infer/src/clang/cFrontend.ml +++ b/infer/src/clang/cFrontend.ml @@ -76,7 +76,7 @@ let rec translate_one_declaration tenv cg cfg namespace dec = CMethod_declImpl.process_methods tenv cg cfg curr_class namespace decl_list | EnumDecl(decl_info, name_info, opt_type, decl_list, decl_context_info, enum_decl_info) - when should_translate_enum -> + when should_translate_enum -> let name = name_info.Clang_ast_t.ni_name in CEnum_decl.enum_decl name tenv cfg cg namespace decl_list opt_type @@ -155,5 +155,5 @@ let do_source_file source_file ast = if !CFrontend_config.stats_mode then Cfg.check_cfg_connectedness cfg; if !CFrontend_config.stats_mode || !CFrontend_config.debug_mode || !CFrontend_config.testing_mode then (Dotty.print_icfg_dotty cfg []; - Cg.save_call_graph_dotty None Specs.get_specs call_graph) + Cg.save_call_graph_dotty None Specs.get_specs call_graph) diff --git a/infer/src/clang/cFrontend_utils.ml b/infer/src/clang/cFrontend_utils.ml index 67e29cba9..003726805 100644 --- a/infer/src/clang/cFrontend_utils.ml +++ b/infer/src/clang/cFrontend_utils.ml @@ -34,59 +34,59 @@ struct let print_tenv tenv = Sil.tenv_iter (fun typname typ -> - match typname with - | Sil.TN_csu (Sil.Class, _) | Sil.TN_csu (Sil.Protocol, _) -> - (match typ with (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) -> - (print_endline ( - (Sil.typename_to_string typname)^"\n"^ - "---> superclass and protocols "^(list_to_string (fun (csu, x) -> - let nsu = Sil.TN_csu (csu, x) in - "\t"^(Sil.typename_to_string nsu)^"\n") super_classes)^ - "---> methods "^(list_to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^ - "\t---> static fields "^(list_to_string (fun (fieldname, typ, _) -> - "\t "^(Ident.fieldname_to_string fieldname)^" "^ - (Sil.typ_to_string typ)^"\n") static_fields)^ - "\t---> fields "^(list_to_string (fun (fieldname, typ, _) -> - "\t "^(Ident.fieldname_to_string fieldname)^" "^ - (Sil.typ_to_string typ)^"\n") fields - ) - ) - ) - | _ -> ()) - | _ -> () + match typname with + | Sil.TN_csu (Sil.Class, _) | Sil.TN_csu (Sil.Protocol, _) -> + (match typ with (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) -> + (print_endline ( + (Sil.typename_to_string typname)^"\n"^ + "---> superclass and protocols "^(list_to_string (fun (csu, x) -> + let nsu = Sil.TN_csu (csu, x) in + "\t"^(Sil.typename_to_string nsu)^"\n") super_classes)^ + "---> methods "^(list_to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^ + "\t---> static fields "^(list_to_string (fun (fieldname, typ, _) -> + "\t "^(Ident.fieldname_to_string fieldname)^" "^ + (Sil.typ_to_string typ)^"\n") static_fields)^ + "\t---> fields "^(list_to_string (fun (fieldname, typ, _) -> + "\t "^(Ident.fieldname_to_string fieldname)^" "^ + (Sil.typ_to_string typ)^"\n") fields + ) + ) + ) + | _ -> ()) + | _ -> () ) tenv let print_tenv_struct_unions tenv = Sil.tenv_iter (fun typname typ -> - match typname with - | Sil.TN_csu (Sil.Struct, _) | Sil.TN_csu (Sil.Union, _) -> - (match typ with - | (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) -> - (print_endline ( - (Sil.typename_to_string typname)^"\n"^ - "\t---> fields "^(list_to_string (fun (fieldname, typ, _) -> - match typ with - | Sil.Tvar tname -> "tvar"^(Sil.typename_to_string tname) - | Sil.Tstruct (_, _, _, _, _, _, _) | _ -> - "\t struct "^(Ident.fieldname_to_string fieldname)^" "^ - (Sil.typ_to_string typ)^"\n") fields - ) - ) - ) - | _ -> ()) - | Sil.TN_typedef typname -> - print_endline ((Mangled.to_string typname)^"-->"^(Sil.typ_to_string typ)) - | _ -> () + match typname with + | Sil.TN_csu (Sil.Struct, _) | Sil.TN_csu (Sil.Union, _) -> + (match typ with + | (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) -> + (print_endline ( + (Sil.typename_to_string typname)^"\n"^ + "\t---> fields "^(list_to_string (fun (fieldname, typ, _) -> + match typ with + | Sil.Tvar tname -> "tvar"^(Sil.typename_to_string tname) + | Sil.Tstruct (_, _, _, _, _, _, _) | _ -> + "\t struct "^(Ident.fieldname_to_string fieldname)^" "^ + (Sil.typ_to_string typ)^"\n") fields + ) + ) + ) + | _ -> ()) + | Sil.TN_typedef typname -> + print_endline ((Mangled.to_string typname)^"-->"^(Sil.typ_to_string typ)) + | _ -> () ) tenv let print_procedures cfg = let procs = Cfg.get_all_procs cfg in print_endline (list_to_string (fun pdesc -> - let pname = Cfg.Procdesc.get_proc_name pdesc in - "name> "^ - (Procname.to_string pname) ^ - " defined? " ^ (string_of_bool (Cfg.Procdesc.is_defined pdesc)) ^ "\n") + let pname = Cfg.Procdesc.get_proc_name pdesc in + "name> "^ + (Procname.to_string pname) ^ + " defined? " ^ (string_of_bool (Cfg.Procdesc.is_defined pdesc)) ^ "\n") procs) let print_failure_info pointer = @@ -133,8 +133,8 @@ struct match stmt with | OpaqueValueExpr(_, lstmt, _, opaque_value_expr_info) -> (match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with - | Some stmt -> lstmt@[stmt] - | _ -> lstmt) + | Some stmt -> lstmt@[stmt] + | _ -> lstmt) (* given that this has not been translated, looking up for variables *) (* inside leads to inconsistencies *) | ObjCAtCatchStmt (stmt_info, stmt_list, obj_c_message_expr_kind) -> @@ -152,8 +152,8 @@ struct match property_impl_decl_info.Clang_ast_t.opidi_property_decl with | Some decl_ref -> (match decl_ref.Clang_ast_t.dr_name with - | Some n -> n.Clang_ast_t.ni_name - | _ -> no_property_name) + | Some n -> n.Clang_ast_t.ni_name + | _ -> no_property_name) | None -> no_property_name let generated_ivar_name property_name = diff --git a/infer/src/clang/cGlobal_vars.ml b/infer/src/clang/cGlobal_vars.ml index adff48cde..dcf287166 100644 --- a/infer/src/clang/cGlobal_vars.ml +++ b/infer/src/clang/cGlobal_vars.ml @@ -54,4 +54,4 @@ let print_map () = (Sil.pp_typ_full Utils.pe_text) value._type in if !CFrontend_config.debug_mode then (L.out "GLOBAL VARS:@."; - MangledMap.iter print_item !varMap) + MangledMap.iter print_item !varMap) diff --git a/infer/src/clang/cLocation.ml b/infer/src/clang/cLocation.ml index 8100be44d..c2ac8a91b 100644 --- a/infer/src/clang/cLocation.ml +++ b/infer/src/clang/cLocation.ml @@ -26,15 +26,15 @@ let init_curr_source_file source_file = let source_file_from_path path = if Filename.is_relative path then (Logging.out - "ERROR: Path %s is relative. Please pass an absolute path in the -c argument.@." - path; - exit 1); + "ERROR: Path %s is relative. Please pass an absolute path in the -c argument.@." + path; + exit 1); match !Config.project_root with | Some root -> (try - DB.rel_source_file_from_abs_path root path - with DB.Path_not_prefix_root -> - DB.source_file_from_string path) + DB.rel_source_file_from_abs_path root path + with DB.Path_not_prefix_root -> + DB.source_file_from_string path) | None -> DB.source_file_from_string path let choose_sloc sloc1 sloc2 prefer_first = @@ -57,10 +57,10 @@ let choose_sloc_to_update_curr_file sloc1 sloc2 = let update_curr_file di = match di.Clang_ast_t.di_source_range with (loc_start, loc_end) -> - let loc = choose_sloc_to_update_curr_file loc_start loc_end in - (match loc.Clang_ast_t.sl_file with - | Some f -> curr_file := source_file_from_path f - | None -> ()) + let loc = choose_sloc_to_update_curr_file loc_start loc_end in + (match loc.Clang_ast_t.sl_file with + | Some f -> curr_file := source_file_from_path f + | None -> ()) let clang_to_sil_location clang_loc parent_line_number procdesc_opt = let line = match clang_loc.Clang_ast_t.sl_line with @@ -91,42 +91,42 @@ let clang_to_sil_location clang_loc parent_line_number procdesc_opt = let should_translate_lib source_range = if !CFrontend_config.no_translate_libs then match source_range with (loc_start, loc_end) -> - let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in - let loc = clang_to_sil_location loc_start (-1) None in - DB.source_file_equal loc.Sil.file !DB.current_source + let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in + let loc = clang_to_sil_location loc_start (-1) None in + DB.source_file_equal loc.Sil.file !DB.current_source else true let should_translate_enum source_range = if !CFrontend_config.testing_mode then match source_range with (loc_start, loc_end) -> - let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in - let loc = clang_to_sil_location loc_start (-1) None in - DB.source_file_equal loc.Sil.file !DB.current_source + let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in + let loc = clang_to_sil_location loc_start (-1) None in + DB.source_file_equal loc.Sil.file !DB.current_source else true let get_sil_location_from_range source_range prefer_first = match source_range with (sloc1, sloc2) -> - let sloc = choose_sloc sloc1 sloc2 prefer_first in - clang_to_sil_location sloc (-1) None + let sloc = choose_sloc sloc1 sloc2 prefer_first in + clang_to_sil_location sloc (-1) None let get_sil_location stmt_info parent_line_number context = match stmt_info.Clang_ast_t.si_source_range with (sloc1, sloc2) -> - let sloc = choose_sloc sloc1 sloc2 true in - clang_to_sil_location sloc parent_line_number (Some (CContext.get_procdesc context)) + let sloc = choose_sloc sloc1 sloc2 true in + clang_to_sil_location sloc parent_line_number (Some (CContext.get_procdesc context)) let get_line stmt_info line_number = match stmt_info.Clang_ast_t.si_source_range with | (sloc1, sloc2) -> let sloc = choose_sloc sloc1 sloc2 true in (match sloc.Clang_ast_t.sl_line with - | Some l -> l - | None -> line_number) + | Some l -> l + | None -> line_number) let check_source_file source_file = let extensions_allowed = [".m"; ".mm"; ".c"; ".cc"; ".cpp"; ".h"] in let allowed = list_exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in if not allowed then (Printing.log_stats "%s" - ("\nThe source file "^source_file^ - " should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n"); - assert false) + ("\nThe source file "^source_file^ + " should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n"); + assert false) diff --git a/infer/src/clang/cMain.ml b/infer/src/clang/cMain.ml index 8cc3d16c8..1f47c1fd3 100644 --- a/infer/src/clang/cMain.ml +++ b/infer/src/clang/cMain.ml @@ -8,8 +8,8 @@ *) (* Take as input an ast file and a C or ObjectiveC file such that the ast file -corresponds to the compilation of the C file with clang. -Parse the ast file into a data structure and translates it into a cfg. *) + corresponds to the compilation of the C file with clang. + Parse the ast file into a data structure and translates it into a cfg. *) module L = Logging @@ -26,55 +26,55 @@ let arg_desc = let desc = (filter Utils.base_arg_desc) @ [ - "-c", - Arg.String (fun cfile -> source_file := Some cfile), - Some "cfile", - "C File to translate"; - "-x", - Arg.String (fun lang -> CFrontend_config.lang_from_string lang), - Some "cfile", - "Language (c, objective-c, c++, objc-++)"; - "-ast", - Arg.String (fun file -> ast_file := Some file), - Some "file", - "AST file for the translation"; - "-dotty_cfg_libs", - Arg.Unit (fun _ -> Config.dotty_cfg_libs := true), - None, - "Prints the cfg of the code coming from the libraries"; - "-no_headers", - Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := true), - None, - "Do not translate code in header files (default)"; - "-headers", - Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := false), - None, - "Translate code in header files"; - "-testing_mode", - Arg.Unit (fun _ -> CFrontend_config.testing_mode := true), - None, - "Mode for testing, where no libraries are translated, including enums defined in the libraries"; - "-debug", - Arg.Unit (fun _ -> CFrontend_config.debug_mode := true), - None, - "Enables debug mode"; - "-stats", - Arg.Unit (fun _ -> CFrontend_config.stats_mode := true), - None, - "Enables stats mode"; - "-project_root", - Arg.String (fun s -> + "-c", + Arg.String (fun cfile -> source_file := Some cfile), + Some "cfile", + "C File to translate"; + "-x", + Arg.String (fun lang -> CFrontend_config.lang_from_string lang), + Some "cfile", + "Language (c, objective-c, c++, objc-++)"; + "-ast", + Arg.String (fun file -> ast_file := Some file), + Some "file", + "AST file for the translation"; + "-dotty_cfg_libs", + Arg.Unit (fun _ -> Config.dotty_cfg_libs := true), + None, + "Prints the cfg of the code coming from the libraries"; + "-no_headers", + Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := true), + None, + "Do not translate code in header files (default)"; + "-headers", + Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := false), + None, + "Translate code in header files"; + "-testing_mode", + Arg.Unit (fun _ -> CFrontend_config.testing_mode := true), + None, + "Mode for testing, where no libraries are translated, including enums defined in the libraries"; + "-debug", + Arg.Unit (fun _ -> CFrontend_config.debug_mode := true), + None, + "Enables debug mode"; + "-stats", + Arg.Unit (fun _ -> CFrontend_config.stats_mode := true), + None, + "Enables stats mode"; + "-project_root", + Arg.String (fun s -> Config.project_root := Some (Utils.filename_to_absolute s)), - Some "dir", - "Toot directory of the project"; - "-fobjc-arc", - Arg.Unit (fun s -> Config.arc_mode := true), - None, - "Translate with Objective-C Automatic Reference Counting (ARC)"; - "-models_mode", - Arg.Unit (fun _ -> CFrontend_config.models_mode := true), - None, - "Mode for computing the models"; + Some "dir", + "Toot directory of the project"; + "-fobjc-arc", + Arg.Unit (fun s -> Config.arc_mode := true), + None, + "Translate with Objective-C Automatic Reference Counting (ARC)"; + "-models_mode", + Arg.Unit (fun _ -> CFrontend_config.models_mode := true), + None, + "Mode for computing the models"; ] in Utils.Arg2.create_options_desc false "Parsing Options" desc in base_arg @@ -123,7 +123,7 @@ let _ = Config.print_types:= true; if Option.is_none !source_file then (Printing.log_err "Incorrect command line arguments\n"; - print_usage_exit ()) + print_usage_exit ()) else match !source_file with | Some path -> do_run path !ast_file diff --git a/infer/src/clang/cMethod_decl.ml b/infer/src/clang/cMethod_decl.ml index d054ce4c7..ec68ef9fb 100644 --- a/infer/src/clang/cMethod_decl.ml +++ b/infer/src/clang/cMethod_decl.ml @@ -18,13 +18,13 @@ module L = Logging module type CMethod_decl = sig val process_methods : Sil.tenv -> Cg.t -> Cfg.cfg -> CContext.curr_class -> string option -> - Clang_ast_t.decl list -> unit + Clang_ast_t.decl list -> unit val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info -> - string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit + string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit val create_function_signature : Clang_ast_t.decl_info -> Clang_ast_t.function_decl_info -> string -> - Clang_ast_t.qual_type -> bool -> Procname.t option -> Clang_ast_t.stmt option * CMethod_signature.method_signature + Clang_ast_t.qual_type -> bool -> Procname.t option -> Clang_ast_t.stmt option * CMethod_signature.method_signature val process_getter_setter : CContext.t -> Procname.t -> bool end @@ -92,8 +92,8 @@ struct let ms = build_method_signature di procname (Func_decl_info (fdecl_info, CTypes.get_type qt)) is_instance is_anonym_block false in (match method_body_to_translate di ms fdecl_info.Clang_ast_t.fdi_body with - | Some body -> Some body, ms - | None -> None, ms) + | Some body -> Some body, ms + | None -> None, ms) let model_exists procname = Specs.summary_exists_in_models procname && not !CFrontend_config.models_mode @@ -104,12 +104,12 @@ struct | decl:: rest -> let rest_assume_calls = add_assume_not_null_calls rest attributes in (match decl with - | ParmVarDecl(decl_info, name_info, qtype, var_decl_info) - when CFrontend_utils.Ast_utils.is_type_nonnull qtype attributes -> - let name = name_info.Clang_ast_t.ni_name in - let assume_call = Ast_expressions.create_assume_not_null_call decl_info name qtype in - assume_call:: rest_assume_calls - | _ -> rest_assume_calls) + | ParmVarDecl(decl_info, name_info, qtype, var_decl_info) + when CFrontend_utils.Ast_utils.is_type_nonnull qtype attributes -> + let name = name_info.Clang_ast_t.ni_name in + let assume_call = Ast_expressions.create_assume_not_null_call decl_info name qtype in + assume_call:: rest_assume_calls + | _ -> rest_assume_calls) (* Translates the method/function's body into nodes of the cfg. *) let add_method tenv cg cfg class_decl_opt procname namespace instrs is_objc_method is_instance @@ -118,34 +118,34 @@ struct "\n\n>>---------- ADDING METHOD: '%s' ---------<<\n@." (Procname.to_string procname); try (match Cfg.Procdesc.find_from_name cfg procname with - | Some procdesc -> - if (Cfg.Procdesc.is_defined procdesc && not (model_exists procname)) then - (let context = - CContext.create_context tenv cg cfg procdesc namespace class_decl_opt - is_objc_method captured_vars is_instance in - CVar_decl.get_fun_locals context instrs; - let local_vars = list_map (fun (n, t, _) -> n, t) context.CContext.local_vars in - let start_node = Cfg.Procdesc.get_start_node procdesc in - let exit_node = Cfg.Procdesc.get_exit_node procdesc in - Cfg.Procdesc.append_locals procdesc local_vars; - Cfg.Node.add_locals_ret_declaration start_node local_vars; - Printing.log_out - "\n\n>>---------- Start translating body of function: '%s' ---------<<\n@." - (Procname.to_string procname); - let nonnull_assume_calls = add_assume_not_null_calls param_decls in - let instrs' = instrs@nonnull_assume_calls attributes in - let meth_body_nodes = T.instructions_trans context instrs' exit_node in - if (not is_anonym_block) then CContext.LocalVars.reset_block (); - Cfg.Node.set_succs_exn start_node meth_body_nodes []; - Cg.add_node (CContext.get_cg context) (Cfg.Procdesc.get_proc_name procdesc)) - | None -> ()) + | Some procdesc -> + if (Cfg.Procdesc.is_defined procdesc && not (model_exists procname)) then + (let context = + CContext.create_context tenv cg cfg procdesc namespace class_decl_opt + is_objc_method captured_vars is_instance in + CVar_decl.get_fun_locals context instrs; + let local_vars = list_map (fun (n, t, _) -> n, t) context.CContext.local_vars in + let start_node = Cfg.Procdesc.get_start_node procdesc in + let exit_node = Cfg.Procdesc.get_exit_node procdesc in + Cfg.Procdesc.append_locals procdesc local_vars; + Cfg.Node.add_locals_ret_declaration start_node local_vars; + Printing.log_out + "\n\n>>---------- Start translating body of function: '%s' ---------<<\n@." + (Procname.to_string procname); + let nonnull_assume_calls = add_assume_not_null_calls param_decls in + let instrs' = instrs@nonnull_assume_calls attributes in + let meth_body_nodes = T.instructions_trans context instrs' exit_node in + if (not is_anonym_block) then CContext.LocalVars.reset_block (); + Cfg.Node.set_succs_exn start_node meth_body_nodes []; + Cg.add_node (CContext.get_cg context) (Cfg.Procdesc.get_proc_name procdesc)) + | None -> ()) with | Not_found -> () | CTrans_utils.Self.SelfClassException _ -> assert false (* this shouldn't happen, because self or [a class] should always be arguments of functions. This is to make sure I'm not wrong. *) | Assert_failure (file, line, column) -> print_endline ("Fatal error: exception Assert_failure("^ - file^", "^(string_of_int line)^", "^(string_of_int column)^")"); + file^", "^(string_of_int line)^", "^(string_of_int column)^")"); Cfg.Procdesc.remove cfg procname true; CMethod_trans.create_external_procdesc cfg procname is_objc_method None; () @@ -178,13 +178,13 @@ struct Printing.log_out " ....Processing implementation for method '%s'\n" (Procname.to_string procname); CMethod_signature.add ms; (match method_body_to_translate decl_info ms method_decl_info.Clang_ast_t.omdi_body with - | Some body -> - let is_instance = CMethod_signature.ms_is_instance ms in - let attributes = CMethod_signature.ms_get_attributes ms in - if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_instance then - add_method tenv cg cfg curr_class procname namespace [body] true is_instance [] false - method_decl_info.Clang_ast_t.omdi_parameters attributes - | None -> ()) + | Some body -> + let is_instance = CMethod_signature.ms_is_instance ms in + let attributes = CMethod_signature.ms_get_attributes ms in + if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_instance then + add_method tenv cg cfg curr_class procname namespace [body] true is_instance [] false + method_decl_info.Clang_ast_t.omdi_parameters attributes + | None -> ()) let rec process_one_method_decl tenv cg cfg curr_class namespace dec = match dec with @@ -199,7 +199,7 @@ struct | EmptyDecl _ | ObjCIvarDecl _ | ObjCPropertyDecl _ -> () | d -> Printing.log_err - "\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d); + "\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d); () let process_methods tenv cg cfg curr_class namespace decl_list = @@ -211,17 +211,17 @@ struct let method_name = Procname.c_get_method procname in match ObjcProperty_decl.method_is_property_accesor cls method_name with | Some (property_name, property_type, is_getter) when - CMethod_trans.should_create_procdesc context.cfg procname true true -> + CMethod_trans.should_create_procdesc context.cfg procname true true -> (match property_type with qt, atts, decl_info, _, _, ivar_opt -> - let ivar_name = ObjcProperty_decl.get_ivar_name property_name ivar_opt in - let field = CField_decl.build_sil_field_property cls context.tenv ivar_name qt (Some atts) in - ignore (CField_decl.add_missing_fields context.tenv class_name [field]); - let accessor = - if is_getter then - ObjcProperty_decl.make_getter cls property_name property_type - else ObjcProperty_decl.make_setter cls property_name property_type in - list_iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor; - true) + let ivar_name = ObjcProperty_decl.get_ivar_name property_name ivar_opt in + let field = CField_decl.build_sil_field_property cls context.tenv ivar_name qt (Some atts) in + ignore (CField_decl.add_missing_fields context.tenv class_name [field]); + let accessor = + if is_getter then + ObjcProperty_decl.make_getter cls property_name property_type + else ObjcProperty_decl.make_setter cls property_name property_type in + list_iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor; + true) | _ -> false end diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index 356bc83e8..d84a518e0 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -46,8 +46,8 @@ let resolve_method tenv class_name method_name = | Some (Sil.TN_csu (Sil.Class, class_name)) -> let class_method_name = mk_procname_from_method (Mangled.to_string class_name) method_name in (try let ms = CMethod_signature.find class_method_name in - Some ms - with Not_found -> None) + Some ms + with Not_found -> None) | _ -> None let get_superclass_curr_class context = @@ -60,8 +60,8 @@ let get_superclass_curr_class context = | _ -> Printing.log_err "NOT FOUND superclass = '%s'\n\n%!" (Sil.typename_to_string iname); (match super_opt with - | Some super -> super - | _ -> assert false) in + | Some super -> super + | _ -> assert false) in match CContext.get_curr_class context with | CContext.ContextCls (cname, super_opt, _) -> retrive_super cname super_opt @@ -76,10 +76,10 @@ let get_class_selector_instance context obj_c_message_expr_info act_params = | `Class qt -> (CTypes.get_type qt, selector, MCStatic) | `Instance -> (match act_params with - | (instance_obj, Sil.Tptr(t, _)):: _ - | (instance_obj, t):: _ -> - (CTypes.classname_of_type t, selector, MCVirtual) - | _ -> assert false) + | (instance_obj, Sil.Tptr(t, _)):: _ + | (instance_obj, t):: _ -> + (CTypes.classname_of_type t, selector, MCVirtual) + | _ -> assert false) | `SuperInstance -> let superclass = get_superclass_curr_class context in (superclass, selector, MCNoVirtual) @@ -115,18 +115,18 @@ let captured_vars_from_block_info context cvl = | [] -> [] | cv:: cvl'' -> (match cv.Clang_ast_t.bcv_variable with - | Some dr -> - (match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_qual_type with - | Some name_info, _ -> - let n = name_info.Clang_ast_t.ni_name in - if n = CFrontend_config.self && not context.is_instance then [] - else - (let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in - (Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals)); - let formals = list_map formal2captured procdesc_formals in - [find (context.local_vars @ formals) n]) - | _ -> assert false) - | None -> []) :: f cvl'' in + | Some dr -> + (match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_qual_type with + | Some name_info, _ -> + let n = name_info.Clang_ast_t.ni_name in + if n = CFrontend_config.self && not context.is_instance then [] + else + (let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in + (Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals)); + let formals = list_map formal2captured procdesc_formals in + [find (context.local_vars @ formals) n]) + | _ -> assert false) + | None -> []) :: f cvl'' in list_flatten (f cvl) let get_return_type tenv ms = @@ -153,9 +153,9 @@ let should_create_procdesc cfg procname defined generated = let is_generated_previous = (Cfg.Procdesc.get_attributes prevoius_procdesc).Sil.is_generated in if defined && - ((not is_defined_previous) || (generated && is_generated_previous)) then + ((not is_defined_previous) || (generated && is_generated_previous)) then (Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name prevoius_procdesc) true; - true) + true) else false | None -> true @@ -195,25 +195,25 @@ let create_local_procdesc cfg tenv ms fbody captured is_objc_inst_method = Sil.is_generated = is_generated; } in create { - cfg = cfg; - name = procname; - is_defined = defined; - ret_type = ret_type; - formals = formals; - locals = []; - captured = captured'; - loc = loc_start; - proc_attributes = proc_attributes; - } in + cfg = cfg; + name = procname; + is_defined = defined; + ret_type = ret_type; + formals = formals; + locals = []; + captured = captured'; + loc = loc_start; + proc_attributes = proc_attributes; + } in if defined then (if !Config.arc_mode then - Cfg.Procdesc.set_flag procdesc Mleak_buckets.objc_arc_flag "true"; - let start_kind = Cfg.Node.Start_node procdesc in - let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in - let exit_kind = Cfg.Node.Exit_node procdesc in - let exit_node = Cfg.Node.create cfg loc_exit exit_kind [] procdesc [] in - Cfg.Procdesc.set_start_node procdesc start_node; - Cfg.Procdesc.set_exit_node procdesc exit_node) in + Cfg.Procdesc.set_flag procdesc Mleak_buckets.objc_arc_flag "true"; + let start_kind = Cfg.Node.Start_node procdesc in + let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in + let exit_kind = Cfg.Node.Exit_node procdesc in + let exit_node = Cfg.Node.create cfg loc_exit exit_kind [] procdesc [] in + Cfg.Procdesc.set_start_node procdesc start_node; + Cfg.Procdesc.set_exit_node procdesc exit_node) in let generated = CMethod_signature.ms_is_generated ms in if should_create_procdesc cfg procname defined generated then (create_new_procdesc (); true) @@ -226,9 +226,9 @@ let create_external_procdesc cfg procname is_objc_inst_method type_opt = | None -> let ret_type, formals = (match type_opt with - | Some (ret_type, arg_types) -> - ret_type, list_map (fun typ -> ("x", typ)) arg_types - | None -> Sil.Tvoid, []) in + | Some (ret_type, arg_types) -> + ret_type, list_map (fun typ -> ("x", typ)) arg_types + | None -> Sil.Tvoid, []) in let loc = Sil.loc_none in let _ = let open Cfg.Procdesc in @@ -246,16 +246,16 @@ let create_external_procdesc cfg procname is_objc_inst_method type_opt = Sil.is_generated = false; } in create { - cfg = cfg; - name = procname; - is_defined = false; - ret_type = ret_type; - formals = formals; - locals = []; - captured = []; - loc = loc; - proc_attributes = proc_attributes; - } in + cfg = cfg; + name = procname; + is_defined = false; + ret_type = ret_type; + formals = formals; + locals = []; + captured = []; + loc = loc; + proc_attributes = proc_attributes; + } in () let instance_to_method_call_type instance = diff --git a/infer/src/clang/cModule_type.ml b/infer/src/clang/cModule_type.ml index acee9f41c..6c64374f5 100644 --- a/infer/src/clang/cModule_type.ml +++ b/infer/src/clang/cModule_type.ml @@ -15,7 +15,7 @@ end module type CMethod_declaration = sig val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info -> - string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit + string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit val process_getter_setter : CContext.t -> Procname.t -> bool end diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index b4318b1d5..2508c817e 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -22,10 +22,10 @@ open CTrans_utils.Nodes module L = Logging module type CTrans = sig -(** Translates instructions: (statements and expressions) from the ast into sil *) + (** Translates instructions: (statements and expressions) from the ast into sil *) -(** It receives the context, a list of statements and the exit node and it returns a list of cfg nodes *) -(** that reporesent the translation of the stmts into sil. *) + (** It receives the context, a list of statements and the exit node and it returns a list of cfg nodes *) + (** that reporesent the translation of the stmts into sil. *) val instructions_trans : CContext.t -> Clang_ast_t.stmt list -> Cfg.Node.t -> Cfg.Node.t list (** It receives the context and a statement and a warning string and returns the translated sil expression *) @@ -44,7 +44,7 @@ struct CMethod_trans.get_class_selector_instance context obj_c_message_expr_info act_params in let is_instance = mc_type != CMethod_trans.MCStatic in match CTrans_models.get_predefined_model_method_signature class_name method_name - CMethod_trans.mk_procname_from_method with + CMethod_trans.mk_procname_from_method with | Some ms -> ignore (CMethod_trans.create_local_procdesc context.cfg context.tenv ms [] [] is_instance); CMethod_signature.ms_get_name ms, CMethod_trans.MCNoVirtual @@ -52,10 +52,10 @@ struct match CMethod_trans.resolve_method context.tenv class_name method_name with | Some callee_ms -> (let procname = CMethod_signature.ms_get_name callee_ms in - if not (M.process_getter_setter context procname) then - (let is_instance = is_instance || (CMethod_signature.ms_is_instance callee_ms) in - ignore (CMethod_trans.create_local_procdesc context.cfg context.tenv callee_ms [] [] is_instance)); - procname, mc_type) + if not (M.process_getter_setter context procname) then + (let is_instance = is_instance || (CMethod_signature.ms_is_instance callee_ms) in + ignore (CMethod_trans.create_local_procdesc context.cfg context.tenv callee_ms [] [] is_instance)); + procname, mc_type) | None -> let callee_pn = CMethod_trans.mk_procname_from_method class_name method_name in CMethod_trans.create_external_procdesc context.cfg callee_pn is_instance None; @@ -64,8 +64,8 @@ struct let add_autorelease_call context exp typ sil_loc = let method_name = Procname.c_get_method (Cfg.Procdesc.get_proc_name context.procdesc) in if !Config.arc_mode && - not (CTrans_utils.is_owning_name method_name) && - ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv typ then + not (CTrans_utils.is_owning_name method_name) && + ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv typ then let fname = SymExec.ModelBuiltins.__set_autorelease_attribute in let ret_id = Ident.create_fresh Ident.knormal in let stmt_call = Sil.Call([ret_id], (Sil.Const (Sil.Cfun fname)), [(exp, typ)], sil_loc, Sil.cf_default) in @@ -106,7 +106,7 @@ struct let fields = CFrontend_utils.General_utils.sort_fields fields in Printing.log_out "Block %s field:\n" block_name; list_iter (fun (fn, ft, _) -> - Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; + Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; let mblock = Mangled.from_string block_name in let block_type = Sil.Tstruct(fields, [], Sil.Class, Some mblock, [], [], []) in let block_name = Sil.TN_csu(Sil.Class, mblock) in @@ -124,16 +124,16 @@ struct if pred_exit = [] then [Sil.Nullify(block_var, loc, true)] else (list_iter (fun n -> let loc = Cfg.Node.get_loc n in - Cfg.Node.append_instrs_temps n [Sil.Nullify(block_var, loc, true)] []) pred_exit; - []) in + Cfg.Node.append_instrs_temps n [Sil.Nullify(block_var, loc, true)] []) pred_exit; + []) in let set_instr = Sil.Set(Sil.Lvar block_var, block_type, Sil.Var id_block, loc) in let ids, captured_instrs = list_split (list_map (fun (vname, typ, _) -> - let id = Ident.create_fresh Ident.knormal in - id, Sil.Letderef(id, Sil.Lvar (Sil.mk_pvar vname procname), typ, loc) - ) captured_vars) in + let id = Ident.create_fresh Ident.knormal in + id, Sil.Letderef(id, Sil.Lvar (Sil.mk_pvar vname procname), typ, loc) + ) captured_vars) in let fields_ids = list_combine fields ids in let set_fields = list_map (fun ((f, t, _), id) -> - Sil.Set(Sil.Lfield(Sil.Var id_block, f, block_type), t, Sil.Var id, loc)) fields_ids in + Sil.Set(Sil.Lfield(Sil.Var id_block, f, block_type), t, Sil.Var id, loc)) fields_ids in (declare_block_local :: trans_res.instrs) @ [set_instr] @ captured_instrs @ set_fields @ block_nullify_instr , id_block:: ids (* From a list of expression extract blocks from tuples and *) @@ -180,9 +180,9 @@ struct try f trans_state stmt with Self.SelfClassException class_name -> - let typ = CTypes_decl.type_name_to_sil_type trans_state.context.tenv class_name in - { empty_res_trans with - exps = [(Sil.Sizeof(typ, Sil.Subtype.exact), typ)]} + let typ = CTypes_decl.type_name_to_sil_type trans_state.context.tenv class_name in + { empty_res_trans with + exps = [(Sil.Sizeof(typ, Sil.Subtype.exact), typ)]} (* Execute translation of e forcing to release priority (if it's not free) and then setting it back.*) (* This is used in conditional operators where we need to force the priority to be free for the *) @@ -209,9 +209,9 @@ struct { empty_res_trans with exps = [(exp, typ)]} (* FROM CLANG DOCS: "Implements the GNU __null extension, which is a name for a null pointer constant *) - (* that has integral type (e.g., int or long) and is the same size and alignment as a pointer. The __null *) - (* extension is typically only used by system headers, which define NULL as __null in C++ rather than using 0 *) - (* (which is an integer that may not match the size of a pointer)". So we implement it as the constant zero *) + (* that has integral type (e.g., int or long) and is the same size and alignment as a pointer. The __null *) + (* extension is typically only used by system headers, which define NULL as __null in C++ rather than using 0 *) + (* (which is an integer that may not match the size of a pointer)". So we implement it as the constant zero *) let gNUNullExpr_trans trans_state stmt_info expr_info = Printing.log_out "Passing from GNUNullExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer; let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in @@ -261,7 +261,7 @@ struct exp, [] with | Failure _ -> - (* Parse error: return a nondeterministic value *) + (* Parse error: return a nondeterministic value *) let id = Ident.create_fresh Ident.knormal in let exp = Sil.Var id in exp, [id] in @@ -286,8 +286,8 @@ struct | None -> typ in (* Some default type since the type is missing *) { empty_res_trans with exps = [(Sil.Sizeof(sizeof_typ, Sil.Subtype.exact), sizeof_typ)]} | k -> Printing.log_stats - "\nWARNING: 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); + "\nWARNING: 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 =[(Sil.exp_minus_one, typ)]} (* search the label into the hashtbl - create a fake node eventually *) @@ -335,13 +335,13 @@ struct (* As e.g. in fun_ptr = foo; *) let non_mangled_func_name = if name = CFrontend_config.malloc && - (!CFrontend_config.language = CFrontend_config.OBJC || - !CFrontend_config.language = CFrontend_config.OBJCPP) then + (!CFrontend_config.language = CFrontend_config.OBJC || + !CFrontend_config.language = CFrontend_config.OBJCPP) then SymExec.ModelBuiltins.malloc_no_fail else Procname.from_string_c_fun name in let is_builtin = SymExec.function_is_builtin non_mangled_func_name in if is_builtin then (* malloc, free, exit, scanf, ... *) - { empty_res_trans with exps = [(Sil.Const (Sil.Cfun non_mangled_func_name), typ)]} + { empty_res_trans with exps = [(Sil.Const (Sil.Cfun non_mangled_func_name), typ)]} else begin if address_of_function then Cfg.set_procname_priority context.cfg pname; @@ -387,7 +387,7 @@ struct let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let array_stmt, idx_stmt = (match stmt_list with | [a; i] -> a, i (* Assumption: the statement list contains 2 elements, - the first is the array expr and the second the index *) + the first is the array expr and the second the index *) | _ -> assert false) in (* Let's get notified if the assumption is wrong...*) let line_number = get_line stmt_info trans_state.parent_line_number in let trans_state'= { trans_state with parent_line_number = line_number } in @@ -434,103 +434,103 @@ struct let sil_loc = get_sil_location stmt_info parent_line_number context in let typ = CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in (match stmt_list with - | [s1; ImplicitCastExpr (stmt, [CompoundLiteralExpr (cle_stmt_info, stmts, expr_info)], _, cast_expr_info)] -> - let di, line_number = get_decl_ref_info s1 parent_line_number in - let line_number = get_line cle_stmt_info line_number in - let trans_state' = { trans_state with parent_line_number = line_number } in - let res_trans_tmp = initListExpr_trans trans_state' stmt_info expr_info di stmts in - { res_trans_tmp with leaf_nodes =[]} - | [s1; s2] -> (* Assumption: We expect precisely 2 stmt corresponding to the 2 operands*) - let rhs_owning_method = CTrans_utils.is_owning_method s2 in - (* NOTE: we create a node only if required. In that case this node *) - (* becomes the successor of the nodes that may be created when *) - (* translating the operands. *) - let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let line_number = get_line stmt_info parent_line_number in - let trans_state'' = { trans_state_pri with parent_line_number = line_number; succ_nodes =[]} in - let res_trans_e1 = exec_with_self_exception instruction trans_state'' s1 in - let res_trans_e2 = - (* translation of s2 is done taking care of block special case *) - exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state'' s2 stmt_info in - let (sil_e1, sil_typ1) = extract_exp_from_list res_trans_e1.exps "\nWARNING: Missing LHS operand in BinOp. Returning -1. Fix needed...\n" in - let (sil_e2, sil_typ2) = extract_exp_from_list res_trans_e2.exps "\nWARNING: Missing RHS operand in BinOp. Returning -1. Fix needed...\n" in - let exp_op, instr, ids_bin = - CArithmetic_trans.binary_operation_instruction context binary_operator_info sil_e1 typ sil_e2 sil_loc rhs_owning_method in - let instrs = res_trans_e1.instrs@res_trans_e2.instrs@instr in - let ids = res_trans_e1.ids@res_trans_e2.ids@ids_bin in - - (* Create a node if the priority if free and there are instructions *) - let creating_node = - (PriorityNode.own_priority_node trans_state_pri.priority stmt_info) && - (list_length instrs >0) in - - let instrs_after_assign, assign_ids, exp_to_parent = - if (is_binary_assign_op binary_operator_info) - && ((not creating_node) || (is_return_temp trans_state.continuation)) then ( - (* We are in this case when an assignment is inside *) - (* another operator that creates a node. Eg. another *) - (* assignment. *) - (* As no node is created here ids are passed to the parent *) - let id = Ident.create_fresh Ident.knormal in - let res_instr = [Sil.Letderef (id, sil_e1, sil_typ1, sil_loc)] in - instrs@res_instr, ids@[id], Sil.Var id - ) else ( - instrs, ids, exp_op) in - - let instruction_to_ancestor, ids_to_ancestor, succ_nodes' = - if creating_node then ( - let node_kind = - Cfg.Node.Stmt_node ("BinaryOperatorStmt: "^ - (CArithmetic_trans.bin_op_to_string binary_operator_info)) in - let node_bin_op = create_node node_kind [] [] sil_loc context in - Cfg.Node.set_succs_exn node_bin_op succ_nodes []; - let succ_nodes'' = [node_bin_op] in - (* If a node was created, ids are passed to the parent*) - (* if the binop is in the translation of a condition.*) - (* Otherwise ids are added to the node. *) - (* ids_parent/ids_nodes are the list of ids for the parent/node respectively.*) - (* They are computed with continuation which tells us *) - (* if we are translating a condition or not *) - let ids_parent = ids_to_parent trans_state.continuation assign_ids in - let ids_node = ids_to_node trans_state.continuation assign_ids in - list_iter (fun n -> Cfg.Node.append_instrs_temps n instrs_after_assign ids_node) succ_nodes''; - [], ids_parent, succ_nodes'' - ) else ( - instrs_after_assign, assign_ids, succ_nodes) in - - let e1_has_nodes = res_trans_e1.root_nodes <> [] - and e2_has_nodes = res_trans_e2.root_nodes <> [] in - - let e1_succ_nodes = - if e2_has_nodes then res_trans_e2.root_nodes else succ_nodes' in - list_iter (fun n -> Cfg.Node.set_succs_exn n e1_succ_nodes []) res_trans_e1.leaf_nodes; - list_iter (fun n -> Cfg.Node.set_succs_exn n succ_nodes' []) res_trans_e2.leaf_nodes; - - let root_nodes_to_ancestor = match e1_has_nodes, e2_has_nodes with - | false, false -> succ_nodes' - | true, _ -> res_trans_e1.root_nodes - | false, true -> res_trans_e2.root_nodes in - - let leaf_nodes_to_ancestor = - if creating_node then succ_nodes' - else if e2_has_nodes then res_trans_e2.leaf_nodes - else res_trans_e1.leaf_nodes in - - Printing.log_out "....BinaryOperator '%s' " bok; - Printing.log_out "has ids_to_ancestor |ids_to_ancestor|=%s " - (string_of_int (list_length ids_to_ancestor)); - Printing.log_out " |nodes_e1|=%s .\n" - (string_of_int (list_length res_trans_e1.root_nodes)); - Printing.log_out " |nodes_e2|=%s .\n" - (string_of_int (list_length res_trans_e2.root_nodes)); - list_iter (fun id -> Printing.log_out " ... '%s'\n" - (Ident.to_string id)) ids_to_ancestor; - { root_nodes = root_nodes_to_ancestor; - leaf_nodes = leaf_nodes_to_ancestor; - ids = ids_to_ancestor; - instrs = instruction_to_ancestor; - exps = [(exp_to_parent, sil_typ1)] } - | _ -> assert false) (* Binary operator should have two operands*) + | [s1; ImplicitCastExpr (stmt, [CompoundLiteralExpr (cle_stmt_info, stmts, expr_info)], _, cast_expr_info)] -> + let di, line_number = get_decl_ref_info s1 parent_line_number in + let line_number = get_line cle_stmt_info line_number in + let trans_state' = { trans_state with parent_line_number = line_number } in + let res_trans_tmp = initListExpr_trans trans_state' stmt_info expr_info di stmts in + { res_trans_tmp with leaf_nodes =[]} + | [s1; s2] -> (* Assumption: We expect precisely 2 stmt corresponding to the 2 operands*) + let rhs_owning_method = CTrans_utils.is_owning_method s2 in + (* NOTE: we create a node only if required. In that case this node *) + (* becomes the successor of the nodes that may be created when *) + (* translating the operands. *) + let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in + let line_number = get_line stmt_info parent_line_number in + let trans_state'' = { trans_state_pri with parent_line_number = line_number; succ_nodes =[]} in + let res_trans_e1 = exec_with_self_exception instruction trans_state'' s1 in + let res_trans_e2 = + (* translation of s2 is done taking care of block special case *) + exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state'' s2 stmt_info in + let (sil_e1, sil_typ1) = extract_exp_from_list res_trans_e1.exps "\nWARNING: Missing LHS operand in BinOp. Returning -1. Fix needed...\n" in + let (sil_e2, sil_typ2) = extract_exp_from_list res_trans_e2.exps "\nWARNING: Missing RHS operand in BinOp. Returning -1. Fix needed...\n" in + let exp_op, instr, ids_bin = + CArithmetic_trans.binary_operation_instruction context binary_operator_info sil_e1 typ sil_e2 sil_loc rhs_owning_method in + let instrs = res_trans_e1.instrs@res_trans_e2.instrs@instr in + let ids = res_trans_e1.ids@res_trans_e2.ids@ids_bin in + + (* Create a node if the priority if free and there are instructions *) + let creating_node = + (PriorityNode.own_priority_node trans_state_pri.priority stmt_info) && + (list_length instrs >0) in + + let instrs_after_assign, assign_ids, exp_to_parent = + if (is_binary_assign_op binary_operator_info) + && ((not creating_node) || (is_return_temp trans_state.continuation)) then ( + (* We are in this case when an assignment is inside *) + (* another operator that creates a node. Eg. another *) + (* assignment. *) + (* As no node is created here ids are passed to the parent *) + let id = Ident.create_fresh Ident.knormal in + let res_instr = [Sil.Letderef (id, sil_e1, sil_typ1, sil_loc)] in + instrs@res_instr, ids@[id], Sil.Var id + ) else ( + instrs, ids, exp_op) in + + let instruction_to_ancestor, ids_to_ancestor, succ_nodes' = + if creating_node then ( + let node_kind = + Cfg.Node.Stmt_node ("BinaryOperatorStmt: "^ + (CArithmetic_trans.bin_op_to_string binary_operator_info)) in + let node_bin_op = create_node node_kind [] [] sil_loc context in + Cfg.Node.set_succs_exn node_bin_op succ_nodes []; + let succ_nodes'' = [node_bin_op] in + (* If a node was created, ids are passed to the parent*) + (* if the binop is in the translation of a condition.*) + (* Otherwise ids are added to the node. *) + (* ids_parent/ids_nodes are the list of ids for the parent/node respectively.*) + (* They are computed with continuation which tells us *) + (* if we are translating a condition or not *) + let ids_parent = ids_to_parent trans_state.continuation assign_ids in + let ids_node = ids_to_node trans_state.continuation assign_ids in + list_iter (fun n -> Cfg.Node.append_instrs_temps n instrs_after_assign ids_node) succ_nodes''; + [], ids_parent, succ_nodes'' + ) else ( + instrs_after_assign, assign_ids, succ_nodes) in + + let e1_has_nodes = res_trans_e1.root_nodes <> [] + and e2_has_nodes = res_trans_e2.root_nodes <> [] in + + let e1_succ_nodes = + if e2_has_nodes then res_trans_e2.root_nodes else succ_nodes' in + list_iter (fun n -> Cfg.Node.set_succs_exn n e1_succ_nodes []) res_trans_e1.leaf_nodes; + list_iter (fun n -> Cfg.Node.set_succs_exn n succ_nodes' []) res_trans_e2.leaf_nodes; + + let root_nodes_to_ancestor = match e1_has_nodes, e2_has_nodes with + | false, false -> succ_nodes' + | true, _ -> res_trans_e1.root_nodes + | false, true -> res_trans_e2.root_nodes in + + let leaf_nodes_to_ancestor = + if creating_node then succ_nodes' + else if e2_has_nodes then res_trans_e2.leaf_nodes + else res_trans_e1.leaf_nodes in + + Printing.log_out "....BinaryOperator '%s' " bok; + Printing.log_out "has ids_to_ancestor |ids_to_ancestor|=%s " + (string_of_int (list_length ids_to_ancestor)); + Printing.log_out " |nodes_e1|=%s .\n" + (string_of_int (list_length res_trans_e1.root_nodes)); + Printing.log_out " |nodes_e2|=%s .\n" + (string_of_int (list_length res_trans_e2.root_nodes)); + list_iter (fun id -> Printing.log_out " ... '%s'\n" + (Ident.to_string id)) ids_to_ancestor; + { root_nodes = root_nodes_to_ancestor; + leaf_nodes = leaf_nodes_to_ancestor; + ids = ids_to_ancestor; + instrs = instruction_to_ancestor; + exps = [(exp_to_parent, sil_typ1)] } + | _ -> assert false) (* Binary operator should have two operands*) and callExpr_trans trans_state si stmt_list expr_info = let pln = trans_state.parent_line_number in @@ -564,8 +564,8 @@ struct let should_translate_args = match callee_pname_opt with | Some pn -> - (* we cannot translate the arguments of this builtin because preprocessing copies them *) - (* verbatim from a call to a different function, and they might be side-effecting *) + (* we cannot translate the arguments of this builtin because preprocessing copies them *) + (* verbatim from a call to a different function, and they might be side-effecting *) (Procname.to_string pn) <> CFrontend_config.builtin_object_size | _ -> true in let params_stmt = if should_translate_args then @@ -584,8 +584,8 @@ struct let act_params = if list_length res_trans_par.exps = list_length params_stmt then res_trans_par.exps else (Printing.log_err - "WARNING: stmt_list and res_trans_par.exps must have same size. NEED TO BE FIXED\n\n"; - fix_param_exps_mismatch params_stmt res_trans_par.exps) in + "WARNING: stmt_list and res_trans_par.exps must have same size. NEED TO BE FIXED\n\n"; + fix_param_exps_mismatch params_stmt res_trans_par.exps) in let act_params = if is_cf_retain_release then (Sil.Const (Sil.Cint Sil.Int.one), Sil.Tint Sil.IBool):: act_params else act_params in @@ -608,21 +608,21 @@ struct let res_trans_to_parent = PriorityNode.compute_results_to_parent trans_state_pri sil_loc nname si res_trans_tmp in (match callee_pname_opt with - | Some callee_pname -> - if not (SymExec.function_is_builtin callee_pname) then - begin - Cg.add_edge context.cg procname callee_pname; - try - let callee_ms = CMethod_signature.find callee_pname in - ignore (CMethod_trans.create_local_procdesc context.cfg context.tenv callee_ms [] [] false) - with Not_found -> - CMethod_trans.create_external_procdesc context.cfg callee_pname false None - end - | None -> ()); + | Some callee_pname -> + if not (SymExec.function_is_builtin callee_pname) then + begin + Cg.add_edge context.cg procname callee_pname; + try + let callee_ms = CMethod_signature.find callee_pname in + ignore (CMethod_trans.create_local_procdesc context.cfg context.tenv callee_ms [] [] false) + with Not_found -> + CMethod_trans.create_external_procdesc context.cfg callee_pname false None + end + | None -> ()); (match ret_id with - | [] -> { res_trans_to_parent with exps =[] } - | [ret_id'] -> { res_trans_to_parent with exps =[(Sil.Var ret_id', function_type)] } - | _ -> assert false) (* by construction of red_id, we cannot be in this case *) + | [] -> { res_trans_to_parent with exps =[] } + | [ret_id'] -> { res_trans_to_parent with exps =[(Sil.Var ret_id', function_type)] } + | _ -> assert false) (* by construction of red_id, we cannot be in this case *) and objCMessageExpr_trans trans_state si obj_c_message_expr_info stmt_list expr_info = Printing.log_out "Passing from ObjMessageExpr '%s' priority node free ='%s'.\n@." si.Clang_ast_t.si_pointer @@ -643,17 +643,17 @@ struct { trans_state_pri with parent_line_number = line_number; succ_nodes = [] } in let obj_c_message_expr_info, res_trans_par = (match stmt_list with - | stmt:: rest -> - let obj_c_message_expr_info, fst_res_trans = - (try + | stmt:: rest -> + let obj_c_message_expr_info, fst_res_trans = + (try let fst_res_trans = instruction trans_state_param stmt in obj_c_message_expr_info, fst_res_trans with Self.SelfClassException class_name -> - let obj_c_message_expr_info = Ast_expressions.make_obj_c_message_expr_info_class selector class_name in - obj_c_message_expr_info, empty_res_trans) in - let l = list_map (fun i -> exec_with_self_exception instruction trans_state_param i) rest in - obj_c_message_expr_info, collect_res_trans (fst_res_trans :: l) - | [] -> obj_c_message_expr_info, empty_res_trans) in + let obj_c_message_expr_info = Ast_expressions.make_obj_c_message_expr_info_class selector class_name in + obj_c_message_expr_info, empty_res_trans) in + let l = list_map (fun i -> exec_with_self_exception instruction trans_state_param i) rest in + obj_c_message_expr_info, collect_res_trans (fst_res_trans :: l) + | [] -> obj_c_message_expr_info, empty_res_trans) in let (class_type, _, _) = CMethod_trans.get_class_selector_instance context obj_c_message_expr_info res_trans_par.exps in if (selector = CFrontend_config.class_method && CTypes.is_class method_type) then raise (Self.SelfClassException class_type) @@ -682,11 +682,11 @@ struct exps =[] } in let res_trans_to_parent = ( - PriorityNode.compute_results_to_parent trans_state_pri sil_loc nname si res_trans_tmp) in + PriorityNode.compute_results_to_parent trans_state_pri sil_loc nname si res_trans_tmp) in (match ret_id with - | [] -> { res_trans_to_parent with exps = [] } - | [ret_id'] -> { res_trans_to_parent with exps = [(Sil.Var ret_id', method_type)] } - | _ -> assert false) (* by construction of red_id, we cannot be in this case *) + | [] -> { res_trans_to_parent with exps = [] } + | [ret_id'] -> { res_trans_to_parent with exps = [(Sil.Var ret_id', method_type)] } + | _ -> assert false) (* by construction of red_id, we cannot be in this case *) and dispatch_function_trans trans_state stmt_info stmt_list ei n = Printing.log_out "\n Call to a dispatch function treated as special case...\n"; @@ -718,10 +718,10 @@ struct let transformed_stmt, vars_to_register = Ast_expressions.translate_block_enumerate (Sil.pvar_to_string pvar) stmt_info stmt_list ei in let pvars_types = list_map (fun (v, pointer, qt) -> - let pvar = Sil.mk_pvar (Mangled.from_string v) procname in - let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv qt in - CContext.LocalVars.add_pointer_var pointer pvar trans_state.context; - (pvar, typ)) vars_to_register in + let pvar = Sil.mk_pvar (Mangled.from_string v) procname in + let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv qt in + CContext.LocalVars.add_pointer_var pointer pvar trans_state.context; + (pvar, typ)) vars_to_register in let loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let res_state = instruction trans_state transformed_stmt in let preds = list_flatten (list_map (fun n -> Cfg.Node.get_preds n) trans_state.succ_nodes) in @@ -758,9 +758,9 @@ struct let pvar = mk_temp_var (Cfg.Node.get_id n) in let pvar' = mk_temp_var (Cfg.Node.get_id n') in let ilist =[Sil.Letderef (id, Sil.Lvar pvar', typ, sil_loc); - Sil.Declare_locals([(pvar, typ)], sil_loc); - Sil.Set (Sil.Lvar pvar, typ, Sil.Var id, sil_loc); - Sil.Nullify(pvar', sil_loc, true)] in + Sil.Declare_locals([(pvar, typ)], sil_loc); + Sil.Set (Sil.Lvar pvar, typ, Sil.Var id, sil_loc); + Sil.Nullify(pvar', sil_loc, true)] in Cfg.Node.append_instrs_temps n' ilist [id]; n' | _ -> create_node (Cfg.Node.Join_node) [] [] sil_loc context in Cfg.Node.set_succs_exn join_node' succ_nodes []; @@ -786,12 +786,12 @@ struct | _, true -> list_iter (fun n' -> - (* If there is a node with instructions we need to only *) - (* add the set of the temp variable *) - if not (is_prune_node n') then - Cfg.Node.append_instrs_temps n' - (res_trans_b.instrs @ instr_e''@ set_temp_var) - (res_trans_b.ids @ id_e'') + (* If there is a node with instructions we need to only *) + (* add the set of the temp variable *) + if not (is_prune_node n') then + Cfg.Node.append_instrs_temps n' + (res_trans_b.instrs @ instr_e''@ set_temp_var) + (res_trans_b.ids @ id_e'') ) node_b; node_b | _, false -> node_b) in @@ -799,26 +799,26 @@ struct let prune_nodes' = if branch then prune_nodes_t else prune_nodes_f in list_iter (fun n -> Cfg.Node.set_succs_exn n nodes_branch []) prune_nodes' in (match stmt_list with - | [cond; exp1; exp2] -> - let typ = - CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in - let join_node = compute_join_node typ in - let pvar = mk_temp_var (Cfg.Node.get_id join_node) in - let continuation' = mk_cond_continuation trans_state.continuation in - let trans_state' = { trans_state with continuation = continuation'; parent_line_number = line_number; succ_nodes =[]} in - let res_trans_cond = exec_with_priority_exception trans_state' cond cond_trans in - (* Note: by contruction prune nodes are leafs_nodes_cond *) - do_branch true exp1 typ res_trans_cond.leaf_nodes join_node pvar; - do_branch false exp2 typ res_trans_cond.leaf_nodes join_node pvar; - let id = Ident.create_fresh Ident.knormal in - let instrs =[Sil.Letderef (id, Sil.Lvar pvar, typ, sil_loc); Sil.Nullify (pvar, sil_loc, true)] in - { root_nodes = res_trans_cond.root_nodes; - leaf_nodes = [join_node]; - ids = [id]; - instrs = instrs; - exps = [(Sil.Var id, typ)] - } - | _ -> assert false) + | [cond; exp1; exp2] -> + let typ = + CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in + let join_node = compute_join_node typ in + let pvar = mk_temp_var (Cfg.Node.get_id join_node) in + let continuation' = mk_cond_continuation trans_state.continuation in + let trans_state' = { trans_state with continuation = continuation'; parent_line_number = line_number; succ_nodes =[]} in + let res_trans_cond = exec_with_priority_exception trans_state' cond cond_trans in + (* Note: by contruction prune nodes are leafs_nodes_cond *) + do_branch true exp1 typ res_trans_cond.leaf_nodes join_node pvar; + do_branch false exp2 typ res_trans_cond.leaf_nodes join_node pvar; + let id = Ident.create_fresh Ident.knormal in + let instrs =[Sil.Letderef (id, Sil.Lvar pvar, typ, sil_loc); Sil.Nullify (pvar, sil_loc, true)] in + { root_nodes = res_trans_cond.root_nodes; + leaf_nodes = [join_node]; + ids = [id]; + instrs = instrs; + exps = [(Sil.Var id, typ)] + } + | _ -> assert false) (* Translate a condition for if/loops statement. It shorts-circuit and/or. *) (* The invariant is that the translation of a condition always contains (at least) *) @@ -838,8 +838,8 @@ struct Printing.log_out " No short-circuit condition\n"; let res_trans_cond = if is_null_stmt cond then { - empty_res_trans with exps = [(Sil.Const (Sil.Cint Sil.Int.one), (Sil.Tint Sil.IBool))] - } + empty_res_trans with exps = [(Sil.Const (Sil.Cint Sil.Int.one), (Sil.Tint Sil.IBool))] + } (* Assumption: If it's a null_stmt, it is a loop with no bound, so we set condition to 1 *) else instruction trans_state cond in @@ -886,9 +886,9 @@ struct match cond with | BinaryOperator(si, [s1; s2], expr_info, boi) -> (match boi.Clang_ast_t.boi_kind with - | `LAnd -> short_circuit (Sil.LAnd) s1 s2 - | `LOr -> short_circuit (Sil.LOr) s1 s2 - | _ -> no_short_circuit_cond ()) + | `LAnd -> short_circuit (Sil.LAnd) s1 s2 + | `LOr -> short_circuit (Sil.LOr) s1 s2 + | _ -> no_short_circuit_cond ()) | ParenExpr(_,[s], _) -> (* condition can be wrapped in parenthesys *) cond_trans trans_state s | _ -> no_short_circuit_cond () @@ -914,16 +914,16 @@ struct list_iter (fun n -> Cfg.Node.set_succs_exn n nodes_branch []) prune_nodes'; res_trans_b.ids in (match stmt_list with - | [null_stmt; cond; stmt1; stmt2] -> (* Note: for the moment we don't do anything with the null_stmt/decl*) - (* set the flat to inform that we are translating a condition of a if *) - let continuation' = mk_cond_continuation trans_state.continuation in - let trans_state'' = { trans_state with continuation = continuation'; succ_nodes = []; parent_line_number = line_number } in - let res_trans_cond = cond_trans trans_state'' cond in - (* Note: by contruction prune nodes are leafs_nodes_cond *) - let ids_t = do_branch true stmt1 res_trans_cond.leaf_nodes in - let ids_f = do_branch false stmt2 res_trans_cond.leaf_nodes in - { root_nodes = res_trans_cond.root_nodes; leaf_nodes =[join_node]; ids = res_trans_cond.ids@ids_t@ids_f; instrs =[]; exps =[] } - | _ -> assert false) + | [null_stmt; cond; stmt1; stmt2] -> (* Note: for the moment we don't do anything with the null_stmt/decl*) + (* set the flat to inform that we are translating a condition of a if *) + let continuation' = mk_cond_continuation trans_state.continuation in + let trans_state'' = { trans_state with continuation = continuation'; succ_nodes = []; parent_line_number = line_number } in + let res_trans_cond = cond_trans trans_state'' cond in + (* Note: by contruction prune nodes are leafs_nodes_cond *) + let ids_t = do_branch true stmt1 res_trans_cond.leaf_nodes in + let ids_f = do_branch false stmt2 res_trans_cond.leaf_nodes in + { root_nodes = res_trans_cond.root_nodes; leaf_nodes =[join_node]; ids = res_trans_cond.ids@ids_t@ids_f; instrs =[]; exps =[] } + | _ -> assert false) (* Assumption: the CompoundStmt can be made of different stmts, not just CaseStmts *) and switchStmt_trans trans_state stmt_info switch_stmt_list = @@ -934,118 +934,118 @@ struct let continuation = trans_state.continuation in let sil_loc = get_sil_location stmt_info pln context in (match switch_stmt_list with - | [_; cond; CompoundStmt(stmt_info, stmt_list)] -> - let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let trans_state' ={ trans_state_pri with succ_nodes = []} in - let res_trans_cond = instruction trans_state' cond in - let switch_special_cond_node = - create_node (Cfg.Node.Stmt_node "Switch_stmt") [] res_trans_cond.instrs sil_loc context in - let trans_state_no_pri = if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then - { trans_state_pri with priority = Free } - else trans_state_pri in - let (switch_e_cond', switch_e_cond'_typ) = - extract_exp_from_list res_trans_cond.exps - "\nWARNING: The condition of the SwitchStmt is not singleton. Need to be fixed\n" in - let switch_exit_point = succ_nodes in - let continuation' = - match continuation with - | Some cont -> Some { cont with break = switch_exit_point } - | None -> Some { break = switch_exit_point; continue = []; return_temp = false } in - let trans_state'' = { trans_state_no_pri with continuation = continuation'} in - let merge_into_cases stmt_list = (* returns list_of_cases * before_any_case_instrs *) - let rec aux rev_stmt_list acc cases = - (match rev_stmt_list with - | CaseStmt(info, a :: b :: (CaseStmt x) :: c) :: rest -> (* case x: case y: ... *) - if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) - let rest' = [CaseStmt(info, a :: b :: [])] @ rest in - let rev_stmt_list' = (CaseStmt x) :: rest' in - aux rev_stmt_list' acc cases - | CaseStmt(info, a :: b :: (DefaultStmt x) :: c) :: rest -> - (* case x: default: ... *) - if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) - let rest' = [CaseStmt(info, a :: b :: [])] @ rest in - let rev_stmt_list' = (DefaultStmt x) :: rest' in - aux rev_stmt_list' acc cases - | DefaultStmt(info, (CaseStmt x) :: c) :: rest -> (* default: case x: ... *) - if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) - let rest' = [DefaultStmt(info, [])] @ rest in - let rev_stmt_list' = (CaseStmt x) :: rest' in - aux rev_stmt_list' acc cases - | CaseStmt(info, a :: b :: c) :: rest -> - aux rest [] (CaseStmt(info, a :: b :: c@acc):: cases) - | DefaultStmt(info, c) :: rest -> (* default is always the last in the list *) - aux rest [] (DefaultStmt(info, c@acc) :: cases) - | x :: rest -> - aux rest (x:: acc) cases - | [] -> - cases, acc) in - aux (list_rev stmt_list) [] [] in - let list_of_cases, pre_case_stmts = merge_into_cases stmt_list in - let rec connected_instruction rev_instr_list successor_nodes = - (* returns the entry point of the translated set of instr *) - match rev_instr_list with - | [] -> successor_nodes - | instr :: rest -> - let trans_state''' = { trans_state'' with succ_nodes = successor_nodes } in - let res_trans_instr = instruction trans_state''' instr in - let instr_entry_points = res_trans_instr.root_nodes in - connected_instruction rest instr_entry_points in - let rec translate_and_connect_cases cases next_nodes next_prune_nodes = - let create_prune_nodes_for_case case = - match case with - | CaseStmt(stmt_info, case_const:: _:: _) -> - let trans_state_pri = - PriorityNode.try_claim_priority_node trans_state'' stmt_info in - let res_trans_case_const = instruction trans_state_pri case_const in - let e_const = res_trans_case_const.exps in - let e_const' = - match e_const with - | [(head, typ)] -> head - | _ -> assert false in - let sil_eq_cond = Sil.BinOp(Sil.Eq, switch_e_cond', e_const') in - let sil_loc = get_sil_location stmt_info pln context in - let true_prune_node = - create_prune_node true [(sil_eq_cond, switch_e_cond'_typ)] - res_trans_case_const.ids res_trans_case_const.instrs - sil_loc (Sil.Ik_switch) context in - let false_prune_node = - create_prune_node false [(sil_eq_cond, switch_e_cond'_typ)] - res_trans_case_const.ids res_trans_case_const.instrs - sil_loc (Sil.Ik_switch) context in - (true_prune_node, false_prune_node) - | _ -> assert false in - match cases with (* top-down to handle default cases *) - | [] -> next_nodes, next_prune_nodes - | CaseStmt(stmt_info, _ :: _ :: case_content) as case :: rest -> - let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in - let case_entry_point = connected_instruction (list_rev case_content) last_nodes in - (* connects between cases, then continuation has priority about breaks *) - let prune_node_t, prune_node_f = create_prune_nodes_for_case case in - Cfg.Node.set_succs_exn prune_node_t case_entry_point []; - Cfg.Node.set_succs_exn prune_node_f last_prune_nodes []; - case_entry_point, [prune_node_t; prune_node_f] - | DefaultStmt(stmt_info, default_content) :: rest -> - let sil_loc = get_sil_location stmt_info pln context in - let placeholder_entry_point = - create_node (Cfg.Node.Stmt_node "DefaultStmt_placeholder") [] [] sil_loc context in - let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes [placeholder_entry_point] in - let default_entry_point = connected_instruction (list_rev default_content) last_nodes in - Cfg.Node.set_succs_exn placeholder_entry_point default_entry_point []; - default_entry_point, last_prune_nodes - | _ -> assert false in - let top_entry_point, top_prune_nodes = translate_and_connect_cases list_of_cases succ_nodes succ_nodes in - let _ = connected_instruction (list_rev pre_case_stmts) top_entry_point in - Cfg.Node.set_succs_exn switch_special_cond_node top_prune_nodes []; - let top_nodes = - match res_trans_cond.root_nodes with - | [] -> (* here if no root or if the translation of cond needed priority *) - [switch_special_cond_node] - | _ -> - list_iter (fun n' -> Cfg.Node.set_succs_exn n' [switch_special_cond_node] []) res_trans_cond.leaf_nodes; - res_trans_cond.root_nodes in - list_iter (fun n' -> Cfg.Node.append_instrs_temps n' [] res_trans_cond.ids) succ_nodes; (* succ_nodes will remove the temps *) - { root_nodes = top_nodes; leaf_nodes = succ_nodes; ids = []; instrs = []; exps =[]} - | _ -> assert false) + | [_; cond; CompoundStmt(stmt_info, stmt_list)] -> + let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in + let trans_state' ={ trans_state_pri with succ_nodes = []} in + let res_trans_cond = instruction trans_state' cond in + let switch_special_cond_node = + create_node (Cfg.Node.Stmt_node "Switch_stmt") [] res_trans_cond.instrs sil_loc context in + let trans_state_no_pri = if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then + { trans_state_pri with priority = Free } + else trans_state_pri in + let (switch_e_cond', switch_e_cond'_typ) = + extract_exp_from_list res_trans_cond.exps + "\nWARNING: The condition of the SwitchStmt is not singleton. Need to be fixed\n" in + let switch_exit_point = succ_nodes in + let continuation' = + match continuation with + | Some cont -> Some { cont with break = switch_exit_point } + | None -> Some { break = switch_exit_point; continue = []; return_temp = false } in + let trans_state'' = { trans_state_no_pri with continuation = continuation'} in + let merge_into_cases stmt_list = (* returns list_of_cases * before_any_case_instrs *) + let rec aux rev_stmt_list acc cases = + (match rev_stmt_list with + | CaseStmt(info, a :: b :: (CaseStmt x) :: c) :: rest -> (* case x: case y: ... *) + if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) + let rest' = [CaseStmt(info, a :: b :: [])] @ rest in + let rev_stmt_list' = (CaseStmt x) :: rest' in + aux rev_stmt_list' acc cases + | CaseStmt(info, a :: b :: (DefaultStmt x) :: c) :: rest -> + (* case x: default: ... *) + if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) + let rest' = [CaseStmt(info, a :: b :: [])] @ rest in + let rev_stmt_list' = (DefaultStmt x) :: rest' in + aux rev_stmt_list' acc cases + | DefaultStmt(info, (CaseStmt x) :: c) :: rest -> (* default: case x: ... *) + if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) + let rest' = [DefaultStmt(info, [])] @ rest in + let rev_stmt_list' = (CaseStmt x) :: rest' in + aux rev_stmt_list' acc cases + | CaseStmt(info, a :: b :: c) :: rest -> + aux rest [] (CaseStmt(info, a :: b :: c@acc):: cases) + | DefaultStmt(info, c) :: rest -> (* default is always the last in the list *) + aux rest [] (DefaultStmt(info, c@acc) :: cases) + | x :: rest -> + aux rest (x:: acc) cases + | [] -> + cases, acc) in + aux (list_rev stmt_list) [] [] in + let list_of_cases, pre_case_stmts = merge_into_cases stmt_list in + let rec connected_instruction rev_instr_list successor_nodes = + (* returns the entry point of the translated set of instr *) + match rev_instr_list with + | [] -> successor_nodes + | instr :: rest -> + let trans_state''' = { trans_state'' with succ_nodes = successor_nodes } in + let res_trans_instr = instruction trans_state''' instr in + let instr_entry_points = res_trans_instr.root_nodes in + connected_instruction rest instr_entry_points in + let rec translate_and_connect_cases cases next_nodes next_prune_nodes = + let create_prune_nodes_for_case case = + match case with + | CaseStmt(stmt_info, case_const:: _:: _) -> + let trans_state_pri = + PriorityNode.try_claim_priority_node trans_state'' stmt_info in + let res_trans_case_const = instruction trans_state_pri case_const in + let e_const = res_trans_case_const.exps in + let e_const' = + match e_const with + | [(head, typ)] -> head + | _ -> assert false in + let sil_eq_cond = Sil.BinOp(Sil.Eq, switch_e_cond', e_const') in + let sil_loc = get_sil_location stmt_info pln context in + let true_prune_node = + create_prune_node true [(sil_eq_cond, switch_e_cond'_typ)] + res_trans_case_const.ids res_trans_case_const.instrs + sil_loc (Sil.Ik_switch) context in + let false_prune_node = + create_prune_node false [(sil_eq_cond, switch_e_cond'_typ)] + res_trans_case_const.ids res_trans_case_const.instrs + sil_loc (Sil.Ik_switch) context in + (true_prune_node, false_prune_node) + | _ -> assert false in + match cases with (* top-down to handle default cases *) + | [] -> next_nodes, next_prune_nodes + | CaseStmt(stmt_info, _ :: _ :: case_content) as case :: rest -> + let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in + let case_entry_point = connected_instruction (list_rev case_content) last_nodes in + (* connects between cases, then continuation has priority about breaks *) + let prune_node_t, prune_node_f = create_prune_nodes_for_case case in + Cfg.Node.set_succs_exn prune_node_t case_entry_point []; + Cfg.Node.set_succs_exn prune_node_f last_prune_nodes []; + case_entry_point, [prune_node_t; prune_node_f] + | DefaultStmt(stmt_info, default_content) :: rest -> + let sil_loc = get_sil_location stmt_info pln context in + let placeholder_entry_point = + create_node (Cfg.Node.Stmt_node "DefaultStmt_placeholder") [] [] sil_loc context in + let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes [placeholder_entry_point] in + let default_entry_point = connected_instruction (list_rev default_content) last_nodes in + Cfg.Node.set_succs_exn placeholder_entry_point default_entry_point []; + default_entry_point, last_prune_nodes + | _ -> assert false in + let top_entry_point, top_prune_nodes = translate_and_connect_cases list_of_cases succ_nodes succ_nodes in + let _ = connected_instruction (list_rev pre_case_stmts) top_entry_point in + Cfg.Node.set_succs_exn switch_special_cond_node top_prune_nodes []; + let top_nodes = + match res_trans_cond.root_nodes with + | [] -> (* here if no root or if the translation of cond needed priority *) + [switch_special_cond_node] + | _ -> + list_iter (fun n' -> Cfg.Node.set_succs_exn n' [switch_special_cond_node] []) res_trans_cond.leaf_nodes; + res_trans_cond.root_nodes in + list_iter (fun n' -> Cfg.Node.append_instrs_temps n' [] res_trans_cond.ids) succ_nodes; (* succ_nodes will remove the temps *) + { root_nodes = top_nodes; leaf_nodes = succ_nodes; ids = []; instrs = []; exps =[]} + | _ -> assert false) and stmtExpr_trans trans_state stmt_info stmt_list expr_info = let context = trans_state.context in @@ -1055,19 +1055,19 @@ struct let idl = res_trans_stmt.ids in let exps'= list_rev res_trans_stmt.exps in (match exps' with - | (last, typ):: _ -> - (* The StmtExpr contains a single CompoundStmt node, which it evaluates and *) - (* takes the value of the last subexpression.*) - (* Exp returned by StmtExpr is always a RValue. So we need to assign to a temp and return the temp.*) - let id = Ident.create_fresh Ident.knormal in - let loc = get_sil_location stmt_info trans_state.parent_line_number context in - let instr' = Sil.Letderef (id, last, typ, loc) in - { root_nodes = res_trans_stmt.root_nodes; - leaf_nodes = res_trans_stmt.leaf_nodes; - ids = id:: idl; - instrs = res_trans_stmt.instrs@[instr']; - exps = [(Sil.Var id, typ)]} - | _ -> assert false) + | (last, typ):: _ -> + (* The StmtExpr contains a single CompoundStmt node, which it evaluates and *) + (* takes the value of the last subexpression.*) + (* Exp returned by StmtExpr is always a RValue. So we need to assign to a temp and return the temp.*) + let id = Ident.create_fresh Ident.knormal in + let loc = get_sil_location stmt_info trans_state.parent_line_number context in + let instr' = Sil.Letderef (id, last, typ, loc) in + { root_nodes = res_trans_stmt.root_nodes; + leaf_nodes = res_trans_stmt.leaf_nodes; + ids = id:: idl; + instrs = res_trans_stmt.instrs@[instr']; + exps = [(Sil.Var id, typ)]} + | _ -> assert false) and loop_instruction trans_state loop_kind stmt_info = let outer_continuation = trans_state.continuation in @@ -1163,44 +1163,44 @@ struct let sil_typ = CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in (match stmt_list with - | [s1; s2] -> - let trans_state' = { trans_state_pri with succ_nodes = []; parent_line_number = line_number } in - let res_trans_s1 = instruction trans_state' s1 in - let res_trans_s2 = instruction trans_state' s2 in - let (lhs_e, lhs_typ) = extract_exp_from_list res_trans_s1.exps - "\nWARNING: Missing LHS operand in Compount Assign operator. Need Fixing.\n" in - let (sil_e2, sil_typ2) = extract_exp_from_list res_trans_s2.exps - "\nWARNING: Missing RHS operand in Compount Assign operator. Need Fixing.\n" in - let id_op, exp_op, instr_op = CArithmetic_trans.compound_assignment_binary_operation_instruction - binary_operator_info lhs_e sil_typ sil_e2 sil_loc in - let ids = res_trans_s1.ids@res_trans_s2.ids@id_op in - let instrs = res_trans_s1.instrs@res_trans_s2.instrs@instr_op in - let res_trans_tmp = { res_trans_s2 with ids = ids; instrs = instrs; exps =[]} in - let res_trans_to_parent = - PriorityNode.compute_results_to_parent trans_state_pri sil_loc "ComppoundAssignStmt" stmt_info res_trans_tmp in - - let trans_s1_succs = - if res_trans_to_parent.root_nodes <> [] - then res_trans_to_parent.root_nodes - else trans_state_pri.succ_nodes in - list_iter - (fun n -> Cfg.Node.set_succs_exn n trans_s1_succs []) - res_trans_s1.leaf_nodes; - - let instrs_to_parent', ids_to_parent', exp_to_parent' = - compute_instr_ids_exp_to_parent stmt_info res_trans_to_parent.instrs res_trans_to_parent.ids - [(exp_op, sil_typ)] lhs_e sil_typ sil_loc trans_state_pri.priority in - - let root_nodes = - if res_trans_s1.root_nodes <> [] - then res_trans_s1.root_nodes - else res_trans_to_parent.root_nodes in - { root_nodes = root_nodes; - leaf_nodes = res_trans_to_parent.leaf_nodes; - ids = ids_to_parent'; - instrs = instrs_to_parent'; - exps = exp_to_parent' } - | _ -> assert false) (* Compound assign statement should have two operands*) + | [s1; s2] -> + let trans_state' = { trans_state_pri with succ_nodes = []; parent_line_number = line_number } in + let res_trans_s1 = instruction trans_state' s1 in + let res_trans_s2 = instruction trans_state' s2 in + let (lhs_e, lhs_typ) = extract_exp_from_list res_trans_s1.exps + "\nWARNING: Missing LHS operand in Compount Assign operator. Need Fixing.\n" in + let (sil_e2, sil_typ2) = extract_exp_from_list res_trans_s2.exps + "\nWARNING: Missing RHS operand in Compount Assign operator. Need Fixing.\n" in + let id_op, exp_op, instr_op = CArithmetic_trans.compound_assignment_binary_operation_instruction + binary_operator_info lhs_e sil_typ sil_e2 sil_loc in + let ids = res_trans_s1.ids@res_trans_s2.ids@id_op in + let instrs = res_trans_s1.instrs@res_trans_s2.instrs@instr_op in + let res_trans_tmp = { res_trans_s2 with ids = ids; instrs = instrs; exps =[]} in + let res_trans_to_parent = + PriorityNode.compute_results_to_parent trans_state_pri sil_loc "ComppoundAssignStmt" stmt_info res_trans_tmp in + + let trans_s1_succs = + if res_trans_to_parent.root_nodes <> [] + then res_trans_to_parent.root_nodes + else trans_state_pri.succ_nodes in + list_iter + (fun n -> Cfg.Node.set_succs_exn n trans_s1_succs []) + res_trans_s1.leaf_nodes; + + let instrs_to_parent', ids_to_parent', exp_to_parent' = + compute_instr_ids_exp_to_parent stmt_info res_trans_to_parent.instrs res_trans_to_parent.ids + [(exp_op, sil_typ)] lhs_e sil_typ sil_loc trans_state_pri.priority in + + let root_nodes = + if res_trans_s1.root_nodes <> [] + then res_trans_s1.root_nodes + else res_trans_to_parent.root_nodes in + { root_nodes = root_nodes; + leaf_nodes = res_trans_to_parent.leaf_nodes; + ids = ids_to_parent'; + instrs = instrs_to_parent'; + exps = exp_to_parent' } + | _ -> assert false) (* Compound assign statement should have two operands*) and initListExpr_trans trans_state stmt_info expr_info di_pointer stmts = let context = trans_state.context in @@ -1218,14 +1218,14 @@ struct let rec collect_left_hand_exprs e typ tns = match typ with | (Sil.Tvar tn) -> (match Sil.tenv_lookup context.tenv tn with - | Some (Sil.Tstruct _ as str) -> collect_left_hand_exprs e str tns - | Some ((Sil.Tvar typename) as tvar) -> - if (StringSet.mem (Sil.typename_to_string typename) tns) then ([[(e, typ)]]) - else (collect_left_hand_exprs e tvar (StringSet.add (Sil.typename_to_string typename) tns)); - | _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*)) + | Some (Sil.Tstruct _ as str) -> collect_left_hand_exprs e str tns + | Some ((Sil.Tvar typename) as tvar) -> + if (StringSet.mem (Sil.typename_to_string typename) tns) then ([[(e, typ)]]) + else (collect_left_hand_exprs e tvar (StringSet.add (Sil.typename_to_string typename) tns)); + | _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*)) | (Sil.Tstruct (struct_fields, _, _, _, _, _, _) as type_struct) -> let lh_exprs = list_map ( fun (fieldname, fieldtype, _) -> - Sil.Lfield (e, fieldname, type_struct) ) + Sil.Lfield (e, fieldname, type_struct) ) struct_fields in let lh_types = list_map ( fun (fieldname, fieldtype, _) -> fieldtype) struct_fields in @@ -1255,15 +1255,15 @@ struct let sil_loc = get_sil_location stmt_info trans_state_pri.parent_line_number context in let big_zip = list_map (fun ( (lh_exp, lh_t), (_, _, rh_exp, is_method_call, rhs_owning_method, rh_t) ) -> - let is_pointer_object = ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv rh_t in - if !Config.arc_mode && (is_method_call || is_pointer_object) then - (* In arc mode, if it's a method call or we are initializing with a pointer to objc class *) - (* we need to add retain/release *) - let (e, instrs, ids) = - CArithmetic_trans.assignment_arc_mode context lh_exp lh_t rh_exp sil_loc rhs_owning_method true in - ([(e, lh_t)], instrs, ids) - else - ([], [Sil.Set (lh_exp, lh_t, rh_exp, sil_loc)], [])) + let is_pointer_object = ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv rh_t in + if !Config.arc_mode && (is_method_call || is_pointer_object) then + (* In arc mode, if it's a method call or we are initializing with a pointer to objc class *) + (* we need to add retain/release *) + let (e, instrs, ids) = + CArithmetic_trans.assignment_arc_mode context lh_exp lh_t rh_exp sil_loc rhs_owning_method true in + ([(e, lh_t)], instrs, ids) + else + ([], [Sil.Set (lh_exp, lh_t, rh_exp, sil_loc)], [])) (zip lh rh) in let rh_instrs = list_flatten ( list_map (fun (_, instrs, _, _, _, _) -> instrs) rh) in let assign_instrs = list_flatten(list_map (fun (_, instrs, _) -> instrs) big_zip) in @@ -1283,60 +1283,60 @@ struct let pln = trans_state.parent_line_number in let do_var_dec (di, var_name, qtype, vdi) next_node = (match vdi.Clang_ast_t.vdi_init_expr with - | None -> { empty_res_trans with root_nodes = next_node } (* Nothing to do if no init expression *) - | Some (ImplicitValueInitExpr (_, stmt_list, _)) -> - (* Seems unclear what it does, so let's keep an eye on the stmts *) - (* and report a warning if it finds a non empty list of stmts *) - (match stmt_list with - | [] -> () - | _ -> Printing.log_stats "\n!!!!WARNING: found statement <\"ImplicitValueInitExpr\"> with non-empty stmt_list.\n"); - { empty_res_trans with root_nodes = next_node } - | Some (InitListExpr (stmt_info , stmts , expr_info)) - | Some (ExprWithCleanups(_, [InitListExpr (stmt_info , stmts , expr_info)], _, _)) -> - initListExpr_trans trans_state stmt_info expr_info di.Clang_ast_t.di_pointer stmts - | Some ie -> (*For init expr, translate how to compute it and assign to the var*) - let sil_loc = get_sil_location stmt_info pln context in - let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let next_node = - if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( - let node_kind = Cfg.Node.Stmt_node "DeclStmt" in - let node = create_node node_kind [] [] sil_loc context in - Cfg.Node.set_succs_exn node next_node []; - [node] - ) else next_node in - let pvar = CContext.LocalVars.find_var_with_pointer context di.Clang_ast_t.di_pointer in - let line_number = get_line stmt_info pln in - (* if ie is a block the translation need to be done with the block special cases by exec_with_block_priority*) - let res_trans_ie = - let trans_state' = { trans_state_pri with succ_nodes = next_node; parent_line_number = line_number } in - exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state' ie stmt_info in - let root_nodes = res_trans_ie.root_nodes in - let leaf_nodes = res_trans_ie.leaf_nodes in - let (sil_e1', ie_typ) = extract_exp_from_list res_trans_ie.exps - "WARNING: In DeclStmt we expect only one expression returned in recursive call\n" in - let rhs_owning_method = CTrans_utils.is_owning_method ie in - let _, instrs_assign, ids_assign = - if !Config.arc_mode && - (CTrans_utils.is_method_call ie || ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv ie_typ) then - (* In arc mode, if it's a method call or we are initializing with a pointer to objc class *) - (* we need to add retain/release *) - let (e, instrs, ids) = - CArithmetic_trans.assignment_arc_mode context (Sil.Lvar pvar) ie_typ sil_e1' sil_loc rhs_owning_method true in - ([(e, ie_typ)], instrs, ids) - else ([], [Sil.Set (Sil.Lvar pvar, ie_typ, sil_e1', sil_loc)], []) in - let ids = res_trans_ie.ids@ids_assign in - let instrs = res_trans_ie.instrs@instrs_assign in - if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( - let node = list_hd next_node in - Cfg.Node.append_instrs_temps node instrs ids; - list_iter (fun n -> Cfg.Node.set_succs_exn n [node] []) leaf_nodes; - let root_nodes = if (list_length root_nodes) = 0 then next_node else root_nodes in - { root_nodes = root_nodes; leaf_nodes =[]; ids = ids; instrs = instrs; exps = [(Sil.Lvar pvar, ie_typ)]} - ) else { root_nodes = root_nodes; leaf_nodes =[]; ids = ids; instrs = instrs; exps =[(Sil.Lvar pvar, ie_typ)]}) in + | None -> { empty_res_trans with root_nodes = next_node } (* Nothing to do if no init expression *) + | Some (ImplicitValueInitExpr (_, stmt_list, _)) -> + (* Seems unclear what it does, so let's keep an eye on the stmts *) + (* and report a warning if it finds a non empty list of stmts *) + (match stmt_list with + | [] -> () + | _ -> Printing.log_stats "\n!!!!WARNING: found statement <\"ImplicitValueInitExpr\"> with non-empty stmt_list.\n"); + { empty_res_trans with root_nodes = next_node } + | Some (InitListExpr (stmt_info , stmts , expr_info)) + | Some (ExprWithCleanups(_, [InitListExpr (stmt_info , stmts , expr_info)], _, _)) -> + initListExpr_trans trans_state stmt_info expr_info di.Clang_ast_t.di_pointer stmts + | Some ie -> (*For init expr, translate how to compute it and assign to the var*) + let sil_loc = get_sil_location stmt_info pln context in + let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in + let next_node = + if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( + let node_kind = Cfg.Node.Stmt_node "DeclStmt" in + let node = create_node node_kind [] [] sil_loc context in + Cfg.Node.set_succs_exn node next_node []; + [node] + ) else next_node in + let pvar = CContext.LocalVars.find_var_with_pointer context di.Clang_ast_t.di_pointer in + let line_number = get_line stmt_info pln in + (* if ie is a block the translation need to be done with the block special cases by exec_with_block_priority*) + let res_trans_ie = + let trans_state' = { trans_state_pri with succ_nodes = next_node; parent_line_number = line_number } in + exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state' ie stmt_info in + let root_nodes = res_trans_ie.root_nodes in + let leaf_nodes = res_trans_ie.leaf_nodes in + let (sil_e1', ie_typ) = extract_exp_from_list res_trans_ie.exps + "WARNING: In DeclStmt we expect only one expression returned in recursive call\n" in + let rhs_owning_method = CTrans_utils.is_owning_method ie in + let _, instrs_assign, ids_assign = + if !Config.arc_mode && + (CTrans_utils.is_method_call ie || ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv ie_typ) then + (* In arc mode, if it's a method call or we are initializing with a pointer to objc class *) + (* we need to add retain/release *) + let (e, instrs, ids) = + CArithmetic_trans.assignment_arc_mode context (Sil.Lvar pvar) ie_typ sil_e1' sil_loc rhs_owning_method true in + ([(e, ie_typ)], instrs, ids) + else ([], [Sil.Set (Sil.Lvar pvar, ie_typ, sil_e1', sil_loc)], []) in + let ids = res_trans_ie.ids@ids_assign in + let instrs = res_trans_ie.instrs@instrs_assign in + if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( + let node = list_hd next_node in + Cfg.Node.append_instrs_temps node instrs ids; + list_iter (fun n -> Cfg.Node.set_succs_exn n [node] []) leaf_nodes; + let root_nodes = if (list_length root_nodes) = 0 then next_node else root_nodes in + { root_nodes = root_nodes; leaf_nodes =[]; ids = ids; instrs = instrs; exps = [(Sil.Lvar pvar, ie_typ)]} + ) else { root_nodes = root_nodes; leaf_nodes =[]; ids = ids; instrs = instrs; exps =[(Sil.Lvar pvar, ie_typ)]}) in match var_decls with | [] -> { empty_res_trans with root_nodes = next_nodes } | VarDecl(di, n, qt, vdi):: var_decls' -> - (* Var are defined when procdesc is created, here we only take care of initialization*) + (* Var are defined when procdesc is created, here we only take care of initialization*) let res_trans_vd = collect_all_decl trans_state var_decls' next_nodes stmt_info in let res_trans_tmp = do_var_dec (di, n, qt, vdi) res_trans_vd.root_nodes in { root_nodes = res_trans_tmp.root_nodes; leaf_nodes = []; @@ -1345,7 +1345,7 @@ struct exps = res_trans_tmp.exps @ res_trans_vd.exps } | CXXRecordDecl _ :: var_decls' (*C++/C record decl treated in the same way *) | RecordDecl _ :: var_decls' -> - (* Record declaration is done in the beginning when procdesc is defined.*) + (* Record declaration is done in the beginning when procdesc is defined.*) collect_all_decl trans_state var_decls' next_nodes stmt_info | _ -> assert false @@ -1371,16 +1371,16 @@ struct and objCPropertyRefExpr_trans trans_state stmt_info stmt_list = Printing.log_out "Passing from ObjCPropertyRefExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; (match stmt_list with - | [stmt] -> instruction trans_state stmt - | _ -> assert false) + | [stmt] -> instruction trans_state stmt + | _ -> assert false) (* For OpaqueValueExpr we return the translation generated from its source expression*) and opaqueValueExpr_trans trans_state stmt_info opaque_value_expr_info = Printing.log_out "Passing from OpaqueValueExpr '%s' priority node free ='%s'\n@." stmt_info.Clang_ast_t.si_pointer (string_of_bool (PriorityNode.is_priority_free trans_state)); (match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with - | Some stmt -> instruction trans_state stmt - | _ -> assert false) + | Some stmt -> instruction trans_state stmt + | _ -> assert false) (* NOTE: This translation has several hypothesis. Need to be verified when we have more*) (* experience with this construct. Assert false will help to see if we encounter programs*) @@ -1403,13 +1403,13 @@ struct (string_of_bool (PriorityNode.is_priority_free trans_state)); let rec do_semantic_elements el = (match el with - | OpaqueValueExpr _ :: el' -> do_semantic_elements el' - | stmt:: _ -> instruction trans_state' stmt - | _ -> assert false) in + | OpaqueValueExpr _ :: el' -> do_semantic_elements el' + | stmt:: _ -> instruction trans_state' stmt + | _ -> assert false) in (match stmt_list with - | syntactic_form:: semantic_form -> - do_semantic_elements semantic_form - | _ -> assert false) + | syntactic_form:: semantic_form -> + do_semantic_elements semantic_form + | _ -> assert false) (* Cast expression are treated the same apart from the cast operation kind*) and cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_expr_info is_objc_bridged = @@ -1441,17 +1441,17 @@ struct "WARNING: in MemberExpr we expect the translation of the stmt to return an expression\n" in let class_typ = (match class_typ with - | Sil.Tptr (t, _) -> CTypes_decl.expand_structured_type trans_state.context.tenv t - | t -> t) in + | Sil.Tptr (t, _) -> CTypes_decl.expand_structured_type trans_state.context.tenv t + | t -> t) in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let exp = (match class_typ with - | Sil.Tvoid -> Sil.exp_minus_one - | _ -> - Printing.log_out "Type is '%s' @." (Sil.typ_to_string class_typ); - ( match ObjcInterface_decl.find_field trans_state.context.tenv nfield (Some class_typ) false with - | Some (fn, _, _) -> Sil.Lfield (e, fn, class_typ) - | None -> assert false)) in + | Sil.Tvoid -> Sil.exp_minus_one + | _ -> + Printing.log_out "Type is '%s' @." (Sil.typ_to_string class_typ); + ( match ObjcInterface_decl.find_field trans_state.context.tenv nfield (Some class_typ) false with + | Some (fn, _, _) -> Sil.Lfield (e, fn, class_typ) + | None -> assert false)) in { res_trans_exp_stmt with exps = [(exp, typ)] } @@ -1547,7 +1547,7 @@ struct | [] -> (* return; *) { empty_res_trans with root_nodes =[ret_node]; leaf_nodes =[ret_node]} | _ -> Printing.log_out - "\nWARNING: Missing translation of Return Expression. Return Statement ignored. Need fixing!\n"; + "\nWARNING: 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 *) trans_result @@ -1588,7 +1588,7 @@ struct and objCStringLiteral_trans trans_state stmt_info stmts info = let stmts = [Ast_expressions.create_implicit_cast_expr stmt_info stmts - (Ast_expressions.create_char_type ()) `ArrayToPointerDecay] in + (Ast_expressions.create_char_type ()) `ArrayToPointerDecay] in let typ = CTypes_decl.class_from_pointer_type trans_state.context.tenv info.Clang_ast_t.ei_qual_type in let obj_c_message_expr_info = Ast_expressions.make_obj_c_message_expr_info_class CFrontend_config.string_with_utf8_m typ in @@ -1596,8 +1596,8 @@ struct instruction trans_state message_stmt (** When objects are autoreleased, they get added a flag AUTORELEASE. All these objects will be - ignored when checking for memory leaks. When the end of the block autoreleasepool is reached, - then those objects are released and the autorelease flag is removed. *) + ignored when checking for memory leaks. When the end of the block autoreleasepool is reached, + then those objects are released and the autorelease flag is removed. *) and objcAutoreleasePool_trans trans_state stmt_info stmts = let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let fname = SymExec.ModelBuiltins.__objc_release_autorelease_pool in @@ -1617,8 +1617,8 @@ struct and objCAtSynchronizedStmt_trans trans_state stmt_info stmt_list = Printing.log_out "Passing from `ObjCAtSynchronizedStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer; (match stmt_list with - | [_; compound_stmt] -> instruction trans_state compound_stmt - | _ -> assert false) + | [_; compound_stmt] -> instruction trans_state compound_stmt + | _ -> assert false) and blockExpr_trans trans_state stmt_info expr_info decl = Printing.log_out "Passing from BlockExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; @@ -1627,7 +1627,7 @@ struct let procname = Cfg.Procdesc.get_proc_name context.procdesc in let loc = (match stmt_info.Clang_ast_t.si_source_range with (l1, l2) -> - CLocation.clang_to_sil_location l1 pln (Some context.procdesc)) in + CLocation.clang_to_sil_location l1 pln (Some context.procdesc)) in (* Given a mangled name (possibly full) returns a plain mangled name *) let ensure_plain_mangling m = Mangled.from_string (Mangled.to_string m) in @@ -1649,32 +1649,32 @@ struct let instr = Sil.Letderef (id, Sil.Lvar (Sil.mk_pvar cvar procname), typ, loc) in (id, instr) in (match decl with - | BlockDecl(decl_info, decl_list, decl_context_info, block_decl_info) -> - let qual_type = expr_info.Clang_ast_t.ei_qual_type in - let block_pname = CFrontend_utils.General_utils.mk_fresh_block_procname procname in - let typ = CTypes_decl.qual_type_to_sil_type context.tenv qual_type in - (* We need to set the explicit dependency between the newly created block and the *) - (* defining procedure. We add an edge in the call graph.*) - Cg.add_edge context.cg procname block_pname; - let function_decl_info = CFrontend_utils.General_utils.mk_function_decl_info_from_block block_decl_info in - let static_locals = list_filter (fun (v, t, s) -> s = true) context.local_vars in - (*list_iter (fun (v, _, _) -> L.err "Static Locals %s@." (Mangled.to_string v)) static_locals;*) - let static_formals = list_filter (fun (v, t, s) -> s = true) context.captured_vars in - (*list_iter (fun (v, _, _) -> L.err "Formal Static %s@." (Mangled.to_string v)) static_formals;*) - let static_vars = static_locals @ static_formals in - let captured_vars = - (CMethod_trans.captured_vars_from_block_info context block_decl_info.Clang_ast_t.bdi_captured_variables) in - let all_captured_vars = captured_vars @ static_vars in - let ids_instrs = list_map assign_captured_var all_captured_vars in - let ids, instrs = list_split ids_instrs in - M.function_decl context.tenv context.cfg context.cg context.namespace context.is_instance decl_info - (Procname.to_string block_pname) qual_type function_decl_info all_captured_vars (Some block_pname) context.curr_class; - Cfg.set_procname_priority context.cfg block_pname; - let captured_exps = list_map (fun id -> Sil.Var id) ids in - let tu = Sil.Ctuple ((Sil.Const (Sil.Cfun block_pname)):: captured_exps) in - let alloc_block_instr, ids_block = allocate_block trans_state (Procname.to_string block_pname) all_captured_vars loc in - { empty_res_trans with ids = ids_block @ ids; instrs = alloc_block_instr @ instrs; exps = [(Sil.Const tu, typ)]} - | _ -> assert false) + | BlockDecl(decl_info, decl_list, decl_context_info, block_decl_info) -> + let qual_type = expr_info.Clang_ast_t.ei_qual_type in + let block_pname = CFrontend_utils.General_utils.mk_fresh_block_procname procname in + let typ = CTypes_decl.qual_type_to_sil_type context.tenv qual_type in + (* We need to set the explicit dependency between the newly created block and the *) + (* defining procedure. We add an edge in the call graph.*) + Cg.add_edge context.cg procname block_pname; + let function_decl_info = CFrontend_utils.General_utils.mk_function_decl_info_from_block block_decl_info in + let static_locals = list_filter (fun (v, t, s) -> s = true) context.local_vars in + (*list_iter (fun (v, _, _) -> L.err "Static Locals %s@." (Mangled.to_string v)) static_locals;*) + let static_formals = list_filter (fun (v, t, s) -> s = true) context.captured_vars in + (*list_iter (fun (v, _, _) -> L.err "Formal Static %s@." (Mangled.to_string v)) static_formals;*) + let static_vars = static_locals @ static_formals in + let captured_vars = + (CMethod_trans.captured_vars_from_block_info context block_decl_info.Clang_ast_t.bdi_captured_variables) in + let all_captured_vars = captured_vars @ static_vars in + let ids_instrs = list_map assign_captured_var all_captured_vars in + let ids, instrs = list_split ids_instrs in + M.function_decl context.tenv context.cfg context.cg context.namespace context.is_instance decl_info + (Procname.to_string block_pname) qual_type function_decl_info all_captured_vars (Some block_pname) context.curr_class; + Cfg.set_procname_priority context.cfg block_pname; + let captured_exps = list_map (fun id -> Sil.Var id) ids in + let tu = Sil.Ctuple ((Sil.Const (Sil.Cfun block_pname)):: captured_exps) in + let alloc_block_instr, ids_block = allocate_block trans_state (Procname.to_string block_pname) all_captured_vars loc in + { empty_res_trans with ids = ids_block @ ids; instrs = alloc_block_instr @ instrs; exps = [(Sil.Const tu, typ)]} + | _ -> assert false) (* Translates a clang instruction into SIL instructions. It takes a *) (* a trans_state containing current info on the translation and it returns *) @@ -1696,10 +1696,10 @@ struct | CallExpr(stmt_info, stmt_list, ei) -> (match is_dispatch_function stmt_list with - | Some block_arg_pos -> - dispatch_function_trans trans_state stmt_info stmt_list ei block_arg_pos - | None -> - callExpr_trans trans_state stmt_info stmt_list ei) + | Some block_arg_pos -> + dispatch_function_trans trans_state stmt_info stmt_list ei block_arg_pos + | None -> + callExpr_trans trans_state stmt_info stmt_list ei) | ObjCMessageExpr(stmt_info, stmt_list, expr_info, obj_c_message_expr_info) -> if is_block_enumerate_function obj_c_message_expr_info then @@ -1708,11 +1708,11 @@ struct objCMessageExpr_trans trans_state stmt_info obj_c_message_expr_info stmt_list expr_info | CompoundStmt (stmt_info, stmt_list) -> - (* No node for this statement. We just collect its statement list*) + (* No node for this statement. We just collect its statement list*) compoundStmt_trans trans_state stmt_info stmt_list | ConditionalOperator(stmt_info, stmt_list, expr_info) -> - (* Ternary operator "cond ? exp1 : exp2" *) + (* Ternary operator "cond ? exp1 : exp2" *) conditionalOperator_trans trans_state stmt_info stmt_list expr_info | IfStmt(stmt_info, stmt_list) -> @@ -1728,7 +1728,7 @@ struct stmtExpr_trans trans_state stmt_info stmt_list expr_info | ForStmt(stmt_info, [init; null_stmt; cond; incr; body]) -> - (* Note: we ignore null_stmt at the moment.*) + (* Note: we ignore null_stmt at the moment.*) forStmt_trans trans_state init cond incr body stmt_info | WhileStmt(stmt_info, [_; cond; body]) -> (* Note: we ignore null_stmt at the moment.*) @@ -1867,16 +1867,16 @@ struct | BinaryConditionalOperator (stmt_info, stmts, expr_info) -> (match stmts with - | [stmt1; ostmt1; ostmt2; stmt2] when contains_opaque_value_expr ostmt1 && contains_opaque_value_expr ostmt2 -> - conditionalOperator_trans trans_state stmt_info [stmt1; stmt1; stmt2] expr_info - | _ -> Printing.log_stats - "BinaryConditionalOperator not translated %s @." - (Ast_utils.string_of_stmt instr); - assert false) + | [stmt1; ostmt1; ostmt2; stmt2] when contains_opaque_value_expr ostmt1 && contains_opaque_value_expr ostmt2 -> + conditionalOperator_trans trans_state stmt_info [stmt1; stmt1; stmt2] expr_info + | _ -> Printing.log_stats + "BinaryConditionalOperator not translated %s @." + (Ast_utils.string_of_stmt instr); + assert false) | s -> (Printing.log_stats - "\n!!!!WARNING: found statement %s. \nACTION REQUIRED: Translation need to be defined. Statement ignored.... \n" - (Ast_utils.string_of_stmt s); - assert false) + "\n!!!!WARNING: found statement %s. \nACTION REQUIRED: Translation need to be defined. Statement ignored.... \n" + (Ast_utils.string_of_stmt s); + assert false) (* Given a translation state, this function traslates a list of clang statements. *) and instructions trans_state clang_stmt_list = diff --git a/infer/src/clang/cTrans_models.ml b/infer/src/clang/cTrans_models.ml index d848c25f7..e25051c8e 100644 --- a/infer/src/clang/cTrans_models.ml +++ b/infer/src/clang/cTrans_models.ml @@ -32,7 +32,7 @@ let is_alloc_model typ funct = else let funct = Procname.to_string procname in (* if (Core_foundation_model.is_core_lib_create typ funct) then - print_endline ("\nCore Foundation create not modelled "^(Sil.typ_to_string typ)^" "^(funct));*) + print_endline ("\nCore Foundation create not modelled "^(Sil.typ_to_string typ)^" "^(funct));*) Core_foundation_model.is_core_lib_create typ funct | None -> false @@ -104,12 +104,12 @@ let builtin_predefined_model fun_stmt sil_fe = | Some exp -> let typ = CTypes.get_type exp in (match sil_fe with - | Sil.Const (Sil.Cfun pn) when Specs.summary_exists pn -> sil_fe, false - | Sil.Const (Sil.Cfun pn) when is_retain_predefined_model typ (Procname.to_string pn) -> - Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_retain_cf) , true - | Sil.Const (Sil.Cfun pn) when is_release_predefined_model typ (Procname.to_string pn) -> - Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_release_cf), true - | _ -> sil_fe, false) + | Sil.Const (Sil.Cfun pn) when Specs.summary_exists pn -> sil_fe, false + | Sil.Const (Sil.Cfun pn) when is_retain_predefined_model typ (Procname.to_string pn) -> + Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_retain_cf) , true + | Sil.Const (Sil.Cfun pn) when is_release_predefined_model typ (Procname.to_string pn) -> + Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_release_cf), true + | _ -> sil_fe, false) | _ -> sil_fe, false (** If the function is a builtin model, return the model, otherwise return the function *) @@ -153,7 +153,7 @@ let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname = let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname = let condition = (method_name = release || method_name = drain) && - (class_name = nsautorelease_pool_cl) in + (class_name = nsautorelease_pool_cl) in get_predefined_ms_method condition class_name method_name mk_procname [(self, class_name, None)] void [] (Some SymExec.ModelBuiltins.__objc_release_autorelease_pool) @@ -177,7 +177,7 @@ let dispatch_functions = [ ("dispatch_group_notify", 2); ("dispatch_group_wait", 2); ("dispatch_barrier_async", 1); - ] +] let is_dispatch_function_name function_name = let rec is_dispatch functions = diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index c70306086..5f13d17d7 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -99,10 +99,10 @@ struct try Hashtbl.find goto_label_node_map label with Not_found -> - let node_name = Format.sprintf "GotoLabel_%s" label in - let new_node = Nodes.create_node (Cfg.Node.Skip_node node_name) [] [] sil_loc context in - Hashtbl.add goto_label_node_map label new_node; - new_node + let node_name = Format.sprintf "GotoLabel_%s" label in + let new_node = Nodes.create_node (Cfg.Node.Skip_node node_name) [] [] sil_loc context in + Hashtbl.add goto_label_node_map label new_node; + new_node end type continuation = { @@ -233,8 +233,8 @@ struct instrs =[]; exps = []} | _, true -> - (* We need to create a node but params also created some,*) - (* so we need to pass back the nodes/leafs params*) + (* We need to create a node but params also created some,*) + (* so we need to pass back the nodes/leafs params*) let node' = mk_node () in Cfg.Node.set_succs_exn node' trans_state.succ_nodes []; let ids_parent = ids_to_parent trans_state.continuation res_state_param.ids in @@ -342,7 +342,7 @@ let cast_trans context exps sil_loc callee_pname_opt function_type = let builtin_trans trans_state loc stmt_info function_type callee_pname_opt = if CTrans_models.is_cf_non_null_alloc callee_pname_opt || - CTrans_models.is_alloc_model function_type callee_pname_opt then + CTrans_models.is_alloc_model function_type callee_pname_opt then Some (alloc_trans trans_state loc stmt_info function_type true) else if CTrans_models.is_alloc callee_pname_opt then Some (alloc_trans trans_state loc stmt_info function_type false) @@ -361,8 +361,8 @@ let cast_operation context cast_kind exps cast_typ sil_loc is_objc_bridged = | `IntegralToBoolean -> (* This is treated as a nop by returning the same expressions exps*) ([],[], exp) | `LValueToRValue -> - (* Takes an LValue and allow it to use it as RValue. *) - (* So we assign the LValue to a temp and we pass it to the parent.*) + (* Takes an LValue and allow it to use it as RValue. *) + (* So we assign the LValue to a temp and we pass it to the parent.*) let id = Ident.create_fresh Ident.knormal in let sil_instr = [Sil.Letderef (id, exp, typ, sil_loc)] in ([id], sil_instr, Sil.Var id) @@ -435,11 +435,11 @@ let fix_param_exps_mismatch params_stmt exps_param = let get_name_decl_ref_exp_info decl_ref_expr_info si = match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with | Some d -> (match d.Clang_ast_t.dr_name with - | Some n -> n.Clang_ast_t.ni_name - | _ -> assert false) + | Some n -> n.Clang_ast_t.ni_name + | _ -> assert false) | _ -> L.err "FAILING WITH %s pointer=%s@.@." - (Clang_ast_j.string_of_decl_ref_expr_info decl_ref_expr_info ) - (Clang_ast_j.string_of_stmt_info si); assert false + (Clang_ast_j.string_of_decl_ref_expr_info decl_ref_expr_info ) + (Clang_ast_j.string_of_stmt_info si); assert false let is_superinstance mei = match mei.Clang_ast_t.omei_receiver_kind with @@ -463,10 +463,10 @@ let get_value_enum_constant tenv enum_type stmt = let _, v = try list_find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants with _ -> (Printing.log_err - "Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in + "Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in v | _ -> Printing.log_err - "Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename); + "Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename); assert false let get_selector_receiver obj_c_message_expr_info = @@ -487,10 +487,10 @@ let is_enumeration_constant stmt = match stmt with | DeclRefExpr(_, _, _, drei) -> (match drei.Clang_ast_t.drti_decl_ref with - | Some d -> (match d.Clang_ast_t.dr_kind with - | `EnumConstant -> true - | _ -> false) - | _ -> false) + | Some d -> (match d.Clang_ast_t.dr_kind with + | `EnumConstant -> true + | _ -> false) + | _ -> false) | _ -> false let is_null_stmt s = @@ -511,8 +511,8 @@ let rec get_type_from_exp_stmt stmt = let do_decl_ref_exp i = match i.Clang_ast_t.drti_decl_ref with | Some d -> (match d.Clang_ast_t.dr_qual_type with - | Some n -> n - | _ -> assert false ) + | Some n -> n + | _ -> assert false ) | _ -> assert false in match stmt with | CXXOperatorCallExpr(_, _, ei) @@ -578,14 +578,14 @@ let is_owning_name n = match Str.split (Str.regexp_string ":") n with | fst:: _ -> (match Str.split (Str.regexp "['_']+") fst with - | [no_und] - | _:: no_und:: _ -> - is_family CFrontend_config.alloc no_und || - is_family CFrontend_config.copy no_und || - is_family CFrontend_config.new_str no_und || - is_family CFrontend_config.mutableCopy no_und || - is_family CFrontend_config.init no_und - | _ -> assert false) + | [no_und] + | _:: no_und:: _ -> + is_family CFrontend_config.alloc no_und || + is_family CFrontend_config.copy no_und || + is_family CFrontend_config.new_str no_und || + is_family CFrontend_config.mutableCopy no_und || + is_family CFrontend_config.init no_und + | _ -> assert false) | _ -> assert false let rec is_owning_method s = @@ -593,15 +593,15 @@ let rec is_owning_method s = | ObjCMessageExpr(_, _ , _, mei) -> is_owning_name mei.Clang_ast_t.omei_selector | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with - | [] -> false - | s'':: _ -> is_owning_method s'') + | [] -> false + | s'':: _ -> is_owning_method s'') let rec is_method_call s = match s with | ObjCMessageExpr(_, _ , _, mei) -> true | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with - | [] -> false - | s'':: _ -> is_method_call s'') + | [] -> false + | s'':: _ -> is_method_call s'') let rec get_decl_ref_info s parent_line_number = match s with @@ -609,17 +609,17 @@ let rec get_decl_ref_info s parent_line_number = let line_number = CLocation.get_line stmt_info parent_line_number in stmt_info.Clang_ast_t.si_pointer, line_number | _ -> (match Clang_ast_proj.get_stmt_tuple s with - | stmt_info, [] -> assert false - | stmt_info, s'':: _ -> - let line_number = CLocation.get_line stmt_info parent_line_number in - get_decl_ref_info s'' line_number) + | stmt_info, [] -> assert false + | stmt_info, s'':: _ -> + let line_number = CLocation.get_line stmt_info parent_line_number in + get_decl_ref_info s'' line_number) let rec contains_opaque_value_expr s = match s with | OpaqueValueExpr (_, _, _, _) -> true | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with - | [] -> false - | s'':: _ -> contains_opaque_value_expr s'') + | [] -> false + | s'':: _ -> contains_opaque_value_expr s'') let rec compute_autorelease_pool_vars context stmts = match stmts with @@ -632,10 +632,10 @@ let rec compute_autorelease_pool_vars context stmts = list_filter (fun (m, t) -> Mangled.to_string m = name) local_vars with _ -> [] in (match mname with - | [(m, t)] -> - CFrontend_utils.General_utils.append_no_duplicated_pvars - [(Sil.Lvar (Sil.mk_pvar m procname), t)] (compute_autorelease_pool_vars context stmts') - | _ -> compute_autorelease_pool_vars context stmts') + | [(m, t)] -> + CFrontend_utils.General_utils.append_no_duplicated_pvars + [(Sil.Lvar (Sil.mk_pvar m procname), t)] (compute_autorelease_pool_vars context stmts') + | _ -> compute_autorelease_pool_vars context stmts') | s:: stmts' -> let sl = snd(Clang_ast_proj.get_stmt_tuple s) in compute_autorelease_pool_vars context (sl@stmts') @@ -651,21 +651,21 @@ let is_dispatch_function stmt_list = match stmt_list with | ImplicitCastExpr(_,[DeclRefExpr(_, _, _, di)], _, _):: stmts -> (match di.Clang_ast_t.drti_decl_ref with - | None -> None - | Some d -> - (match d.Clang_ast_t.dr_kind, d.Clang_ast_t.dr_name with - | `Function, Some name_info -> - let s = name_info.Clang_ast_t.ni_name in - (match (CTrans_models.is_dispatch_function_name s) with - | None -> None - | Some (dispatch_function, block_arg_pos) -> - try - (match list_nth stmts block_arg_pos with - | BlockExpr _ -> Some block_arg_pos - | _ -> None) - with Not_found -> None - ) - | _ -> None)) + | None -> None + | Some d -> + (match d.Clang_ast_t.dr_kind, d.Clang_ast_t.dr_name with + | `Function, Some name_info -> + let s = name_info.Clang_ast_t.ni_name in + (match (CTrans_models.is_dispatch_function_name s) with + | None -> None + | Some (dispatch_function, block_arg_pos) -> + try + (match list_nth stmts block_arg_pos with + | BlockExpr _ -> Some block_arg_pos + | _ -> None) + with Not_found -> None + ) + | _ -> None)) | _ -> None let assign_default_params params_stmt callee_pname_opt = @@ -683,7 +683,7 @@ let assign_default_params params_stmt callee_pname_opt = list_map replace_default_arg params_args with | Invalid_argument _ -> - (* list_combine failed because of different list lengths *) + (* list_combine failed because of different list lengths *) Printing.log_err "Param count doesn't match %s\n" (Procname.to_string callee_pname); params_stmt | Not_found -> params_stmt diff --git a/infer/src/clang/cTypes.ml b/infer/src/clang/cTypes.ml index 901d8b11a..2fc5345f9 100644 --- a/infer/src/clang/cTypes.ml +++ b/infer/src/clang/cTypes.ml @@ -46,22 +46,22 @@ let lookup_var_type context pvar = Printing.log_out "found '%s' in formals.@." (Sil.typ_to_string t); t with Not_found -> + try + let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in + Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar); + Printing.log_out "found '%s' in locals.@." (Sil.typ_to_string t); + t + with Not_found -> try - let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in - Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar); - Printing.log_out "found '%s' in locals.@." (Sil.typ_to_string t); - t + let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in + Printing.log_out "When looking for type of variable '%s'" (Sil.pvar_to_string pvar); + Printing.log_out " found '%s' in globals.@." (Sil.typ_to_string typ); + typ with Not_found -> - try - let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in - Printing.log_out "When looking for type of variable '%s'" (Sil.pvar_to_string pvar); - Printing.log_out " found '%s' in globals.@." (Sil.typ_to_string typ); - typ - with Not_found -> - Printing.log_err - "WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!" - (Sil.pvar_to_string pvar); - Sil.Tvoid + Printing.log_err + "WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!" + (Sil.pvar_to_string pvar); + Sil.Tvoid (* Extract the type out of a statement. This is useful when the statement *) (* denotes actually an expression *) @@ -176,8 +176,8 @@ let get_raw_qual_type_decl_ref_exp_info decl_ref_expr_info = match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with | Some d -> (match d.Clang_ast_t.dr_qual_type with - | Some qt -> Some qt.Clang_ast_t.qt_raw - | None -> None) + | Some qt -> Some qt.Clang_ast_t.qt_raw + | None -> None) | None -> None (* Iterates over the tenv to find the value of the enumeration constant *) diff --git a/infer/src/clang/cTypes_decl.ml b/infer/src/clang/cTypes_decl.ml index 733ee1a80..9e83d65f1 100644 --- a/infer/src/clang/cTypes_decl.ml +++ b/infer/src/clang/cTypes_decl.ml @@ -24,12 +24,12 @@ let add_predefined_types tenv = let objc_class_name = Sil.TN_csu (Sil.Class, objc_class_mangled) in let objc_class_type_info = Sil.Tstruct ([], [], Sil.Struct, - Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in + Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in Sil.tenv_add tenv objc_class_name objc_class_type_info; let mn = Mangled.from_string CFrontend_config.class_type in let class_typename = Sil.TN_typedef(mn) in let class_typ = Sil.Tptr ((Sil.Tvar - (Sil.TN_csu (Sil.Struct, objc_class_mangled))), Sil.Pk_pointer) in + (Sil.TN_csu (Sil.Struct, objc_class_mangled))), Sil.Pk_pointer) in Sil.tenv_add tenv class_typename class_typ; let typename_objc_object = Sil.TN_csu (Sil.Struct, Mangled.from_string CFrontend_config.objc_object) in @@ -42,24 +42,24 @@ let rec search_for_named_type tenv typ = match typename with | Sil.TN_typedef name -> (match Sil.tenv_lookup tenv typename with - | Some _ -> typename - | None -> - let pot_class_type = Sil.TN_csu (Sil.Class, name) in - match Sil.tenv_lookup tenv pot_class_type with - | Some _ -> pot_class_type - | None -> - let pot_protocol_type = Sil.TN_csu (Sil.Protocol, name) in - match Sil.tenv_lookup tenv pot_protocol_type with - | Some _ -> pot_protocol_type - | None -> - let pot_struct_type = Sil.TN_csu (Sil.Struct, name) in - match Sil.tenv_lookup tenv pot_struct_type with - | Some _ -> pot_struct_type - | None -> - let pot_union_type = Sil.TN_csu (Sil.Union, name) in - match Sil.tenv_lookup tenv pot_union_type with - | Some _ -> pot_union_type - | None -> raise Typename_not_found) + | Some _ -> typename + | None -> + let pot_class_type = Sil.TN_csu (Sil.Class, name) in + match Sil.tenv_lookup tenv pot_class_type with + | Some _ -> pot_class_type + | None -> + let pot_protocol_type = Sil.TN_csu (Sil.Protocol, name) in + match Sil.tenv_lookup tenv pot_protocol_type with + | Some _ -> pot_protocol_type + | None -> + let pot_struct_type = Sil.TN_csu (Sil.Struct, name) in + match Sil.tenv_lookup tenv pot_struct_type with + | Some _ -> pot_struct_type + | None -> + let pot_union_type = Sil.TN_csu (Sil.Union, name) in + match Sil.tenv_lookup tenv pot_union_type with + | Some _ -> pot_union_type + | None -> raise Typename_not_found) | _ -> typename in match typ with | Sil.Tvar typename -> Sil.Tvar (search typename) @@ -85,10 +85,10 @@ let string_type_to_sil_type tenv s = (* 'union '*) let s = (match Str.split (Str.regexp "[ \t]+") s with | "struct"::"(anonymous":: "struct":: s' -> - (*Printing.log_out " ...Getting rid of the extra 'struct' word@."; *) + (*Printing.log_out " ...Getting rid of the extra 'struct' word@."; *) string_from_list ("struct"::"(anonymous":: s') | "union"::"(anonymous":: "union":: s' -> - (*Printing.log_out " ...Getting rid of the extra 'union' word@."; *) + (*Printing.log_out " ...Getting rid of the extra 'union' word@."; *) string_from_list ("union"::"(anonymous":: s') | _ -> s) in let lexbuf = Lexing.from_string s in @@ -99,14 +99,14 @@ let string_type_to_sil_type tenv s = " ...Parsed. Translated with sil TYPE '%a'@." (Sil.pp_typ_full pe_text) t; t with Parsing.Parse_error -> ( - Printing.log_stats - "\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s; - Sil.Tvoid) in + Printing.log_stats + "\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s; + Sil.Tvoid) in try search_for_named_type tenv t with Typename_not_found -> Printing.log_stats - "\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s; - t) + "\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s; + t) let qual_type_to_sil_type_no_expansions tenv qt = string_type_to_sil_type tenv (CTypes.get_type qt) @@ -129,8 +129,8 @@ let parse_func_type name func_type = ((Sil.typ_to_string return_type)^" <- "^(Utils.list_to_string (Sil.typ_to_string) arg_types)); Some (return_type, arg_types) with Parsing.Parse_error -> ( - Printing.log_stats "\nXXXXXXX PARSE ERROR for string '%s'." func_type; - None) + Printing.log_stats "\nXXXXXXX PARSE ERROR for string '%s'." func_type; + None) (*In case of typedef like *) (* typedef struct { f1; f2; ... } s; *) @@ -147,18 +147,18 @@ let rec disambiguate_typedef tenv namespace t mn = (* Eg. TN_typdef(mn) --> TN_typedef(mn). We need to break it*) let tn = Sil.TN_csu(Sil.Struct, mn) in (match Sil.tenv_lookup tenv tn with - | Some _ -> - (* There is a struct in tenv, so we make the typedef mn pointing to the struct*) - Printing.log_out " ...Found type TN_typdef('%s') " (Mangled.to_string mn); - Printing.log_out "in typedef of '%s'@." (Mangled.to_string mn); - Printing.log_out - "Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@." - (Mangled.to_string mn); - Sil.Tvar(tn) - | None -> - if add_late_defined_record tenv namespace tn then - disambiguate_typedef tenv namespace t mn - else t) + | Some _ -> + (* There is a struct in tenv, so we make the typedef mn pointing to the struct*) + Printing.log_out " ...Found type TN_typdef('%s') " (Mangled.to_string mn); + Printing.log_out "in typedef of '%s'@." (Mangled.to_string mn); + Printing.log_out + "Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@." + (Mangled.to_string mn); + Sil.Tvar(tn) + | None -> + if add_late_defined_record tenv namespace tn then + disambiguate_typedef tenv namespace t mn + else t) else t | _ -> t @@ -189,10 +189,10 @@ and get_struct_fields tenv record_name namespace decl_list = let annotation_items = [] in (* For the moment we don't use them*) (id, typ, annotation_items):: get_struct_fields tenv record_name namespace decl_list' | CXXRecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info) - :: decl_list' + :: decl_list' (* C++/C Records treated in the same way*) | RecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info) - :: decl_list'-> + :: decl_list'-> do_record_declaration tenv namespace decl_info name.Clang_ast_t.ni_name opt_type decl_list decl_context_info record_decl_info; get_struct_fields tenv record_name namespace decl_list' | _ :: decl_list' -> get_struct_fields tenv record_name namespace decl_list' @@ -234,7 +234,7 @@ and get_declaration_type tenv namespace decl_info n opt_type decl_list decl_cont let methods_list = [] in (* No methods list for structs *) let item_annotation = Sil.item_annotation_empty in (* No annotations for struts *) Sil.Tstruct - (non_static_fields, static_fields, csu, name, superclass_list, methods_list, item_annotation) + (non_static_fields, static_fields, csu, name, superclass_list, methods_list, item_annotation) (* Look for a record definition that is defined after it is dereferenced. *) (* It returns true if a new record definition has been added to tenv.*) @@ -246,26 +246,26 @@ and add_late_defined_record tenv namespace typename = match decls with | [] -> false | CXXRecordDecl - (decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info) - :: decls' + (decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info) + :: decls' | RecordDecl - (decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info) - :: decls' -> + (decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info) + :: decls' -> (match opt_type with - | `Type t -> - (* the string t contains the name of the type preceded by the word struct. *) - let t_no_struct = CTypes.cut_struct_union t in - let pot_struct_type = Sil.TN_csu (Sil.Struct, (Mangled.from_string t_no_struct)) in - let pot_union_type = Sil.TN_csu (Sil.Union, (Mangled.from_string t_no_struct)) in - if (Sil.typename_equal typename pot_struct_type || - Sil.typename_equal typename pot_union_type) && - record_decl_info.Clang_ast_t.rdi_is_complete_definition then ( - Printing.log_out "!!!! Adding late-defined record '%s'\n" t; - do_record_declaration tenv namespace decl_info record_name.Clang_ast_t.ni_name opt_type decl_list - decl_context_info record_decl_info; - true) - else scan decls' - | _ -> scan decls') + | `Type t -> + (* the string t contains the name of the type preceded by the word struct. *) + let t_no_struct = CTypes.cut_struct_union t in + let pot_struct_type = Sil.TN_csu (Sil.Struct, (Mangled.from_string t_no_struct)) in + let pot_union_type = Sil.TN_csu (Sil.Union, (Mangled.from_string t_no_struct)) in + if (Sil.typename_equal typename pot_struct_type || + Sil.typename_equal typename pot_union_type) && + record_decl_info.Clang_ast_t.rdi_is_complete_definition then ( + Printing.log_out "!!!! Adding late-defined record '%s'\n" t; + do_record_declaration tenv namespace decl_info record_name.Clang_ast_t.ni_name opt_type decl_list + decl_context_info record_decl_info; + true) + else scan decls' + | _ -> scan decls') | LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls') | _:: decls' -> scan decls' in scan !CFrontend_config.global_translation_unit_decls @@ -283,13 +283,13 @@ and add_late_defined_typedef tenv namespace typename = | TypedefDecl (decl_info, name_info, opt_type, tdi) :: decls' -> let name' = name_info.Clang_ast_t.ni_name in (match opt_type with - | `Type t -> - if (Mangled.to_string name) = name' then ( - Printing.log_out "!!!! Adding late-defined typedef '%s'\n" t; - do_typedef_declaration tenv namespace decl_info name' opt_type tdi; - true) - else scan decls' - | _ -> scan decls') + | `Type t -> + if (Mangled.to_string name) = name' then ( + Printing.log_out "!!!! Adding late-defined typedef '%s'\n" t; + do_typedef_declaration tenv namespace decl_info name' opt_type tdi; + true) + else scan decls' + | _ -> scan decls') | LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls') | _:: decls' -> scan decls' in scan !CFrontend_config.global_translation_unit_decls @@ -300,16 +300,16 @@ and expand_structured_type tenv typ = match typ with | Sil.Tvar tn -> (match Sil.tenv_lookup tenv tn with - | Some t -> - Printing.log_out - " Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t); - if Sil.typ_equal t typ then - typ - else expand_structured_type tenv t - | None -> if (add_late_defined_record tenv None tn || - add_late_defined_typedef tenv None tn) then - expand_structured_type tenv typ - else typ) + | Some t -> + Printing.log_out + " Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t); + if Sil.typ_equal t typ then + typ + else expand_structured_type tenv t + | None -> if (add_late_defined_record tenv None tn || + add_late_defined_typedef tenv None tn) then + expand_structured_type tenv typ + else typ) | Sil.Tptr(t, _) -> typ (*do not expand types under pointers *) | _ -> typ @@ -329,8 +329,8 @@ and add_struct_to_tenv tenv typ = Printing.log_out " >>>Verifying that Typename TN_csu('%s') is in tenv\n" (Sil.typename_to_string typename); (match Sil.tenv_lookup tenv typename with - | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) - | None -> Printing.log_out " >>>NOT Found!!\n") + | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) + | None -> Printing.log_out " >>>NOT Found!!\n") and qual_type_to_sil_type_general tenv qt no_pointer = let typ = string_type_to_sil_type tenv (CTypes.get_type qt) in diff --git a/infer/src/clang/cVar_decl.ml b/infer/src/clang/cVar_decl.ml index c165855ac..35a1cc9ad 100644 --- a/infer/src/clang/cVar_decl.ml +++ b/infer/src/clang/cVar_decl.ml @@ -56,7 +56,7 @@ let rec lookup_ahead_for_vardecl context pointer var_name kind decl_list = let global_var = CGlobal_vars.find mangled_var_name in CGlobal_vars.var_get_name global_var) else (Printing.log_out "SKIPPING VarDecl for '%s'\n" var_name; - lookup_ahead_for_vardecl context pointer var_name kind rest) + lookup_ahead_for_vardecl context pointer var_name kind rest) | _ :: rest -> lookup_ahead_for_vardecl context pointer var_name kind rest @@ -94,9 +94,9 @@ let lookup_var stmt_info context pointer var_name kind = try lookup_var_static_globals context var_name with Not_found -> - (Printing.log_out "Looking on later-defined decls for '%s' with pointer '%s' \n" var_name stmt_info.Clang_ast_t.si_pointer; - let decl_list = !CFrontend_config.global_translation_unit_decls in - lookup_ahead_for_vardecl context pointer var_name kind decl_list ) + (Printing.log_out "Looking on later-defined decls for '%s' with pointer '%s' \n" var_name stmt_info.Clang_ast_t.si_pointer; + let decl_list = !CFrontend_config.global_translation_unit_decls in + lookup_ahead_for_vardecl context pointer var_name kind decl_list ) (* Traverses the body of the method top down and collects the *) (* variable definitions in a map in the context. To be able to find the right variable name *) @@ -108,17 +108,17 @@ let rec get_variables_stmt context (stmt : Clang_ast_t.stmt) : unit = get_variables_decls context decl_list; get_fun_locals context lstmt; | DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> - (* Notice that DeclRefExpr is the reference to a declared var/function/enum... *) - (* so no declaration here *) + (* Notice that DeclRefExpr is the reference to a declared var/function/enum... *) + (* so no declaration here *) Printing.log_out "Collecting variables, passing from DeclRefExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer; let var_name = CTrans_utils.get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in let kind = CTrans_utils.get_decl_kind decl_ref_expr_info in (match kind with - | `EnumConstant | `ObjCIvar | `CXXMethod | `ObjCProperty -> () - | _ -> - let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in - CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context) + | `EnumConstant | `ObjCIvar | `CXXMethod | `ObjCProperty -> () + | _ -> + let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in + CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context) | CompoundStmt(stmt_info, lstmt) -> Printing.log_out "Collecting variables, passing from CompoundStmt '%s'\n" stmt_info.Clang_ast_t.si_pointer; @@ -147,15 +147,15 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit = let name = name_info.Clang_ast_t.ni_name in let typ = get_var_type context.CContext.tenv name qual_type in (match var_decl_info.Clang_ast_t.vdi_storage_class with - | Some "static" -> - let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in - let static_name = (Procname.to_string pname)^"_"^name in - CGlobal_vars.add static_name typ; - let var = Sil.mk_pvar_global (Mangled.from_string static_name) in - CContext.LocalVars.add_pointer_var decl_info.Clang_ast_t.di_pointer var context - | _ -> - CContext.LocalVars.add_local_var context name typ decl_info.Clang_ast_t.di_pointer - (CFrontend_utils.General_utils.is_static_var var_decl_info)) + | Some "static" -> + let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in + let static_name = (Procname.to_string pname)^"_"^name in + CGlobal_vars.add static_name typ; + let var = Sil.mk_pvar_global (Mangled.from_string static_name) in + CContext.LocalVars.add_pointer_var decl_info.Clang_ast_t.di_pointer var context + | _ -> + CContext.LocalVars.add_local_var context name typ decl_info.Clang_ast_t.di_pointer + (CFrontend_utils.General_utils.is_static_var var_decl_info)) | CXXRecordDecl(di, n_info, ot, dl, dci, rdi) | RecordDecl(di, n_info, ot, dl, dci, rdi) -> let typ = CTypes_decl.get_declaration_type context.CContext.tenv context.CContext.namespace @@ -169,7 +169,7 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit = "WARNING: When collecting variables, passing from StaticAssertDecl '%s'. Skipped.\n" decl_info.Clang_ast_t.di_pointer | _ -> Printing.log_out - "!!! When collecting locals of a function found '%s'. Cannot continue\n\n" - (Clang_ast_j.string_of_decl decl); + "!!! When collecting locals of a function found '%s'. Cannot continue\n\n" + (Clang_ast_j.string_of_decl decl); assert false in list_iter do_one_decl decl_list diff --git a/infer/src/clang/objcInterface_decl.ml b/infer/src/clang/objcInterface_decl.ml index d8b1a05f5..24fb9f0d8 100644 --- a/infer/src/clang/objcInterface_decl.ml +++ b/infer/src/clang/objcInterface_decl.ml @@ -35,10 +35,10 @@ let is_pointer_to_objc_class tenv typ = match typ with | Sil.Tptr (Sil.Tvar (Sil.TN_csu (Sil.Class, cname)), _) -> (match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, cname)) with - | Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true - | _ -> false) + | Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true + | _ -> false) | Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, _, _, _, a), _) when - is_objc_class_annotation a -> true + is_objc_class_annotation a -> true | _ -> false let get_super_interface_decl otdi_super = @@ -48,10 +48,10 @@ let get_super_interface_decl otdi_super = let get_protocols protocols = let protocol_names = list_map ( - fun decl -> match decl.Clang_ast_t.dr_name with - | Some name -> name.Clang_ast_t.ni_name - | None -> assert false - ) protocols in + fun decl -> match decl.Clang_ast_t.dr_name with + | Some name -> name.Clang_ast_t.ni_name + | None -> assert false + ) protocols in protocol_names (*The superclass is the first element in the list of super classes of structs in the tenv, *) @@ -62,8 +62,8 @@ let get_interface_superclasses super_opt protocols = | None -> [] | Some super -> [(Sil.Class, Mangled.from_string super)] in let protocol_names = list_map ( - fun name -> (Sil.Protocol, Mangled.from_string name) - ) protocols in + fun name -> (Sil.Protocol, Mangled.from_string name) + ) protocols in let super_classes = super_class@protocol_names in super_classes @@ -77,11 +77,11 @@ let create_curr_class_and_superclasses_fields tenv decl_list class_name otdi_sup let update_curr_class curr_class superclasses = let get_protocols protocols = list_fold_right ( - fun protocol converted_protocols -> - match protocol with - | (Sil.Protocol, name) -> (Mangled.to_string name):: converted_protocols - | _ -> converted_protocols - ) protocols [] in + fun protocol converted_protocols -> + match protocol with + | (Sil.Protocol, name) -> (Mangled.to_string name):: converted_protocols + | _ -> converted_protocols + ) protocols [] in match curr_class with | CContext.ContextCls (class_name, _, _) -> let super, protocols = @@ -102,8 +102,8 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info = let methods = ObjcProperty_decl.get_methods curr_class decl_list in let fields_sc = CField_decl.fields_superclass tenv obj_c_interface_decl_info in list_iter (fun (fn, ft, _) -> - Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn); - Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc; + Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn); + Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc; (*In case we found categories, or partial definition of this class earlier and they are already in the tenv *) let fields, superclasses, methods = match Sil.tenv_lookup tenv interface_name with @@ -118,16 +118,16 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info = let fields = CFrontend_utils.General_utils.sort_fields fields in Printing.log_out "Class %s field:\n" class_name; list_iter (fun (fn, ft, _) -> - Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; + Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; let interface_type_info = Sil.Tstruct(fields, [], Sil.Class, Some (Mangled.from_string class_name), - superclasses, methods, objc_class_annotation) in + superclasses, methods, objc_class_annotation) in Sil.tenv_add tenv interface_name interface_type_info; Printing.log_out " >>>Verifying that Typename '%s' is in tenv\n" (Sil.typename_to_string interface_name); (match Sil.tenv_lookup tenv interface_name with - | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) - | None -> Printing.log_out " >>>NOT Found!!\n"); + | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) + | None -> Printing.log_out " >>>NOT Found!!\n"); curr_class let add_missing_methods tenv class_name decl_list curr_class = @@ -165,14 +165,14 @@ let lookup_late_defined_interface tenv cname = match decls with | [] -> () | ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) - :: decls' - when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> + :: decls' + when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> scan decls' | ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) - :: decls' - when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> - (* Assumption: here we assume that the first interface declaration with non empty set of fields is the *) - (* correct one. So we stop. *) + :: decls' + when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> + (* Assumption: here we assume that the first interface declaration with non empty set of fields is the *) + (* correct one. So we stop. *) ignore (interface_declaration tenv name_info.Clang_ast_t.ni_name decl_list obj_c_interface_decl_info) | _:: decls' -> scan decls' in scan !CFrontend_config.global_translation_unit_decls @@ -181,9 +181,9 @@ let lookup_late_defined_interface tenv cname = (* the search is extended in a recursive way to the hierarchy of superclasses. *) let rec find_field tenv nfield str searched_late_defined = (* let add_namespace_to_namefield cname = - match namespace with - | Some _ -> nfield - | None -> (Mangled.to_string cname)^"_"^nfield in *) + match namespace with + | Some _ -> nfield + | None -> (Mangled.to_string cname)^"_"^nfield in *) let print_error name_field fields = Printing.log_err "\nFaild to find name field '%s'\n\n" (Ident.fieldname_to_string name_field) ; Printing.log_err "In the following list of fields\n"; @@ -196,8 +196,8 @@ let rec find_field tenv nfield str searched_late_defined = Printing.log_err "@. ....Searching field in superclass (Class, '%s')@." (Mangled.to_string sname); let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, sname)) in (match find_field tenv nfield str' searched_late_defined with - | Some field -> Some field - | None -> search_super s') + | Some field -> Some field + | None -> search_super s') | (Sil.Protocol, sname):: s' -> Printing.log_err "@. ... Searching field in protocol (Protocol, '%s')@." (Mangled.to_string sname); search_super s' @@ -211,24 +211,24 @@ let rec find_field tenv nfield str searched_late_defined = | Some Sil.Tstruct (sf, nsf, Sil.Struct, Some cname, _, _, _) | Some Sil.Tstruct (sf, nsf, Sil.Union, Some cname, _, _, _) -> (let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in - try - Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf)) - with Not_found -> - print_error name_field (sf@nsf); None) + try + Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf)) + with Not_found -> + print_error name_field (sf@nsf); None) | Some Sil.Tstruct (sf, nsf, Sil.Class, Some cname, super, _, _) -> (let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in - try - Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf)) - with Not_found -> - (* if we have already searched for late defined interfaces we check recursively *) - (* whether the field is defined in the hiearchy of superclasses.*) - (* If we don't find it we stop, giving error. *) - print_error name_field (sf@nsf); - if searched_late_defined then search_super super - else ( - Printing.log_err "@. Search late defined...@.@."; - (* if we don't find the field the first thing we do is scanning later definitions of interfaces. *) - lookup_late_defined_interface tenv cname; - let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, cname)) in - find_field tenv nfield str' true)) + try + Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf)) + with Not_found -> + (* if we have already searched for late defined interfaces we check recursively *) + (* whether the field is defined in the hiearchy of superclasses.*) + (* If we don't find it we stop, giving error. *) + print_error name_field (sf@nsf); + if searched_late_defined then search_super super + else ( + Printing.log_err "@. Search late defined...@.@."; + (* if we don't find the field the first thing we do is scanning later definitions of interfaces. *) + lookup_late_defined_interface tenv cname; + let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, cname)) in + find_field tenv nfield str' true)) | _ -> None diff --git a/infer/src/clang/objcProperty_decl.ml b/infer/src/clang/objcProperty_decl.ml index f675289c4..d69dbf891 100644 --- a/infer/src/clang/objcProperty_decl.ml +++ b/infer/src/clang/objcProperty_decl.ml @@ -29,7 +29,7 @@ type prop_getter_setter = string * (Clang_ast_t.decl * bool) option (** A property type is a tuple: *) (** (qual_type, property attributes, decl_info, (getter_name, getter), (setter_name, setter), ivar name) *) type property_type = Clang_ast_t.qual_type * Clang_ast_t.property_attribute list * - Clang_ast_t.decl_info * prop_getter_setter * prop_getter_setter * string option + Clang_ast_t.decl_info * prop_getter_setter * prop_getter_setter * string option (** A table that record the property defined in the interface and its getter/setter. *) (** This info used later on in the implementation if the getter/setter need to automatically *) @@ -54,7 +54,7 @@ sig val replace_property : property_key -> property_type -> unit val add_property : property_key -> Clang_ast_t.qual_type -> - Clang_ast_t.property_attribute list -> Clang_ast_t.decl_info -> unit + Clang_ast_t.property_attribute list -> Clang_ast_t.decl_info -> unit val print_property_table : unit -> unit @@ -91,25 +91,25 @@ struct let rec find_property curr_class property_name = try PropertyTableHash.find property_table (curr_class, property_name) with Not_found -> - match curr_class with - | ContextCls (name, _, protocols) -> - let res_opt = list_fold_right - (fun protocol found_procname_opt -> - match found_procname_opt with - | Some found_procname -> Some found_procname - | None -> - Some (find_property (ContextProtocol protocol) property_name)) protocols None in - (match res_opt with - | Some res -> res - | None -> raise Not_found) - | _ -> raise Not_found + match curr_class with + | ContextCls (name, _, protocols) -> + let res_opt = list_fold_right + (fun protocol found_procname_opt -> + match found_procname_opt with + | Some found_procname -> Some found_procname + | None -> + Some (find_property (ContextProtocol protocol) property_name)) protocols None in + (match res_opt with + | Some res -> res + | None -> raise Not_found) + | _ -> raise Not_found let find_property_name_from_ivar curr_class ivar = let res = ref None in PropertyTableHash.iter (fun (cl, pname) (_, _, _, _, _, ivar') -> - match ivar' with - | Some s when (CContext.curr_class_equal curr_class cl) && s = ivar -> res:= Some pname - | _ -> ()) property_table; + match ivar' with + | Some s when (CContext.curr_class_equal curr_class cl) && s = ivar -> res:= Some pname + | _ -> ()) property_table; !res let is_mem_property property = @@ -168,8 +168,8 @@ let find_properties_class = Property.find_properties_class let get_ivarname_property pidi = match pidi.Clang_ast_t.opidi_ivar_decl with | Some dr -> (match dr.Clang_ast_t.dr_name with - | Some n -> n.Clang_ast_t.ni_name - | _ -> assert false) + | Some n -> n.Clang_ast_t.ni_name + | _ -> assert false) | _ -> (* If ivar is not defined than we need to take the name of the property to define ivar*) Ast_utils.property_name pidi @@ -194,14 +194,14 @@ let check_for_property curr_class method_name meth_decl body = let check_property_accessor curr_class method_name is_getter = let method_is_getter (property_name, property_type) = match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) -> - let found = - if is_getter then (method_name = getter_name) - else (method_name = setter_name) in - if found then - (Printing.log_out " Found property '%s' defined in property table\n" - (Property.property_key_to_string (curr_class, property_name)); - upgrade_property_accessor - (curr_class, property_name) property_type meth_decl defined is_getter) in + let found = + if is_getter then (method_name = getter_name) + else (method_name = setter_name) in + if found then + (Printing.log_out " Found property '%s' defined in property table\n" + (Property.property_key_to_string (curr_class, property_name)); + upgrade_property_accessor + (curr_class, property_name) property_type meth_decl defined is_getter) in list_iter method_is_getter properties_class in check_property_accessor curr_class method_name true; check_property_accessor curr_class method_name false @@ -213,34 +213,34 @@ let method_is_property_accesor cls method_name = | Some res -> res_opt | None -> match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) -> - if method_name = getter_name then Some (property_name, property_type, true) - else if method_name = setter_name then Some (property_name, property_type, false) - else None in + if method_name = getter_name then Some (property_name, property_type, true) + else if method_name = setter_name then Some (property_name, property_type, false) + else None in list_fold_right method_is_getter properties_class None let prepare_dynamic_property curr_class decl_info property_impl_decl_info = let pname = Ast_utils.property_name property_impl_decl_info in let res = (try - let qt', atts, di, getter, setter, _ = Property.find_property curr_class pname in - let ivar = (match property_impl_decl_info.Clang_ast_t.opidi_ivar_decl with - | Some dr -> (match dr.Clang_ast_t.dr_name with - | Some name_info -> name_info.Clang_ast_t.ni_name - | None -> assert false) - | None -> Ast_utils.generated_ivar_name pname) in - (* update property info with proper ivar name *) - Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, Some ivar); - Printing.log_out "Updated property table by adding ivar name for property pname '%s'\n" pname; - Some (qt', ivar) - with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname; - None) in + let qt', atts, di, getter, setter, _ = Property.find_property curr_class pname in + let ivar = (match property_impl_decl_info.Clang_ast_t.opidi_ivar_decl with + | Some dr -> (match dr.Clang_ast_t.dr_name with + | Some name_info -> name_info.Clang_ast_t.ni_name + | None -> assert false) + | None -> Ast_utils.generated_ivar_name pname) in + (* update property info with proper ivar name *) + Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, Some ivar); + Printing.log_out "Updated property table by adding ivar name for property pname '%s'\n" pname; + Some (qt', ivar) + with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname; + None) in match property_impl_decl_info.Clang_ast_t.opidi_implementation, res with | `Dynamic, Some (qt, ivar) -> - (* For Dynamic property we need to create the ObjCIvarDecl which specifies*) - (* the field of the property. In case of Dynamic this is not in the AST.*) - (* Once created the ObjCIvarDecl then we treat the property as synthesized *) + (* For Dynamic property we need to create the ObjCIvarDecl which specifies*) + (* the field of the property. In case of Dynamic this is not in the AST.*) + (* Once created the ObjCIvarDecl then we treat the property as synthesized *) [Ast_expressions.make_objc_ivar_decl decl_info qt property_impl_decl_info ivar] | _ -> - (* No names of fields/method to collect from ObjCPropertyImplDecl when Synthesized *) + (* No names of fields/method to collect from ObjCPropertyImplDecl when Synthesized *) [] (*NOTE: Assumption: if there is a getter or a setter defined manually, *) @@ -258,8 +258,8 @@ let is_property_read_only attributes = let get_memory_management_attribute attributes = let memory_management_attributes = Ast_utils.get_memory_management_attributes () in try Some (list_find ( - fun att -> list_mem (Ast_utils.property_attribute_eq) - att memory_management_attributes) attributes) + fun att -> list_mem (Ast_utils.property_attribute_eq) + att memory_management_attributes) attributes) with Not_found -> None let create_generated_method_name name_info = @@ -287,7 +287,7 @@ let make_getter curr_class prop_name prop_type = Property.replace_property (curr_class, prop_name) (qt, attributes, decl_info, - (getter_name, Some (ObjCMethodDecl(di, name_info, mdi), true)), (setter_name, setter), Some ivar_name); + (getter_name, Some (ObjCMethodDecl(di, name_info, mdi), true)), (setter_name, setter), Some ivar_name); [ObjCMethodDecl(dummy_info, generated_name_info, mdi')] | _ -> [] @@ -332,8 +332,8 @@ let make_setter curr_class prop_name prop_type = Property.replace_property (curr_class, prop_name) (qt, attributes, decl_info, - (getter_name, getter), - (setter_name, Some (ObjCMethodDecl(di, name, mdi), true)), Some ivar_name); + (getter_name, getter), + (setter_name, Some (ObjCMethodDecl(di, name, mdi), true)), Some ivar_name); [ObjCMethodDecl(dummy_info, name_generated, mdi')] | _ -> [] @@ -351,15 +351,15 @@ let make_getter_setter curr_class decl_info prop_name = try Property.find_property curr_class prop_name with _ -> - Printing.log_out "Property %s not found@." prop_name; - assert false in + Printing.log_out "Property %s not found@." prop_name; + assert false in (make_getter curr_class prop_name prop_type)@ (make_setter curr_class prop_name prop_type) let add_properties_to_table curr_class decl_list = let add_property_to_table dec = match dec with | ObjCPropertyDecl(decl_info, name_info, pdi) -> - (* Property declaration register the property on the property table to be *) + (* Property declaration register the property on the property table to be *) let pname = name_info.Clang_ast_t.ni_name in Printing.log_out "ADDING: ObjCPropertyDecl for property '%s' " pname; Printing.log_out " pointer= '%s' \n" decl_info.Clang_ast_t.di_pointer; diff --git a/infer/src/harness/androidFramework.ml b/infer/src/harness/androidFramework.ml index e49e5d4fe..47266fae6 100644 --- a/infer/src/harness/androidFramework.ml +++ b/infer/src/harness/androidFramework.ml @@ -37,28 +37,28 @@ let android_lifecycles = let android_app = "android.app" in let fragment_lifecycle = ["onInflate"; "onAttach"; "onCreate"; "onCreateView"; "onViewCreated"; "onActivityCreated"; - "onViewStateRestored"; "onStart"; "onResume"; "onPause"; "onSaveInstanceState"; "onStop"; - on_destroy_view; on_destroy; "onDetach"] in + "onViewStateRestored"; "onStart"; "onResume"; "onPause"; "onSaveInstanceState"; "onStop"; + on_destroy_view; on_destroy; "onDetach"] in [ (android_content, - "ContentProvider", - ["onCreate"]); - (android_app, - "Activity", - ["onCreate"; "onStart"; "onRestoreInstanceState"; "onPostCreate"; "onResume"; "onPostResume"; - "onCreateDescription"; "onSaveInstanceState"; "onPause"; "onStop"; on_destroy]); - (android_app, - "Service", - ["onCreate"; "onStart"; "onStartCommand"; "onBind"; "onUnbind"; on_destroy]); - (android_content, - "BroadcastReceiever", - ["onReceive"]); - (android_app, - "Fragment", - fragment_lifecycle); - (* this is the pre-Android 3.0 Fragment type (can also be used post-3.0) *) - ("android.support.v4.app", - "Fragment", - fragment_lifecycle); + "ContentProvider", + ["onCreate"]); + (android_app, + "Activity", + ["onCreate"; "onStart"; "onRestoreInstanceState"; "onPostCreate"; "onResume"; "onPostResume"; + "onCreateDescription"; "onSaveInstanceState"; "onPause"; "onStop"; on_destroy]); + (android_app, + "Service", + ["onCreate"; "onStart"; "onStartCommand"; "onBind"; "onUnbind"; on_destroy]); + (android_content, + "BroadcastReceiever", + ["onReceive"]); + (android_app, + "Fragment", + fragment_lifecycle); + (* this is the pre-Android 3.0 Fragment type (can also be used post-3.0) *) + ("android.support.v4.app", + "Fragment", + fragment_lifecycle); ] let android_callbacks = @@ -244,10 +244,10 @@ let android_callbacks = ("android.widget", "TextView$OnEditorActionListener"); ("android.widget", "TimePicker$OnTimeChangedListener"); ("android.widget", "ZoomButtonsController$OnZoomListener"); - ] in + ] in list_fold_left (fun cbSet (pkg, clazz) -> - let qualified_name = Mangled.from_string (pkg ^ "." ^ clazz) in - Mangled.MangledSet.add qualified_name cbSet) Mangled.MangledSet.empty cb_strs + let qualified_name = Mangled.from_string (pkg ^ "." ^ clazz) in + Mangled.MangledSet.add qualified_name cbSet) Mangled.MangledSet.empty cb_strs (** return the complete set of superclasses of [typ *) (* TODO (t4644852): factor out subtyping functions into some sort of JavaUtil module *) @@ -274,9 +274,9 @@ let is_callback_class_name class_name = Mangled.MangledSet.mem class_name androi let is_callback_class typ tenv = let supertyps = get_all_supertypes typ tenv in TypSet.exists (fun typ -> match typ with - | Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _) -> - is_callback_class_name classname - | _ -> false) supertyps + | Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _) -> + is_callback_class_name classname + | _ -> false) supertyps (** return true if [typ] is a subclass of [lifecycle_typ] *) let typ_is_lifecycle_typ typ lifecycle_typ tenv = @@ -289,24 +289,24 @@ let is_android_lib_class class_name = string_is_prefix "android" class_str || string_is_prefix "com.android" class_str (** returns an option containing the var name and type of a callback registered by [procname], None -if no callback is registered *) + if no callback is registered *) let get_callback_registered_by procname args tenv = (* TODO (t4565077): this check should be replaced with a membership check in a hardcoded list of - * Android callback registration methods *) + * Android callback registration methods *) (* for now, we assume a method is a callback registration method if it is a setter and has a - * callback class as a non - receiver argument *) + * callback class as a non - receiver argument *) let is_callback_register_like = let has_non_this_callback_arg args = list_length args > 1 in let has_registery_name procname = Procname.is_java procname && (PatternMatch.is_setter procname || - is_known_callback_register_method (Procname.java_get_method procname)) in + is_known_callback_register_method (Procname.java_get_method procname)) in has_registery_name procname && has_non_this_callback_arg args in let is_ptr_to_callback_class typ tenv = match typ with | Sil.Tptr (typ, Sil.Pk_pointer) -> is_callback_class typ tenv | _ -> false in if is_callback_register_like then (* we don't want to check if the receiver is a callback class; it's one of the method arguments - * that's being registered as a callback *) + * that's being registered as a callback *) let get_non_this_args args = list_tl args in try Some (list_find (fun (_, typ) -> is_ptr_to_callback_class typ tenv) (get_non_this_args args)) @@ -332,20 +332,20 @@ let is_callback_register_method procname args tenv = | None -> false (** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity) and -a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *) + a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *) let get_lifecycle_for_framework_typ_opt lifecycle_typ lifecycle_proc_strs tenv = match Sil.get_typ lifecycle_typ None tenv with | Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) -> - (* TODO (t4645631): collect the procedures for which is_java is returning false *) + (* TODO (t4645631): collect the procedures for which is_java is returning false *) let lookup_proc lifecycle_proc = list_find (fun decl_proc -> - Procname.is_java decl_proc && lifecycle_proc = Procname.java_get_method decl_proc + Procname.is_java decl_proc && lifecycle_proc = Procname.java_get_method decl_proc ) decl_procs in (* convert each of the framework lifecycle proc strings to a lifecycle method procname *) let lifecycle_procs = list_fold_left (fun lifecycle_procs lifecycle_proc_str -> - try (lookup_proc lifecycle_proc_str) :: lifecycle_procs - with Not_found -> lifecycle_procs) + try (lookup_proc lifecycle_proc_str) :: lifecycle_procs + with Not_found -> lifecycle_procs) [] lifecycle_proc_strs in Some (lifecycle_typ, lifecycle_procs) | _ -> None diff --git a/infer/src/harness/harness.ml b/infer/src/harness/harness.ml index 08cb01f4b..855d71fb7 100644 --- a/infer/src/harness/harness.ml +++ b/infer/src/harness/harness.ml @@ -15,8 +15,8 @@ open Utils (** Automatically create a harness method to exercise code under test *) (** given a list [lst] = fst @ (e :: rest), a test predicate [test], and a list [to_insert], returns -the list fst @ (e :: to_insert) @ rest, where e is the first element such that test(e) evaluates -to true. if test(e) does not evaluate to true for any element of the list, returns [lst]. *) + the list fst @ (e :: to_insert) @ rest, where e is the first element such that test(e) evaluates + to true. if test(e) does not evaluate to true for any element of the list, returns [lst]. *) let insert_after lst test to_insert = let rec insert_rec to_process processed = match to_process with | instr :: to_process -> @@ -29,10 +29,10 @@ let insert_after lst test to_insert = insert_rec lst [] (** find callees that register callbacks and add instrumentation to extract the callback. -return the set of new global static fields created to extract callbacks and their types *) + return the set of new global static fields created to extract callbacks and their types *) let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callback_fields = (* try to turn a nasty callback name like MyActivity$1 into a nice callback name like - * Button.OnClickListener[line 7]*) + * Button.OnClickListener[line 7]*) let create_descriptive_callback_name callback_typ loc = let typ_str = match PatternMatch.type_get_class_name callback_typ with | Some mangled -> Mangled.get_mangled mangled @@ -41,11 +41,11 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb if Procname.is_anonymous_inner_class_name typ_str then match PatternMatch.type_get_direct_supertypes callback_typ with | [] -> - (* this should never happen since an inner class always has a supertype *) + (* this should never happen since an inner class always has a supertype *) assert false | l -> - (* choose to describe this anonymous inner class with one of the interfaces that it - * implements. translation always places interfaces at the end of the supertypes list *) + (* choose to describe this anonymous inner class with one of the interfaces that it + * implements. translation always places interfaces at the end of the supertypes list *) Mangled.get_mangled (list_hd (list_rev l)) else typ_str in Mangled.from_string (pretty_typ_str ^ "[line " ^ Sil.loc_to_string loc ^ "]") in @@ -57,13 +57,13 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb let callback_fld_name = create_descriptive_callback_name ptr_to_cb_typ loc in let created_fld = Ident.create_fieldname callback_fld_name 0 in (* create a function that takes the type of the harness class as an argument and modifies - * the instruction set with callback extraction code. we do this because we need to know - * the typ of the harness class before we can write to any of its fields, but we cannot - * actually create this typ until we know how many fields we are going to create in order - * to extract callbacks *) + * the instruction set with callback extraction code. we do this because we need to know + * the typ of the harness class before we can write to any of its fields, but we cannot + * actually create this typ until we know how many fields we are going to create in order + * to extract callbacks *) let mk_field_write harness_class_typ = (* create an instruction that writes the registered callback object to a global static - * field in the harness class *) + * field in the harness class *) let fld_write_lhs = Sil.Lfield (harness_lvar, created_fld, harness_class_typ) in let extract_cb_instr = Sil.Set (fld_write_lhs, cb_typ, cb_obj, loc) in let instrumented_instrs = @@ -80,52 +80,52 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb (** find all of the callbacks registered by methods in [lifecycle_trace *) let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv = (* what would be ideal to do here is to go through every method (transitively) called by a - * lifecycle method and look for registered callbacks, however, this would need to be a complex - * iterative process, as detecting callbacks can lead to more methods being called, which in - * turn can lead to more callbacks being registered. so what we do here is iterate through each - * file that a lifecycle proc is defined in and collect all callbacks possibly registered in - * methods in that file. this can err on the side of including too many callbacks (for example, if - * a callback is registered in a superclass method that is overridden, this scheme would - * wrongly include it). on the other hand, this will miss callbacks registered in - * callees of lifecycle methods that aren't in our list of "lifecycle methods files" *) + * lifecycle method and look for registered callbacks, however, this would need to be a complex + * iterative process, as detecting callbacks can lead to more methods being called, which in + * turn can lead to more callbacks being registered. so what we do here is iterate through each + * file that a lifecycle proc is defined in and collect all callbacks possibly registered in + * methods in that file. this can err on the side of including too many callbacks (for example, if + * a callback is registered in a superclass method that is overridden, this scheme would + * wrongly include it). on the other hand, this will miss callbacks registered in + * callees of lifecycle methods that aren't in our list of "lifecycle methods files" *) (* TODO (t4793988): do something more principled here *) let harness_lvar = Sil.Lvar (Sil.mk_pvar_global harness_name) in let lifecycle_cfg_files = list_fold_left (fun lifecycle_files (lifecycle_proc, _) -> - try - let cfg_fname = - let source_dir = Inhabit.source_dir_from_name lifecycle_proc proc_file_map in - DB.source_dir_get_internal_file source_dir ".cfg" in - DB.FilenameSet.add cfg_fname lifecycle_files - with Not_found -> lifecycle_files + try + let cfg_fname = + let source_dir = Inhabit.source_dir_from_name lifecycle_proc proc_file_map in + DB.source_dir_get_internal_file source_dir ".cfg" in + DB.FilenameSet.add cfg_fname lifecycle_files + with Not_found -> lifecycle_files ) DB.FilenameSet.empty lifecycle_trace in DB.FilenameSet.fold (fun cfg_file registered_callbacks -> - match Cfg.load_cfg_from_file cfg_file with - | Some cfg -> - list_fold_left (fun registered_callbacks procdesc -> - extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar registered_callbacks - ) registered_callbacks (Cfg.get_all_procs cfg) - | None -> registered_callbacks + match Cfg.load_cfg_from_file cfg_file with + | Some cfg -> + list_fold_left (fun registered_callbacks procdesc -> + extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar registered_callbacks + ) registered_callbacks (Cfg.get_all_procs cfg) + | None -> registered_callbacks ) lifecycle_cfg_files [] (** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a -lifecycle trace *) + lifecycle trace *) let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map tenv = match typ with | Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _) - when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv && - not (AndroidFramework.is_android_lib_class class_name) -> + when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv && + not (AndroidFramework.is_android_lib_class class_name) -> let ptr_to_typ = Some (Sil.Tptr (typ, Sil.Pk_pointer)) in list_fold_left (fun trace lifecycle_proc -> (* given a lifecycle subclass T, resolve the call T.lifecycle_proc() to the procname - * that will actually be called at runtime *) - let resolved_proc = SymExec.resolve_method tenv class_name lifecycle_proc in - (resolved_proc, ptr_to_typ) :: trace + * that will actually be called at runtime *) + let resolved_proc = SymExec.resolve_method tenv class_name lifecycle_proc in + (resolved_proc, ptr_to_typ) :: trace ) [] lifecycle_procs | _ -> [] (** get all the callbacks registered in [lifecycle_trace], transform the SIL to "extract" them into -global static fields belong to the harness so that they are easily callable, and return a list -of the (field, typ) pairs that we have created for this purpose *) + global static fields belong to the harness so that they are easily callable, and return a list + of the (field, typ) pairs that we have created for this purpose *) let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv = let harness_name = Mangled.from_string (Procname.to_string harness_procname) in let registered_cbs = @@ -135,14 +135,14 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv = let harness_typ = Sil.Tstruct (fields, [], Sil.Class, Some harness_name, [], [harness_procname], []) in (* update the tenv with our created harness typ. we don't have to save the tenv to disk here - * because this is done immediately after harness generation runs in jMain.ml *) + * because this is done immediately after harness generation runs in jMain.ml *) let harness_class = Sil.TN_csu (Sil.Class, harness_name) in Sil.tenv_add tenv harness_class harness_typ; let cfgs_to_save = list_fold_left (fun cfgs_to_save (_, _, instrument_sil_f) -> (* instrument the cfg's with callback extraction code *) - let (cfg_file, cfg) = instrument_sil_f harness_typ in - DB.FilenameMap.add cfg_file cfg cfgs_to_save + let (cfg_file, cfg) = instrument_sil_f harness_typ in + DB.FilenameMap.add cfg_file cfg cfgs_to_save ) DB.FilenameMap.empty registered_cbs in (* re-save the cfgs that we've modified by extracting callbacks *) DB.FilenameMap.iter @@ -154,26 +154,26 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv = (** generate a harness for each lifecycle type in an Android application *) let create_android_harness proc_file_map tenv = list_iter (fun (pkg, clazz, lifecycle_methods) -> - let typ_name = Mangled.from_package_class pkg clazz in - match AndroidFramework.get_lifecycle_for_framework_typ_opt typ_name lifecycle_methods tenv with - | Some (framework_typ, framework_procs) -> + let typ_name = Mangled.from_package_class pkg clazz in + match AndroidFramework.get_lifecycle_for_framework_typ_opt typ_name lifecycle_methods tenv with + | Some (framework_typ, framework_procs) -> (* iterate through the type environment and generate a lifecycle harness for each subclass of - * [lifecycle_typ] *) - Sil.tenv_iter (fun _ typ -> - match try_create_lifecycle_trace typ framework_typ framework_procs proc_file_map tenv with - | [] -> () - | lifecycle_trace -> - (* we have identified an application lifecycle type and created a trace for it. now, - * identify the callbacks registered by methods belonging to this type and get the - * inhabitation module to create a harness for us *) - let harness_procname = - let harness_cls_name = PatternMatch.get_type_name typ in - Procname.mangled_java (None, harness_cls_name) None "InferGeneratedHarness" [] Procname.Static in - let callback_fields = - extract_callbacks lifecycle_trace harness_procname proc_file_map tenv in - Inhabit.inhabit_trace lifecycle_trace callback_fields harness_procname proc_file_map tenv - ) tenv - | None -> () + * [lifecycle_typ] *) + Sil.tenv_iter (fun _ typ -> + match try_create_lifecycle_trace typ framework_typ framework_procs proc_file_map tenv with + | [] -> () + | lifecycle_trace -> + (* we have identified an application lifecycle type and created a trace for it. now, + * identify the callbacks registered by methods belonging to this type and get the + * inhabitation module to create a harness for us *) + let harness_procname = + let harness_cls_name = PatternMatch.get_type_name typ in + Procname.mangled_java (None, harness_cls_name) None "InferGeneratedHarness" [] Procname.Static in + let callback_fields = + extract_callbacks lifecycle_trace harness_procname proc_file_map tenv in + Inhabit.inhabit_trace lifecycle_trace callback_fields harness_procname proc_file_map tenv + ) tenv + | None -> () ) AndroidFramework.get_lifecycles let parse_trace trace = Stacktrace.parse_stack_trace trace diff --git a/infer/src/harness/inhabit.ml b/infer/src/harness/inhabit.ml index 539ab1f3d..22de58aeb 100644 --- a/infer/src/harness/inhabit.ml +++ b/infer/src/harness/inhabit.ml @@ -8,7 +8,7 @@ *) (** Generate a procedure that calls a given sequence of methods. Useful for harness/test -* generation. *) + * generation. *) module L = Logging module F = Format @@ -22,14 +22,14 @@ type lifecycle_trace = (Procname.t * Sil.typ option) list type callback_trace = (Sil.exp * Sil.typ) list (** list of instrs and temporary variables created during inhabitation and a cache of types that -* have already been inhabited *) + * have already been inhabited *) type env = { instrs : Sil.instr list; - tmp_vars : Ident.t list; - cache : Sil.exp TypMap.t; - (* set of types currently being inhabited. consult to prevent infinite recursion *) - cur_inhabiting : TypSet.t; - pc : Sil.location; - harness_name : Procname.t } + tmp_vars : Ident.t list; + cache : Sil.exp TypMap.t; + (* set of types currently being inhabited. consult to prevent infinite recursion *) + cur_inhabiting : TypSet.t; + pc : Sil.location; + harness_name : Procname.t } (** add an instruction to the env, update tmp_vars, and bump the pc *) let env_add_instr instr tmp_vars env = @@ -84,8 +84,8 @@ let tl_or_empty l = if l = [] then l else list_tl l let get_non_receiver_formals formals = tl_or_empty formals (** create Sil corresponding to x = new typ() or x = new typ[]. For ordinary allocation, sizeof_typ -* and ret_typ should be the same, but arrays are slightly odd in that sizeof_typ will have a size -* component but the size component of ret_typ is always -1. *) + * and ret_typ should be the same, but arrays are slightly odd in that sizeof_typ will have a size + * component but the size component of ret_typ is always -1. *) let inhabit_alloc sizeof_typ ret_typ alloc_kind env = let retval = Ident.create_fresh Ident.knormal in let inhabited_exp = Sil.Var retval in @@ -100,59 +100,59 @@ let inhabit_alloc sizeof_typ ret_typ alloc_kind env = let rec inhabit_typ typ proc_file_map env = try (TypMap.find typ env.cache, env) with Not_found -> - let inhabit_internal typ env = match typ with - | Sil.Tptr (Sil.Tarray (inner_typ, Sil.Const (Sil.Cint size)), Sil.Pk_pointer) -> - let arr_size = Sil.Const (Sil.Cint (Sil.Int.one)) in - let arr_typ = Sil.Tarray (inner_typ, arr_size) in - inhabit_alloc arr_typ typ SymExec.ModelBuiltins.__new_array env - | Sil.Tptr (typ, Sil.Pk_pointer) as ptr_to_typ -> - (* TODO (t4575417): this case does not work correctly for enums, but they are currently - * broken in Infer anyway (see t4592290) *) - let (allocated_obj_exp, env) = inhabit_alloc typ typ SymExec.ModelBuiltins.__new env in - (* select methods that are constructors and won't force us into infinite recursion because - * we are already inhabiting one of their argument types *) - let get_all_suitable_constructors typ = match typ with - | Sil.Tstruct (_, _, Sil.Class, _, superclasses, methods, _) -> - let is_suitable_constructor p = - let try_get_non_receiver_formals p = - try get_non_receiver_formals (formals_from_name p proc_file_map) - with Not_found -> [] in - Procname.is_constructor p && list_for_all (fun (_, typ) -> - not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in - list_filter (fun p -> is_suitable_constructor p) methods - | _ -> [] in - let (env, typ_class_name) = match get_all_suitable_constructors typ with - | constructor :: _ -> - (* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to - * nondeterministically call all possible constructors instead *) - let env = - inhabit_constructor constructor (allocated_obj_exp, ptr_to_typ) proc_file_map env in - (* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we - * we can use it as a descriptive local variable name in the harness *) - let typ_class_name = - if Procname.is_java constructor then Procname.java_get_simple_class constructor - else create_fresh_local_name () in - (env, Mangled.from_string typ_class_name) - | [] -> (env, Mangled.from_string (create_fresh_local_name ())) in - (* add the instructions *& local = [allocated_obj_exp]; id = *& local, where local and id are - * both fresh. the only point of this is to add a descriptive local name that makes error - * reports from the harness look nicer -- it's not necessary to make symbolic execution work *) - let fresh_local_exp = Sil.Lvar (Sil.mk_pvar typ_class_name env.harness_name) in - let write_to_local_instr = - Sil.Set (fresh_local_exp, ptr_to_typ, allocated_obj_exp, env.pc) in - let env' = env_add_instr write_to_local_instr [] env in - let fresh_id = Ident.create_fresh Ident.knormal in - let read_from_local_instr = Sil.Letderef (fresh_id, fresh_local_exp, ptr_to_typ, env'.pc) in - (Sil.Var fresh_id, env_add_instr read_from_local_instr [fresh_id] env') - | Sil.Tint (_) -> (Sil.Const (Sil.Cint (Sil.Int.zero)), env) - | Sil.Tfloat (_) -> (Sil.Const (Sil.Cfloat 0.0), env) - | typ -> - L.err "Couldn't inhabit typ: %a@." (Sil.pp_typ pe_text) typ; - assert false in - let (inhabited_exp, env') = - inhabit_internal typ { env with cur_inhabiting = TypSet.add typ env.cur_inhabiting } in - (inhabited_exp, { env' with cache = TypMap.add typ inhabited_exp env.cache; - cur_inhabiting = env.cur_inhabiting }) + let inhabit_internal typ env = match typ with + | Sil.Tptr (Sil.Tarray (inner_typ, Sil.Const (Sil.Cint size)), Sil.Pk_pointer) -> + let arr_size = Sil.Const (Sil.Cint (Sil.Int.one)) in + let arr_typ = Sil.Tarray (inner_typ, arr_size) in + inhabit_alloc arr_typ typ SymExec.ModelBuiltins.__new_array env + | Sil.Tptr (typ, Sil.Pk_pointer) as ptr_to_typ -> + (* TODO (t4575417): this case does not work correctly for enums, but they are currently + * broken in Infer anyway (see t4592290) *) + let (allocated_obj_exp, env) = inhabit_alloc typ typ SymExec.ModelBuiltins.__new env in + (* select methods that are constructors and won't force us into infinite recursion because + * we are already inhabiting one of their argument types *) + let get_all_suitable_constructors typ = match typ with + | Sil.Tstruct (_, _, Sil.Class, _, superclasses, methods, _) -> + let is_suitable_constructor p = + let try_get_non_receiver_formals p = + try get_non_receiver_formals (formals_from_name p proc_file_map) + with Not_found -> [] in + Procname.is_constructor p && list_for_all (fun (_, typ) -> + not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in + list_filter (fun p -> is_suitable_constructor p) methods + | _ -> [] in + let (env, typ_class_name) = match get_all_suitable_constructors typ with + | constructor :: _ -> + (* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to + * nondeterministically call all possible constructors instead *) + let env = + inhabit_constructor constructor (allocated_obj_exp, ptr_to_typ) proc_file_map env in + (* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we + * we can use it as a descriptive local variable name in the harness *) + let typ_class_name = + if Procname.is_java constructor then Procname.java_get_simple_class constructor + else create_fresh_local_name () in + (env, Mangled.from_string typ_class_name) + | [] -> (env, Mangled.from_string (create_fresh_local_name ())) in + (* add the instructions *& local = [allocated_obj_exp]; id = *& local, where local and id are + * both fresh. the only point of this is to add a descriptive local name that makes error + * reports from the harness look nicer -- it's not necessary to make symbolic execution work *) + let fresh_local_exp = Sil.Lvar (Sil.mk_pvar typ_class_name env.harness_name) in + let write_to_local_instr = + Sil.Set (fresh_local_exp, ptr_to_typ, allocated_obj_exp, env.pc) in + let env' = env_add_instr write_to_local_instr [] env in + let fresh_id = Ident.create_fresh Ident.knormal in + let read_from_local_instr = Sil.Letderef (fresh_id, fresh_local_exp, ptr_to_typ, env'.pc) in + (Sil.Var fresh_id, env_add_instr read_from_local_instr [fresh_id] env') + | Sil.Tint (_) -> (Sil.Const (Sil.Cint (Sil.Int.zero)), env) + | Sil.Tfloat (_) -> (Sil.Const (Sil.Cfloat 0.0), env) + | typ -> + L.err "Couldn't inhabit typ: %a@." (Sil.pp_typ pe_text) typ; + assert false in + let (inhabited_exp, env') = + inhabit_internal typ { env with cur_inhabiting = TypSet.add typ env.cur_inhabiting } in + (inhabited_exp, { env' with cache = TypMap.add typ inhabited_exp env.cache; + cur_inhabiting = env.cur_inhabiting }) (** inhabit each of the types in the formals list *) and inhabit_args formals proc_file_map env = @@ -162,11 +162,11 @@ and inhabit_args formals proc_file_map env = list_fold_right inhabit_arg formals ([], env) (** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the -* remaining arguments *) + * remaining arguments *) and inhabit_constructor constr_name (allocated_obj, obj_type) proc_file_map env = try - (* this lookup can fail when we try to get the procdesc of a procedure from a different - * module. this could be solved with a whole - program class hierarchy analysis *) + (* this lookup can fail when we try to get the procdesc of a procedure from a different + * module. this could be solved with a whole - program class hierarchy analysis *) let (args, env) = let non_receiver_formals = tl_or_empty (formals_from_name constr_name proc_file_map) in inhabit_args non_receiver_formals proc_file_map env in @@ -219,12 +219,12 @@ let inhabit_fld_trace flds proc_file_map env = inhabit_args (tl_or_empty formals) proc_file_map env in inhabit_call_with_args procname procdesc ((Sil.Var lhs, fld_typ) :: args) env with Not_found -> - (* TODO (t4645631): investigate why this failure occurs *) - env in + (* TODO (t4645631): investigate why this failure occurs *) + env in list_fold_left (fun env procname -> - if not (Procname.is_constructor procname) && - not (Procname.java_is_access_method procname) then inhabit_cb_call procname env - else env) env procs + if not (Procname.is_constructor procname) && + not (Procname.java_is_access_method procname) then inhabit_cb_call procname env + else env) env procs | _ -> assert false in list_fold_left (fun env fld -> invoke_cb fld env) env flds @@ -247,10 +247,10 @@ let write_harness_to_file harness_instrs harness_file = let harness_file_name = DB.source_file_to_string harness_file in ref (create_outfile harness_file_name) in let pp_harness fmt = list_iter (fun instr -> - Format.fprintf fmt "%a\n" (Sil.pp_instr pe_text) instr) harness_instrs in + Format.fprintf fmt "%a\n" (Sil.pp_instr pe_text) instr) harness_instrs in do_outf harness_file (fun outf -> - pp_harness outf.fmt; - close_outf outf) + pp_harness outf.fmt; + close_outf outf) (** add the harness proc to the cg and make sure its callees can be looked up by sym execution *) let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv = @@ -272,7 +272,7 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv = let array_typ_size = Sil.exp_get_undefined false in Sil.Tptr (Sil.Tarray (lookup_typ stripped_typ, array_typ_size), Sil.Pk_pointer) | _ -> - (* non-primitive/non-array type--resolve it in the tenv *) + (* non-primitive/non-array type--resolve it in the tenv *) match Sil.get_typ (Mangled.from_string typ_str) None tenv with | Some typ -> typ | None -> failwith ("Failed to look up typ " ^ typ_str) in @@ -295,30 +295,30 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv = Sil.is_generated = false; } in create { - cfg = harness_cfg; - name = procname; - is_defined = false; - ret_type = return_typ; - formals = params; - locals = []; - captured = []; - loc = loc; - proc_attributes = proc_attributes; - } in + cfg = harness_cfg; + name = procname; + is_defined = false; + ret_type = return_typ; + formals = params; + locals = []; + captured = []; + loc = loc; + proc_attributes = proc_attributes; + } in list_iter (fun p -> (* add harness -> callee edge to the call graph *) - Cg.add_edge cg harness_name p; - (* create dummy procdescs for callees not in the module. hopefully t4583729 will remove the - * need to do this in the future *) - if not (SymExec.function_is_builtin p) then - (* simulate symbolic execution's lookup of a procedure *) - match Cfg.Procdesc.find_from_name harness_cfg p with - | Some _ -> () - | None -> ignore (create_dummy_procdesc p) + Cg.add_edge cg harness_name p; + (* create dummy procdescs for callees not in the module. hopefully t4583729 will remove the + * need to do this in the future *) + if not (SymExec.function_is_builtin p) then + (* simulate symbolic execution's lookup of a procedure *) + match Cfg.Procdesc.find_from_name harness_cfg p with + | Some _ -> () + | None -> ignore (create_dummy_procdesc p) ) (Cfg.Node.get_callees harness_node) (** create and fill the appropriate nodes and add them to the harness cfg. also add the harness -* proc to the cg *) + * proc to the cg *) let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv = (* TMP: pick an arbitrary cg and cfg to piggyback the harness code onto *) (* TODO (t4707171): create our own fresh cfg / cg instead *) @@ -347,16 +347,16 @@ let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv = Sil.is_generated = false; } in create { - cfg = harness_cfg; - name = harness_name; - is_defined = true; - ret_type = Sil.Tvoid; - formals = []; - locals = []; - captured = []; - loc = env.pc; - proc_attributes = proc_attributes; - } in + cfg = harness_cfg; + name = harness_name; + is_defined = true; + ret_type = Sil.Tvoid; + formals = []; + locals = []; + captured = []; + loc = env.pc; + proc_attributes = proc_attributes; + } in let harness_node = (* important to reverse the list or there will be scoping issues! *) let instrs = (list_rev env.instrs) in @@ -380,7 +380,7 @@ let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv = Cfg.store_cfg_to_file cfg_file false harness_cfg (** create a procedure named harness_name that calls each of the methods in trace in the specified -* order with the specified receiver and add it to the execution environment *) + * order with the specified receiver and add it to the execution environment *) let inhabit_trace trace cb_flds harness_name proc_file_map tenv = if list_length trace > 0 then let harness_cfg = Cfg.Node.create_cfg () in let harness_file = create_dummy_harness_file harness_name harness_cfg tenv in diff --git a/infer/src/harness/stacktrace.ml b/infer/src/harness/stacktrace.ml index b49242b69..dd00f40f0 100644 --- a/infer/src/harness/stacktrace.ml +++ b/infer/src/harness/stacktrace.ml @@ -32,7 +32,7 @@ type stack_frame = | Unresolved of str_frame (** list representation of a stack trace. head of the list is the top of the stack (line/proc where -exception occurs *) + exception occurs *) type stack_trace = stack_frame list (** given [str_frame], try to resolve its components in [exe_env] *) @@ -40,8 +40,8 @@ let try_resolve_frame str_frame exe_env tenv = try let class_name = Mangled.from_string str_frame.class_str in (* find the class name in the tenv and get the procedure(s) whose names match the procedure name - * in the stack trace. Note that the stack trace does not have any type or argument information; - * the name is all that we have to go on *) + * in the stack trace. Note that the stack trace does not have any type or argument information; + * the name is all that we have to go on *) match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, class_name)) with | Some Sil.Tstruct (_, _, Sil.Class, _, _, decl_procs, _) -> let possible_calls = @@ -53,13 +53,13 @@ let try_resolve_frame str_frame exe_env tenv = * same file, which will be true in Java but not necessarily in other languages *) let file_name = Exe_env.get_source exe_env (list_hd possible_calls) in Resolved - { possible_calls = possible_calls; file_name = file_name; line_num = str_frame.line_num; } + { possible_calls = possible_calls; file_name = file_name; line_num = str_frame.line_num; } else Unresolved str_frame | _ -> Unresolved str_frame with Not_found -> Unresolved str_frame (** given a stack trace line like "at com.foo.Class.method(Class.java:42)" extract the class name, -method name, file name, and line number *) + method name, file name, and line number *) let parse_frame frame_str exe_env tenv = (* separate the qualified method name and the parenthesized text/line number*) ignore(Str.string_match (Str.regexp "at \\(.*\\)(\\(.*\\))") frame_str 0); diff --git a/infer/src/java/jClasspath.ml b/infer/src/java/jClasspath.ml index ba73bff24..792f4debd 100644 --- a/infer/src/java/jClasspath.ml +++ b/infer/src/java/jClasspath.ml @@ -149,14 +149,14 @@ let lookup_node cn (program: program) = try Some (JBasics.ClassMap.find cn (get_classmap program)) with Not_found -> - try - let jclass = Javalib.get_class (get_classpath program) cn in - add_class cn jclass program; - Some jclass - with - | JBasics.No_class_found _ - | JBasics.Class_structure_error _ - | Invalid_argument _ -> None + try + let jclass = Javalib.get_class (get_classpath program) cn in + add_class cn jclass program; + Some jclass + with + | JBasics.No_class_found _ + | JBasics.Class_structure_error _ + | Invalid_argument _ -> None let classname_of_class_filename class_filename = diff --git a/infer/src/java/jContext.ml b/infer/src/java/jContext.ml index da0b8dda1..0ae28914b 100644 --- a/infer/src/java/jContext.ml +++ b/infer/src/java/jContext.ml @@ -81,11 +81,11 @@ let get_or_set_pvar_type context var typ = else set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map); (pvar, typ) with Not_found -> - let procname = (Cfg.Procdesc.get_proc_name (get_procdesc context)) in - let varname = Mangled.from_string (JBir.var_name_g var) in - let pvar = Sil.mk_pvar varname procname in - set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map); - (pvar, typ) + let procname = (Cfg.Procdesc.get_proc_name (get_procdesc context)) in + let varname = Mangled.from_string (JBir.var_name_g var) in + let pvar = Sil.mk_pvar varname procname in + set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map); + (pvar, typ) let lookup_pvar_type context var typ = (get_or_set_pvar_type context var typ) @@ -95,7 +95,7 @@ let reset_pvar_type context = let var_map = get_var_map context in let aux var item = match item with (pvar, otyp, typ) -> - set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in + set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in JBir.VarMap.iter aux var_map let get_var_type context var = diff --git a/infer/src/java/jFrontend.ml b/infer/src/java/jFrontend.ml index 659716de1..4d6d5f98d 100644 --- a/infer/src/java/jFrontend.ml +++ b/infer/src/java/jFrontend.ml @@ -73,13 +73,13 @@ let add_cmethod never_null_matcher program icfg node cm is_static = let cn, ms = JBasics.cms_split cm.Javalib.cm_class_method_signature in let is_clinit = JBasics.ms_equal ms JBasics.clinit_signature in if !JTrans.no_static_final = false - && is_clinit - && not (JTransStaticField.has_static_final_fields node) then + && is_clinit + && not (JTransStaticField.has_static_final_fields node) then JUtils.log "\t\tskipping class initializer: %s@." (JBasics.ms_name ms) else match JTrans.get_method_procdesc program cfg tenv cn ms is_static with | JTrans.Defined procdesc when JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc) -> - (* do not capture the method if there is a model for it *) + (* do not capture the method if there is a model for it *) JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc)); | JTrans.Defined procdesc -> let start_node = Cfg.Procdesc.get_start_node procdesc in @@ -112,7 +112,7 @@ let add_amethod program icfg node am is_static = let cn, ms = JBasics.cms_split am.Javalib.am_class_method_signature in match JTrans.get_method_procdesc program cfg tenv cn ms is_static with | JTrans.Defined procdesc when (JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc)) -> - (* do not capture the method if there is a model for it *) + (* do not capture the method if there is a model for it *) JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc)); | JTrans.Defined procdesc -> Cg.add_node icfg.JContext.cg (Cfg.Procdesc.get_proc_name procdesc) @@ -150,8 +150,8 @@ let is_classname_cached cn = Sys.file_exists (path_of_cached_classname cn) (* Given a source file and a class, translates the code of this class. -In init - mode, finds out whether this class contains initializers at all, -in this case translates it. In standard mode, all methods are translated *) + In init - mode, finds out whether this class contains initializers at all, + in this case translates it. In standard mode, all methods are translated *) let create_icfg never_null_matcher linereader program icfg source_file cn node = JUtils.log "\tclassname: %s@." (JBasics.cn_name cn); cache_classname cn; @@ -160,12 +160,12 @@ let create_icfg never_null_matcher linereader program icfg source_file cn node = begin Javalib.m_iter (JTrans.create_local_procdesc program linereader cfg tenv node) node; Javalib.m_iter (fun m -> - let method_kind = JTransType.get_method_kind m in - match m with - | Javalib.ConcreteMethod cm -> - add_cmethod never_null_matcher program icfg node cm method_kind - | Javalib.AbstractMethod am -> - add_amethod program icfg node am method_kind + let method_kind = JTransType.get_method_kind m in + match m with + | Javalib.ConcreteMethod cm -> + add_cmethod never_null_matcher program icfg node cm method_kind + | Javalib.AbstractMethod am -> + add_amethod program icfg node am method_kind ) node end @@ -196,8 +196,8 @@ let should_capture classes source_basename node = (* Computes the control - flow graph and call - graph of a given source file. -In the standard - mode, it translated all the classes that correspond to this -source file. *) + In the standard - mode, it translated all the classes that correspond to this + source file. *) let compute_source_icfg never_null_matcher linereader classes program tenv source_basename source_file = let icfg = @@ -215,8 +215,8 @@ let compute_source_icfg let () = JBasics.ClassMap.iter (select - (should_capture classes source_basename) - (create_icfg never_null_matcher linereader program icfg source_file)) + (should_capture classes source_basename) + (create_icfg never_null_matcher linereader program icfg source_file)) (JClasspath.get_classmap program) in (icfg.JContext.cg, icfg.JContext.cfg) diff --git a/infer/src/java/jMain.ml b/infer/src/java/jMain.ml index 615674981..c358cbea7 100644 --- a/infer/src/java/jMain.ml +++ b/infer/src/java/jMain.ml @@ -21,14 +21,14 @@ let arg_desc = let desc = (filter base_arg_desc) @ [ - "-models", Arg.String (fun filename -> JClasspath.add_models filename), Some "paths", "set the path to the jar containing the models"; - "-debug", Arg.Unit (fun () -> JConfig.debug_mode := true), None, "write extra translation information"; - "-dependencies", Arg.Unit (fun _ -> JConfig.dependency_mode := true), None, "translate all the dependencies during the capture"; - "-no-static_final", Arg.Unit (fun () -> JTrans.no_static_final := true), None, "no special treatment for static final fields"; - "-tracing", Arg.Unit (fun () -> JConfig.translate_checks := true), None, - "Translate JVM checks"; - "-verbose_out", Arg.String (fun path -> JClasspath.set_verbose_out path), None, - "Set the path to the javac verbose output" + "-models", Arg.String (fun filename -> JClasspath.add_models filename), Some "paths", "set the path to the jar containing the models"; + "-debug", Arg.Unit (fun () -> JConfig.debug_mode := true), None, "write extra translation information"; + "-dependencies", Arg.Unit (fun _ -> JConfig.dependency_mode := true), None, "translate all the dependencies during the capture"; + "-no-static_final", Arg.Unit (fun () -> JTrans.no_static_final := true), None, "no special treatment for static final fields"; + "-tracing", Arg.Unit (fun () -> JConfig.translate_checks := true), None, + "Translate JVM checks"; + "-verbose_out", Arg.String (fun path -> JClasspath.set_verbose_out path), None, + "Set the path to the javac verbose output" ] in Arg2.create_options_desc false "Parsing Options" desc in base_arg @@ -93,7 +93,7 @@ let do_source_file if JConfig.create_harness then list_fold_left (fun proc_file_map pdesc -> - Procname.Map.add (Cfg.Procdesc.get_proc_name pdesc) source_file proc_file_map) + Procname.Map.add (Cfg.Procdesc.get_proc_name pdesc) source_file proc_file_map) proc_file_map (Cfg.get_all_procs cfg) else proc_file_map diff --git a/infer/src/java/jTrans.ml b/infer/src/java/jTrans.ml index 4bcf1ef3c..dafbbe1a9 100644 --- a/infer/src/java/jTrans.ml +++ b/infer/src/java/jTrans.ml @@ -28,8 +28,8 @@ let constr_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap. let init_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap.empty (** Fix the line associated to a method definition. -Since Sawja often reports a method off by a few lines, we search -backwards for a line where the method name is. *) + Since Sawja often reports a method off by a few lines, we search + backwards for a line where the method name is. *) let fix_method_definition_line linereader proc_name loc = let method_name = if Procname.is_constructor proc_name then @@ -42,7 +42,7 @@ let fix_method_definition_line linereader proc_name loc = | None -> raise Not_found | Some line -> (try ignore (Str.search_forward regex line 0); true - with Not_found -> false) in + with Not_found -> false) in let line = ref loc.Sil.line in try while not (method_is_defined_here !line) do @@ -111,9 +111,9 @@ let get_field_name program static tenv cn fs context = (fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs) (if static then sfields else fields) with Not_found -> - (* TODO: understand why fields cannot be found here *) - JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs); - raise (Frontend_error "Cannot find fieldname") in + (* TODO: understand why fields cannot be found here *) + JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs); + raise (Frontend_error "Cannot find fieldname") in fieldname | _ -> assert false @@ -142,8 +142,8 @@ let formals program tenv cn impl = list_rev (list_fold_left collect [] (JBir.params impl)) (** Creates the local and formal variables from a procedure based on the -impl argument. If the meth_kind is Init, we add a parameter field to -the initialiser method. *) + impl argument. If the meth_kind is Init, we add a parameter field to + the initialiser method. *) let locals_formals program tenv cn impl meth_kind = let form_list = if meth_kind = JContext.Init then @@ -298,16 +298,16 @@ let create_local_procdesc program linereader cfg tenv node m = Sil.is_generated = false; } in create { - cfg = cfg; - name = procname; - is_defined = true; - ret_type = JTransType.return_type program tenv ms meth_kind; - formals = formals; - locals = []; - captured = []; - loc = Sil.dummy_location; - proc_attributes = proc_attributes - } in + cfg = cfg; + name = procname; + is_defined = true; + ret_type = JTransType.return_type program tenv ms meth_kind; + formals = formals; + locals = []; + captured = []; + loc = Sil.dummy_location; + proc_attributes = proc_attributes + } in let start_kind = Cfg.Node.Start_node procdesc in let start_node = Cfg.Node.create cfg Sil.dummy_location start_kind [] procdesc [] in let exit_kind = (Cfg.Node.Exit_node procdesc) in @@ -334,16 +334,16 @@ let create_local_procdesc program linereader cfg tenv node m = Sil.is_generated = false; } in create { - cfg = cfg; - name = procname; - is_defined = false; - ret_type = JTransType.return_type program tenv ms meth_kind; - formals = formals; - locals = []; - captured = []; - loc = Sil.dummy_location; - proc_attributes = proc_attributes; - } in + cfg = cfg; + name = procname; + is_defined = false; + ret_type = JTransType.return_type program tenv ms meth_kind; + formals = formals; + locals = []; + captured = []; + loc = Sil.dummy_location; + proc_attributes = proc_attributes; + } in () | Javalib.ConcreteMethod cm -> let impl = get_implementation cm in @@ -371,16 +371,16 @@ let create_local_procdesc program linereader cfg tenv node m = Sil.is_generated = false; } in create { - cfg = cfg; - name = procname; - is_defined = true; - ret_type = JTransType.return_type program tenv ms meth_kind; - formals = formals; - locals = locals; - captured = []; - loc = loc_start; - proc_attributes = proc_attributes; - } in + cfg = cfg; + name = procname; + is_defined = true; + ret_type = JTransType.return_type program tenv ms meth_kind; + formals = formals; + locals = locals; + captured = []; + loc = loc_start; + proc_attributes = proc_attributes; + } in let start_kind = Cfg.Node.Start_node procdesc in let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in let exit_kind = (Cfg.Node.Exit_node procdesc) in @@ -392,7 +392,7 @@ let create_local_procdesc program linereader cfg tenv node m = Cfg.Procdesc.set_exit_node procdesc exit_node; Cfg.Node.add_locals_ret_declaration start_node locals; with JBir.Subroutine -> - L.err "create_local_procdesc raised JBir.Subroutine on %a@." Procname.pp procname in + L.err "create_local_procdesc raised JBir.Subroutine on %a@." Procname.pp procname in match lookup_procdesc cfg procname with | Unknown -> create_new_procdesc () | Created defined_status -> @@ -412,31 +412,31 @@ let create_external_procdesc program cfg tenv cn ms method_annotation kind = let formals = formals_from_signature program tenv cn ms kind in let procname = JTransType.get_method_procname cn ms kind in ignore ( - let open Cfg.Procdesc in - let proc_attributes = - { - Sil.access = Sil.Default; - Sil.exceptions = []; - Sil.is_abstract = false; - Sil.is_bridge_method = false; - Sil.is_objc_instance_method = false; - Sil.is_synthetic_method = false; - Sil.language = Sil.Java; - Sil.func_attributes = []; - Sil.method_annotation = method_annotation; - Sil.is_generated = false; - } in - create { - cfg = cfg; - name = procname; - is_defined = false; - ret_type = return_type; - formals = formals; - locals = []; - captured = []; - loc = Sil.dummy_location; - proc_attributes = proc_attributes; - }) + let open Cfg.Procdesc in + let proc_attributes = + { + Sil.access = Sil.Default; + Sil.exceptions = []; + Sil.is_abstract = false; + Sil.is_bridge_method = false; + Sil.is_objc_instance_method = false; + Sil.is_synthetic_method = false; + Sil.language = Sil.Java; + Sil.func_attributes = []; + Sil.method_annotation = method_annotation; + Sil.is_generated = false; + } in + create { + cfg = cfg; + name = procname; + is_defined = false; + ret_type = return_type; + formals = formals; + locals = []; + captured = []; + loc = Sil.dummy_location; + proc_attributes = proc_attributes; + }) (** returns the procedure description of the given method and creates it if it hasn't been created before *) let rec get_method_procdesc program cfg tenv cn ms kind = @@ -510,16 +510,16 @@ let rec expression context pc expr = | JBir.InstanceOf ot | JBir.Cast ot -> let subtypes = (match unop with - | JBir.InstanceOf _ -> Sil.Subtype.subtypes_instof - | JBir.Cast _ -> Sil.Subtype.subtypes_cast - | _ -> assert false) in + | JBir.InstanceOf _ -> Sil.Subtype.subtypes_instof + | JBir.Cast _ -> Sil.Subtype.subtypes_cast + | _ -> assert false) in let sizeof_expr = JTransType.sizeof_of_object_type program tenv ot subtypes in let builtin = (match unop with - | JBir.InstanceOf ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) - | JBir.Cast ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast) - | _ -> assert false) in + | JBir.InstanceOf ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) + | JBir.Cast ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast) + | _ -> assert false) in let args = [(sil_ex, type_of_ex); (sizeof_expr, Sil.Tvoid)] in let ret_id = Ident.create_fresh Ident.knormal in let call = Sil.Call([ret_id], builtin, args, loc, Sil.cf_default) in @@ -532,7 +532,7 @@ let rec expression context pc expr = begin match binop with | JBir.ArrayLoad vt -> - (* add an instruction that dereferences the array *) + (* add an instruction that dereferences the array *) let array_typ = Sil.Tarray(type_of_expr, Sil.Var (Ident.create_fresh Ident.kprimed)) in let fresh_id, deref_array_instr = create_sil_deref sil_ex1 array_typ loc in let id = Ident.create_fresh Ident.knormal in @@ -609,7 +609,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_ match sil_obj_opt with | None -> ([], [], []) | Some (sil_obj_expr, sil_obj_type) -> - (* for non-constructors, add an instruction that dereferences the receiver *) + (* for non-constructors, add an instruction that dereferences the receiver *) let ids, instrs = let is_non_constructor_call = match invoke_code with @@ -628,9 +628,9 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_ let (idl, instrs, call_args) = list_fold_left (fun (idl_accu, instrs_accu, args_accu) expr -> - let (idl, instrs, sil_expr) = expression context pc expr in - let sil_expr_type = JTransType.expr_type context expr in - (idl_accu @ idl, instrs_accu @ instrs, args_accu @ [(sil_expr, sil_expr_type)])) + let (idl, instrs, sil_expr) = expression context pc expr in + let sil_expr_type = JTransType.expr_type context expr in + (idl_accu @ idl, instrs_accu @ instrs, args_accu @ [(sil_expr, sil_expr_type)])) init expr_list in let callee_procname = @@ -659,22 +659,22 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_ (* add a file attribute when calling the constructor of a subtype of Closeable *) | (var, typ) as exp :: _ - when Procname.is_constructor callee_procname && JTransType.is_closeable program tenv typ -> - let set_file_attr = - let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_file_attribute) in - Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in - (* Exceptions thrown in the constructor should prevent adding the resource attribute *) - call_instrs @ [set_file_attr] + when Procname.is_constructor callee_procname && JTransType.is_closeable program tenv typ -> + let set_file_attr = + let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_file_attribute) in + Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in + (* Exceptions thrown in the constructor should prevent adding the resource attribute *) + call_instrs @ [set_file_attr] (* remove file attribute when calling the close method of a subtype of Closeable *) | (var, typ) as exp :: [] - when Procname.java_is_close callee_procname && JTransType.is_closeable program tenv typ -> - let set_mem_attr = - let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_mem_attribute) in - Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in - (* Exceptions thrown in the close method should not prevent the resource from being *) - (* considered as closed *) - [set_mem_attr] @ call_instrs + when Procname.java_is_close callee_procname && JTransType.is_closeable program tenv typ -> + let set_mem_attr = + let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_mem_attribute) in + Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in + (* Exceptions thrown in the close method should not prevent the resource from being *) + (* considered as closed *) + [set_mem_attr] @ call_instrs | _ -> call_instrs in @@ -791,15 +791,15 @@ let rec extends context node1 node2 = let instruction_array_call ms obj_type obj args var_opt vt = if is_clone ms then (let cn = JBasics.make_cn JConfig.infer_array_cl in - let vt = (JBasics.TObject obj_type) in - let ms = JBasics.make_ms JConfig.clone_name [vt] (Some vt) in - JBir.InvokeStatic (var_opt, cn, ms, obj:: args)) + let vt = (JBasics.TObject obj_type) in + let ms = JBasics.make_ms JConfig.clone_name [vt] (Some vt) in + JBir.InvokeStatic (var_opt, cn, ms, obj:: args)) else (let undef_cn, undef_ms = get_undefined_method_call (JBasics.ms_rtype ms) in - JBir.InvokeStatic (var_opt, undef_cn, undef_ms, [])) + JBir.InvokeStatic (var_opt, undef_cn, undef_ms, [])) (* special translation of the method start() of a Thread or a Runnable object. -We translate it directly as the run() method *) + We translate it directly as the run() method *) let instruction_thread_start context cn ms obj args var_opt = match JClasspath.lookup_node cn (JContext.get_program context) with | None -> @@ -849,7 +849,7 @@ let rec instruction context pc instr : translation = cfg (get_location (JContext.get_impl context) pc meth_kind cn) node_kind sil_instrs (JContext.get_procdesc context) temps in let return_not_null () = (match_never_null loc.Sil.file proc_name - || list_exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in + || list_exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in try match instr with | JBir.AffectVar (var, expr) -> @@ -990,8 +990,8 @@ let rec instruction context pc instr : translation = let sil_obj_opt, args, ids, instrs = match args with | [arg] when is_clone ms -> - (* hack to null check the receiver of clone when clone is an array. in the array.clone() - case, clone is a virtual call that we translate as a static call *) + (* hack to null check the receiver of clone when clone is an array. in the array.clone() + case, clone is a virtual call that we translate as a static call *) let (ids, instrs, sil_arg_expr) = expression context pc arg in let arg_typ = JTransType.expr_type context arg in Some (sil_arg_expr, arg_typ), [], ids, instrs @@ -1051,7 +1051,7 @@ let rec instruction context pc instr : translation = Instr call_node | JBir.Check (JBir.CheckNullPointer expr) when !JConfig.translate_checks && is_this expr -> - (* TODO #6509339: refactor the boilterplate code in the translattion of JVM checks *) + (* TODO #6509339: refactor the boilterplate code in the translattion of JVM checks *) let (ids, instrs, sil_expr) = expression context pc expr in let this_not_null_node = create_node @@ -1183,5 +1183,5 @@ let rec instruction context pc instr : translation = | _ -> Skip with Frontend_error s -> - JUtils.log "Skipping because of: %s@." s; - Skip + JUtils.log "Skipping because of: %s@." s; + Skip diff --git a/infer/src/java/jTransExn.ml b/infer/src/java/jTransExn.ml index 2d038cec1..0cca387a9 100644 --- a/infer/src/java/jTransExn.ml +++ b/infer/src/java/jTransExn.ml @@ -20,7 +20,7 @@ let create_handler_table impl = let handlers = Hashtbl.find handler_tb pc in Hashtbl.replace handler_tb pc (exn_handler:: handlers) with Not_found -> - Hashtbl.add handler_tb pc [exn_handler] in + Hashtbl.add handler_tb pc [exn_handler] in List.iter collect (JBir.exception_edges impl); handler_tb @@ -46,62 +46,62 @@ let translate_exceptions context exit_nodes get_body_nodes handler_table = try ignore (Hashtbl.find catch_block_table handler_list) with Not_found -> - let collect succ_nodes last_handler rethrow_exception handler = - let catch_nodes = get_body_nodes handler.JBir.e_handler in - let loc = match catch_nodes with - | n:: _ -> Cfg.Node.get_loc n - | [] -> Sil.dummy_location in - let exn_type = - let class_name = - match handler.JBir.e_catch_type with - | None -> JBasics.make_cn "java.lang.Exception" - | Some cn -> cn in - match JTransType.get_class_type (JContext.get_program context) (JContext.get_tenv context) class_name with - | Sil.Tptr (typ, _) -> typ - | _ -> assert false in - let id_instanceof = Ident.create_fresh Ident.knormal in - let instr_call_instanceof = - let instanceof_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) in - let args = [(Sil.Var id_exn_val, Sil.Tptr(exn_type, Sil.Pk_pointer)); (Sil.Sizeof (exn_type, Sil.Subtype.exact), Sil.Tvoid)] in - Sil.Call ([id_instanceof], instanceof_builtin, args, loc, Sil.cf_default) in - let if_kind = Sil.Ik_switch in - let instr_prune_true = Sil.Prune (Sil.Var id_instanceof, loc, true, if_kind) in - let instr_prune_false = Sil.Prune (Sil.UnOp(Sil.LNot, Sil.Var id_instanceof, None), loc, false, if_kind) in - let instr_set_catch_var = - let catch_var = JContext.set_pvar context handler.JBir.e_catch_var ret_type in - Sil.Set (Sil.Lvar catch_var, ret_type, Sil.Var id_exn_val, loc) in - let instr_rethrow_exn = Sil.Set (Sil.Lvar ret_var, ret_type, Sil.Const (Sil.Cexn (Sil.Var id_exn_val)), loc) in - let node_kind_true = Cfg.Node.Prune_node (true, if_kind, exn_message) in - let node_kind_false = Cfg.Node.Prune_node (false, if_kind, exn_message) in - let node_true = - let instrs_true = [instr_call_instanceof; instr_prune_true; instr_set_catch_var] in - let ids_true = [id_exn_val; id_instanceof] in - create_node loc node_kind_true instrs_true ids_true in - let node_false = - let instrs_false = [instr_call_instanceof; instr_prune_false] @ (if rethrow_exception then [instr_rethrow_exn] else []) in - let ids_false = (if last_handler then [id_exn_val] else []) @ [id_instanceof] in - create_node loc node_kind_false instrs_false ids_false in - Cfg.Node.set_succs_exn node_true catch_nodes exit_nodes; - Cfg.Node.set_succs_exn node_false succ_nodes exit_nodes; - let is_finally = handler.JBir.e_catch_type = None in - if is_finally - then [node_true] (* TODO (#4759480): clean up the translation so prune nodes are not created at all *) - else [node_true; node_false] in - let is_last_handler = ref true in - let process_handler succ_nodes handler = (* process handlers starting from the last one *) - let is_finally_handler = handler.JBir.e_catch_type = None in - let remove_temps = !is_last_handler in (* remove temporary variables on last handler *) - let rethrow_exception = !is_last_handler && not is_finally_handler in (* rethrow exception if there is no finally *) - is_last_handler := false; - collect succ_nodes remove_temps rethrow_exception handler in - - let nodes_first_handler = List.fold_left process_handler exit_nodes (List.rev handler_list) in - let loc = match nodes_first_handler with + let collect succ_nodes last_handler rethrow_exception handler = + let catch_nodes = get_body_nodes handler.JBir.e_handler in + let loc = match catch_nodes with | n:: _ -> Cfg.Node.get_loc n | [] -> Sil.dummy_location in - let entry_node = create_entry_node loc in - Cfg.Node.set_succs_exn entry_node nodes_first_handler exit_nodes; - Hashtbl.add catch_block_table handler_list [entry_node] in + let exn_type = + let class_name = + match handler.JBir.e_catch_type with + | None -> JBasics.make_cn "java.lang.Exception" + | Some cn -> cn in + match JTransType.get_class_type (JContext.get_program context) (JContext.get_tenv context) class_name with + | Sil.Tptr (typ, _) -> typ + | _ -> assert false in + let id_instanceof = Ident.create_fresh Ident.knormal in + let instr_call_instanceof = + let instanceof_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) in + let args = [(Sil.Var id_exn_val, Sil.Tptr(exn_type, Sil.Pk_pointer)); (Sil.Sizeof (exn_type, Sil.Subtype.exact), Sil.Tvoid)] in + Sil.Call ([id_instanceof], instanceof_builtin, args, loc, Sil.cf_default) in + let if_kind = Sil.Ik_switch in + let instr_prune_true = Sil.Prune (Sil.Var id_instanceof, loc, true, if_kind) in + let instr_prune_false = Sil.Prune (Sil.UnOp(Sil.LNot, Sil.Var id_instanceof, None), loc, false, if_kind) in + let instr_set_catch_var = + let catch_var = JContext.set_pvar context handler.JBir.e_catch_var ret_type in + Sil.Set (Sil.Lvar catch_var, ret_type, Sil.Var id_exn_val, loc) in + let instr_rethrow_exn = Sil.Set (Sil.Lvar ret_var, ret_type, Sil.Const (Sil.Cexn (Sil.Var id_exn_val)), loc) in + let node_kind_true = Cfg.Node.Prune_node (true, if_kind, exn_message) in + let node_kind_false = Cfg.Node.Prune_node (false, if_kind, exn_message) in + let node_true = + let instrs_true = [instr_call_instanceof; instr_prune_true; instr_set_catch_var] in + let ids_true = [id_exn_val; id_instanceof] in + create_node loc node_kind_true instrs_true ids_true in + let node_false = + let instrs_false = [instr_call_instanceof; instr_prune_false] @ (if rethrow_exception then [instr_rethrow_exn] else []) in + let ids_false = (if last_handler then [id_exn_val] else []) @ [id_instanceof] in + create_node loc node_kind_false instrs_false ids_false in + Cfg.Node.set_succs_exn node_true catch_nodes exit_nodes; + Cfg.Node.set_succs_exn node_false succ_nodes exit_nodes; + let is_finally = handler.JBir.e_catch_type = None in + if is_finally + then [node_true] (* TODO (#4759480): clean up the translation so prune nodes are not created at all *) + else [node_true; node_false] in + let is_last_handler = ref true in + let process_handler succ_nodes handler = (* process handlers starting from the last one *) + let is_finally_handler = handler.JBir.e_catch_type = None in + let remove_temps = !is_last_handler in (* remove temporary variables on last handler *) + let rethrow_exception = !is_last_handler && not is_finally_handler in (* rethrow exception if there is no finally *) + is_last_handler := false; + collect succ_nodes remove_temps rethrow_exception handler in + + let nodes_first_handler = List.fold_left process_handler exit_nodes (List.rev handler_list) in + let loc = match nodes_first_handler with + | n:: _ -> Cfg.Node.get_loc n + | [] -> Sil.dummy_location in + let entry_node = create_entry_node loc in + Cfg.Node.set_succs_exn entry_node nodes_first_handler exit_nodes; + Hashtbl.add catch_block_table handler_list [entry_node] in Hashtbl.iter (fun pc handler_list -> create_entry_block pc handler_list) handler_table; catch_block_table @@ -112,8 +112,8 @@ let create_exception_handlers context exit_nodes get_body_nodes impl = let handler_table = create_handler_table impl in let catch_block_table = translate_exceptions context exit_nodes get_body_nodes handler_table in fun pc -> - try - let handler_list = Hashtbl.find handler_table pc in - Hashtbl.find catch_block_table handler_list - with Not_found -> - exit_nodes + try + let handler_list = Hashtbl.find handler_table pc in + Hashtbl.find catch_block_table handler_list + with Not_found -> + exit_nodes diff --git a/infer/src/java/jTransStaticField.ml b/infer/src/java/jTransStaticField.ml index f8e5262cb..6078cdd68 100644 --- a/infer/src/java/jTransStaticField.ml +++ b/infer/src/java/jTransStaticField.ml @@ -33,7 +33,7 @@ let is_basic_type fs = | JBasics.TObject ot -> false (** Returns whether the node contains static final fields -that are not of a primitive type or String. *) + that are not of a primitive type or String. *) let rec has_static_final_fields node = let detect fs f test = test || (Javalib.is_static_field f && Javalib.is_final_field f) in @@ -42,7 +42,7 @@ let rec has_static_final_fields node = (* Patricia trees *) (** collects the code line where the fields are initialised. The list is -reversed in order to access the previous element in the list easier (as the successor.) *) + reversed in order to access the previous element in the list easier (as the successor.) *) let collect_field_pc instrs field_pc_list = let aux pc instr = match instr with @@ -53,7 +53,7 @@ let collect_field_pc instrs field_pc_list = (List.rev !field_pc_list) (** Changes every position in the code where a static field is set to a value, -to returning that value *) + to returning that value *) let add_return_field instrs = let aux instr = match instr with @@ -63,8 +63,8 @@ let add_return_field instrs = (Array.map aux instrs) (** Given a list with the lines where the fields are initialised, -finds the line where the code for the initialisation of the given field starts, -which is the line after the previous field has been initialised. *) + finds the line where the code for the initialisation of the given field starts, + which is the line after the previous field has been initialised. *) let rec find_pc field list = match list with | (fs, pc):: rest -> @@ -107,9 +107,9 @@ let has_unclear_control_flow code = (** In the initialiser of static fields, we add instructions -for returning the field selected by the parameter. *) + for returning the field selected by the parameter. *) (* The constant s means the parameter field of the function. -Note that we remove the initialisation of non - final static fields. *) + Note that we remove the initialisation of non - final static fields. *) let rec static_field_init_complex cn code fields length = let code = Array.append [| (JBir.Goto length ) |] code in let s = JConfig.field_cst in @@ -130,7 +130,7 @@ let rec static_field_init_complex cn code fields length = else let _ = if Javalib.is_static_field field && pc <> -1 then - field_nonfinal_pcs := pc::!field_nonfinal_pcs in + field_nonfinal_pcs := pc::!field_nonfinal_pcs in aux s rest | [] -> [| JBir.Nop |] in let new_instrs = aux s fields in @@ -140,8 +140,8 @@ let rec static_field_init_complex cn code fields length = code (** In the initialiser of static fields, we add instructions -for returning the field selected by the parameter without changing -the control flow of the original code. *) + for returning the field selected by the parameter without changing + the control flow of the original code. *) let rec static_field_init_simple cn code fields length = let s = JConfig.field_cst in let rec aux s pc fields = @@ -161,13 +161,13 @@ let rec static_field_init_simple cn code fields length = code (** In the initialiser of static fields, we add instructions -for returning the field selected by the parameter. In normal -cases the code for the initialisation of each field is clearly separated -from the code for the initialisation of the next field. However, in some cases -the fields are initialised in static blocks in which they may use try and catch. -In these cases it is not possible to separate the code for the initialisation -of each field, so we do not change the original code, but append intructions -for returning the selected field. *) + for returning the field selected by the parameter. In normal + cases the code for the initialisation of each field is clearly separated + from the code for the initialisation of the next field. However, in some cases + the fields are initialised in static blocks in which they may use try and catch. + In these cases it is not possible to separate the code for the initialisation + of each field, so we do not change the original code, but append intructions + for returning the selected field. *) let rec static_field_init node cn code = try let field_list = JBasics.FieldMap.elements (Javalib.get_fields node) in @@ -200,9 +200,9 @@ let is_static_final_field context cn fs = match JClasspath.lookup_node cn (JContext.get_program context) with | None -> false | Some node -> - try - let f = Javalib.get_field node fs in - let is_static = Javalib.is_static_field f in - let is_final = Javalib.is_final_field f in - (is_static && is_final) - with Not_found -> false + try + let f = Javalib.get_field node fs in + let is_static = Javalib.is_static_field f in + let is_final = Javalib.is_final_field f in + (is_static && is_final) + with Not_found -> false diff --git a/infer/src/java/jTransType.ml b/infer/src/java/jTransType.ml index 498fcaae0..00d590a11 100644 --- a/infer/src/java/jTransType.ml +++ b/infer/src/java/jTransType.ml @@ -105,14 +105,14 @@ let rec array_type_to_string vt = match vt with | JBasics.TBasic bt -> (match bt with - | `Bool -> JConfig.boolean_code - | `Byte -> JConfig.byte_code - | `Char -> JConfig.char_code - | `Double -> JConfig.double_code - | `Float -> JConfig.float_code - | `Int -> JConfig.int_code - | `Long -> JConfig.long_code - | `Short -> JConfig.short_code) + | `Bool -> JConfig.boolean_code + | `Byte -> JConfig.byte_code + | `Char -> JConfig.char_code + | `Double -> JConfig.double_code + | `Float -> JConfig.float_code + | `Int -> JConfig.int_code + | `Long -> JConfig.long_code + | `Short -> JConfig.short_code) | JBasics.TObject ot -> object_type_to_string' ot in "["^s and object_type_to_string' ot = @@ -158,7 +158,7 @@ let package_to_string p = let cn_to_java_type cn = (package_to_string (JBasics.cn_package cn), - (JBasics.cn_simple_name cn)) + (JBasics.cn_simple_name cn)) let rec vt_to_java_type vt = @@ -274,7 +274,7 @@ let collect_models_class_fields classpath_field_map static cn cf l = (Sil.pp_typ_full pe_text) classpath_ft (Sil.pp_typ_full pe_text) field_type in l with Not_found -> - (field_name, field_type, annotation):: l + (field_name, field_type, annotation):: l let add_model_fields program (static_fields, nonstatic_fields) cn = @@ -312,7 +312,7 @@ let rec create_sil_type program tenv cn = let item_annotation = JAnnotation.translate_item jinterface.Javalib.i_annotations in (sil_interface_list, [], static_fields, item_annotation) | Javalib.JClass jclass -> - (* TODO: create two functions to get static fields and non-static ones *) + (* TODO: create two functions to get static fields and non-static ones *) let static_fields, nonstatic_fields = let classpath_static_fields = get_all_fields program true cn and classpath_nonstatic_fields = get_all_fields program false cn in @@ -421,7 +421,7 @@ let extract_array_type typ = (** translate the type of an expression, looking in the method signature for formal parameters -this is because variables in expressions do not have accurate types *) + this is because variables in expressions do not have accurate types *) let rec expr_type context expr = let program = JContext.get_program context in let tenv = JContext.get_tenv context in @@ -429,8 +429,8 @@ let rec expr_type context expr = | JBir.Const const -> value_type program tenv (const_type const) | JBir.Var (vt, var) -> (match get_var_type context var with - | Some typ -> typ - | None -> (value_type program tenv vt)) + | Some typ -> typ + | None -> (value_type program tenv vt)) | JBir.Binop ((JBir.ArrayLoad typ), e1, e2) -> let typ = expr_type context e1 in (extract_array_type typ) @@ -438,8 +438,8 @@ let rec expr_type context expr = (** Returns the return type of the method based on the return type -specified in ms. If the method is the initialiser, return the type -Object instead. *) + specified in ms. If the method is the initialiser, return the type + Object instead. *) let return_type program tenv ms meth_kind = if meth_kind = JContext.Init then get_class_type program tenv (JBasics.make_cn JConfig.object_cl) @@ -467,7 +467,7 @@ let saturate_tenv_with_classpath classpath tenv = Sil.TN_csu (Sil.Class, classname) in let rec is_useful_subtype jar_tenv = function | Sil.TN_csu (Sil.Class, classname) when - Mangled.equal classname JConfig.java_lang_object_classname -> false + Mangled.equal classname JConfig.java_lang_object_classname -> false | typename when Sil.tenv_mem tenv typename -> true | typename -> begin @@ -515,8 +515,8 @@ let never_returning_null = let fragment_type = "android.support.v4.app.Fragment" in let never_null_method_sigs = [ - (fragment_type, "getContext", [], "android.content.Context", Procname.Non_Static); - (fragment_type, "getActivity", [], "android.support.v4.app.FragmentActivity", Procname.Non_Static) + (fragment_type, "getContext", [], "android.content.Context", Procname.Non_Static); + (fragment_type, "getActivity", [], "android.support.v4.app.FragmentActivity", Procname.Non_Static) ] in let make_procname = function | (class_name, method_name, arg_types, ret_type, kind) -> diff --git a/infer/src/llvm/lMain.ml b/infer/src/llvm/lMain.ml index bb5dc838c..993255fa3 100644 --- a/infer/src/llvm/lMain.ml +++ b/infer/src/llvm/lMain.ml @@ -12,13 +12,13 @@ open Printf exception UsageError of string let () = try - if Array.length Sys.argv < 2 then - raise (UsageError ("Missing source file as first command line argument.")) - else - let filename = Sys.argv.(1) in - let lexbuf = Lexing.from_channel (open_in filename) in - let prog = LParser.prog LLexer.token lexbuf in - let pretty = LPretty.pretty_prog prog in - LTrans.gen_prog prog; () -with + if Array.length Sys.argv < 2 then + raise (UsageError ("Missing source file as first command line argument.")) + else + let filename = Sys.argv.(1) in + let lexbuf = Lexing.from_channel (open_in filename) in + let prog = LParser.prog LLexer.token lexbuf in + let pretty = LPretty.pretty_prog prog in + LTrans.gen_prog prog; () + with | UsageError msg -> print_string ("Usage error: " ^ msg ^ "\n") diff --git a/infer/src/llvm/lPretty.ml b/infer/src/llvm/lPretty.ml index be110e5e5..fdd655e67 100644 --- a/infer/src/llvm/lPretty.ml +++ b/infer/src/llvm/lPretty.ml @@ -47,10 +47,10 @@ let pretty_instr : instr -> string = function let pretty_instr_ln (i : instr) : string = pretty_instr i ^ "\n" let pretty_func_def : func_def -> string = function - FuncDef (name, ret_tp, params, instrs) -> - "define " ^ pretty_ret_typ ret_tp ^ " " ^ pretty_variable name ^ "(" ^ - concatmap ", " (fun (tp, id) -> pretty_typ tp ^ " " ^ id) params ^ ") {\n" ^ - concatmap "" pretty_instr_ln instrs ^ "}\n" + FuncDef (name, ret_tp, params, instrs) -> + "define " ^ pretty_ret_typ ret_tp ^ " " ^ pretty_variable name ^ "(" ^ + concatmap ", " (fun (tp, id) -> pretty_typ tp ^ " " ^ id) params ^ ") {\n" ^ + concatmap "" pretty_instr_ln instrs ^ "}\n" let pretty_prog : prog -> string = function - Prog defs -> concatmap "" pretty_func_def defs + Prog defs -> concatmap "" pretty_func_def defs diff --git a/infer/src/llvm/lTrans.ml b/infer/src/llvm/lTrans.ml index 4a79080aa..3c98a053e 100644 --- a/infer/src/llvm/lTrans.ml +++ b/infer/src/llvm/lTrans.ml @@ -41,42 +41,42 @@ let gen_instr (cfg : Cfg.cfg) (pdesc : Cfg.Procdesc.t) : instr -> Sil.instr list (* Modify the cfg in place *) let gen_func_def (old_cfg : Cfg.cfg) : func_def -> unit = function - FuncDef (func_name, ret_tp_opt, params, instrs) -> - let (proc_attrs : Sil.proc_attributes) = - { access = Sil.Default; - exceptions = []; - is_abstract = false; - is_bridge_method = false; - is_objc_instance_method = false; - is_synthetic_method = false; - language = Sil.C_CPP; - func_attributes = []; - method_annotation = Sil.method_annotation_empty; - is_generated = false - } in - let (pdesc_builder : Cfg.Procdesc.proc_desc_builder) = - { cfg = old_cfg; - name = Procname.from_string_c_fun (string_of_variable func_name); - is_defined = true; (** is defined and not just declared *) - proc_attributes = proc_attrs; - ret_type = (match ret_tp_opt with - | None -> Sil.Tvoid - | Some ret_tp -> gen_typ ret_tp); - formals = List.map (fun (tp, name) -> (name, gen_typ tp)) params; - locals = []; (* TODO *) - captured = []; - loc = Sil.dummy_location - } in - let nodekind_of_instr : instr -> Cfg.Node.nodekind = function - | Ret _ -> Cfg.Node.Stmt_node "method_body" - | _ -> raise (Unimplemented "Need to get node type for instruction.") in - let add_instr (cfg : Cfg.cfg) (pdesc : Cfg.Procdesc.t) (ins : instr) : unit = - Cfg.Node.create cfg Sil.dummy_location (nodekind_of_instr ins) + FuncDef (func_name, ret_tp_opt, params, instrs) -> + let (proc_attrs : Sil.proc_attributes) = + { access = Sil.Default; + exceptions = []; + is_abstract = false; + is_bridge_method = false; + is_objc_instance_method = false; + is_synthetic_method = false; + language = Sil.C_CPP; + func_attributes = []; + method_annotation = Sil.method_annotation_empty; + is_generated = false + } in + let (pdesc_builder : Cfg.Procdesc.proc_desc_builder) = + { cfg = old_cfg; + name = Procname.from_string_c_fun (string_of_variable func_name); + is_defined = true; (** is defined and not just declared *) + proc_attributes = proc_attrs; + ret_type = (match ret_tp_opt with + | None -> Sil.Tvoid + | Some ret_tp -> gen_typ ret_tp); + formals = List.map (fun (tp, name) -> (name, gen_typ tp)) params; + locals = []; (* TODO *) + captured = []; + loc = Sil.dummy_location + } in + let nodekind_of_instr : instr -> Cfg.Node.nodekind = function + | Ret _ -> Cfg.Node.Stmt_node "method_body" + | _ -> raise (Unimplemented "Need to get node type for instruction.") in + let add_instr (cfg : Cfg.cfg) (pdesc : Cfg.Procdesc.t) (ins : instr) : unit = + Cfg.Node.create cfg Sil.dummy_location (nodekind_of_instr ins) (gen_instr cfg pdesc ins) pdesc []; () in - let pdesc = Cfg.Procdesc.create pdesc_builder in - List.iter (fun ins -> add_instr old_cfg pdesc ins) instrs + let pdesc = Cfg.Procdesc.create pdesc_builder in + List.iter (fun ins -> add_instr old_cfg pdesc ins) instrs let gen_prog : prog -> Cfg.cfg = function - Prog fds -> - let cfg = Cfg.Node.create_cfg () in - List.iter (gen_func_def cfg) fds; cfg + Prog fds -> + let cfg = Cfg.Node.create_cfg () in + List.iter (gen_func_def cfg) fds; cfg