(*
* Copyright ( c ) 2009 - 2013 Monoidics ltd .
* Copyright ( c ) 2013 - present Facebook , Inc .
* All rights reserved .
*
* This source code is licensed under the BSD style license found in the
* LICENSE file in the root directory of this source tree . An additional grant
* of patent rights can be found in the PATENTS file in the same directory .
* )
(* * Execution Paths *)
module L = Logging
module F = Format
open Utils
(* =============== START of the Path module =============== *)
module Path : sig
(* * type for paths *)
type t
type session = int
(* * add a call with its sub-path, the boolean indicates whether the subtrace for the procedure should be included *)
val add_call : bool -> t -> Procname . t -> t -> t
(* * check whether a path contains another path *)
val contains : t -> t -> bool
(* * check wether the path contains the given position *)
val contains_position : t -> Sil . path_pos -> bool
(* * Create the location trace of the path, up to the path position if specified *)
val create_loc_trace : t -> Sil . path_pos option -> Errlog . loc_trace
(* * return the current node of the path *)
val curr_node : t -> Cfg . node
(* * dump a path *)
val d : t -> unit
(* * dump statistics of the path *)
val d_stats : t -> unit
(* * equality for paths *)
val equal : t -> t -> bool
(* * extend a path with a new node reached from the given session, with an optional string for exceptions *)
val extend : Cfg . node -> Mangled . t option -> session -> t -> t
(* * extend a path with a new node reached from the given session, with an optional string for exceptions *)
val add_description : t -> string -> t
val get_description : t -> string option
(* * iterate over each node in the path, excluding calls, once *)
val iter_all_nodes_nocalls : ( Cfg . node -> unit ) -> t -> unit
(* * iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
Do not iterate past the given position .
[ f level path session exn_opt ] is passed the current nesting [ level ] and [ path ] and previous [ session ] * )
val iter_longest_sequence : ( int -> t -> int -> Mangled . t option -> unit ) -> Sil . path_pos option -> t -> unit
(* * join two paths *)
val join : t -> t -> t
(* * pretty print a path *)
val pp : Format . formatter -> t -> unit
(* * pretty print statistics of the path *)
val pp_stats : Format . formatter -> t -> unit
(* * create a new path with given start node *)
val start : Cfg . node -> t
end = struct
type session = int
type stats =
{ mutable max_length : int ; (* length of the longest linear sequence *)
mutable linear_num : float ; (* number of linear sequences described by the path *) }
type path =
(* INVARIANT: stats are always set to dummy_stats unless we are in the middle of a traversal *)
(* in particular: a new traversal cannot be initiated during an existing traversal *)
| Pstart of Cfg . node * stats (* * start node *)
| Pnode of Cfg . node * Mangled . t option * session * path * stats * string option (* * we got to [node] from last [session] perhaps propagating exception [exn_opt], and continue with [path]. *)
| Pjoin of path * path * stats (* * join of two paths *)
| Pcall of path * Procname . t * path * stats (* * add a sub-path originating from a call *)
type t = path
let get_dummy_stats () =
{ max_length = - 1 ;
linear_num = - 1 . 0 }
let get_description path =
match path with
| Pnode ( node , exn_opt , session , path , stats , descr_opt ) ->
descr_opt
| _ -> None
let add_description path description =
let add_descr descr_option description =
match descr_option with
| Some descr -> descr ^ " " ^ description
| None -> description in
match path with
| Pnode ( node , exn_opt , session , path , stats , descr_opt ) ->
let description = add_descr descr_opt description in
Pnode ( node , exn_opt , session , path , stats , Some description )
| _ -> path
let set_dummy_stats stats =
stats . max_length <- - 1 ;
stats . linear_num <- - 1 . 0
let rec curr_node = function
| Pstart ( node , _ ) -> node
| Pnode ( node , _ , _ , _ , _ , _ ) -> node
| Pcall ( p1 , _ , _ , _ ) -> curr_node p1
| Pjoin _ -> assert false
let exname_opt_compare eo1 eo2 = match eo1 , eo2 with
| None , None -> 0
| None , _ -> - 1
| _ , None -> 1
| Some n1 , Some n2 -> Mangled . compare n1 n2
let rec compare p1 p2 : int =
if p1 = = p2 then 0 else match p1 , p2 with
| Pstart ( n1 , _ ) , Pstart ( n2 , _ ) ->
Cfg . Node . compare n1 n2
| Pstart _ , _ -> - 1
| _ , Pstart _ -> 1
| Pnode ( n1 , eo1 , s1 , p1 , _ , _ ) , Pnode ( n2 , eo2 , s2 , p2 , _ , _ ) ->
let n = Cfg . Node . compare n1 n2 in
if n < > 0 then n else let n = exname_opt_compare eo1 eo2 in
if n < > 0 then n else let n = int_compare s1 s2 in
if n < > 0 then n else compare p1 p2
| Pnode _ , _ -> - 1
| _ , Pnode _ -> 1
| Pjoin ( p1 , q1 , _ ) , Pjoin ( p2 , q2 , _ ) ->
let n = compare p1 p2 in
if n < > 0 then n else compare q1 q2
| Pjoin _ , _ -> - 1
| _ , Pjoin _ -> 1
| Pcall ( p1 , _ , sub1 , _ ) , Pcall ( p2 , _ , sub2 , _ ) ->
let n = compare p1 p2 in
if n < > 0 then n else compare sub1 sub2
let equal p1 p2 =
compare p1 p2 = 0
let start node = Pstart ( node , get_dummy_stats () )
let extend ( node : Cfg . node ) exn_opt session path =
Pnode ( node , exn_opt , session , path , get_dummy_stats () , None )
let join p1 p2 =
Pjoin ( p1 , p2 , get_dummy_stats () )
let add_call include_subtrace p pname p_sub =
if include_subtrace then Pcall ( p , pname , p_sub , get_dummy_stats () )
else p
module Invariant = (* * functions in this module either do not assume, or do not re-establish, the invariant on dummy stats *)
struct
(* * check whether a stats is the dummy stats *)
let stats_is_dummy stats =
stats . max_length = = - 1
(* * return the stats of the path *)
(* * assumes that the stats are computed *)
let get_stats = function
| Pstart ( _ , stats ) -> stats
| Pnode ( _ , _ , _ , _ , stats , _ ) -> stats
| Pjoin ( _ , _ , stats ) -> stats
| Pcall ( _ , _ , _ , stats ) -> stats
(* * restore the invariant that all the stats are dummy, so the path is ready for another traversal *)
(* * assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *)
let rec reset_stats = function
| Pstart ( node , stats ) ->
if not ( stats_is_dummy stats ) then set_dummy_stats stats
| Pnode ( node , exn_opt , session , path , stats , _ ) ->
if not ( stats_is_dummy stats ) then
begin
reset_stats path ;
set_dummy_stats stats
end
| Pjoin ( path1 , path2 , stats ) ->
if not ( stats_is_dummy stats ) then
begin
reset_stats path1 ;
reset_stats path2 ;
set_dummy_stats stats
end
| Pcall ( path1 , pname , path2 , stats ) ->
if not ( stats_is_dummy stats ) then
begin
reset_stats path1 ;
reset_stats path2 ;
set_dummy_stats stats
end
(* * Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *)
(* * Function [f] ( typically with side-effects ) is applied once to every node, and max_length in the stats
is the length of a longest sequence of nodes in the path where [ f ] returned [ true ] on at least one node .
max_length is 0 if the path was visited but no node satisfying [ f ] was found . * )
(* * Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *)
(* * Since this breaks the invariant, it must be followed by reset_stats. *)
let rec compute_stats do_calls ( f : Cfg . Node . t -> bool ) =
let nodes_found stats = stats . max_length > 0 in
function
| Pstart ( node , stats ) ->
if stats_is_dummy stats then
begin
let found = f node in
stats . max_length <- if found then 1 else 0 ;
stats . linear_num <- 1 . 0 ;
end
| Pnode ( node , exn_opt , session , path , stats , _ ) ->
if stats_is_dummy stats then
begin
compute_stats do_calls f path ;
let stats1 = get_stats path in
let found = f node | | nodes_found stats1 (* the order is important as f has side-effects *) in
stats . max_length <- if found then 1 + stats1 . max_length else 0 ;
stats . linear_num <- stats1 . linear_num ;
end
| Pjoin ( path1 , path2 , stats ) ->
if stats_is_dummy stats then
begin
compute_stats do_calls f path1 ;
compute_stats do_calls f path2 ;
let stats1 , stats2 = get_stats path1 , get_stats path2 in
stats . max_length <- max stats1 . max_length stats2 . max_length ;
stats . linear_num <- stats1 . linear_num + . stats2 . linear_num
end
| Pcall ( path1 , pname , path2 , stats ) ->
if stats_is_dummy stats then
begin
let stats2 = match do_calls with
| true ->
compute_stats do_calls f path2 ;
get_stats path2
| false ->
{ max_length = 0 ;
linear_num = 0 . 0 } in
let stats1 =
let f' =
if nodes_found stats2
then fun _ -> true (* already found in call, no need to search before the call *)
else f in
compute_stats do_calls f' path1 ;
get_stats path1 in
stats . max_length <- stats1 . max_length + stats2 . max_length ;
stats . linear_num <- stats1 . linear_num ;
end
end (* End of module Invariant *)
(* * iterate over each node in the path, excluding calls, once *)
let iter_all_nodes_nocalls f path =
Invariant . compute_stats false ( fun node -> f node ; true ) path ;
Invariant . reset_stats path
let get_path_pos node =
let pn = Cfg . Procdesc . get_proc_name ( Cfg . Node . get_proc_desc node ) in
let n_id = Cfg . Node . get_id node in
( pn , n_id )
let contains_position path pos =
let found = ref false in
let f node =
if Sil . path_pos_equal ( get_path_pos node ) pos then found := true ;
true in
Invariant . compute_stats true f path ;
Invariant . reset_stats path ;
! found
(* * iterate over the longest sequence belonging to the path, restricting to those where [filter] holds of some element.
if a node is reached via an exception , pass the exception information to [ f ] on the previous node * )
let iter_longest_sequence_filter ( f : int -> t -> int -> Mangled . t option -> unit ) ( filter : Cfg . Node . t -> bool ) ( path : t ) : unit =
let rec doit level session path prev_exn_opt = match path with
| Pstart _ -> f level path session prev_exn_opt
| Pnode ( node , exn_opt , session' , p , _ , _ ) ->
let next_exn_opt = if prev_exn_opt < > None then None else exn_opt in (* no two consecutive exceptions *)
doit level session' p next_exn_opt ;
f level path session prev_exn_opt
| Pjoin ( p1 , p2 , _ ) ->
if ( Invariant . get_stats p1 ) . max_length > = ( Invariant . get_stats p2 ) . max_length then doit level session p1 prev_exn_opt else doit level session p2 prev_exn_opt
| Pcall ( p1 , _ , p2 , _ ) ->
let next_exn_opt = None in (* exn must already be inside the call *)
doit level session p1 next_exn_opt ;
doit ( level + 1 ) session p2 next_exn_opt in
Invariant . compute_stats true filter path ;
doit 0 0 path None ;
Invariant . reset_stats path
(* * iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
Do not iterate past the last occurrence of the given position .
[ f level path session exn_opt ] is passed the current nesting [ level ] and [ path ] and previous [ session ] and possible exception [ exn_opt ] * )
let iter_longest_sequence ( f : int -> t -> int -> Mangled . t option -> unit ) ( pos_opt : Sil . path_pos option ) ( path : t ) : unit =
let filter node = match pos_opt with
| None -> true
| Some pos -> Sil . path_pos_equal ( get_path_pos node ) pos in
let path_pos_at_path p =
try
let node = curr_node p in
pos_opt < > None && filter node
with exn when exn_not_timeout exn -> false in
let position_seen = ref false in
let inverse_sequence =
let log = ref [] in
let g level p session exn_opt =
if path_pos_at_path p then position_seen := true ;
log := ( level , p , session , exn_opt ) :: ! log in
iter_longest_sequence_filter g filter path ;
! log in
let sequence_up_to_last_seen =
if ! position_seen then
let rec remove_until_seen = function
| ( ( level , p , session , exn_opt ) as x ) :: l ->
if path_pos_at_path p then list_rev ( x :: l )
else remove_until_seen l
| [] -> [] in
remove_until_seen inverse_sequence
else list_rev inverse_sequence in
list_iter ( fun ( level , p , session , exn_opt ) -> f level p session exn_opt ) sequence_up_to_last_seen
module NodeMap = Map . Make ( Cfg . Node )
(* * return the node visited most, and number of visits, in the longest linear sequence *)
let repetitions path =
let map = ref NodeMap . empty in
let add_node node =
try
let n = NodeMap . find node ! map in
map := NodeMap . add node ( n + 1 ) ! map
with Not_found ->
map := NodeMap . add node 1 ! map in
iter_longest_sequence ( fun level p s exn_opt -> add_node ( curr_node p ) ) None path ;
let max_rep_node = ref ( Cfg . Node . dummy () ) in
let max_rep_num = ref 0 in
NodeMap . iter ( fun node num -> if num > ! max_rep_num then ( max_rep_node := node ; max_rep_num := num ) ) ! map ;
( ! max_rep_node , ! max_rep_num )
let stats_string path =
Invariant . compute_stats true ( fun _ -> true ) path ;
let node , repetitions = repetitions path in
let str =
" linear paths: " ^ string_of_float ( Invariant . get_stats path ) . linear_num ^
" max length: " ^ string_of_int ( Invariant . get_stats path ) . max_length ^
" has repetitions: " ^ string_of_int repetitions ^
" of node " ^ ( string_of_int ( Cfg . Node . get_id node ) ) in
Invariant . reset_stats path ;
str
let pp_stats fmt path =
F . fprintf fmt " %s " ( stats_string path )
let d_stats path =
L . d_str ( stats_string path )
module PathMap = Map . Make ( struct
type t = path
let compare = compare
end )
let pp fmt path =
let delayed_num = ref 0 in
let delayed = ref PathMap . empty in
let add_path p =
try ignore ( PathMap . find p ! delayed ) with Not_found ->
incr delayed_num ;
delayed := PathMap . add p ! delayed_num ! delayed in
let path_seen p = (* path seen before *)
PathMap . mem p ! delayed in
let rec add_delayed path =
if not ( path_seen path ) (* avoid exponential blowup *)
then match path with (* build a map from delayed paths to a unique number *)
| Pstart _ -> ()
| Pnode ( _ , _ , _ , p , _ , _ ) -> add_delayed p
| Pjoin ( p1 , p2 , _ ) | Pcall ( p1 , _ , p2 , _ ) -> (* delay paths occurring in a join *)
add_delayed p1 ;
add_delayed p2 ;
add_path p1 ;
add_path p2 in
let rec doit n fmt path =
try
if n > 0 then raise Not_found ;
let num = PathMap . find path ! delayed in
F . fprintf fmt " P%d " num
with Not_found ->
match path with
| Pstart ( node , _ ) -> F . fprintf fmt " n%a " Cfg . Node . pp node
| Pnode ( node , exn_top , session , path , _ , _ ) -> F . fprintf fmt " %a(s%d).n%a " ( doit ( n - 1 ) ) path session Cfg . Node . pp node
| Pjoin ( path1 , path2 , _ ) -> F . fprintf fmt " (%a + %a) " ( doit ( n - 1 ) ) path1 ( doit ( n - 1 ) ) path2
| Pcall ( path1 , _ , path2 , _ ) -> F . fprintf fmt " (%a{%a}) " ( doit ( n - 1 ) ) path1 ( doit ( n - 1 ) ) path2 in
let print_delayed () =
if not ( PathMap . is_empty ! delayed ) then begin
let f path num = F . fprintf fmt " P%d = %a@ \n " num ( doit 1 ) path in
F . fprintf fmt " where@ \n " ;
PathMap . iter f ! delayed
end in
add_delayed path ;
doit 0 fmt path ;
print_delayed ()
let d p =
L . add_print_action ( L . PTpath , Obj . repr p )
let rec contains p1 p2 = match p2 with
| Pjoin ( p2' , p2'' , _ ) ->
contains p1 p2' | | contains p1 p2''
| _ -> p1 = = p2
let create_loc_trace path pos_opt : Errlog . loc_trace =
let trace = ref [] in
let mk_trace_elem level loc descr node_tags =
{ Errlog . lt_level = level ;
Errlog . lt_loc = loc ;
Errlog . lt_description = descr ;
Errlog . lt_node_tags = node_tags } in
let g level path session exn_opt =
let curr_node = curr_node path in
let curr_loc = Cfg . Node . get_loc curr_node in
match Cfg . Node . get_kind curr_node with
| Cfg . Node . Join_node -> () (* omit join nodes from error traces *)
| Cfg . Node . Start_node pdesc ->
let pname = Cfg . Procdesc . get_proc_name pdesc in
let name = Procname . to_string pname in
let name_id = Procname . to_filename pname in
let descr = " start of procedure " ^ ( Procname . to_simplified_string pname ) in
let node_tags = [ ( Io_infer . Xml . tag_kind , " procedure_start " ) ; ( Io_infer . Xml . tag_name , name ) ; ( Io_infer . Xml . tag_name_id , name_id ) ] in
trace := mk_trace_elem level curr_loc descr node_tags :: ! trace
| Cfg . Node . Prune_node ( is_true_branch , if_kind , _ ) ->
let descr = match is_true_branch , if_kind with
| true , Sil . Ik_if -> " Taking true branch "
| false , Sil . Ik_if -> " Taking false branch "
| true , ( Sil . Ik_for | Sil . Ik_while | Sil . Ik_dowhile ) -> " Loop condition is true. Entering loop body "
| false , ( Sil . Ik_for | Sil . Ik_while | Sil . Ik_dowhile ) -> " Loop condition is false. Leaving loop "
| true , Sil . Ik_switch -> " Switch condition is true. Entering switch case "
| false , Sil . Ik_switch -> " Switch condition is false. Skipping switch case "
| true , ( Sil . Ik_bexp | Sil . Ik_land_lor ) -> " Condition is true "
| false , ( Sil . Ik_bexp | Sil . Ik_land_lor ) -> " Condition is false " in
let node_tags = [ ( Io_infer . Xml . tag_kind , " condition " ) ; ( Io_infer . Xml . tag_branch , if is_true_branch then " true " else " false " ) ] in
trace := mk_trace_elem level curr_loc descr node_tags :: ! trace
| Cfg . Node . Exit_node pdesc ->
let pname = Cfg . Procdesc . get_proc_name pdesc in
let descr = " return from a call to " ^ ( Procname . to_string pname ) in
let name = Procname . to_string pname in
let name_id = Procname . to_filename pname in
let node_tags = [ ( Io_infer . Xml . tag_kind , " procedure_end " ) ; ( Io_infer . Xml . tag_name , name ) ; ( Io_infer . Xml . tag_name_id , name_id ) ] in
trace := mk_trace_elem level curr_loc descr node_tags :: ! trace
| _ ->
let descr , node_tags =
match exn_opt with
| None -> " " , []
| Some exn_name ->
let exn_str = Mangled . to_string exn_name in
if exn_str = " "
then " exception " , [ ( Io_infer . Xml . tag_kind , " exception " ) ]
else " exception " ^ exn_str , [ ( Io_infer . Xml . tag_kind , " exception " ) ; ( Io_infer . Xml . tag_name , exn_str ) ] in
let descr =
match get_description path with
| Some path_descr ->
if String . length descr > 0 then descr ^ " " ^ path_descr else path_descr
| None -> descr in
trace := mk_trace_elem level curr_loc descr node_tags :: ! trace in
iter_longest_sequence g pos_opt path ;
let compare lt1 lt2 =
let n = int_compare lt1 . Errlog . lt_level lt2 . Errlog . lt_level in
if n < > 0 then n else Sil . loc_compare lt1 . Errlog . lt_loc lt2 . Errlog . lt_loc in
let relevant lt = lt . Errlog . lt_node_tags < > [] in
list_remove_irrelevant_duplicates compare relevant ( list_rev ! trace )
(* list_remove_duplicates compare ( list_sort compare !trace ) *)
end
(* =============== END of the Path module =============== *)
module PropMap = Map . Make ( struct
type t = Prop . normal Prop . t
let compare = Prop . prop_compare
end )
(* =============== START of the PathSet module =============== *)
module PathSet : sig
type t
(* * It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *)
val add_renamed_prop : Prop . normal Prop . t -> Path . t -> t -> t
(* * dump the pathset *)
val d : t -> unit
(* * difference between two pathsets *)
val diff : t -> t -> t
(* * empty pathset *)
val empty : t
(* * list of elements in a pathset *)
val elements : t -> ( Prop . normal Prop . t * Path . t ) list
(* * equality for pathsets *)
val equal : t -> t -> bool
(* * filter a pathset on the prop component *)
val filter : ( Prop . normal Prop . t -> bool ) -> t -> t
(* * find the list of props whose associated path contains the given path *)
val filter_path : Path . t -> t -> Prop . normal Prop . t list
(* * fold over a pathset *)
val fold : ( Prop . normal Prop . t -> Path . t -> ' a -> ' a ) -> t -> ' a -> ' a
(* * It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *)
val from_renamed_list : ( Prop . normal Prop . t * Path . t ) list -> t
(* * check whether the pathset is empty *)
val is_empty : t -> bool
(* * iterate over a pathset *)
val iter : ( Prop . normal Prop . t -> Path . t -> unit ) -> t -> unit
(* * map over the prop component of a pathset *)
val map : ( Prop . normal Prop . t -> Prop . normal Prop . t ) -> t -> t
(* * map over the prop component of a pathset using a partial function; elements mapped to None are discarded *)
val map_option : ( Prop . normal Prop . t -> Prop . normal Prop . t option ) -> t -> t
(* * partition a pathset on the prop component *)
val partition : ( Prop . normal Prop . t -> bool ) -> t -> t * t
(* * pretty print the pathset *)
val pp : printenv -> Format . formatter -> t -> unit
(* * number of elements in the pathset *)
val size : t -> int
(* * convert to a list of props *)
val to_proplist : t -> Prop . normal Prop . t list
(* * convert to a set of props *)
val to_propset : t -> Propset . t
(* * union of two pathsets *)
val union : t -> t -> t
end = struct
type t = Path . t PropMap . t
let equal = PropMap . equal ( fun p1 p2 -> true ) (* only discriminate props, and ignore paths *) (* Path.equal *)
let empty : t = PropMap . empty
let elements ps =
let plist = ref [] in
let f prop path = plist := ( prop , path ) :: ! plist in
PropMap . iter f ps ;
! plist
let to_proplist ps =
list_map fst ( elements ps )
let to_propset ps =
Propset . from_proplist ( to_proplist ps )
let filter f ps =
let elements = ref [] in
PropMap . iter ( fun p _ -> elements := p :: ! elements ) ps ;
elements := list_filter ( fun p -> not ( f p ) ) ! elements ;
let filtered_map = ref ps in
list_iter ( fun p -> filtered_map := PropMap . remove p ! filtered_map ) ! elements ;
! filtered_map
let partition f ps =
let elements = ref [] in
PropMap . iter ( fun p _ -> elements := p :: ! elements ) ps ;
let el1 , el2 = ref ps , ref ps in
list_iter ( fun p -> if f p then el2 := PropMap . remove p ! el2 else el1 := PropMap . remove p ! el1 ) ! elements ;
! el1 , ! el2
(* * It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *)
let add_renamed_prop ( p : Prop . normal Prop . t ) ( path : Path . t ) ( ps : t ) : t =
let path_new =
try
let path_old = PropMap . find p ps in
Path . join path_old path
with Not_found -> path in
PropMap . add p path_new ps
let union ( ps1 : t ) ( ps2 : t ) : t =
PropMap . fold add_renamed_prop ps1 ps2
(* * check if the nodes in path p1 are a subset of those in p2 ( not trace subset ) *)
let path_nodes_subset p1 p2 =
let get_nodes p =
let s = ref Cfg . NodeSet . empty in
Path . iter_all_nodes_nocalls ( fun n -> s := Cfg . NodeSet . add n ! s ) p ;
! s in
Cfg . NodeSet . subset ( get_nodes p1 ) ( get_nodes p2 )
(* * difference between pathsets for the differential fixpoint *)
let diff ( ps1 : t ) ( ps2 : t ) : t =
let res = ref ps1 in
let rem p path =
try
let path_old = PropMap . find p ! res in
if path_nodes_subset path path_old (* do not propagate new path if it has no new nodes *)
then res := PropMap . remove p ! res
with Not_found ->
res := PropMap . remove p ! res in
PropMap . iter rem ps2 ;
! res
let is_empty = PropMap . is_empty
let iter = PropMap . iter
let fold = PropMap . fold
let map_option f ps =
let res = ref empty in
let do_elem prop path = match f prop with
| None -> ()
| Some prop' -> res := add_renamed_prop prop' path ! res in
iter do_elem ps ;
! res
let map f ps =
map_option ( fun p -> Some ( f p ) ) ps
let size ps =
let res = ref 0 in
let add p _ = incr res in
let () = PropMap . iter add ps
in ! res
let pp pe fmt ps =
let count = ref 0 in
let pp_path fmt path =
F . fprintf fmt " [path: %a@ \n %a] " Path . pp_stats path Path . pp path in
let f prop path =
incr count ;
F . fprintf fmt " PROP %d:%a@ \n %a@ \n " ! count pp_path path ( Prop . pp_prop pe ) prop in
iter f ps
let d ( ps : t ) = L . add_print_action ( L . PTpathset , Obj . repr ps )
let filter_path path ps =
let plist = ref [] in
let f prop path' =
if Path . contains path path'
then plist := prop :: ! plist in
iter f ps ;
! plist
(* * It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *)
let from_renamed_list ( pl : ( ' a Prop . t * Path . t ) list ) : t =
list_fold_left ( fun ps ( p , pa ) -> add_renamed_prop p pa ps ) empty pl
end
(* =============== END of the PathSet module =============== *)
