[whitespace] indent .ml files as well

master
Jules Villard 10 years ago
parent 6911a1516c
commit bae8a4dced

@ -216,9 +216,9 @@ let read_whole_file fd =
buf buf
(** Update the file contents with the update function provided. (** Update the file contents with the update function provided.
If the directory does not exist, it is created. 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. 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. *) A lock is used to allow write attempts in parallel. *)
let update_file_with_lock dir fname update = let update_file_with_lock dir fname update =
let reset_file fd = let reset_file fd =
let n = Unix.lseek fd 0 Unix.SEEK_SET in let n = Unix.lseek fd 0 Unix.SEEK_SET in

@ -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)) else Prop.normalize (Prop.replace_sigma sigma_new (Prop.replace_sigma_footprint sigma_fp_new prop))
(** Check whether the prop contains junk. (** 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 = let abstract_junk ?original_prop pname tenv prop =
Absarray.array_abstraction_performed := false; Absarray.array_abstraction_performed := false;
check_junk ~original_prop: original_prop pname tenv prop 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 list_filter filter_non_stack sigma
(** [prop_set_fooprint p p_foot] removes a local stack from [p_foot], (** [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 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_pure = Prop.get_pure p_foot in
let p_foot_sigma = Prop.get_sigma p_foot in let p_foot_sigma = Prop.get_sigma p_foot in

@ -18,7 +18,7 @@ type sigma = Sil.hpred list
(** Matcher for the sigma part specialized to strexps *) (** Matcher for the sigma part specialized to strexps *)
module StrexpMatch : sig module StrexpMatch : sig
(** path through a strexp *) (** path through a strexp *)
type path type path
(** convert a path into a list of expressions *) (** convert a path into a list of expressions *)
@ -247,12 +247,12 @@ end = struct
end end
(** This function renames expressions in [p]. The renaming is, roughly (** 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 let prop_replace_path_index
(p: Prop.exposed Prop.t) (p: Prop.exposed Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(map : (Sil.exp * Sil.exp) list) : Prop.exposed Prop.t (map : (Sil.exp * Sil.exp) list) : Prop.exposed Prop.t
= =
let elist_path = StrexpMatch.path_to_exps path in let elist_path = StrexpMatch.path_to_exps path in
let expmap_list = let expmap_list =
list_fold_left (fun acc_outer e_path -> list_fold_left (fun acc_outer e_path ->
@ -270,11 +270,11 @@ let prop_replace_path_index
Prop.prop_expmap expmap_fun p Prop.prop_expmap expmap_fun p
(** This function uses [update] and transforms the two sigma parts of [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 let prop_update_sigma_and_fp_sigma
(p : Prop.normal Prop.t) (p : Prop.normal Prop.t)
(update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool (update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool
= =
let sigma', changed = update false (Prop.get_sigma p) in let sigma', changed = update false (Prop.get_sigma p) in
let ep1 = Prop.replace_sigma sigma' p in let ep1 = Prop.replace_sigma sigma' p in
let ep2, changed2 = let ep2, changed2 =
@ -285,13 +285,13 @@ let prop_update_sigma_and_fp_sigma
(Prop.normalize ep2, changed || changed2) (Prop.normalize ep2, changed || changed2)
(** This function uses [update] and transforms the sigma of the (** This function uses [update] and transforms the sigma of the
current SH of [p] or that of the footprint of [p], depending on current SH of [p] or that of the footprint of [p], depending on
[footprint_part]. *) [footprint_part]. *)
let prop_update_sigma_or_fp_sigma let prop_update_sigma_or_fp_sigma
(footprint_part : bool) (footprint_part : bool)
(p : Prop.normal Prop.t) (p : Prop.normal Prop.t)
(update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool (update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool
= =
let ep1, changed1 = let ep1, changed1 =
if footprint_part then (Prop.expose p, false) if footprint_part then (Prop.expose p, false)
else else
@ -311,15 +311,15 @@ let prop_update_sigma_or_fp_sigma
let array_abstraction_performed = ref false let array_abstraction_performed = ref false
(** This function abstracts strexps. The parameter [can_abstract] spots strexps (** This function abstracts strexps. The parameter [can_abstract] spots strexps
where the abstraction might be applicable, and the parameter [do_abstract] does where the abstraction might be applicable, and the parameter [do_abstract] does
the abstraction to those spotted strexps. *) the abstraction to those spotted strexps. *)
let generic_strexp_abstract let generic_strexp_abstract
(abstraction_name : string) (abstraction_name : string)
(p_in : Prop.normal Prop.t) (p_in : Prop.normal Prop.t)
(_can_abstract : sigma -> StrexpMatch.strexp_data -> bool) (_can_abstract : sigma -> StrexpMatch.strexp_data -> bool)
(do_abstract : bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * 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 can_abstract s data =
let r = _can_abstract s data in let r = _can_abstract s data in
if r then array_abstraction_performed := true; if r then array_abstraction_performed := true;
@ -382,7 +382,7 @@ let blur_array_index
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(index: Sil.exp) : Prop.normal Prop.t (index: Sil.exp) : Prop.normal Prop.t
= =
try try
let fresh_index = Sil.Var (Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) in let fresh_index = Sil.Var (Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) in
let p2 = let p2 =
@ -415,7 +415,7 @@ let blur_array_indices
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(root: StrexpMatch.path) (root: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool (indices: Sil.exp list) : Prop.normal Prop.t * bool
= =
let f prop index = blur_array_index footprint_part prop root index in let f prop index = blur_array_index footprint_part prop root index in
(list_fold_left f p indices, list_length indices > 0) (list_fold_left f p indices, list_length indices > 0)
@ -426,7 +426,7 @@ let keep_only_indices
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool (indices: Sil.exp list) : Prop.normal Prop.t * bool
= =
let prune_sigma footprint_part sigma = let prune_sigma footprint_part sigma =
try try
let matched = StrexpMatch.find_path sigma path in let matched = StrexpMatch.find_path sigma path in

@ -21,7 +21,7 @@ module IdMap = Map.Make (Ident) (** maps from identifiers *)
(** Constraint solving module *) (** Constraint solving module *)
module Constraint : sig 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 val solve_from_pure : Sil.atom list -> Ident.t list -> Sil.Int.t IdMap.t
end = struct end = struct
(** flag for debug mode of the module *) (** flag for debug mode of the module *)

@ -17,7 +17,7 @@ open Utils
let verbose = Config.trace_error let verbose = Config.trace_error
(** check if the error was reported inside a nested loop (** 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 check_nested_loop path pos_opt =
let trace_length = ref 0 in let trace_length = ref 0 in
let loop_visits_log = ref [] in let loop_visits_log = ref [] in
@ -44,7 +44,7 @@ let check_nested_loop path pos_opt =
in_nested_loop () in_nested_loop ()
(** Check that we know where the value was last assigned, (** 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 check_access access_opt de_opt =
let find_bucket line_number null_case_flag = let find_bucket line_number null_case_flag =
let find_formal_ids node = (* find ids obtained by a letref on a formal parameter *) let find_formal_ids node = (* find ids obtained by a letref on a formal parameter *)

@ -894,7 +894,7 @@ let remove_locals_ret (curr_f : Procdesc.t) p =
snd (remove_locals curr_f (remove_ret curr_f p)) snd (remove_locals curr_f (remove_ret curr_f p))
(** Remove locals and formal parameters from the prop. (** 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 remove_locals_formals (curr_f : Procdesc.t) p =
let pvars1, p1 = remove_formals curr_f p in let pvars1, p1 = remove_formals curr_f p in
let pvars2, p2 = remove_locals curr_f p1 in let pvars2, p2 = remove_locals curr_f p1 in

@ -113,31 +113,31 @@ let project_root : string option ref = ref None
(** FLAGS AND GLOBAL VARIABLES *) (** FLAGS AND GLOBAL VARIABLES *)
(** Flag for abstracting fields of structs (** Flag for abstracting fields of structs
0 = no 0 = no
1 = forget some fields during matching (and so lseg abstraction) *) 1 = forget some fields during matching (and so lseg abstraction) *)
let abs_struct = ref 1 let abs_struct = ref 1
(** Flag for abstracting numerical values (** Flag for abstracting numerical values
0 = no abstraction. 0 = no abstraction.
1 = evaluate all expressions abstractly. 1 = evaluate all expressions abstractly.
2 = 1 + abstract constant integer values during join. 2 = 1 + abstract constant integer values during join.
*) *)
let abs_val = ref 2 let abs_val = ref 2
(** if true, completely ignore the possibility that errors can be caused by unknown procedures (** 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 let angelic_execution = ref true
(** Flag for forgetting memory leak (** Flag for forgetting memory leak
false = no false = no
true = forget leaked memory cells during abstraction true = forget leaked memory cells during abstraction
*) *)
let allowleak = ref false let allowleak = ref false
(** Flag for ignoring arrays and pointer arithmetic. (** Flag for ignoring arrays and pointer arithmetic.
0 = treats both features soundly. 0 = treats both features soundly.
1 = assumes that the size of every array is infinite. 1 = assumes that the size of every array is infinite.
2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct. 2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct.
*) *)
let array_level = ref 0 let array_level = ref 0
@ -186,14 +186,14 @@ let intraprocedural = ref false
let join_plus = ref true let join_plus = ref true
(** Flag to tune the final information-loss check used by the join (** Flag to tune the final information-loss check used by the join
0 = use the most aggressive join for preconditions 0 = use the most aggressive join for preconditions
1 = use the least aggressive join for preconditions 1 = use the least aggressive join for preconditions
*) *)
let join_cond = ref 1 let join_cond = ref 1
(** Flag for turning on the transformation that (** 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 let liveness = ref true
(** if true, give static procs a long name filename::procname *) (** 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 let max_recursion = ref 5
(** Flag to tune the level of applying the meet operator for (** Flag to tune the level of applying the meet operator for
preconditions during the footprint analysis. preconditions during the footprint analysis.
0 = do not use the meet. 0 = do not use the meet.
1 = use the meet to generate new preconditions. 1 = use the meet to generate new preconditions.
*) *)
let meet_level = ref 1 let meet_level = ref 1
@ -258,9 +258,9 @@ let results_dir = ref default_results_dir
let slice_fun = ref "" let slice_fun = ref ""
(** Flag to tune the level of abstracting the postconditions of specs discovered (** Flag to tune the level of abstracting the postconditions of specs discovered
by the footprint analysis. by the footprint analysis.
0 = nothing special. 0 = nothing special.
1 = filter out redundant posts implied by other posts. *) 1 = filter out redundant posts implied by other posts. *)
let spec_abs_level = ref 1 let spec_abs_level = ref 1
(** Flag for test mode *) (** Flag for test mode *)
@ -294,15 +294,15 @@ let taint_analysis = ref false
let trace_anal = ref false let trace_anal = ref false
(** Flag for turning on the optimization based on locality (** Flag for turning on the optimization based on locality
0 = no 0 = no
1 = based on reachability 1 = based on reachability
*) *)
let undo_join = ref true let undo_join = ref true
(** visit mode for the worklist: (** visit mode for the worklist:
0 depth - fist visit 0 depth - fist visit
1 bias towards exit node 1 bias towards exit node
2 least visited first *) 2 least visited first *)
let worklist_mode = ref 0 let worklist_mode = ref 0
(** flag: if true write dot files in db dir*) (** 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 let dotty_cfg_libs = ref true
(** if true, it deals with messages (method calls) in objective-c using the objective-c (** 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. 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 *) When the flag is false we deal with messages as standard method / function calls *)
let objc_method_call_semantics = ref true let objc_method_call_semantics = ref true
(** if true, generate preconditions for runtime exceptions in Java and report errors for the public (** 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 let report_runtime_exceptions = ref false
(** if true, sanity-check inferred preconditions against Nullable annotations and report (** if true, sanity-check inferred preconditions against Nullable annotations and report
inconsistencies *) inconsistencies *)
let report_nullable_inconsistency = ref true let report_nullable_inconsistency = ref true
(** true if the current objective-c source file is compiled with automatic reference counting (ARC) *) (** true if the current objective-c source file is compiled with automatic reference counting (ARC) *)

@ -1321,7 +1321,7 @@ let same_pred (hpred1: Sil.hpred) (hpred2: Sil.hpred) : bool =
| _ -> false | _ -> false
(* check that applying renaming to the lhs / rhs of [sigma_new] (* 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) = let sigma_renaming_check (lhs: side) (sigma: sigma) (sigma_new: sigma) =
(* apply the lhs / rhs of the renaming to sigma, (* apply the lhs / rhs of the renaming to sigma,
@ -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 let pi_partial_join mode
(ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t)
(pi1: Sil.atom list) (pi2: Sil.atom list) : Sil.atom list (pi1: Sil.atom list) (pi2: Sil.atom list) : Sil.atom list
= =
let exp_is_const = function let exp_is_const = function
(* | Sil.Var id -> is_normal id *) (* | Sil.Var id -> is_normal id *)
| Sil.Const _ -> true | Sil.Const _ -> true
@ -1966,7 +1966,7 @@ let join_time = ref 0.0
let pathset_join let pathset_join
pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) 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 mode = JoinState.Post in
let initial_time = Unix.gettimeofday () in let initial_time = Unix.gettimeofday () in
let pset_to_plist pset = let pset_to_plist pset =
@ -2004,14 +2004,14 @@ let pathset_join
res res
(** (**
The meet operator does two things: The meet operator does two things:
1) makes the result logically stronger (just like additive conjunction) 1) makes the result logically stronger (just like additive conjunction)
2) makes the result spatially larger (just like multiplicative 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 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. 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. 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 The operation is dependent on the order in which elements are combined; there is a straightforward
order - independent algorithm but it is exponential. order - independent algorithm but it is exponential.
*) *)
let proplist_meet_generate plist = let proplist_meet_generate plist =
let props_done = ref Propset.empty in let props_done = ref Propset.empty in

@ -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*) (* look-up the ids in the list of nodes corresponding to expression e*)
(* let look_up_nodes_ids nodes 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 *) (* create a list of dangling nodes *)
let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) = let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =

@ -92,7 +92,7 @@ let id_is_assigned_then_dead node id =
| _ -> false | _ -> false
(** Find the function call instruction used to initialize normal variable [id], (** 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 let find_normal_variable_funcall
(node: Cfg.Node.t) (node: Cfg.Node.t)
(id: Ident.t): (Sil.exp * (Sil.exp list) * Sil.location * Sil.call_flags) option = (id: Ident.t): (Sil.exp * (Sil.exp list) * Sil.location * Sil.call_flags) option =
@ -163,7 +163,7 @@ let find_ident_assignment node id : (Cfg.Node.t * Sil.exp) option =
find node find node
(** Find a boolean assignment to a temporary variable holding a boolean condition. (** 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 rec find_boolean_assignment node pvar true_branch : Cfg.Node.t option =
let find_instr n = let find_instr n =
let filter = function let filter = function
@ -213,7 +213,7 @@ let pvar_is_frontend_tmp pvar =
else pvar_is_cil_tmp pvar || pvar_is_edg_tmp pvar else pvar_is_cil_tmp pvar || pvar_is_edg_tmp pvar
(** Find the Letderef instruction used to declare normal variable [id], (** 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 rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp option =
let res = ref None in let res = ref None in
let node_instrs = Cfg.Node.get_instrs node in let node_instrs = Cfg.Node.get_instrs node in
@ -453,9 +453,9 @@ let find_pvar_typ_without_ptr tenv prop pvar =
!res !res
(** Produce a description of a leak by looking at the current state. (** Produce a description of a leak by looking at the current state.
If the current instruction is a variable nullify, blame the variable. 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 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 there is an alloc attribute, print the function call and line number. *)
let explain_leak tenv hpred prop alloc_att_opt bucket = let explain_leak tenv hpred prop alloc_att_opt bucket =
let instro = State.get_instr () in let instro = State.get_instr () in
let loc = State.get_loc () in let loc = State.get_loc () 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 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 (** 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 = 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 ()); 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 = let rec find sigma_acc sigma_todo exp =
@ -757,9 +757,9 @@ let create_dereference_desc
else desc else desc
(** explain memory access performed by the current instruction (** explain memory access performed by the current instruction
if outermost_array is true, the outermost array access is removed if outermost_array is true, the outermost array access is removed
if outermost_dereference is true, stop at the outermost dereference if outermost_dereference is true, stop at the outermost dereference
(skipping e.g. outermost field access) *) (skipping e.g. outermost field access) *)
let _explain_access let _explain_access
?use_buckets: (use_buckets = false) ?use_buckets: (use_buckets = false)
?outermost_array: (outermost_array = false) ?outermost_array: (outermost_array = false)
@ -824,7 +824,7 @@ let _explain_access
de_opt deref_str prop loc de_opt deref_str prop loc
(** Produce a description of which expression is dereferenced in the current instruction, if any. (** 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 let explain_dereference
?use_buckets: (use_buckets = false) ?use_buckets: (use_buckets = false)
?is_nullable: (is_nullable = false) ?is_nullable: (is_nullable = false)
@ -835,7 +835,7 @@ let explain_dereference
deref_str prop loc deref_str prop loc
(** Produce a description of the array access performed in the current instruction, if any. (** 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 = let explain_array_access deref_str prop loc =
_explain_access ~outermost_array: true deref_str prop loc _explain_access ~outermost_array: true deref_str prop loc
@ -859,7 +859,7 @@ let dexp_apply_pvar_off dexp pvar_off =
| Fstruct [] -> dexp (* case should not happen *) | Fstruct [] -> dexp (* case should not happen *)
(** Produce a description of the nth parameter of the function call, if the current instruction (** 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 explain_nth_function_parameter use_buckets deref_str prop n pvar_off =
let node = State.get_node () in let node = State.get_node () in
let loc = State.get_loc () in let loc = State.get_loc () in
@ -902,7 +902,7 @@ let find_pvar_with_exp prop exp =
!res !res
(** return a description explaining value [exp] in [prop] in terms of a source expression (** 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 let explain_dereference_as_caller_expression
?use_buckets: (use_buckets = false) ?use_buckets: (use_buckets = false)
deref_str actual_pre spec_pre exp node loc formal_params = deref_str actual_pre spec_pre exp node loc formal_params =

@ -55,8 +55,8 @@ module ErrLogHash = Hashtbl.Make (struct
end) end)
(** Type of the error log, to be reset once per function. (** Type of the error log, to be reset once per function.
Map err_kind, fotprint / re - execution flag, error name, Map err_kind, fotprint / re - execution flag, error name,
error description, severity, to set of err_data. *) error description, severity, to set of err_data. *)
type t = ErrDataSet.t ErrLogHash.t type t = ErrDataSet.t ErrLogHash.t
(** Empty error log *) (** Empty error log *)
@ -125,7 +125,7 @@ let severity_to_str severity = match severity with
| Exceptions.Low -> "LOW" | Exceptions.Low -> "LOW"
(** Add an error description to the error log unless there is (** 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 = let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataSet.t) : bool =
try try
let current_eds = ErrLogHash.find tbl (ekind, in_footprint, err_name, desc, severity) in let current_eds = ErrLogHash.find tbl (ekind, in_footprint, err_name, desc, severity) in

@ -290,7 +290,7 @@ let compute_weighed_pnameset gr =
!pnameset !pnameset
(* Return true if there are no children of [pname] whose specs (* 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 = let proc_is_up_to_date gr pname =
match Specs.get_summary pname with match Specs.get_summary pname with
| None -> false | None -> false
@ -303,7 +303,7 @@ let proc_is_up_to_date gr pname =
res res
(** Return the list of procedures which should perform a phase (** 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 should_perform_transition gr proc_name : Procname.t list =
let recursive_dependents = Cg.get_recursive_dependents gr proc_name in let recursive_dependents = Cg.get_recursive_dependents gr proc_name in
let recursive_dependents_plus_self = Procname.Set.add proc_name recursive_dependents in let recursive_dependents_plus_self = Procname.Set.add proc_name recursive_dependents in
@ -453,12 +453,12 @@ let post_process_procs exe_env procs_done =
) procs_done ) procs_done
(** Activate a check which ensures that multi-core mode gives the same result as one-core. (** 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) If true, detect when a dependent proc is active (analyzed concurrently)
and in that case wait for a process to terminate next *) and in that case wait for a process to terminate next *)
let one_core_compatibility_mode = ref true let one_core_compatibility_mode = ref true
(** Find the max string in the [set] which satisfies [filter], and count the number of attempts. (** 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 filter_max exe_env cg filter set priority_set =
let rec find_max n filter set = let rec find_max n filter set =
let elem = WeightedPnameSet.max_elt set in let elem = WeightedPnameSet.max_elt set in
@ -555,8 +555,8 @@ end
module Process = Process_fork module Process = Process_fork
(** Main algorithm responsible for driving the analysis of an Exe_env (set of procedures). (** Main algorithm responsible for driving the analysis of an Exe_env (set of procedures).
The algorithm computes dependencies between procedures, spawns processes if required, The algorithm computes dependencies between procedures, spawns processes if required,
propagates results, and handles fixpoints in the call graph. *) propagates results, and handles fixpoints in the call graph. *)
let parallel_execution exe_env num_processes analyze_proc filter_out process_result : unit = let parallel_execution exe_env num_processes analyze_proc filter_out process_result : unit =
parallel_mode := num_processes > 1 || !Config.max_num_proc > 0; parallel_mode := num_processes > 1 || !Config.max_num_proc > 0;
let call_graph = Exe_env.get_cg exe_env in let call_graph = Exe_env.get_cg exe_env in
@ -665,10 +665,10 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res
done done
(** [parallel_iter_nodes cfg call_graph analyze_proc process_result filter_out] (** [parallel_iter_nodes cfg call_graph analyze_proc process_result filter_out]
executes [analyze_proc] in parallel as much as possible as allowed executes [analyze_proc] in parallel as much as possible as allowed
by the call graph, and applies [process_result] to the result as 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 soon as it is returned by a child process. If [filter_out] returns
true, no execution. *) 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 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 *) let analyze_proc exe_env pname = (* wrap _analyze_proc and handle exceptions *)
try _analyze_proc exe_env pname with try _analyze_proc exe_env pname with

@ -88,12 +88,12 @@ module IdentHash =
module FieldSet = Set.Make(struct module FieldSet = Set.Make(struct
type t = fieldname type t = fieldname
let compare = fieldname_compare let compare = fieldname_compare
end) end)
module FieldMap = Map.Make(struct module FieldMap = Map.Make(struct
type t = fieldname type t = fieldname
let compare = fieldname_compare let compare = fieldname_compare
end) end)
let idlist_to_idset ids = let idlist_to_idset ids =
list_fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids list_fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids

@ -93,9 +93,9 @@ let objc_ml_buckets_arg = ref "cf"
let allow_specs_cleanup = ref false let allow_specs_cleanup = ref false
(** Compute the exclude function from excluded_files and source_path. (** 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 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. 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 *) Prefixes are obtained by prepending source_path, if any, to relative paths in excluded_fies *)
let compute_exclude_fun () : DB.source_file -> bool = let compute_exclude_fun () : DB.source_file -> bool =
let prepend_source_path s = let prepend_source_path s =
if Filename.is_relative s then Filename.concat !source_path s if Filename.is_relative s then Filename.concat !source_path s
@ -270,7 +270,7 @@ let list_add_nth x l nth =
add [] l nth add [] l nth
(** sort a list weakly w.r.t. a compare function which doest not have to be a total order (** 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_sort compare list =
let weak_add l x = let weak_add l x =
let length = list_length l in let length = list_length l in
@ -316,8 +316,8 @@ let weak_sort_nodes cg =
weak_sort cmp nodes weak_sort cmp nodes
(** cluster element: the file name, the number of procedures defined in it, and the list of active procedures (** 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 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) *) is the representative file for it (see Exe_env.add_cg) *)
type cluster_elem = type cluster_elem =
{ ce_file : DB.source_file; { ce_file : DB.source_file;
ce_naprocs : int; (** number of active procedures defined in the file *) ce_naprocs : int; (** number of active procedures defined in the file *)
@ -625,7 +625,7 @@ let compute_clusters exe_env (files_changed : Procname.Set.t) : cluster list =
clusters' clusters'
(** Check whether the cg file is changed. It is unchanged if for each defined procedure, the .specs (** 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_check_changed exe_env source_dir cg =
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
let defined_nodes = Cg.get_defined_nodes cg in let defined_nodes = Cg.get_defined_nodes cg in

@ -614,7 +614,7 @@ module UnitTest = struct
end end
(** Module to compute the top procedures. (** 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 module TopProcedures : sig
type t type t
val create : unit -> t val create : unit -> t

@ -709,9 +709,9 @@ let create_seed_vars sigma =
list_fold_left hpred_add_seed [] sigma list_fold_left hpred_add_seed [] sigma
(** Initialize proposition for execution given formal and global (** Initialize proposition for execution given formal and global
parameters. The footprint is initialized according to the parameters. The footprint is initialized according to the
execution mode. The prop is not necessarily emp, so it execution mode. The prop is not necessarily emp, so it
should be incorporated when the footprint is constructed. *) 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 prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Prop.t =
let sigma_new_formals = let sigma_new_formals =
let do_formal (pv, typ) = let do_formal (pv, typ) =
@ -736,7 +736,7 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
Prop.replace_sigma_footprint (Prop.get_sigma_footprint prop' @ sigma_new_formals) prop' 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 (** 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 initial_prop tenv (curr_f: Cfg.Procdesc.t) (prop : 'a Prop.t) add_formals : Prop.normal Prop.t =
let construct_decl (x, typ) = let construct_decl (x, typ) =
(Sil.mk_pvar (Mangled.from_string x) (Cfg.Procdesc.get_proc_name curr_f), typ) in (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. *) (** 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) 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 let proc_name = Cfg.Procdesc.get_proc_name pdesc in
do_before_node 0 init_node; do_before_node 0 init_node;
L.d_strln ("#### Start: RE-execution for " ^ Procname.to_string proc_name ^ " ####"); L.d_strln ("#### Start: RE-execution for " ^ Procname.to_string proc_name ^ " ####");
@ -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 F.fprintf fmt "(%d nodes containing %d states)" (list_length nodes) !nstates
(** Return functions to perform one phase of the analysis for a procedure. (** 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 Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase
and [get_results ()] returns the results computed. and [get_results ()] returns the results computed.
This function is architected so that [get_results ()] can be called even after This function is architected so that [get_results ()] can be called even after
[go ()] was interrupted by and exception. *) [go ()] was interrupted by and exception. *)
let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t) 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 start_node = Cfg.Procdesc.get_start_node pdesc in
let check_recursion_level () = let check_recursion_level () =
@ -988,8 +988,8 @@ let remove_this_not_null prop =
(** Detects if there are specs of the form {precondition} proc {runtime exception} and report (** 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 an error in that case, generating the trace that lead to the runtime exception if the method is
called in the context { precondition } *) called in the context { precondition } *)
let report_runtime_exceptions tenv cfg pdesc summary = let report_runtime_exceptions tenv cfg pdesc summary =
let pname = Specs.get_proc_name summary in let pname = Specs.get_proc_name summary in
let is_public_method = 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 (** Analyze [proc_name] and return the updated summary. Use module
[Timeout] to call [perform_analysis_phase] with a time limit, and [Timeout] to call [perform_analysis_phase] with a time limit, and
then return the updated summary. Executed as a child process. *) then return the updated summary. Executed as a child process. *)
let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary = let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
if !Config.trace_anal then L.err "===analyze_proc@."; if !Config.trace_anal then L.err "===analyze_proc@.";
let init_time = Unix.gettimeofday () in let init_time = Unix.gettimeofday () in
@ -1067,7 +1067,7 @@ let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
updated_summary updated_summary
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for (** 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 perform_transition exe_env cg proc_name =
let proc_names = Fork.should_perform_transition cg proc_name in let proc_names = Fork.should_perform_transition cg proc_name in
let transition pname = let transition pname =
@ -1101,8 +1101,8 @@ let perform_transition exe_env cg proc_name =
list_iter transition proc_names list_iter transition proc_names
(** Process the result of the analysis of [proc_name]: update the (** Process the result of the analysis of [proc_name]: update the
returned summary and add it to the spec table. Executed in the returned summary and add it to the spec table. Executed in the
parent process as soon as a child process returns a result. *) 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 = let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary) : unit =
if !Config.trace_anal then L.err "===process_result@."; if !Config.trace_anal then L.err "===process_result@.";
Ident.reset_name_generator (); (* for consistency with multi-core mode *) Ident.reset_name_generator (); (* for consistency with multi-core mode *)
@ -1118,8 +1118,8 @@ let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary
Fork.post_process_procs exe_env procs_done Fork.post_process_procs exe_env procs_done
(** Return true if the analysis of [proc_name] should be (** Return true if the analysis of [proc_name] should be
skipped. Called by the parent process before attempting to analyze a skipped. Called by the parent process before attempting to analyze a
proc. *) proc. *)
let filter_out (call_graph: Cg.t) (proc_name: Procname.t) : bool = let filter_out (call_graph: Cg.t) (proc_name: Procname.t) : bool =
if !Config.trace_anal then L.err "===filter_out@."; if !Config.trace_anal then L.err "===filter_out@.";
let slice_out = (* filter out if slicing is active and [proc_name] not in slice *) let slice_out = (* filter out if slicing is active and [proc_name] not in slice *)
@ -1218,7 +1218,7 @@ let visited_and_total_nodes cfg =
Cfg.NodeSet.elements visited_nodes_re, Cfg.NodeSet.elements counted_nodes 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 (** 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 print_stats_cfg proc_shadowed proc_is_active cfg =
let err_table = Errlog.create_err_table () in let err_table = Errlog.create_err_table () in
let active_procs = list_filter proc_is_active (Cfg.get_defined_procs cfg) in let active_procs = list_filter proc_is_active (Cfg.get_defined_procs cfg) in

@ -142,7 +142,7 @@ module BucketLevel = struct
end end
(** takes in input a tag to extract from the given error_desc (** 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 error_desc_extract_tag_value (_, _, tags) tag_to_extract =
let find_value tag v = let find_value tag v =
match v with match v with

@ -181,7 +181,7 @@ let stdout fmt_string =
do_print F.std_formatter fmt_string do_print F.std_formatter fmt_string
(** print a warning with information of the position in the ml source where it oririnated. (** 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) = let warning_position (s: string) (mloc: ml_location) =
err "WARNING: %s in %a@." s pp_ml_location_opt (Some mloc) err "WARNING: %s in %a@." s pp_ml_location_opt (Some mloc)

@ -18,8 +18,8 @@ let mem_idlist i l =
list_exists (Ident.equal i) l list_exists (Ident.equal i) l
(** Type for a hpred pattern. flag=false means that the implication (** Type for a hpred pattern. flag=false means that the implication
between hpreds is not considered, and flag = true means that it is between hpreds is not considered, and flag = true means that it is
considered during pattern matching *) considered during pattern matching *)
type hpred_pat = { hpred : Sil.hpred; flag : bool } type hpred_pat = { hpred : Sil.hpred; flag : bool }
let pp_hpat pe f hpat = 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 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. (** 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 rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
let check_equal sub vars e1 e2 = let check_equal sub vars e1 e2 =
let e2_inst = Sil.exp_sub sub e2 let e2_inst = Sil.exp_sub sub e2
@ -87,9 +87,9 @@ let exp_list_match es1 sub vars es2 =
in es_match_res in es_match_res
(** Checks sexp1 = sexp2[sub ++ sub'] for some sub' with (** Checks sexp1 = sexp2[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')).
WARNING: This function does not consider the fact that the analyzer WARNING: This function does not consider the fact that the analyzer
sometimes forgets fields of hpred. It can possibly cause a problem. *) 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 = let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option =
match sexp1, sexp2 with match sexp1, sexp2 with
| Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) -> | Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) ->
@ -107,7 +107,7 @@ let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option =
(** Checks fsel1 = fsel2[sub ++ sub'] for some sub' with (** 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 = and fsel_match fsel1 sub vars fsel2 =
match fsel1, fsel2 with match fsel1, fsel2 with
| [], [] -> Some (sub, vars) | [], [] -> Some (sub, vars)
@ -128,7 +128,7 @@ and fsel_match fsel1 sub vars fsel2 =
else None else None
(** Checks isel1 = isel2[sub ++ sub'] for some sub' with (** 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 = and isel_match isel1 sub vars isel2 =
match isel1, isel2 with match isel1, isel2 with
| [], [] -> Some (sub, vars) | [], [] -> 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 instantiate_to_emp p condition sub_new vars_leftover hpats
(* This function has to be changed in order to (* This function has to be changed in order to
* implement the idea "All lsegs outside are NE, and all lsegs inside * implement the idea "All lsegs outside are NE, and all lsegs inside
* are PE" *) * are PE" *)
let rec iter_match_with_impl iter condition sub vars hpat hpats = let rec iter_match_with_impl iter condition sub vars hpat hpats =
(* (*
@ -460,10 +460,10 @@ and hpara_dll_match_with_impl impl_ok para1 para2 : bool =
(** [prop_match_with_impl p condition vars hpat hpats] (** [prop_match_with_impl p condition vars hpat hpats]
returns [(subst, p_leftover)] such that returns [(subst, p_leftover)] such that
1) [dom(subst) = vars] 1) [dom(subst) = vars]
2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover]. 2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover].
Using the flag [field], we can control the strength of |-. *) Using the flag [field], we can control the strength of |-. *)
let prop_match_with_impl p condition vars hpat hpats = let prop_match_with_impl p condition vars hpat hpats =
prop_match_with_impl_sub p condition Sil.sub_empty 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]. (** [generic_find_partial_iso] finds isomorphic subsigmas of [sigma_todo].
The function [update] is used to get rid of hpred pairs from [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 [sigma_corres] records the isormophic copies discovered so far. The first
parameter determines how much flexibility we will allow during this partial parameter determines how much flexibility we will allow during this partial
isomorphism finding. *) isomorphism finding. *)
let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_todo = let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_todo =
match todos with match todos with
| [] -> | [] ->
@ -660,11 +660,11 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
| _ -> None | _ -> None
(** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma. (** [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 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 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, 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 and it uses expressions in the range of the isomorphism. The third is the unused
part of the input sigma. *) part of the input sigma. *)
let find_partial_iso eq corres todos sigma = let find_partial_iso eq corres todos sigma =
let update e1 e2 sigma0 = let update e1 e2 sigma0 =
let (hpredo1, sigma0_no_e1) = sigma_remove_hpred eq sigma0 e1 in 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 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 (** [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 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 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, 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 and it uses expressions in the range of the isomorphism. The third and fourth
are the unused parts of the two input sigmas. *) are the unused parts of the two input sigmas. *)
let find_partial_iso_from_two_sigmas mode eq corres todos sigma1 sigma2 = let find_partial_iso_from_two_sigmas mode eq corres todos sigma1 sigma2 =
let update e1 e2 sigma_todo = let update e1 e2 sigma_todo =
let sigma_todo1, sigma_todo2 = sigma_todo in 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 list_map hpred_lift_to_pe sigma
(** [generic_para_create] takes a correspondence, and a sigma (** [generic_para_create] takes a correspondence, and a sigma
and a list of expressions for the first part of this and a list of expressions for the first part of this
correspondence. Then, it creates a renaming of expressions correspondence. Then, it creates a renaming of expressions
in the domain of the given correspondence, and applies this in the domain of the given correspondence, and applies this
renaming to the given sigma. The result is a tuple of the renaming, renaming to the given sigma. The result is a tuple of the renaming,
the renamed sigma, ids for existentially quantified expressions, the renamed sigma, ids for existentially quantified expressions,
ids for shared expressions, and shared expressions. *) ids for shared expressions, and shared expressions. *)
let generic_para_create corres sigma1 elist1 = let generic_para_create corres sigma1 elist1 =
let corres_ids = let corres_ids =
let not_same_consts = function let not_same_consts = function
@ -732,9 +732,9 @@ let generic_para_create corres sigma1 elist1 =
(renaming, body, ids_exists, ids_shared, es_shared) (renaming, body, ids_exists, ids_shared, es_shared)
(** [hpara_create] takes a correspondence, and a sigma, a root (** [hpara_create] takes a correspondence, and a sigma, a root
and a next for the first part of this correspondence. Then, it creates a and a next for the first part of this correspondence. Then, it creates a
hpara and discovers a list of shared expressions that are hpara and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *) passed as arguments to hpara. Both of them are returned as a result. *)
let hpara_create corres sigma1 root1 next1 = let hpara_create corres sigma1 root1 next1 =
let renaming, body, ids_exists, ids_shared, es_shared = let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; next1] in generic_para_create corres sigma1 [root1; next1] in
@ -755,9 +755,9 @@ let hpara_create corres sigma1 root1 next1 =
(hpara, es_shared) (hpara, es_shared)
(** [hpara_dll_create] takes a correspondence, and a sigma, a root, (** [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 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 hpara_dll and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *) passed as arguments to hpara. Both of them are returned as a result. *)
let hpara_dll_create corres sigma1 root1 blink1 flink1 = let hpara_dll_create corres sigma1 root1 blink1 flink1 =
let renaming, body, ids_exists, ids_shared, es_shared = let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; blink1; flink1] in generic_para_create corres sigma1 [root1; blink1; flink1] in

@ -12,7 +12,7 @@
open Utils open Utils
(** This module models special c struct types from the Apple's Core Foundation libraries (** 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 = module Core_foundation_model =
struct struct

@ -17,7 +17,7 @@ open Utils
(* =============== START of the Path module ===============*) (* =============== START of the Path module ===============*)
module Path : sig module Path : sig
(** type for paths *) (** type for paths *)
type t type t
type session = int type session = int

@ -298,7 +298,7 @@ let node_assigns_no_variables cfg node =
Vset.is_empty assign_set Vset.is_empty assign_set
(** Set the dead variables of a node, by default as dead_after. (** 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 = 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; *) (* 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 let seen = ref Cfg.NodeSet.empty in
@ -329,7 +329,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
add_after_prune_join true n add_after_prune_join true n
(** Find the set of dead variables for the procedure pname and add nullify instructions. (** 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 analyze_and_annotate_proc cfg tenv pname pdesc =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in let exit_node = Cfg.Procdesc.get_exit_node pdesc in
let exit_node_is_succ node = let exit_node_is_succ node =

@ -284,7 +284,7 @@ let create_err_message err_string =
"\n<div class=\"msg\" style=\"margin-left:9ex\">" ^ err_string ^ "</div>" "\n<div class=\"msg\" style=\"margin-left:9ex\">" ^ err_string ^ "</div>"
(** Module to read specific lines from files. (** 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 module LineReader : sig
type t type t

@ -279,8 +279,8 @@ let java_is_anonymous_inner_class = function
| _ -> false | _ -> false
(** Check if the last parameter is a hidden inner class, and remove it if present. (** 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 This is used in private constructors, where a proxy constructor is generated
with an extra parameter and calls the normal constructor. *) with an extra parameter and calls the normal constructor. *)
let java_remove_hidden_inner_class_parameter = function let java_remove_hidden_inner_class_parameter = function
| JAVA js -> | JAVA js ->
(match list_rev js.parameters with (match list_rev js.parameters with
@ -299,7 +299,7 @@ let java_is_anonymous_inner_class_constructor = function
| _ -> false | _ -> false
(** Check if the procedure name is an acess method (e.g. access$100 used to (** 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 let java_is_access_method = function
| JAVA js -> | JAVA js ->
(match string_split_character js.methodname '$' with (match string_split_character js.methodname '$' with
@ -311,7 +311,7 @@ let java_is_access_method = function
| _ -> false | _ -> false
(** Check if the proc name has the type of a java vararg. (** 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 let java_is_vararg = function
| JAVA js -> | JAVA js ->
begin begin

@ -15,8 +15,8 @@ module F = Format
open Utils open Utils
(** type to describe different strategies for initializing fields of a structure. [No_init] does not (** 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 initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh
variables (C) or default values (Java). *) variables (C) or default values (Java). *)
type struct_init_mode = type struct_init_mode =
| No_init | No_init
| Fld_init | Fld_init
@ -31,12 +31,12 @@ type normal = Normal (** kind for normal props, i.e. normalized *)
type exposed = Exposed (** kind for exposed props *) type exposed = Exposed (** kind for exposed props *)
(** A proposition. The following invariants are mantained. [sub] is of (** 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 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 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 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 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 and normalized, and does not contain x = e. [sigma] is sorted and
normalized. *) normalized. *)
type 'a t = type 'a t =
{ sigma: Sil.hpred list; { sigma: Sil.hpred list;
sub: Sil.subst; sub: Sil.subst;
@ -173,7 +173,7 @@ let pp_sigma pe =
pp_semicolon_seq pe (Sil.pp_hpred pe) pp_semicolon_seq pe (Sil.pp_hpred pe)
(** Split sigma into stack and nonstack parts. (** 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 sigma_get_stack_nonstack only_local_vars sigma =
let hpred_is_stack_var = function let hpred_is_stack_var = function
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not only_local_vars || Sil.pvar_is_local pvar | Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not only_local_vars || Sil.pvar_is_local pvar
@ -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) let exp_reorder e1 e2 = if Sil.exp_compare e1 e2 <= 0 then (e1, e2) else (e2, e1)
(** Normalize an atom. (** Normalize an atom.
We keep the convention that inequalities with constants We keep the convention that inequalities with constants
are only of the form [e <= n] and [n < e]. *) are only of the form [e <= n] and [n < e]. *)
let atom_normalize sub a0 = let atom_normalize sub a0 =
let a = Sil.atom_sub sub a0 in let a = Sil.atom_sub sub a0 in
let rec normalize_eq eq = match eq with let rec normalize_eq eq = match eq with
@ -1144,7 +1144,7 @@ let mk_ptsto lexp sexp te =
Sil.Hpointsto(lexp, nsexp, te) Sil.Hpointsto(lexp, nsexp, te)
(** Construct a points-to predicate for an expression using either the provided expression [name] as (** 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 mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred =
let default_strexp () = match te with let default_strexp () = match te with
| Sil.Sizeof (typ, st) -> | Sil.Sizeof (typ, st) ->
@ -1293,7 +1293,7 @@ let sigma_get_unsigned_exps sigma =
!uexps !uexps
(** Normalization of pi. (** 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_normalize sub sigma pi0 =
let pi = list_map (atom_normalize sub) pi0 in let pi = list_map (atom_normalize sub) pi0 in
let ineq_list, nonineq_list = pi_tighten_ineq pi in let ineq_list, nonineq_list = pi_tighten_ineq pi in
@ -1372,8 +1372,8 @@ let lexp_normalize_prop p lexp =
Sil.exp_add_offsets nroot noffsets Sil.exp_add_offsets nroot noffsets
(** Collapse consecutive indices that should be added. For instance, (** Collapse consecutive indices that should be added. For instance,
this function reduces x[1][1] to x[2]. The [typ] argument is used this function reduces x[1][1] to x[2]. The [typ] argument is used
to ensure the soundness of this collapsing. *) to ensure the soundness of this collapsing. *)
let exp_collapse_consecutive_indices_prop p typ exp = let exp_collapse_consecutive_indices_prop p typ exp =
let typ_is_base = function let typ_is_base = function
| Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true | Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true
@ -1481,7 +1481,7 @@ let unstructured_type = function
| _ -> true | _ -> true
(** Construct a points-to predicate for a single program variable. (** 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 = 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 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' } { p with sigma = sigma' }
(** Eliminates all empty lsegs from sigma, and collect equalities (** Eliminates all empty lsegs from sigma, and collect equalities
The empty lsegs include The empty lsegs include
(a) "lseg_pe para 0 e elist", (a) "lseg_pe para 0 e elist",
(b) "dllseg_pe para iF oB oF iB elist" with iF = 0 or iB = 0, (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, (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 (d) "dllseg_pe para iF oB oF iB elist" and the rest of sigma contains
cell iF or iB. *) cell iF or iB. *)
let sigma_remove_emptylseg sigma = let sigma_remove_emptylseg sigma =
let alloc_set = let alloc_set =
let rec f_alloc set = function let rec f_alloc set = function
@ -1880,7 +1880,7 @@ let find_arithmetic_problem proc_node_session prop exp =
| _ -> None, !res) | _ -> None, !res)
(** Deallocate the stack variables in [pvars], and replace them by normal variables. (** 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 deallocate_stack_vars p pvars =
let filter = function let filter = function
| Sil.Hpointsto (Sil.Lvar v, _, _) -> | Sil.Hpointsto (Sil.Lvar v, _, _) ->
@ -1916,8 +1916,8 @@ let deallocate_stack_vars p pvars =
(** {1 Functions for transforming footprints into propositions.} *) (** {1 Functions for transforming footprints into propositions.} *)
(** The ones used for abstraction add/remove local stacks in order to (** The ones used for abstraction add/remove local stacks in order to
stop the firing of some abstraction rules. The other usual stop the firing of some abstraction rules. The other usual
transforation functions do not use this hack. *) transforation functions do not use this hack. *)
(** Extract the footprint and return it as a prop *) (** Extract the footprint and return it as a prop *)
let extract_footprint p = let extract_footprint p =
@ -2318,7 +2318,7 @@ let prop_ren_sub (ren_sub: Sil.subst) (prop: normal t) : normal t =
normalize (prop_sub ren_sub prop) normalize (prop_sub ren_sub prop)
(** Existentially quantify the [ids] in [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 exist_quantify fav prop =
let ids = Sil.fav_to_list fav in let ids = Sil.fav_to_list fav in
if list_exists Ident.is_primed ids then assert false; (* sanity check *) if list_exists Ident.is_primed ids then assert false; (* sanity check *)
@ -2434,13 +2434,13 @@ let prop_iter_to_prop iter =
prop iter.pit_newpi prop iter.pit_newpi
(** Add an atom to the pi part of prop iter. The (** Add an atom to the pi part of prop iter. The
first parameter records whether it is done first parameter records whether it is done
during footprint or during re - execution. *) during footprint or during re - execution. *)
let prop_iter_add_atom footprint iter atom = let prop_iter_add_atom footprint iter atom =
{ iter with pit_newpi = (footprint, atom):: iter.pit_newpi } { iter with pit_newpi = (footprint, atom):: iter.pit_newpi }
(** Remove the current element of the iterator, and return the prop (** 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 prop_iter_remove_curr_then_to_prop iter =
let sigma = list_rev_append iter.pit_old iter.pit_new in let sigma = list_rev_append iter.pit_old iter.pit_new in
let normalized_sigma = sigma_normalize iter.pit_sub sigma in let normalized_sigma = sigma_normalize iter.pit_sub sigma in
@ -2697,7 +2697,7 @@ let trans_land_lor op ((idl1, stml1), e1) ((idl2, stml2), e2) loc =
end end
(** Input of this mehtod is an exp in a prop. Output is a formal variable or path from a (** 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 find_equal_formal_path e prop =
let rec find_in_sigma e seen_hpreds = let rec find_in_sigma e seen_hpreds =
list_fold_right ( list_fold_right (

@ -67,7 +67,7 @@ let get_subl footprint_part g =
if footprint_part then [] else Sil.sub_to_list (Prop.get_sub 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]. (** [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 edge_from_source g n footprint_part is_hpred =
let edges = let edges =
if is_hpred if is_hpred
@ -78,7 +78,7 @@ let edge_from_source g n footprint_part is_hpred =
| edge:: _ -> Some edge | edge:: _ -> Some edge
(** [get_succs g n footprint_part is_hpred] returns the successor nodes of [n] in [g]. (** [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 = let get_succs g n footprint_part is_hpred =
match edge_from_source g n footprint_part is_hpred with match edge_from_source g n footprint_part is_hpred with
| None -> [] | None -> []
@ -98,13 +98,13 @@ let edge_equal e1 e2 = match e1, e2 with
| _ -> false | _ -> false
(** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e], (** [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) = 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 try ignore (list_find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true
with Not_found -> false 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]; (** [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 = 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 *) list_iter f (get_edges footprint_part g) (* For now simple iterator; later might use a specific traversal *)
@ -192,13 +192,13 @@ let compute_diff default_color oldgraph newgraph : diff =
diff_cmap_foot = colormap_foot } diff_cmap_foot = colormap_foot }
(** [diff_get_colormap footprint_part diff] returns the colormap of a computed diff, (** [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 = let diff_get_colormap footprint_part diff =
if footprint_part then diff.diff_cmap_foot else diff.diff_cmap_norm 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. (** 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, 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. *) extracting its local stack vars if the boolean is true. *)
let pp_proplist pe0 s (base_prop, extract_stack) f plist = let pp_proplist pe0 s (base_prop, extract_stack) f plist =
let num = list_length plist in let num = list_length plist in
let base_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma base_prop)) in let base_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma base_prop)) in

@ -25,7 +25,7 @@ module PropSet =
let compare = PropSet.compare let compare = PropSet.compare
(** Sets of propositions. (** 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 type t = PropSet.t
let add p pset = let add p pset =
@ -78,13 +78,13 @@ let map f pset =
from_proplist (list_map f (to_proplist pset)) from_proplist (list_map f (to_proplist pset))
(** [fold f pset a] computes [f (... (f (f a p1) p2) ...) pn] (** [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 fold f a pset =
let l = to_proplist pset in let l = to_proplist pset in
list_fold_left f a l list_fold_left f a l
(** [iter f pset] computes (f p1;f p2;..;f pN) (** [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 = let iter =
PropSet.iter PropSet.iter

@ -191,7 +191,7 @@ let check_type_size_lt t1 t2 = match type_size_compare t1 t2 with
(** Reasoning about inequalities *) (** Reasoning about inequalities *)
module Inequalities : sig module Inequalities : sig
(** type for inequalities (and implied disequalities) *) (** type for inequalities (and implied disequalities) *)
type t type t
(** Extract inequalities and disequalities from [pi] *) (** Extract inequalities and disequalities from [pi] *)
@ -533,9 +533,9 @@ let check_zero e =
check_equal Prop.prop_emp e Sil.exp_zero check_equal Prop.prop_emp e Sil.exp_zero
(** [is_root prop base_exp exp] checks whether [base_exp = (** [is_root prop base_exp exp] checks whether [base_exp =
exp.offlist] for some list of offsets [offlist]. If so, it returns exp.offlist] for some list of offsets [offlist]. If so, it returns
[Some(offlist)]. Otherwise, it returns [None]. Assumes that [Some(offlist)]. Otherwise, it returns [None]. Assumes that
[base_exp] points to the beginning of a structure, not the middle. [base_exp] points to the beginning of a structure, not the middle.
*) *)
let is_root prop base_exp exp = let is_root prop base_exp exp =
let rec f offlist_past e = match e with let rec f offlist_past e = match e with
@ -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) 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 (** Extend [sub1] and [sub2] to witnesses that each instance of
[e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not [e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not
possible. *) possible. *)
let exp_imply calc_missing subs e1_in e2_in : subst2 = let exp_imply calc_missing subs e1_in e2_in : subst2 =
let e1 = Prop.exp_normalize_noabs (fst subs) e1_in in let e1 = Prop.exp_normalize_noabs (fst subs) e1_in in
let e2 = Prop.exp_normalize_noabs (snd subs) e2_in in let e2 = Prop.exp_normalize_noabs (snd subs) e2_in in
@ -1177,9 +1177,9 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
do_imply subs e1 e2 do_imply subs e1 e2
(** Convert a path (from lhs of a |-> to a field name present only in (** 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 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 new footprint var. Othewise it is a var with the path in the name
and stamp - 1 *) and stamp - 1 *)
let path_to_id path = let path_to_id path =
let rec f = function let rec f = function
| Sil.Var id -> | Sil.Var id ->
@ -1223,8 +1223,8 @@ let array_size_imply calc_missing subs size1 size2 indices2 =
subs subs
(** Extend [sub1] and [sub2] to witnesses that each instance of (** Extend [sub1] and [sub2] to witnesses that each instance of
[se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not [se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not
possible. *) possible. *)
let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subst2 * (Sil.strexp option) * (Sil.strexp option) = 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(); *) (* 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 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 subs'', fld_frame, (f2, se2):: fld_missing
and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2 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 let typ_elem = Sil.array_typ_elem (Some Sil.Tvoid) typ2 in
match esel1, esel2 with match esel1, esel2 with
| _,[] -> subs, esel1, [] | _,[] -> subs, esel1, []
@ -1415,7 +1415,7 @@ let move_primed_lhs_from_front subs sigma = match sigma with
let name_n = Ident.string_to_name "n" 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. (** [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 expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred =
let rec expand changed calc_index_frame hpred = match hpred with let rec expand changed calc_index_frame hpred = match hpred with
| Sil.Hpointsto (Sil.Lfield (e, fld, typ_fld), se, t) -> | Sil.Hpointsto (Sil.Lfield (e, fld, typ_fld), se, t) ->
@ -1585,7 +1585,7 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing =
None, None 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 (** 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 let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with
| Sil.Eexp (e1, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size -> | Sil.Eexp (e1, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size ->
let se1' = Sil.Earray (texp1, [(Sil.exp_zero, se1)], inst) in 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 | _ -> se1
(** handle parameter subtype for java: when the type of a callee variable in the caller is a strict subtype (** 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 handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) =
let is_callee = match e1 with let is_callee = match e1 with
| Sil.Lvar pv -> Sil.pvar_is_callee pv | Sil.Lvar pv -> Sil.pvar_is_callee pv
@ -1819,9 +1819,9 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
) )
(** Check that [sigma1] implies [sigma2] and return two substitution (** Check that [sigma1] implies [sigma2] and return two substitution
instantiations for the primed variables of [sigma1] and [sigma2] instantiations for the primed variables of [sigma1] and [sigma2]
and a frame. Raise IMPL_FALSE if the implication cannot be and a frame. Raise IMPL_FALSE if the implication cannot be
proven. *) proven. *)
and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * Prop.normal Prop.t) = 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 *) let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *)
| Sil.Hpointsto (_e2, _, _) -> | Sil.Hpointsto (_e2, _, _) ->
@ -1946,8 +1946,8 @@ let imply_atom calc_missing (sub1, sub2) prop a =
imply_pi calc_missing (sub1, sub2) prop [a] imply_pi calc_missing (sub1, sub2) prop [a]
(** Check pure implications before looking at the spatial part. Add (** Check pure implications before looking at the spatial part. Add
necessary instantiations for equalities and check that instantiations necessary instantiations for equalities and check that instantiations
are possible for disequalities. *) are possible for disequalities. *)
let rec pre_check_pure_implication calc_missing subs pi1 pi2 = let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
match pi2 with match pi2 with
| [] -> subs | [] -> subs
@ -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)) 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. (** 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 If there is a provable violation of the array bounds, set the prover status to Bounds_check
and make the proof fail. *) and make the proof fail. *)
let check_array_bounds (sub1, sub2) prop = let check_array_bounds (sub1, sub2) prop =
let check_failed atom = let check_failed atom =
ProverState.checks := Bounds_check :: !ProverState.checks; 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 ()) list_iter check_bound (ProverState.get_bounds_checks ())
(** [check_implication_base] returns true if [prop1|-prop2], (** [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 = let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 =
try try
ProverState.reset prop1 prop2; ProverState.reset prop1 prop2;
@ -2063,9 +2063,9 @@ type implication_result =
| ImplFail of check list | ImplFail of check list
(** [check_implication_for_footprint p1 p2] returns (** [check_implication_for_footprint p1 p2] returns
[Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)] [Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)]
where [sub] is a substitution which instantiates the where [sub] is a substitution which instantiates the
primed vars of [p1] and [p2], which are assumed to be disjoint. *) 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_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) =
let check_frame_empty = false in let check_frame_empty = false in
let calc_missing = true in let calc_missing = true in

@ -34,9 +34,9 @@ let pp_off fmt off =
| Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off | Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off
(** Check whether the index is out of bounds. (** Check whether the index is out of bounds.
If the size is - 1, no check is performed. If the size is - 1, no check is performed.
If the index is provably out of bound, a bound error is given. 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 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 check_bad_index pname tenv p size index loc =
let size_is_constant = match size with let size_is_constant = match size with
@ -177,10 +177,10 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
res res
(** Extend the strexp by populating the path indicated by [off]. (** Extend the strexp by populating the path indicated by [off].
This means that it will add missing flds and do the case - analysis This means that it will add missing flds and do the case - analysis
for array accesses. This does not catch the array - bounds errors. for array accesses. This does not catch the array - bounds errors.
If we want to implement the checks for array bounds errors, If we want to implement the checks for array bounds errors,
we need to change this function. *) we need to change this function. *)
let rec _strexp_extend_values let rec _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp pname tenv orig_prop footprint_part kind max_stamp
se typ (off : Sil.offset list) inst = se typ (off : Sil.offset list) inst =
@ -273,7 +273,7 @@ and array_case_analysis_index pname tenv orig_prop
array_size array_cont array_size array_cont
typ_array_size typ_cont typ_array_size typ_cont
index off inst_arr inst index off inst_arr inst
= =
let check_sound t' = let check_sound t' =
if not (Sil.typ_equal typ_cont t' || array_cont == []) if not (Sil.typ_equal typ_cont t' || array_cont == [])
then raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in then raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
@ -436,7 +436,7 @@ let mk_ptsto_exp_footprint
(ptsto, ptsto_foot, atoms @ atoms') (ptsto, ptsto_foot, atoms @ atoms')
(** Check if the path in exp exists already in the current ptsto predicate. (** 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 prop_iter_check_fields_ptsto_shallow iter lexp =
let offset = Sil.exp_get_offsets lexp in let offset = Sil.exp_get_offsets lexp in
let (e, se, t) = let (e, se, t) =
@ -463,9 +463,9 @@ let fav_max_stamp fav =
max_stamp max_stamp
(** [prop_iter_extend_ptsto iter lexp] extends the current psto (** [prop_iter_extend_ptsto iter lexp] extends the current psto
predicate in [iter] with enough fields to follow the path in predicate in [iter] with enough fields to follow the path in
[lexp] -- field splitting model. It also materializes all [lexp] -- field splitting model. It also materializes all
indices accessed in lexp. *) indices accessed in lexp. *)
let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = 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 ()); 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 let offset = Sil.exp_get_offsets lexp in
@ -558,10 +558,10 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
end end
(** Add a pointsto for [root(lexp): typ] to the sigma and footprint of a (** Add a pointsto for [root(lexp): typ] to the sigma and footprint of a
prop, if it's compatible with the allowed footprint prop, if it's compatible with the allowed footprint
variables. Then, change it into a iterator. This function ensures variables. Then, change it into a iterator. This function ensures
that [root(lexp): typ] is the current hpred of the iterator. typ that [root(lexp): typ] is the current hpred of the iterator. typ
is the type of the root of lexp. *) is the type of the root of lexp. *)
let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst = 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 max_stamp = fav_max_stamp (Prop.prop_footprint_fav prop) in
let ptsto, ptsto_foot, atoms = 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 Prop.prop_iter_set_state iter offsets_default
(** Add a pointsto for [root(lexp): typ] to the iterator and to the (** Add a pointsto for [root(lexp): typ] to the iterator and to the
footprint, if it's compatible with the allowed footprint footprint, if it's compatible with the allowed footprint
variables. This function ensures that [root(lexp): typ] is the variables. This function ensures that [root(lexp): typ] is the
current hpred of the iterator. typ is the type of the root of lexp. *) 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 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 max_stamp = fav_max_stamp (Prop.prop_iter_footprint_fav iter) in
let ptsto, ptsto_foot, atoms = let ptsto, ptsto_foot, atoms =
@ -808,7 +808,7 @@ let type_at_offset texp off =
| _ -> None | _ -> None
(** Check that the size of a type coming from an instruction does not exceed the size of the type from the pointsto predicate (** 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 = let check_type_size pname prop texp off typ_from_instr =
L.d_strln_color Orange "check_type_size"; L.d_strln_color Orange "check_type_size";
L.d_str "off: "; Sil.d_offset_list off; L.d_ln (); 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 () L.d_str "texp: "; Sil.d_texp_full texp; L.d_ln ()
(** Exposes lexp |->- from iter. In case that it is not possible to (** Exposes lexp |->- from iter. In case that it is not possible to
* expose lexp |->-, this function prints an error message and * expose lexp |->-, this function prints an error message and
* faults. There are four things to note. First, typ is the type of the * 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 * root of lexp. Second, prop should mean the same as iter. Third, the
* result [] means that the given input iter is inconsistent. This * result [] means that the given input iter is inconsistent. This
* happens when the theorem prover can prove the inconsistency of prop, * happens when the theorem prover can prove the inconsistency of prop,
* only after unrolling some predicates in prop. This function ensures * only after unrolling some predicates in prop. This function ensures
* that the theorem prover cannot prove the inconsistency of any of the * that the theorem prover cannot prove the inconsistency of any of the
* new iters in the result. *) * new iters in the result. *)
let rec iter_rearrange let rec iter_rearrange
pname tenv lexp typ_from_instr prop iter pname tenv lexp typ_from_instr prop iter
inst: (Sil.offset list) Prop.prop_iter list = inst: (Sil.offset list) Prop.prop_iter list =
@ -1069,8 +1069,8 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
end end
(** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. (** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ].
It returns an iterator with [lexp |-> strexp: typ] as current predicate It returns an iterator with [lexp |-> strexp: typ] as current predicate
and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) 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 rearrange pdesc tenv lexp typ prop loc : (Sil.offset list) Prop.prop_iter list =
let nlexp = match Prop.exp_normalize_prop prop lexp with let nlexp = match Prop.exp_normalize_prop prop lexp with
| Sil.BinOp(Sil.PlusPI, ep, e) -> (* array access with pointer arithmetic *) | Sil.BinOp(Sil.PlusPI, ep, e) -> (* array access with pointer arithmetic *)

@ -651,7 +651,7 @@ type dexp =
| Dretcall of dexp * dexp list * location * call_flags | Dretcall of dexp * dexp list * location * call_flags
(** Value paths: identify an occurrence of a value in a symbolic heap (** 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 = and vpath =
dexp option dexp option
@ -810,11 +810,11 @@ type strexp =
| Estruct of (Ident.fieldname * strexp) list * inst (** C structure *) | Estruct of (Ident.fieldname * strexp) list * inst (** C structure *)
| Earray of exp * (exp * strexp) list * inst (** Array of given size. *) | Earray of exp * (exp * strexp) list * inst (** Array of given size. *)
(** There are two conditions imposed / used in the array case. (** There are two conditions imposed / used in the array case.
First, if some index and value pair appears inside an array 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. in a strexp, then the index is less than the size of the array.
For instance, x |->[10 | e1: v1] implies that e1 <= 9. For instance, x |->[10 | e1: v1] implies that e1 <= 9.
Second, if two indices appear in an array, they should be different. Second, if two indices appear in an array, they should be different.
For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *)
(** an atomic heap predicate *) (** an atomic heap predicate *)
and hpred = and hpred =
@ -827,14 +827,14 @@ and hpred =
This assumption is used in the rearrangement. The last [exp list] parameter 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. *) 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 | 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. (** parameter for the higher-order singly-linked list predicate.
Means "lambda (root,next,svars). Exists evars. body". Means "lambda (root,next,svars). Exists evars. body".
Assume that root, next, svars, evars are disjoint sets of Assume that root, next, svars, evars are disjoint sets of
primed identifiers, and include all the free primed identifiers in body. primed identifiers, and include all the free primed identifiers in body.
body should not contain any non - primed identifiers or program body should not contain any non - primed identifiers or program
variables (i.e. pvars). *) variables (i.e. pvars). *)
and hpara = and hpara =
{ root: Ident.t; { root: Ident.t;
next: Ident.t; next: Ident.t;
@ -843,8 +843,8 @@ and hpara =
body: hpred list } body: hpred list }
(** parameter for the higher-order doubly-linked list predicates. (** parameter for the higher-order doubly-linked list predicates.
Assume that all the free identifiers in body_dll should belong to Assume that all the free identifiers in body_dll should belong to
cell, blink, flink, svars_dll, evars_dll. *) cell, blink, flink, svars_dll, evars_dll. *)
and hpara_dll = and hpara_dll =
{ cell: Ident.t; (** address cell *) { cell: Ident.t; (** address cell *)
blink: Ident.t; (** backward link *) blink: Ident.t; (** backward link *)
@ -1087,8 +1087,8 @@ let binop_compare o1 o2 = match o1, o2 with
let binop_equal o1 o2 = binop_compare o1 o2 = 0 let binop_equal o1 o2 = binop_compare o1 o2 = 0
(** This function returns true if the operation is injective (** This function returns true if the operation is injective
wrt. each argument: op(e,-) and op(-, e) is injective for all e. wrt. each argument: op(e,-) and op(-, e) is injective for all e.
The return value false means "don't know". *) The return value false means "don't know". *)
let binop_injective = function let binop_injective = function
| PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true
| _ -> false | _ -> false
@ -1099,9 +1099,9 @@ let binop_invertible = function
| _ -> false | _ -> false
(** This function inverts an injective binary operator (** This function inverts an injective binary operator
with respect to the first argument. It returns an expression [e'] such that 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, BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible,
the function raises an exception by calling "assert false". *) the function raises an exception by calling "assert false". *)
let binop_invert bop e1 e2 = let binop_invert bop e1 e2 =
let inverted_bop = match bop with let inverted_bop = match bop with
| PlusA -> MinusA | PlusA -> MinusA
@ -1112,7 +1112,7 @@ let binop_invert bop e1 e2 =
BinOp(inverted_bop, e2, e1) BinOp(inverted_bop, e2, e1)
(** This function returns true if 0 is the right unit of [binop]. (** 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 let binop_is_zero_runit = function
| PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true
| _ -> false | _ -> false
@ -2030,8 +2030,8 @@ and pp_typ pe f te =
if !Config.print_types then pp_typ_full pe f te else () if !Config.print_types then pp_typ_full pe f te else ()
(** Pretty print a type declaration. (** Pretty print a type declaration.
pp_base prints the variable for a declaration, or can be skip to print only the type 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_size prints the expression for the array size *)
and pp_type_decl pe pp_base pp_size f = function and pp_type_decl pe pp_base pp_size f = function
| Tvar tname -> F.fprintf f "%s %a" (typename_to_string tname) pp_base () | 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 () | Tint ik -> F.fprintf f "%s %a" (ikind_to_string ik) pp_base ()
@ -2384,9 +2384,9 @@ let rec pp_star_seq pp f = function
(********* START OF MODULE Predicates **********) (********* START OF MODULE Predicates **********)
(** Module Predicates records the occurrences of predicates as parameters (** 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 module Predicates : sig
(** predicate environment *) (** predicate environment *)
type env type env
(** create an empty predicate environment *) (** create an empty predicate environment *)
val empty_env : unit -> env val empty_env : unit -> env
@ -2868,14 +2868,14 @@ let unsome_typ s = function
assert false assert false
(** Turn an expression representing a type into the type it represents (** 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 let texp_to_typ default_opt = function
| Sizeof (t, _) -> t | Sizeof (t, _) -> t
| t -> | t ->
unsome_typ "texp_to_typ" default_opt unsome_typ "texp_to_typ" default_opt
(** If a struct type with field f, return the type of f. (** 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 struct_typ_fld default_opt f =
let def () = unsome_typ "struct_typ_fld" default_opt in let def () = unsome_typ "struct_typ_fld" default_opt in
function function
@ -2885,7 +2885,7 @@ let struct_typ_fld default_opt f =
| _ -> def () | _ -> def ()
(** If an array type, return the type of the element. (** 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 let array_typ_elem default_opt = function
| Tarray (t_el, _) -> t_el | Tarray (t_el, _) -> t_el
| t -> | t ->
@ -2903,7 +2903,7 @@ let rec root_of_lexp lexp = match lexp with
| Sizeof _ -> lexp | Sizeof _ -> lexp
(** Checks whether an expression denotes a location by pointer arithmetic. (** 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 let rec exp_pointer_arith = function
| Lfield (e, _, _) -> exp_pointer_arith e | Lfield (e, _, _) -> exp_pointer_arith e
| Lindex _ -> true | Lindex _ -> true
@ -2999,9 +2999,9 @@ and hpred_fpv = function
@ fpvars_in_elist @ fpvars_in_elist
(** hpara should not contain any program variables. (** hpara should not contain any program variables.
This is because it might cause problems when we do interprocedural This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *) of scopes of program variables. *)
and hpara_fpv para = and hpara_fpv para =
let fpvars_in_body = list_flatten (list_map hpred_fpv para.body) in let fpvars_in_body = list_flatten (list_map hpred_fpv para.body) in
match fpvars_in_body with match fpvars_in_body with
@ -3009,9 +3009,9 @@ and hpara_fpv para =
| _ -> assert false | _ -> assert false
(** hpara_dll should not contain any program variables. (** hpara_dll should not contain any program variables.
This is because it might cause problems when we do interprocedural This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *) of scopes of program variables. *)
and hpara_dll_fpv para = and hpara_dll_fpv para =
let fpvars_in_body = list_flatten (list_map hpred_fpv para.body_dll) in let fpvars_in_body = list_flatten (list_map hpred_fpv para.body_dll) in
match fpvars_in_body with 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)) else x:: (remove_duplicates_from_sorted special_equal (y:: l))
(** Convert a [fav] to a list of identifiers while preserving the order (** 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 = let fav_to_list fav =
list_rev !fav list_rev !fav
@ -3107,7 +3107,7 @@ let rec ident_sorted_list_subset l1 l2 =
else false else false
(** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] (** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1]
is in [fav2].*) is in [fav2].*)
let fav_subset_ident fav1 fav2 = let fav_subset_ident fav1 fav2 =
ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2) ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2)
@ -3173,9 +3173,9 @@ let hpred_fav =
fav_imperative_to_functional hpred_fav_add fav_imperative_to_functional hpred_fav_add
(** This function should be used before adding a new (** This function should be used before adding a new
index to Earray. The [exp] is the newly created 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. 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. *) The function faults in the re - execution mode, as an internal check of the tool. *)
let array_clean_new_index footprint_part new_idx = let array_clean_new_index footprint_part new_idx =
if footprint_part && not !Config.footprint then assert false; if footprint_part && not !Config.footprint then assert false;
let fav = exp_fav new_idx in let fav = exp_fav new_idx in
@ -3288,8 +3288,8 @@ let sub_check_inv sub =
(sub_check_sortedness sub) && not (sub_check_duplicated_ids sub) (sub_check_sortedness sub) && not (sub_check_duplicated_ids sub)
(** Create a substitution from a list of pairs. (** Create a substitution from a list of pairs.
For all (id1, e1), (id2, e2) in the input list, For all (id1, e1), (id2, e2) in the input list,
if id1 = id2, then e1 = e2. *) if id1 = id2, then e1 = e2. *)
let sub_of_list sub = let sub_of_list sub =
let sub' = list_sort ident_exp_compare sub in let sub' = list_sort ident_exp_compare sub in
let sub'' = remove_duplicates_from_sorted ident_exp_equal 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 [] let sub_empty = sub_of_list []
(** Join two substitutions into one. (** 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_join sub1 sub2 =
let sub = sorted_list_merge ident_exp_compare sub1 sub2 in let sub = sorted_list_merge ident_exp_compare sub1 sub2 in
let sub' = remove_duplicates_from_sorted ident_exp_equal sub in let sub' = remove_duplicates_from_sorted ident_exp_equal sub in
@ -3323,9 +3323,9 @@ let sub_join sub1 sub2 =
sub sub
(** Compute the common id-exp part of two inputs [subst1] and [subst2]. (** Compute the common id-exp part of two inputs [subst1] and [subst2].
The first component of the output is this common part. The first component of the output is this common part.
The second and third components are the remainder of [subst1] The second and third components are the remainder of [subst1]
and [subst2], respectively. *) and [subst2], respectively. *)
let sub_symmetric_difference sub1_in sub2_in = let sub_symmetric_difference sub1_in sub2_in =
let rec diff sub_common sub1_only sub2_only sub1 sub2 = let rec diff sub_common sub1_only sub2_only sub1 sub2 =
match sub1, sub2 with match sub1, sub2 with
@ -3353,21 +3353,21 @@ let sub_find filter (sub: subst) =
snd (list_find (fun (i, _) -> filter i) sub) snd (list_find (fun (i, _) -> filter i) sub)
(** [sub_filter filter sub] restricts the domain of [sub] to the (** [sub_filter filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter]. *) identifiers satisfying [filter]. *)
let sub_filter filter (sub: subst) = let sub_filter filter (sub: subst) =
list_filter (fun (i, _) -> filter i) sub list_filter (fun (i, _) -> filter i) sub
(** [sub_filter_pair filter sub] restricts the domain of [sub] to the (** [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 let sub_filter_pair = list_filter
(** [sub_range_partition filter sub] partitions [sub] according to (** [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) = let sub_range_partition filter (sub: subst) =
list_partition (fun (_, e) -> filter e) sub list_partition (fun (_, e) -> filter e) sub
(** [sub_domain_partition filter sub] partitions [sub] according to (** [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) = let sub_domain_partition filter (sub: subst) =
list_partition (fun (i, _) -> filter i) sub 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_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 (** [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 = let sub_map f g sub =
sub_of_list (list_map (fun (i, e) -> (f i, g e)) 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)]) else Some (sorted_list_merge compare sub [(id, exp)])
(** Free auxilary variables in the domain and range of the (** Free auxilary variables in the domain and range of the
substitution. *) substitution. *)
let sub_fav_add fav (sub: subst) = let sub_fav_add fav (sub: subst) =
list_iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub list_iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub
@ -3840,9 +3840,9 @@ let sigma_to_sigma_ne sigma : (atom list * hpred list) list =
[([], sigma)] [([], sigma)]
(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], (** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1],
[e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], [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\]] then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*) for some fresh [_zs'].*)
let hpara_instantiate para e1 e2 elist = let hpara_instantiate para e1 e2 elist =
let subst_for_svars = let subst_for_svars =
let g id e = (id, e) in 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) (ids_evars, list_map (hpred_sub subst) para.body)
(** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], (** [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], [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\]] then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*) for some fresh [_zs'].*)
let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist = let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist =
let subst_for_svars = let subst_for_svars =
let g id e = (id, e) in let g id e = (id, e) in

@ -159,9 +159,9 @@ let visited_str vis =
!s !s
(** A spec consists of: (** A spec consists of:
pre: a joined prop pre: a joined prop
post: a list of props with path post: a list of props with path
visited: a list of pairs (node_id, line) for the visited nodes *) 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 } 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 *) module NormSpec : sig (* encapsulate type for normalized specs *)
@ -619,7 +619,7 @@ let get_summary_unsafe proc_name =
| Some summary -> summary | Some summary -> summary
(** Check if the procedure is from a library: (** 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 proc_is_library proc_name proc_desc =
let defined = Cfg.Procdesc.is_defined proc_desc in let defined = Cfg.Procdesc.is_defined proc_desc in
if not defined then if not defined then
@ -688,7 +688,7 @@ let get_flag proc_name key =
with Not_found -> None with Not_found -> None
(** Get the iterations associated to the procedure if any, or the default timeout from the (** Get the iterations associated to the procedure if any, or the default timeout from the
command line *) command line *)
let get_iterations proc_name = let get_iterations proc_name =
match get_summary proc_name with match get_summary proc_name with
| None -> | None ->
@ -735,7 +735,7 @@ let re_initialize_dependency_map dependency_map =
Procname.Map.map (fun dep_proc -> - 1) dependency_map Procname.Map.map (fun dep_proc -> - 1) dependency_map
(** Update the dependency map of [proc_name] with the current (** Update the dependency map of [proc_name] with the current
timestamps of the dependents *) timestamps of the dependents *)
let update_dependency_map proc_name = let update_dependency_map proc_name =
match get_summary_origin proc_name with match get_summary_origin proc_name with
| None -> | None ->
@ -749,8 +749,8 @@ let update_dependency_map proc_name =
set_summary_origin proc_name { summary with dependency_map = current_dependency_map } origin 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, (** [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)] 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]. *) initializes the summary for [proc_name] given dependent procs in list [depend_list]. *)
let init_summary let init_summary
(proc_name, ret_type, formals, depend_list, loc, (proc_name, ret_type, formals, depend_list, loc,
nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt,

@ -137,8 +137,8 @@ let instrs_normalize instrs =
list_map (Sil.instr_sub subst) instrs list_map (Sil.instr_sub subst) instrs
(** Create a function to find duplicate nodes. (** Create a function to find duplicate nodes.
A node is a duplicate of another one if they have the same kind and location 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. *) 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 mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
let module M = (* map from (loc,kind) *) let module M = (* map from (loc,kind) *)
Map.Make(struct Map.Make(struct
@ -238,7 +238,7 @@ let extract_pre p tenv pdesc abstract_fun =
Prop.normalize (Prop.prop_sub sub pre') Prop.normalize (Prop.prop_sub sub pre')
(** return the normalized precondition extracted form the last prop seen, if any (** 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 = 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 match get_prop_tenv_pdesc () with
| None -> None | None -> None

@ -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]. (** Apply function [f] to the expression at position [offlist] in [strexp].
If not found, expand [strexp] and apply [f] to [None]. If not found, expand [strexp] and apply [f] to [None].
The routine should maintain the invariant that strexp and typ correspond to The routine should maintain the invariant that strexp and typ correspond to
each other exactly, without involving any re - interpretation of some type t 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 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. 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 function can expand a list of higher - order [hpara_psto] predicates, if
the list is stored at [offlist] in [strexp] initially. The expanded list 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 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, 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 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 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 this function. If the tool follows this protocol, it will never hit the assert
false cases for field and array accesses. *) false cases for field and array accesses. *)
let rec apply_offlist let rec apply_offlist
footprint_part pdesc tenv p fp_root nullify_struct footprint_part pdesc tenv p fp_root nullify_struct
(root_lexp, strexp, typ) offlist (f: Sil.exp option -> Sil.exp) inst lookup_inst = (root_lexp, strexp, typ) offlist (f: Sil.exp option -> Sil.exp) inst lookup_inst =
@ -210,20 +210,20 @@ let rec apply_offlist
pp_error(); pp_error();
raise (Exceptions.Internal_error (Localise.verbatim_desc "Array out of bounds in Symexec")) raise (Exceptions.Internal_error (Localise.verbatim_desc "Array out of bounds in Symexec"))
(* This case should not happen. The rearrangement should (* 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], (** Given [lexp |-> se: typ], if the location [offlist] exists in [se],
function [ptsto_lookup p (lexp, se, typ) offlist id] returns a tuple. 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 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], 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 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, higher - order parameters [hpara_psto]. If this expansion happens,
the last component of the tuple is a list of pi - sigma pairs obtained 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. 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]. 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 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 in rearrange.ml for the same se and offlist, so that all the necessary
extensions of se are done before this function. *) extensions of se are done before this function. *)
let ptsto_lookup footprint_part pdesc tenv p (lexp, se, typ, st) offlist id = let ptsto_lookup footprint_part pdesc tenv p (lexp, se, typ, st) offlist id =
let f = let f =
function Some exp -> exp | None -> Sil.Var id in 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) (e', ptsto', pred_insts_op', lookup_uninitialized)
(** [ptsto_update p (lexp,se,typ) offlist exp] takes (** [ptsto_update p (lexp,se,typ) offlist exp] takes
[lexp |-> se: typ], and updates [se] by replacing the [lexp |-> se: typ], and updates [se] by replacing the
expression at [offlist] with [exp]. Then, it returns expression at [offlist] with [exp]. Then, it returns
the updated pointsto predicate. If [lexp |-> se: typ] gets the updated pointsto predicate. If [lexp |-> se: typ] gets
expanded during this update, the generated pi - sigma list from expanded during this update, the generated pi - sigma list from
the expansion gets returned, and otherwise, None is returned. the expansion gets returned, and otherwise, None is returned.
All these happen under the proposition [p], so it is ok call All these happen under the proposition [p], so it is ok call
prover with [p]. Finally, before running this function, prover with [p]. Finally, before running this function,
the tool should run strexp_extend_value in rearrange.ml for the same 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 se and offlist, so that all the necessary extensions of se are done
before this function. *) before this function. *)
let ptsto_update footprint_part pdesc tenv p (lexp, se, typ, st) offlist exp = let ptsto_update footprint_part pdesc tenv p (lexp, se, typ, st) offlist exp =
let f _ = exp in let f _ = exp in
let fp_root = let fp_root =
@ -386,7 +386,7 @@ let print_builtins () =
let function_is_builtin = Builtin.is_registered let function_is_builtin = Builtin.is_registered
(** Precondition: se should not include hpara_psto (** Precondition: se should not include hpara_psto
that could mean nonempty heaps. *) that could mean nonempty heaps. *)
let rec execute_nullify_se = function let rec execute_nullify_se = function
| Sil.Eexp _ -> | Sil.Eexp _ ->
Sil.Eexp (Sil.exp_zero, Sil.inst_nullify) 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) Sil.Earray (size, esel', Sil.inst_nullify)
(** Do pruning for conditional [if (e1 != e2) ] if [positive] is true (** 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 prune_ne tenv positive e1 e2 prop =
let is_inconsistent = let is_inconsistent =
if positive then Prover.check_equal prop e1 e2 if positive then Prover.check_equal prop e1 e2
@ -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 (** 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 = let resolve_virtual_pname cfg tenv prop args pname : Procname.t =
match args with match args with
| [] -> failwith "Expecting the first parameter to be the object expression" | [] -> failwith "Expecting the first parameter to be the object expression"
@ -863,7 +863,7 @@ let normalize_params pdesc prop actual_params =
(** Execute [instr] with a symbolic heap [prop].*) (** Execute [instr] with a symbolic heap [prop].*)
let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path 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 let pname = Cfg.Procdesc.get_proc_name pdesc in
State.set_instr _instr; (* mark instruction last seen *) State.set_instr _instr; (* mark instruction last seen *)
State.set_prop_tenv_pdesc _prop tenv pdesc; (* mark prop,tenv,pdesc last seen *) State.set_prop_tenv_pdesc _prop tenv pdesc; (* mark prop,tenv,pdesc last seen *)
@ -1057,7 +1057,7 @@ and execute_diverge prop path =
[] []
(** Like sym_exec but for generated instructions. (** 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 = and sym_exec_generated mask_errors cfg tenv pdesc instrs ppl =
let exe_instr instr (p, path) = let exe_instr instr (p, path) =
L.d_str "Executing Generated Instruction "; Sil.d_instr instr; L.d_ln (); L.d_str "Executing Generated Instruction "; Sil.d_instr instr; L.d_ln ();
@ -1331,7 +1331,7 @@ and sym_exec_call cfg pdesc tenv pre path ret_ids actual_pars summary loc =
(** perform symbolic execution for a single prop, and check for junk *) (** 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) 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 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 prop_primed_to_normal p = (** Rename primed vars with fresh normal vars, and return them *)
let fav = Prop.prop_fav p in let fav = Prop.prop_fav p in
@ -1394,7 +1394,7 @@ and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t)
let lifted_sym_exec let lifted_sym_exec
handle_exn cfg tenv pdesc (pset : Paths.PathSet.t) node (instrs : Sil.instr list) 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 pname = Cfg.Procdesc.get_proc_name pdesc in
let exe_instr_prop instr p tr (pset1: Paths.PathSet.t) = let exe_instr_prop instr p tr (pset1: Paths.PathSet.t) =
let pset2 = let pset2 =

@ -46,9 +46,9 @@ type valid_res =
vr_incons_res : (Prop.normal Prop.t * Paths.Path.t) list; (** inconsistent result props *) } vr_incons_res : (Prop.normal Prop.t * Paths.Path.t) list; (** inconsistent result props *) }
(** Result of (bi)-abduction on a single spec. (** 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 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. part of the splitting is not empty.
A valid result contains the missing pi ans sigma, as well as the resulting props. *) A valid result contains the missing pi ans sigma, as well as the resulting props. *)
type abduction_res = type abduction_res =
| Valid_res of valid_res (** valid result for a function cal *) | Valid_res of valid_res (** valid result for a function cal *)
| Invalid_res of invalid_res (** reason for invalid result *) | Invalid_res of invalid_res (** reason for invalid result *)
@ -118,9 +118,9 @@ let spec_find_rename trace_call (proc_name : Procname.t) : (int * Prop.exposed S
end end
(** Process a splitting coming straight from a call to the prover: (** Process a splitting coming straight from a call to the prover:
change the instantiating substitution so that it returns primed vars, change the instantiating substitution so that it returns primed vars,
except for vars occurring in the missing part, where it returns except for vars occurring in the missing part, where it returns
footprint vars. *) footprint vars. *)
let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld frame_typ missing_typ = let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld frame_typ missing_typ =
(* (*
let check_precondition () = let check_precondition () =
@ -232,7 +232,7 @@ and find_dereference_without_null_check_in_sexp_list = function
| Some x -> Some x) | Some x -> Some x)
(** Check dereferences implicit in the spec pre. (** 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_dereferences callee_pname actual_pre sub spec_pre formal_params =
let check_dereference e sexp = let check_dereference e sexp =
let e_sub = Sil.exp_sub sub e in let e_sub = Sil.exp_sub sub e in
@ -313,8 +313,8 @@ let check_path_errors_in_post caller_pname post post_path =
list_iter check_attr (Prop.get_all_attributes post) list_iter check_attr (Prop.get_all_attributes post)
(** Post process the instantiated post after the function call so that (** Post process the instantiated post after the function call so that
x.f |-> se becomes x |-> \{ f: se \}. x.f |-> se becomes x |-> \{ f: se \}.
Also, update any Aresource attributes to refer to the caller *) Also, update any Aresource attributes to refer to the caller *)
let post_process_post let post_process_post
caller_pname callee_pname loc actual_pre ((post: Prop.exposed Prop.t), post_path) = 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 let actual_pre_has_freed_attribute e = match Prop.get_resource_undef_attribute actual_pre e with
@ -722,8 +722,8 @@ let combine
Some results Some results
(** Construct the actual precondition: add to the current state a copy (** Construct the actual precondition: add to the current state a copy
of the (callee's) formal parameters instantiated with the actual of the (callee's) formal parameters instantiated with the actual
parameters. *) parameters. *)
let mk_actual_precondition prop actual_params formal_params = let mk_actual_precondition prop actual_params formal_params =
let formals_actuals = let formals_actuals =
let rec comb fpars apars = match fpars, apars with let rec comb fpars apars = match fpars, apars with
@ -925,7 +925,7 @@ let remove_constant_string_class prop =
Prop.normalize prop' Prop.normalize prop'
(** existentially quantify the path identifier generated by the prover to keep track of expansions of lhs paths (** 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 quantify_path_idents_remove_constant_strings (prop: Prop.normal Prop.t) : Prop.normal Prop.t =
let fav = Prop.prop_fav prop in let fav = Prop.prop_fav prop in
Sil.fav_filter_ident fav Ident.is_path; Sil.fav_filter_ident fav Ident.is_path;

@ -44,7 +44,7 @@ end
(* updating the map, add nodes for which the map changed back to TODO. 4. *) (* updating the map, add nodes for which the map changed back to TODO. 4. *)
(* Until the set is empty. *) (* Until the set is empty. *)
module Control_flow = module Control_flow =
functor (TM : TODO_MAP) -> functor (TM : TODO_MAP) ->
struct struct
let set_to_string set = let set_to_string set =

@ -309,7 +309,7 @@ let pe_extend_colormap pe (x: Obj.t) (c: color) =
{ pe with pe_cmap_norm = colormap } { pe with pe_cmap_norm = colormap }
(** Set the object substitution, which is supposed to preserve the type. (** 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 pe_set_obj_sub pe (sub: 'a -> 'a) =
let new_obj_sub x = let new_obj_sub x =
let x' = Obj.repr (sub (Obj.obj x)) in let x' = Obj.repr (sub (Obj.obj x)) in
@ -634,7 +634,7 @@ let copy_file fname_from fname_to =
None None
module FileLOC = (** count lines of code of files and keep processed results in a cache *) module FileLOC = (** count lines of code of files and keep processed results in a cache *)
struct struct
let include_loc_hash = Hashtbl.create 1 let include_loc_hash = Hashtbl.create 1
let reset () = Hashtbl.clear include_loc_hash let reset () = Hashtbl.clear include_loc_hash
@ -646,7 +646,7 @@ module FileLOC = (** count lines of code of files and keep processed results in
| Some l -> list_length l in | Some l -> list_length l in
Hashtbl.add include_loc_hash fname loc; Hashtbl.add include_loc_hash fname loc;
loc loc
end end
(** type for files used for printing *) (** type for files used for printing *)
type outfile = type outfile =

@ -140,7 +140,7 @@ let ia_is ann ia = match ann with
type get_method_annotation = Procname.t -> Cfg.Procdesc.t -> Sil.method_annotation 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, (** 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 get_annotated_signature get_method_annotation proc_desc proc_name : annotated_signature =
let method_annotation = get_method_annotation proc_name proc_desc in let method_annotation = get_method_annotation proc_name proc_desc in
let formals = Cfg.Procdesc.get_formals 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 annotated_signature
(** Check if the annotated signature is for a wrapper of an anonymous inner class method. (** 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 These wrappers have the same name as the original method, every type is Object, and the parameters
are called x0, x1, x2. *) are called x0, x1, x2. *)
let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name = let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
let check_ret (ia, t) = let check_ret (ia, t) =
Sil.item_annotation_is_empty ia && PatternMatch.type_is_object t in Sil.item_annotation_is_empty ia && PatternMatch.type_is_object t in

@ -64,7 +64,7 @@ let done_checking num_methods =
!num_methods_checked = num_methods !num_methods_checked = num_methods
(** ask Eradicate to check each of the procs in [registered_callback_procs] (and their transitive (** 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 = let do_eradicate_check all_procs get_procdesc idenv tenv =
(* tell Eradicate to treat each of the fields nullified in on_destroy as nullable *) (* 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; FldSet.iter (fun fld -> Models.Inference.field_add_nullable_annotation fld) !fields_nullified;
@ -77,8 +77,8 @@ let do_eradicate_check all_procs get_procdesc idenv tenv =
!registered_callback_procs !registered_callback_procs
(** if [procname] belongs to an Android lifecycle type, save the set of callbacks registered in (** 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 * [procname]. in addition, if [procname] is a special "destroy" /"cleanup" method, save the set of
* fields that are nullified *) * fields that are nullified *)
let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc = 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 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) -> | Some (Sil.Tstruct(_, _, csu, Some class_name, _, methods, _) as typ) ->

@ -47,7 +47,7 @@ end
(** Create a module with the toplevel callback. *) (** Create a module with the toplevel callback. *)
module MkCallback module MkCallback
(Extension : ExtensionT) (Extension : ExtensionT)
: CallBackT = : CallBackT =
struct struct
(** Update the summary with stats from the checker. *) (** Update the summary with stats from the checker. *)
let update_summary proc_name proc_desc final_typestate_opt = let update_summary proc_name proc_desc final_typestate_opt =
@ -342,7 +342,7 @@ end (* MkCallback *)
(** Given an extension to the typestate with a check, call the check on each instruction. *) (** Given an extension to the typestate with a check, call the check on each instruction. *)
module Build module Build
(Extension : ExtensionT) (Extension : ExtensionT)
: CallBackT = : CallBackT =
struct struct
module Callback = MkCallback(Extension) module Callback = MkCallback(Extension)
let callback = Callback.callback let callback = Callback.callback

@ -484,7 +484,7 @@ let check_call_parameters
check (list_rev sig_params) (list_rev call_params) check (list_rev sig_params) (list_rev call_params)
(** Checks if the annotations are consistent with the inherited class or with the (** Checks if the annotations are consistent with the inherited class or with the
implemented interfaces *) implemented interfaces *)
let check_overridden_annotations let check_overridden_annotations
find_canonical_duplicate get_proc_desc tenv proc_name proc_desc annotated_signature = find_canonical_duplicate get_proc_desc tenv proc_name proc_desc annotated_signature =

@ -8,7 +8,7 @@
*) *)
(** Environment for temporary identifiers used in instructions. (** 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 type t = (Sil.exp Ident.IdentHash.t) Lazy.t * Cfg.cfg

@ -232,7 +232,7 @@ let get_java_field_access_signature = function
| _ -> None | _ -> None
(** Returns the formal signature (class name, method name, (** 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 let get_java_method_call_formal_signature = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) ->
(try (try
@ -263,7 +263,7 @@ let initializer_methods = [
"onAttach"; "onAttach";
"onCreate"; "onCreate";
"onCreateView"; "onCreateView";
] ]
(** Check if the type has in its supertypes from the initializer_classes list. *) (** Check if the type has in its supertypes from the initializer_classes list. *)
let type_has_initializer let type_has_initializer

@ -201,8 +201,8 @@ let err_tbl : err_state H.t =
let reset () = H.reset err_tbl let reset () = H.reset err_tbl
(** Get the forall status of an err_instance. (** Get the forall status of an err_instance.
The forall status indicates that the error should be printed only if it The forall status indicates that the error should be printed only if it
occurs on every path. *) occurs on every path. *)
let get_forall = function let get_forall = function
| Condition_redundant _ -> true | Condition_redundant _ -> true
| Field_not_initialized _ -> false | 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 (** 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 node_reset_forall node =
let iter (err_instance, instr_ref_opt) err_state = let iter (err_instance, instr_ref_opt) err_state =
match instr_ref_opt, get_forall err_instance with match instr_ref_opt, get_forall err_instance with
@ -518,7 +518,7 @@ let report_error_now
(** Report an error unless is has been reported already, or unless it's a forall error (** 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 let report_error st_report_error find_canonical_duplicate node
err_instance instr_ref_opt loc proc_name = err_instance instr_ref_opt loc proc_name =
let should_report_now = let should_report_now =

@ -8,8 +8,8 @@
*) *)
(** Module to preprocess location information in the AST. (** Module to preprocess location information in the AST.
The original location information is incremental, each location is a delta 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. *) w.r.t. the previous one. This module processes the AST and makes locations explicit. *)
open Utils open Utils
open Clang_ast_j open Clang_ast_j
@ -140,7 +140,7 @@ let pp_ast_decl fmt ast_decl =
(** Compose incremental location information and make locations explicit. *) (** Compose incremental location information and make locations explicit. *)
module LocComposer : sig module LocComposer : sig
(** Status of the composer. *) (** Status of the composer. *)
type status type status
(** Create a new composer with the initial status. *) (** Create a new composer with the initial status. *)
@ -271,9 +271,9 @@ and decl_process_locs loc_composer decl =
(** Process locations in the AST by making them explicit. (** Process locations in the AST by making them explicit.
Each toplevel declaration determines the current file, Each toplevel declaration determines the current file,
and once diving into the details of the declaration, location and once diving into the details of the declaration, location
information about other (include) files is ignored. *) information about other (include) files is ignored. *)
let ast_decl_process_locs loc_composer ast_decl = let ast_decl_process_locs loc_composer ast_decl =
let toplevel_decl_process_locs decl = let toplevel_decl_process_locs decl =

@ -8,8 +8,8 @@
*) *)
(* Take as input an ast file and a C or ObjectiveC file such that the ast file (* 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. corresponds to the compilation of the C file with clang.
Parse the ast file into a data structure and translates it into a cfg. *) Parse the ast file into a data structure and translates it into a cfg. *)
module L = Logging module L = Logging

@ -22,10 +22,10 @@ open CTrans_utils.Nodes
module L = Logging module L = Logging
module type CTrans = sig 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 *) (** 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. *) (** 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 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 *) (** It receives the context and a statement and a warning string and returns the translated sil expression *)

@ -177,7 +177,7 @@ let dispatch_functions = [
("dispatch_group_notify", 2); ("dispatch_group_notify", 2);
("dispatch_group_wait", 2); ("dispatch_group_wait", 2);
("dispatch_barrier_async", 1); ("dispatch_barrier_async", 1);
] ]
let is_dispatch_function_name function_name = let is_dispatch_function_name function_name =
let rec is_dispatch functions = let rec is_dispatch functions =

@ -289,7 +289,7 @@ let is_android_lib_class class_name =
string_is_prefix "android" class_str || string_is_prefix "com.android" class_str 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 (** 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 = let get_callback_registered_by procname args tenv =
(* TODO (t4565077): this check should be replaced with a membership check in a hardcoded list of (* TODO (t4565077): this check should be replaced with a membership check in a hardcoded list of
* Android callback registration methods *) * Android callback registration methods *)
@ -332,7 +332,7 @@ let is_callback_register_method procname args tenv =
| None -> false | None -> false
(** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity) and (** 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 = let get_lifecycle_for_framework_typ_opt lifecycle_typ lifecycle_proc_strs tenv =
match Sil.get_typ lifecycle_typ None tenv with match Sil.get_typ lifecycle_typ None tenv with
| Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) -> | Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) ->

@ -15,8 +15,8 @@ open Utils
(** Automatically create a harness method to exercise code under test *) (** 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 (** 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 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]. *) 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 insert_after lst test to_insert =
let rec insert_rec to_process processed = match to_process with let rec insert_rec to_process processed = match to_process with
| instr :: to_process -> | instr :: to_process ->
@ -29,7 +29,7 @@ let insert_after lst test to_insert =
insert_rec lst [] insert_rec lst []
(** find callees that register callbacks and add instrumentation to extract the callback. (** 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 = 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 (* try to turn a nasty callback name like MyActivity$1 into a nice callback name like
* Button.OnClickListener[line 7]*) * Button.OnClickListener[line 7]*)
@ -109,7 +109,7 @@ let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv =
) lifecycle_cfg_files [] ) lifecycle_cfg_files []
(** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a (** 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 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, _) | Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _)
when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv && when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv &&
@ -124,8 +124,8 @@ let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map t
| _ -> [] | _ -> []
(** get all the callbacks registered in [lifecycle_trace], transform the SIL to "extract" them into (** 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 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 *) of the (field, typ) pairs that we have created for this purpose *)
let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv = let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let harness_name = Mangled.from_string (Procname.to_string harness_procname) in let harness_name = Mangled.from_string (Procname.to_string harness_procname) in
let registered_cbs = let registered_cbs =

@ -8,7 +8,7 @@
*) *)
(** Generate a procedure that calls a given sequence of methods. Useful for harness/test (** Generate a procedure that calls a given sequence of methods. Useful for harness/test
* generation. *) * generation. *)
module L = Logging module L = Logging
module F = Format module F = Format
@ -22,7 +22,7 @@ type lifecycle_trace = (Procname.t * Sil.typ option) list
type callback_trace = (Sil.exp * Sil.typ) list type callback_trace = (Sil.exp * Sil.typ) list
(** list of instrs and temporary variables created during inhabitation and a cache of types that (** 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; type env = { instrs : Sil.instr list;
tmp_vars : Ident.t list; tmp_vars : Ident.t list;
cache : Sil.exp TypMap.t; cache : Sil.exp TypMap.t;
@ -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 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 (** 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 * 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. *) * component but the size component of ret_typ is always -1. *)
let inhabit_alloc sizeof_typ ret_typ alloc_kind env = let inhabit_alloc sizeof_typ ret_typ alloc_kind env =
let retval = Ident.create_fresh Ident.knormal in let retval = Ident.create_fresh Ident.knormal in
let inhabited_exp = Sil.Var retval in let inhabited_exp = Sil.Var retval in
@ -162,7 +162,7 @@ and inhabit_args formals proc_file_map env =
list_fold_right inhabit_arg formals ([], env) list_fold_right inhabit_arg formals ([], env)
(** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the (** 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 = and inhabit_constructor constr_name (allocated_obj, obj_type) proc_file_map env =
try try
(* this lookup can fail when we try to get the procdesc of a procedure from a different (* this lookup can fail when we try to get the procdesc of a procedure from a different
@ -318,7 +318,7 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
) (Cfg.Node.get_callees harness_node) ) (Cfg.Node.get_callees harness_node)
(** create and fill the appropriate nodes and add them to the harness cfg. also add the harness (** 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 = 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 *) (* TMP: pick an arbitrary cg and cfg to piggyback the harness code onto *)
(* TODO (t4707171): create our own fresh cfg / cg instead *) (* TODO (t4707171): create our own fresh cfg / cg instead *)
@ -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 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 (** 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 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_cfg = Cfg.Node.create_cfg () in
let harness_file = create_dummy_harness_file harness_name harness_cfg tenv in let harness_file = create_dummy_harness_file harness_name harness_cfg tenv in

@ -32,7 +32,7 @@ type stack_frame =
| Unresolved of str_frame | Unresolved of str_frame
(** list representation of a stack trace. head of the list is the top of the stack (line/proc where (** 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 type stack_trace = stack_frame list
(** given [str_frame], try to resolve its components in [exe_env] *) (** given [str_frame], try to resolve its components in [exe_env] *)
@ -59,7 +59,7 @@ let try_resolve_frame str_frame exe_env tenv =
with Not_found -> 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, (** 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 = let parse_frame frame_str exe_env tenv =
(* separate the qualified method name and the parenthesized text/line number*) (* separate the qualified method name and the parenthesized text/line number*)
ignore(Str.string_match (Str.regexp "at \\(.*\\)(\\(.*\\))") frame_str 0); ignore(Str.string_match (Str.regexp "at \\(.*\\)(\\(.*\\))") frame_str 0);

@ -150,8 +150,8 @@ let is_classname_cached cn =
Sys.file_exists (path_of_cached_classname cn) Sys.file_exists (path_of_cached_classname cn)
(* Given a source file and a class, translates the code of this class. (* 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 init - mode, finds out whether this class contains initializers at all,
in this case translates it. In standard mode, all methods are translated *) 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 = let create_icfg never_null_matcher linereader program icfg source_file cn node =
JUtils.log "\tclassname: %s@." (JBasics.cn_name cn); JUtils.log "\tclassname: %s@." (JBasics.cn_name cn);
cache_classname cn; cache_classname cn;
@ -196,8 +196,8 @@ let should_capture classes source_basename node =
(* Computes the control - flow graph and call - graph of a given source file. (* 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 In the standard - mode, it translated all the classes that correspond to this
source file. *) source file. *)
let compute_source_icfg let compute_source_icfg
never_null_matcher linereader classes program tenv source_basename source_file = never_null_matcher linereader classes program tenv source_basename source_file =
let icfg = let icfg =

@ -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 let init_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap.empty
(** Fix the line associated to a method definition. (** Fix the line associated to a method definition.
Since Sawja often reports a method off by a few lines, we search Since Sawja often reports a method off by a few lines, we search
backwards for a line where the method name is. *) backwards for a line where the method name is. *)
let fix_method_definition_line linereader proc_name loc = let fix_method_definition_line linereader proc_name loc =
let method_name = let method_name =
if Procname.is_constructor proc_name then if Procname.is_constructor proc_name then
@ -142,8 +142,8 @@ let formals program tenv cn impl =
list_rev (list_fold_left collect [] (JBir.params impl)) list_rev (list_fold_left collect [] (JBir.params impl))
(** Creates the local and formal variables from a procedure based on the (** 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 impl argument. If the meth_kind is Init, we add a parameter field to
the initialiser method. *) the initialiser method. *)
let locals_formals program tenv cn impl meth_kind = let locals_formals program tenv cn impl meth_kind =
let form_list = let form_list =
if meth_kind = JContext.Init then if meth_kind = JContext.Init then
@ -799,7 +799,7 @@ let instruction_array_call ms obj_type obj args var_opt vt =
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. (* 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 = let instruction_thread_start context cn ms obj args var_opt =
match JClasspath.lookup_node cn (JContext.get_program context) with match JClasspath.lookup_node cn (JContext.get_program context) with
| None -> | None ->

@ -33,7 +33,7 @@ let is_basic_type fs =
| JBasics.TObject ot -> false | JBasics.TObject ot -> false
(** Returns whether the node contains static final fields (** 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 rec has_static_final_fields node =
let detect fs f test = let detect fs f test =
test || (Javalib.is_static_field f && Javalib.is_final_field f) in 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 *) (* Patricia trees *)
(** collects the code line where the fields are initialised. The list is (** 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 collect_field_pc instrs field_pc_list =
let aux pc instr = let aux pc instr =
match instr with match instr with
@ -53,7 +53,7 @@ let collect_field_pc instrs field_pc_list =
(List.rev !field_pc_list) (List.rev !field_pc_list)
(** Changes every position in the code where a static field is set to a value, (** 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 add_return_field instrs =
let aux instr = let aux instr =
match instr with match instr with
@ -63,8 +63,8 @@ let add_return_field instrs =
(Array.map aux instrs) (Array.map aux instrs)
(** Given a list with the lines where the fields are initialised, (** 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, 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. *) which is the line after the previous field has been initialised. *)
let rec find_pc field list = let rec find_pc field list =
match list with match list with
| (fs, pc):: rest -> | (fs, pc):: rest ->
@ -107,9 +107,9 @@ let has_unclear_control_flow code =
(** In the initialiser of static fields, we add instructions (** 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. (* 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 rec static_field_init_complex cn code fields length =
let code = Array.append [| (JBir.Goto length ) |] code in let code = Array.append [| (JBir.Goto length ) |] code in
let s = JConfig.field_cst in let s = JConfig.field_cst in
@ -140,8 +140,8 @@ let rec static_field_init_complex cn code fields length =
code code
(** In the initialiser of static fields, we add instructions (** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter without changing for returning the field selected by the parameter without changing
the control flow of the original code. *) the control flow of the original code. *)
let rec static_field_init_simple cn code fields length = let rec static_field_init_simple cn code fields length =
let s = JConfig.field_cst in let s = JConfig.field_cst in
let rec aux s pc fields = let rec aux s pc fields =
@ -161,13 +161,13 @@ let rec static_field_init_simple cn code fields length =
code code
(** In the initialiser of static fields, we add instructions (** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter. In normal for returning the field selected by the parameter. In normal
cases the code for the initialisation of each field is clearly separated 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 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. 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 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 of each field, so we do not change the original code, but append intructions
for returning the selected field. *) for returning the selected field. *)
let rec static_field_init node cn code = let rec static_field_init node cn code =
try try
let field_list = JBasics.FieldMap.elements (Javalib.get_fields node) in let field_list = JBasics.FieldMap.elements (Javalib.get_fields node) in

@ -421,7 +421,7 @@ let extract_array_type typ =
(** translate the type of an expression, looking in the method signature for formal parameters (** 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 rec expr_type context expr =
let program = JContext.get_program context in let program = JContext.get_program context in
let tenv = JContext.get_tenv context in let tenv = JContext.get_tenv context in
@ -438,8 +438,8 @@ let rec expr_type context expr =
(** Returns the return type of the method based on the return type (** Returns the return type of the method based on the return type
specified in ms. If the method is the initialiser, return the type specified in ms. If the method is the initialiser, return the type
Object instead. *) Object instead. *)
let return_type program tenv ms meth_kind = let return_type program tenv ms meth_kind =
if meth_kind = JContext.Init then if meth_kind = JContext.Init then
get_class_type program tenv (JBasics.make_cn JConfig.object_cl) get_class_type program tenv (JBasics.make_cn JConfig.object_cl)

@ -20,5 +20,5 @@ let () = try
let prog = LParser.prog LLexer.token lexbuf in let prog = LParser.prog LLexer.token lexbuf in
let pretty = LPretty.pretty_prog prog in let pretty = LPretty.pretty_prog prog in
LTrans.gen_prog prog; () LTrans.gen_prog prog; ()
with with
| UsageError msg -> print_string ("Usage error: " ^ msg ^ "\n") | UsageError msg -> print_string ("Usage error: " ^ msg ^ "\n")

Loading…
Cancel
Save