@ -42,15 +42,15 @@ module Core : sig
sigma : sigma ; (* * spatial part *)
sigma : sigma ; (* * spatial part *)
sub : Sil . subst ; (* * substitution *)
sub : Sil . subst ; (* * substitution *)
pi : pi ; (* * pure part *)
pi : pi ; (* * pure part *)
foot_ sigma : sigma ; (* * abduced spatial part *)
sigma_fp : sigma ; (* * abduced spatial part *)
foot_ pi: pi ; (* * abduced pure part *)
pi_fp : pi ; (* * abduced pure part *)
}
}
(* * Proposition [true /\ emp]. *)
(* * Proposition [true /\ emp]. *)
val prop_emp : normal t
val prop_emp : normal t
(* * Set individual fields of the prop. *)
(* * Set individual fields of the prop. *)
val set : ? sub : Sil . subst -> ? pi : pi -> ? sigma : sigma -> ? foot_ pi: pi -> ? foot_ sigma: sigma ->
val set : ? sub : Sil . subst -> ? pi : pi -> ? sigma : sigma -> ? pi_fp : pi -> ? sigma_fp : sigma ->
' a t -> exposed t
' a t -> exposed t
(* * Cast an exposed prop to a normalized one by just changing the type *)
(* * Cast an exposed prop to a normalized one by just changing the type *)
@ -70,8 +70,8 @@ end = struct
sigma : sigma ; (* * spatial part *)
sigma : sigma ; (* * spatial part *)
sub : Sil . subst ; (* * substitution *)
sub : Sil . subst ; (* * substitution *)
pi : pi ; (* * pure part *)
pi : pi ; (* * pure part *)
foot_ sigma : sigma ; (* * abduced spatial part *)
sigma_fp : sigma ; (* * abduced spatial part *)
foot_ pi: pi ; (* * abduced pure part *)
pi_fp : pi ; (* * abduced pure part *)
}
}
(* * Proposition [true /\ emp]. *)
(* * Proposition [true /\ emp]. *)
@ -80,17 +80,17 @@ end = struct
sub = Sil . sub_empty ;
sub = Sil . sub_empty ;
pi = [] ;
pi = [] ;
sigma = [] ;
sigma = [] ;
foot_ pi = [] ;
pi_fp = [] ;
foot_ sigma = [] ;
sigma_fp = [] ;
}
}
let set ? sub ? pi ? sigma ? foot_ pi ? foot_ sigma p =
let set ? sub ? pi ? sigma ? pi_fp ? sigma_fp p =
let set_ p
let set_ p
? ( sub = p . sub ) ? ( pi = p . pi ) ? ( sigma = p . sigma ) ? ( foot_ pi= p . foot_ pi) ? ( foot_ sigma= p . foot_ sigma) ()
? ( sub = p . sub ) ? ( pi = p . pi ) ? ( sigma = p . sigma ) ? ( pi_fp = p . pi_fp ) ? ( sigma_fp = p . sigma_fp ) ()
=
=
{ sub ; pi ; sigma ; foot_ pi; foot_ sigma }
{ sub ; pi ; sigma ; pi_fp ; sigma_fp }
in
in
set_ p ? sub ? pi ? sigma ? foot_ pi ? foot_ sigma ()
set_ p ? sub ? pi ? sigma ? pi_fp ? sigma_fp ()
let unsafe_cast_to_normal ( p : exposed t ) : normal t =
let unsafe_cast_to_normal ( p : exposed t ) : normal t =
( p :> normal t )
( p :> normal t )
@ -140,8 +140,8 @@ let prop_compare p1 p2 =
sigma_compare p1 . sigma p2 . sigma
sigma_compare p1 . sigma p2 . sigma
| > next Sil . sub_compare p1 . sub p2 . sub
| > next Sil . sub_compare p1 . sub p2 . sub
| > next pi_compare p1 . pi p2 . pi
| > next pi_compare p1 . pi p2 . pi
| > next sigma_compare p1 . foot_ sigma p2 . foot_ sigma
| > next sigma_compare p1 . sigma_fp p2 . sigma_fp
| > next pi_compare p1 . foot_ pi p2 . foot_ pi
| > next pi_compare p1 . pi_fp p2 . pi_fp
(* * Check the equality of two propositions *)
(* * Check the equality of two propositions *)
let prop_equal p1 p2 =
let prop_equal p1 p2 =
@ -153,11 +153,11 @@ let prop_equal p1 p2 =
let pp_footprint _ pe f fp =
let pp_footprint _ pe f fp =
let pe = { _ pe with pe_cmap_norm = _ pe . pe_cmap_foot } in
let pe = { _ pe with pe_cmap_norm = _ pe . pe_cmap_foot } in
let pp_pi f () =
let pp_pi f () =
if fp . foot_ pi != [] then
if fp . pi_fp != [] then
F . fprintf f " %a ;@ \n " ( pp_semicolon_seq_oneline pe ( Sil . pp_atom pe ) ) fp . foot_ pi in
F . fprintf f " %a ;@ \n " ( pp_semicolon_seq_oneline pe ( Sil . pp_atom pe ) ) fp . pi_fp in
if fp . foot_ pi != [] | | fp . foot_ sigma != [] then
if fp . pi_fp != [] | | fp . sigma_fp != [] then
F . fprintf f " @ \n [footprint@ \n @[%a%a@] ] "
F . fprintf f " @ \n [footprint@ \n @[%a%a@] ] "
pp_pi () ( pp_semicolon_seq pe ( Sil . pp_hpred pe ) ) fp . foot_ sigma
pp_pi () ( pp_semicolon_seq pe ( Sil . pp_hpred pe ) ) fp . sigma_fp
let pp_texp_simple pe = match pe . pe_opt with
let pp_texp_simple pe = match pe . pe_opt with
| PP_SIM_DEFAULT -> Sil . pp_texp pe
| PP_SIM_DEFAULT -> Sil . pp_texp pe
@ -251,12 +251,6 @@ let d_pi_sigma pi sigma =
let d_separator () = if pi != [] && sigma != [] then L . d_strln " * " in
let d_separator () = if pi != [] && sigma != [] then L . d_strln " * " in
d_pi pi ; d_separator () ; d_sigma sigma
d_pi pi ; d_separator () ; d_sigma sigma
(* * Return the sub part of [prop]. *)
let get_sub ( p : ' a t ) : Sil . subst = p . sub
(* * Return the pi part of [prop]. *)
let get_pi ( p : ' a t ) : pi = p . pi
let pi_of_subst sub =
let pi_of_subst sub =
IList . map ( fun ( id1 , e2 ) -> Sil . Aeq ( Exp . Var id1 , e2 ) ) ( Sil . sub_to_list sub )
IList . map ( fun ( id1 , e2 ) -> Sil . Aeq ( Exp . Var id1 , e2 ) ) ( Sil . sub_to_list sub )
@ -325,16 +319,16 @@ let pp_footprint_simple _pe env f fp =
let pp_pure f pi =
let pp_pure f pi =
if pi != [] then
if pi != [] then
F . fprintf f " %a *@ \n " ( pp_pi pe ) pi in
F . fprintf f " %a *@ \n " ( pp_pi pe ) pi in
if fp . foot_ pi != [] | | fp . foot_ sigma != [] then
if fp . pi_fp != [] | | fp . sigma_fp != [] then
F . fprintf f " @ \n [footprint@ \n @[%a%a@] ] "
F . fprintf f " @ \n [footprint@ \n @[%a%a@] ] "
pp_pure fp . foot_ pi
pp_pure fp . pi_fp
( pp_sigma_simple pe env ) fp . foot_ sigma
( pp_sigma_simple pe env ) fp . sigma_fp
(* * Create a predicate environment for a prop *)
(* * Create a predicate environment for a prop *)
let prop_pred_env prop =
let prop_pred_env prop =
let env = Sil . Predicates . empty_env () in
let env = Sil . Predicates . empty_env () in
IList . iter ( Sil . Predicates . process_hpred env ) prop . sigma ;
IList . iter ( Sil . Predicates . process_hpred env ) prop . sigma ;
IList . iter ( Sil . Predicates . process_hpred env ) prop . foot_ sigma;
IList . iter ( Sil . Predicates . process_hpred env ) prop . sigma_fp ;
env
env
(* * Pretty print a proposition. *)
(* * Pretty print a proposition. *)
@ -342,9 +336,9 @@ let pp_prop pe0 f prop =
let pe = prop_update_obj_sub pe0 prop in
let pe = prop_update_obj_sub pe0 prop in
let latex = pe . pe_kind = = PP_LATEX in
let latex = pe . pe_kind = = PP_LATEX in
let do_print f () =
let do_print f () =
let subl = Sil . sub_to_list ( get_sub prop ) in
let subl = Sil . sub_to_list prop . sub in
(* since prop diff is based on physical equality, we need to extract the sub verbatim *)
(* since prop diff is based on physical equality, we need to extract the sub verbatim *)
let pi = get_pi prop in
let pi = prop. pi in
let pp_pure f () =
let pp_pure f () =
if subl != [] then F . fprintf f " %a ;@ \n " ( pp_subl pe ) subl ;
if subl != [] then F . fprintf f " %a ;@ \n " ( pp_subl pe ) subl ;
if pi != [] then F . fprintf f " %a ;@ \n " ( pp_pi pe ) pi in
if pi != [] then F . fprintf f " %a ;@ \n " ( pp_pi pe ) pi in
@ -413,8 +407,8 @@ let sigma_fav =
Sil . fav_imperative_to_functional sigma_fav_add
Sil . fav_imperative_to_functional sigma_fav_add
let prop_footprint_fav_add fav prop =
let prop_footprint_fav_add fav prop =
sigma_fav_add fav prop . foot_ sigma;
sigma_fav_add fav prop . sigma_fp ;
pi_fav_add fav prop . foot_ pi
pi_fav_add fav prop . pi_fp
(* * Find fav of the footprint part of the prop *)
(* * Find fav of the footprint part of the prop *)
let prop_footprint_fav prop =
let prop_footprint_fav prop =
@ -422,10 +416,10 @@ let prop_footprint_fav prop =
let prop_fav_add fav prop =
let prop_fav_add fav prop =
sigma_fav_add fav prop . sigma ;
sigma_fav_add fav prop . sigma ;
sigma_fav_add fav prop . foot_ sigma;
sigma_fav_add fav prop . sigma_fp ;
Sil . sub_fav_add fav prop . sub ;
Sil . sub_fav_add fav prop . sub ;
pi_fav_add fav prop . pi ;
pi_fav_add fav prop . pi ;
pi_fav_add fav prop . foot_ pi
pi_fav_add fav prop . pi_fp
let prop_fav p =
let prop_fav p =
Sil . fav_imperative_to_functional prop_fav_add p
Sil . fav_imperative_to_functional prop_fav_add p
@ -433,7 +427,7 @@ let prop_fav p =
(* * free vars of the prop, excluding the pure part *)
(* * free vars of the prop, excluding the pure part *)
let prop_fav_nonpure_add fav prop =
let prop_fav_nonpure_add fav prop =
sigma_fav_add fav prop . sigma ;
sigma_fav_add fav prop . sigma ;
sigma_fav_add fav prop . foot_ sigma
sigma_fav_add fav prop . sigma_fp
(* * free vars, except pi and sub, of current and footprint parts *)
(* * free vars, except pi and sub, of current and footprint parts *)
let prop_fav_nonpure =
let prop_fav_nonpure =
@ -455,8 +449,8 @@ let pi_fpv pi =
let prop_fpv prop =
let prop_fpv prop =
( Sil . sub_fpv prop . sub ) @
( Sil . sub_fpv prop . sub ) @
( pi_fpv prop . pi ) @
( pi_fpv prop . pi ) @
( pi_fpv prop . foot_ pi) @
( pi_fpv prop . pi_fp ) @
( sigma_fpv prop . foot_ sigma) @
( sigma_fpv prop . sigma_fp ) @
( sigma_fpv prop . sigma )
( sigma_fpv prop . sigma )
(* * {2 Functions for Subsitition} *)
(* * {2 Functions for Subsitition} *)
@ -1383,8 +1377,8 @@ let sigma_normalize sub sigma =
(* * normalize the footprint part, and rename any primed vars
(* * normalize the footprint part, and rename any primed vars
in the footprint with fresh footprint vars * )
in the footprint with fresh footprint vars * )
let footprint_normalize prop =
let footprint_normalize prop =
let nsigma = sigma_normalize Sil . sub_empty prop . foot_ sigma in
let nsigma = sigma_normalize Sil . sub_empty prop . sigma_fp in
let npi = pi_normalize Sil . sub_empty nsigma prop . foot_ pi in
let npi = pi_normalize Sil . sub_empty nsigma prop . pi_fp in
let fp_vars =
let fp_vars =
let fav = pi_fav npi in
let fav = pi_fav npi in
sigma_fav_add fav nsigma ;
sigma_fav_add fav nsigma ;
@ -1409,7 +1403,7 @@ let footprint_normalize prop =
let nsigma' = sigma_normalize Sil . sub_empty ( sigma_sub ren_sub nsigma ) in
let nsigma' = sigma_normalize Sil . sub_empty ( sigma_sub ren_sub nsigma ) in
let npi' = pi_normalize Sil . sub_empty nsigma' ( pi_sub ren_sub npi ) in
let npi' = pi_normalize Sil . sub_empty nsigma' ( pi_sub ren_sub npi ) in
( npi' , nsigma' ) in
( npi' , nsigma' ) in
set prop ~ foot_ pi: npi' ~ foot_ sigma: nsigma'
set prop ~ pi_fp : npi' ~ sigma_fp : nsigma'
let exp_normalize_prop prop exp =
let exp_normalize_prop prop exp =
Config . run_with_abs_val_equal_zero ( exp_normalize prop . sub ) exp
Config . run_with_abs_val_equal_zero ( exp_normalize prop . sub ) exp
@ -1470,18 +1464,6 @@ let prop_compact sh (prop : normal t) : normal t =
(* * {2 Function for replacing occurrences of expressions.} *)
(* * {2 Function for replacing occurrences of expressions.} *)
let replace_pi pi prop : exposed t =
set prop ~ pi
let replace_sigma sigma prop : exposed t =
set prop ~ sigma
let replace_sigma_footprint foot_sigma prop : exposed t =
set prop ~ foot_sigma
let replace_pi_footprint foot_pi prop : exposed t =
set prop ~ foot_pi
let sigma_replace_exp epairs sigma =
let sigma_replace_exp epairs sigma =
let sigma' = IList . map ( Sil . hpred_replace_exp epairs ) sigma in
let sigma' = IList . map ( Sil . hpred_replace_exp epairs ) sigma in
sigma_normalize Sil . sub_empty sigma'
sigma_normalize Sil . sub_empty sigma'
@ -1763,13 +1745,13 @@ let rec prop_atom_and ?(footprint=false) (p : normal t) a : normal t =
match a' with
match a' with
| Sil . Aeq ( Exp . Var i , e ) when not ( Sil . ident_in_exp i e ) ->
| Sil . Aeq ( Exp . Var i , e ) when not ( Sil . ident_in_exp i e ) ->
let mysub = Sil . sub_of_list [ ( i , e ) ] in
let mysub = Sil . sub_of_list [ ( i , e ) ] in
let foot_ sigma' = sigma_normalize mysub p' . foot_ sigma in
let sigma_fp ' = sigma_normalize mysub p' . sigma_fp in
let foot_ pi' = a' :: pi_normalize mysub foot_ sigma' p' . foot_ pi in
let pi_fp ' = a' :: pi_normalize mysub sigma_fp ' p' . pi_fp in
footprint_normalize
footprint_normalize
( set p' ~ foot_ pi: foot_ pi' ~ foot_ sigma: foot_ sigma')
( set p' ~ pi_fp : pi_fp ' ~ sigma_fp : sigma_fp ')
| _ ->
| _ ->
footprint_normalize
footprint_normalize
( set p' ~ foot_ pi: ( a' :: p' . foot_ pi) ) in
( set p' ~ pi_fp : ( a' :: p' . pi_fp ) ) in
if predicate_warning then ( L . d_warning " dropping non-footprint " ; Sil . d_atom a' ; L . d_ln () ) ;
if predicate_warning then ( L . d_warning " dropping non-footprint " ; Sil . d_atom a' ; L . d_ln () ) ;
unsafe_cast_to_normal p''
unsafe_cast_to_normal p''
end
end
@ -1783,22 +1765,11 @@ let conjoin_eq ?(footprint = false) exp1 exp2 prop =
let conjoin_neq ? ( footprint = false ) exp1 exp2 prop =
let conjoin_neq ? ( footprint = false ) exp1 exp2 prop =
prop_atom_and ~ footprint prop ( Sil . Aneq ( exp1 , exp2 ) )
prop_atom_and ~ footprint prop ( Sil . Aneq ( exp1 , exp2 ) )
(* * Return the spatial part *)
let get_sigma ( p : ' a t ) : sigma = p . sigma
(* * Return the pure part of the footprint *)
let get_pi_footprint p =
p . foot_pi
(* * Return the spatial part of the footprint *)
let get_sigma_footprint p =
p . foot_sigma
(* * Reset every inst in the prop using the given map *)
(* * Reset every inst in the prop using the given map *)
let prop_reset_inst inst_map prop =
let prop_reset_inst inst_map prop =
let sigma' = IList . map ( Sil . hpred_instmap inst_map ) ( get_sigma prop ) in
let sigma' = IList . map ( Sil . hpred_instmap inst_map ) prop . sigma in
let sigma_fp' = IList . map ( Sil . hpred_instmap inst_map ) ( get_sigma_footprint prop ) in
let sigma_fp' = IList . map ( Sil . hpred_instmap inst_map ) prop . sigma_fp in
replace_sigma_footprint sigma_fp' ( replace_sigma sigma' prop )
set prop ~ sigma : sigma' ~ sigma_fp : sigma_fp'
(* * {1 Functions for transforming footprints into propositions.} *)
(* * {1 Functions for transforming footprints into propositions.} *)
@ -1809,12 +1780,12 @@ let prop_reset_inst inst_map prop =
(* * 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 =
set prop_emp ~ pi : p . foot_ pi ~ sigma : p . foot_ sigma
set prop_emp ~ pi : p . pi_fp ~ sigma : p . sigma_fp
(* * Extract the ( footprint,current ) pair *)
(* * Extract the ( footprint,current ) pair *)
let extract_spec ( p : normal t ) : normal t * normal t =
let extract_spec ( p : normal t ) : normal t * normal t =
let pre = extract_footprint p in
let pre = extract_footprint p in
let post = set p ~ foot_ pi: [] ~ foot_ sigma: [] in
let post = set p ~ pi_fp : [] ~ sigma_fp : [] in
( unsafe_cast_to_normal pre , unsafe_cast_to_normal post )
( unsafe_cast_to_normal pre , unsafe_cast_to_normal post )
(* * [prop_set_fooprint p p_foot] sets proposition [p_foot] as footprint of [p]. *)
(* * [prop_set_fooprint p p_foot] sets proposition [p_foot] as footprint of [p]. *)
@ -1823,7 +1794,7 @@ let prop_set_footprint p p_foot =
( IList . map
( IList . map
( fun ( i , e ) -> Sil . Aeq ( Exp . Var i , e ) )
( fun ( i , e ) -> Sil . Aeq ( Exp . Var i , e ) )
( Sil . sub_to_list p_foot . sub ) ) @ p_foot . pi in
( Sil . sub_to_list p_foot . sub ) ) @ p_foot . pi in
set p ~ foot_ pi: pi ~ foot_ sigma: p_foot . sigma
set p ~ pi_fp : pi ~ sigma_fp : p_foot . sigma
(* * {2 Functions for renaming primed variables by "canonical names"} *)
(* * {2 Functions for renaming primed variables by "canonical names"} *)
@ -1901,11 +1872,11 @@ let sigma_dfs_sort sigma =
sigma'
sigma'
let prop_dfs_sort p =
let prop_dfs_sort p =
let sigma = get_sigma p in
let sigma = p. sigma in
let sigma' = sigma_dfs_sort sigma in
let sigma' = sigma_dfs_sort sigma in
let sigma_fp = get_sigma_footprint p in
let sigma_fp = p. sigma_f p in
let sigma_fp' = sigma_dfs_sort sigma_fp in
let sigma_fp' = sigma_dfs_sort sigma_fp in
let p' = set p ~ sigma : sigma' ~ foot_ sigma: sigma_fp' in
let p' = set p ~ sigma : sigma' ~ sigma_fp : sigma_fp' in
(* L.err "@[<2>P SORTED:@\n%a@\n@." pp_prop p'; *)
(* L.err "@[<2>P SORTED:@\n%a@\n@." pp_prop p'; *)
p'
p'
@ -2145,8 +2116,8 @@ let prop_rename_primed_footprint_vars (p : normal t) : normal t =
let sub' = sub_captured_ren ren p . sub in
let sub' = sub_captured_ren ren p . sub in
let pi' = pi_captured_ren ren p . pi in
let pi' = pi_captured_ren ren p . pi in
let sigma' = sigma_captured_ren ren p . sigma in
let sigma' = sigma_captured_ren ren p . sigma in
let foot_ pi' = pi_captured_ren ren p . foot_ pi in
let pi_fp ' = pi_captured_ren ren p . pi_fp in
let foot_ sigma' = sigma_captured_ren ren p . foot_ sigma in
let sigma_fp ' = sigma_captured_ren ren p . sigma_fp in
let sub_for_normalize = Sil . sub_empty in
let sub_for_normalize = Sil . sub_empty in
(* It is fine to use the empty substituion during normalization
(* It is fine to use the empty substituion during normalization
@ -2155,7 +2126,7 @@ let prop_rename_primed_footprint_vars (p : normal t) : normal t =
let nsigma' = sigma_normalize sub_for_normalize sigma' in
let nsigma' = sigma_normalize sub_for_normalize sigma' in
let npi' = pi_normalize sub_for_normalize nsigma' pi' in
let npi' = pi_normalize sub_for_normalize nsigma' pi' in
let p' = footprint_normalize
let p' = footprint_normalize
( set prop_emp ~ sub : nsub' ~ pi : npi' ~ sigma : nsigma' ~ foot_ pi: foot_ pi' ~ foot_ sigma: foot_ sigma') in
( set prop_emp ~ sub : nsub' ~ pi : npi' ~ sigma : nsigma' ~ pi_fp : pi_fp ' ~ sigma_fp : sigma_fp ') in
unsafe_cast_to_normal p'
unsafe_cast_to_normal p'
(* * {2 Functions for changing and generating propositions} *)
(* * {2 Functions for changing and generating propositions} *)
@ -2172,15 +2143,15 @@ let normalize (eprop : 'a t) : normal t =
( set prop_emp ~ sigma : ( sigma_normalize Sil . sub_empty eprop . sigma ) ) in
( set prop_emp ~ sigma : ( sigma_normalize Sil . sub_empty eprop . sigma ) ) in
let nprop = IList . fold_left prop_atom_and p0 ( get_pure eprop ) in
let nprop = IList . fold_left prop_atom_and p0 ( get_pure eprop ) in
unsafe_cast_to_normal
unsafe_cast_to_normal
( footprint_normalize ( set nprop ~ foot_ pi: eprop . foot_ pi ~ foot_ sigma: eprop . foot_ sigma) )
( footprint_normalize ( set nprop ~ pi_fp : eprop . pi_fp ~ sigma_fp : eprop . sigma_fp ) )
(* * Apply subsitution to prop. *)
(* * Apply subsitution to prop. *)
let prop_sub subst ( prop : ' a t ) : exposed t =
let prop_sub subst ( prop : ' a t ) : exposed t =
let pi = pi_sub subst ( prop . pi @ pi_of_subst prop . sub ) in
let pi = pi_sub subst ( prop . pi @ pi_of_subst prop . sub ) in
let sigma = sigma_sub subst prop . sigma in
let sigma = sigma_sub subst prop . sigma in
let foot_ pi = pi_sub subst prop . foot_ pi in
let pi_fp = pi_sub subst prop . pi_fp in
let foot_ sigma = sigma_sub subst prop . foot_ sigma in
let sigma_fp = sigma_sub subst prop . sigma_fp in
set prop_emp ~ pi ~ sigma ~ foot_ pi ~ foot_ sigma
set prop_emp ~ pi ~ sigma ~ pi_fp ~ sigma_fp
(* * Apply renaming substitution to a proposition. *)
(* * Apply renaming substitution to a proposition. *)
let prop_ren_sub ( ren_sub : Sil . subst ) ( prop : normal t ) : normal t =
let prop_ren_sub ( ren_sub : Sil . subst ) ( prop : normal t ) : normal t =
@ -2212,9 +2183,9 @@ let prop_expmap (fe: Exp.t -> Exp.t) prop =
let f ( e , sil_opt ) = ( fe e , sil_opt ) in
let f ( e , sil_opt ) = ( fe e , sil_opt ) in
let pi = IList . map ( Sil . atom_expmap fe ) prop . pi in
let pi = IList . map ( Sil . atom_expmap fe ) prop . pi in
let sigma = IList . map ( Sil . hpred_expmap f ) prop . sigma in
let sigma = IList . map ( Sil . hpred_expmap f ) prop . sigma in
let foot_ pi = IList . map ( Sil . atom_expmap fe ) prop . foot_ pi in
let pi_fp = IList . map ( Sil . atom_expmap fe ) prop . pi_fp in
let foot_ sigma = IList . map ( Sil . hpred_expmap f ) prop . foot_ sigma in
let sigma_fp = IList . map ( Sil . hpred_expmap f ) prop . sigma_fp in
set prop ~ pi ~ sigma ~ foot_ pi ~ foot_ sigma
set prop ~ pi ~ sigma ~ pi_fp ~ sigma_fp
(* * convert identifiers in fav to kind [k] *)
(* * convert identifiers in fav to kind [k] *)
let vars_make_unprimed fav prop =
let vars_make_unprimed fav prop =
@ -2243,9 +2214,6 @@ let from_pi pi =
let from_sigma sigma =
let from_sigma sigma =
set prop_emp ~ sigma
set prop_emp ~ sigma
let replace_sub sub prop =
set prop ~ sub
(* * Rename free variables in a prop replacing them with existentially quantified vars *)
(* * Rename free variables in a prop replacing them with existentially quantified vars *)
let prop_rename_fav_with_existentials ( p : normal t ) : normal t =
let prop_rename_fav_with_existentials ( p : normal t ) : normal t =
let fav = Sil . fav_new () in
let fav = Sil . fav_new () in
@ -2269,8 +2237,8 @@ type 'a prop_iter =
pit_curr : Sil . hpred ; (* * current element *)
pit_curr : Sil . hpred ; (* * current element *)
pit_state : ' a ; (* * state of current element *)
pit_state : ' a ; (* * state of current element *)
pit_new : sigma ; (* * sigma not yet visited *)
pit_new : sigma ; (* * sigma not yet visited *)
pit_ foot_ pi : pi ; (* * pure part of the footprint *)
pit_ pi_fp : pi ; (* * pure part of the footprint *)
pit_ foot_ sigma : sigma ; (* * sigma part of the footprint *)
pit_ sigma_fp : sigma ; (* * sigma part of the footprint *)
}
}
let prop_iter_create prop =
let prop_iter_create prop =
@ -2283,8 +2251,8 @@ let prop_iter_create prop =
pit_curr = hpred ;
pit_curr = hpred ;
pit_state = () ;
pit_state = () ;
pit_new = sigma' ;
pit_new = sigma' ;
pit_ foot_ pi = prop . foot_ pi;
pit_ pi_fp = prop . pi_fp ;
pit_ foot_ sigma = prop . foot_ sigma }
pit_ sigma_fp = prop . sigma_fp }
| _ -> None
| _ -> None
(* * Return the prop associated to the iterator. *)
(* * Return the prop associated to the iterator. *)
@ -2296,8 +2264,8 @@ let prop_iter_to_prop iter =
~ sub : iter . pit_sub
~ sub : iter . pit_sub
~ pi : iter . pit_pi
~ pi : iter . pit_pi
~ sigma : sigma
~ sigma : sigma
~ foot_ pi: iter . pit_ foot_ pi
~ pi_fp : iter . pit_ pi_fp
~ foot_ sigma: iter . pit_ foot_ sigma) in
~ sigma_fp : iter . pit_ sigma_fp ) in
IList . fold_left
IList . fold_left
( fun p ( footprint , atom ) -> prop_atom_and ~ footprint : footprint p atom )
( fun p ( footprint , atom ) -> prop_atom_and ~ footprint : footprint p atom )
prop iter . pit_newpi
prop iter . pit_newpi
@ -2318,8 +2286,8 @@ let prop_iter_remove_curr_then_to_prop iter : normal t =
~ sub : iter . pit_sub
~ sub : iter . pit_sub
~ pi : iter . pit_pi
~ pi : iter . pit_pi
~ sigma : normalized_sigma
~ sigma : normalized_sigma
~ foot_ pi: iter . pit_ foot_ pi
~ pi_fp : iter . pit_ pi_fp
~ foot_ sigma: iter . pit_ foot_ sigma in
~ sigma_fp : iter . pit_ sigma_fp in
unsafe_cast_to_normal prop
unsafe_cast_to_normal prop
(* * Return the current hpred and state. *)
(* * Return the current hpred and state. *)
@ -2444,8 +2412,8 @@ let prop_iter_make_id_primed id iter =
pit_new = sigma_sub sub_use iter . pit_new }
pit_new = sigma_sub sub_use iter . pit_new }
let prop_iter_footprint_fav_add fav iter =
let prop_iter_footprint_fav_add fav iter =
sigma_fav_add fav iter . pit_ foot_ sigma;
sigma_fav_add fav iter . pit_ sigma_fp ;
pi_fav_add fav iter . pit_ foot_ pi
pi_fav_add fav iter . pit_ pi_fp
(* * Find fav of the footprint part of the iterator *)
(* * Find fav of the footprint part of the iterator *)
let prop_iter_footprint_fav iter =
let prop_iter_footprint_fav iter =
@ -2473,11 +2441,11 @@ let prop_iter_noncurr_fav_add fav iter =
(* * Extract the sigma part of the footprint *)
(* * Extract the sigma part of the footprint *)
let prop_iter_get_footprint_sigma iter =
let prop_iter_get_footprint_sigma iter =
iter . pit_ foot_ sigma
iter . pit_ sigma_fp
(* * Replace the sigma part of the footprint *)
(* * Replace the sigma part of the footprint *)
let prop_iter_replace_footprint_sigma iter sigma =
let prop_iter_replace_footprint_sigma iter sigma =
{ iter with pit_ foot_ sigma = sigma }
{ iter with pit_ sigma_fp = sigma }
let prop_iter_noncurr_fav iter =
let prop_iter_noncurr_fav iter =
Sil . fav_imperative_to_functional prop_iter_noncurr_fav_add iter
Sil . fav_imperative_to_functional prop_iter_noncurr_fav_add iter
@ -2617,14 +2585,14 @@ end = struct
complexity * )
complexity * )
let prop_size p =
let prop_size p =
let size_current = sigma_size p . sigma in
let size_current = sigma_size p . sigma in
let size_footprint = sigma_size p . foot_ sigma in
let size_footprint = sigma_size p . sigma_fp in
max size_current size_footprint
max size_current size_footprint
(* * Approximate the size of the longest chain by counting the max
(* * Approximate the size of the longest chain by counting the max
number of | -> with the same type and whose lhs is primed or
number of | -> with the same type and whose lhs is primed or
footprint * )
footprint * )
let prop_chain_size p =
let prop_chain_size p =
let fp_size = pi_size p . foot_ pi + sigma_size p . foot_ sigma in
let fp_size = pi_size p . pi_fp + sigma_size p . sigma_fp in
pi_size p . pi + sigma_size p . sigma + fp_size
pi_size p . pi + sigma_size p . sigma + fp_size
end
end
(* * * END of module Metrics * * *)
(* * * END of module Metrics * * *)
@ -2673,7 +2641,7 @@ module CategorizePreconditions = struct
pi = [] in
pi = [] in
let check_sigma sigma =
let check_sigma sigma =
IList . for_all hpred_filter sigma in
IList . for_all hpred_filter sigma in
check_pi ( get_pi pre ) && check_sigma ( get_sigma pre ) in
check_pi pre . pi && check_sigma pre . sigma in
let pres_no_constraints = IList . filter ( check_pre hpred_is_var ) preconditions in
let pres_no_constraints = IList . filter ( check_pre hpred_is_var ) preconditions in
let pres_only_allocation = IList . filter ( check_pre hpred_only_allocation ) preconditions in
let pres_only_allocation = IList . filter ( check_pre hpred_only_allocation ) preconditions in
match preconditions , pres_no_constraints , pres_only_allocation with
match preconditions , pres_no_constraints , pres_only_allocation with
@ -2686,57 +2654,3 @@ module CategorizePreconditions = struct
| _ :: _ , [] , [] ->
| _ :: _ , [] , [] ->
DataConstraints
DataConstraints
end
end
(*
let pp_lseg_kind f = function
| Sil . Lseg_NE -> F . fprintf f " ne "
| Sil . Lseg_PE -> F . fprintf f " "
let pi_av_add fav pi =
IList . iter ( Sil . atom_av_add fav ) pi
let sigma_av_add fav sigma =
IList . iter ( Sil . hpred_av_add fav ) sigma
let prop_av_add fav prop =
Sil . sub_av_add fav prop . sub ;
pi_av_add fav prop . pi ;
sigma_av_add fav prop . sigma ;
pi_av_add fav prop . foot_pi ;
sigma_av_add fav prop . foot_sigma
let prop_av =
Sil . fav_imperative_to_functional prop_av_add
let rec remove_duplicates_from_sorted special_equal = function
| [] -> []
| [ x ] -> [ x ]
| x :: y :: l ->
if ( special_equal x y )
then remove_duplicates_from_sorted special_equal ( y :: l )
else x :: ( remove_duplicates_from_sorted special_equal ( y :: l ) )
(* * Replace the sub part of [prop]. *)
let prop_replace_sub sub p =
let nsub = sub_normalize sub in
{ p with sub = nsub }
let unstructured_type = function
| Typ . Tstruct _ | Typ . Tarray _ -> false
| _ -> true
let rec pp_ren pe f = function
| [] -> ()
| [ ( i , x ) ] -> F . fprintf f " %a->%a " ( Ident . pp pe ) i ( Ident . pp pe ) x
| ( i , x ) :: ren -> F . fprintf f " %a->%a, %a " ( Ident . pp pe ) i ( Ident . pp pe ) x ( pp_ren pe ) ren
let id_exp_compare ( id1 , e1 ) ( id2 , e2 ) =
let n = Exp . compare e1 e2 in
if n < > 0 then n
else Ident . compare id1 id2
(* * Raise an exception if the prop is not normalized *)
let check_prop_normalized prop =
let sigma' = sigma_normalize_prop prop prop . sigma in
if sigma_equal prop . sigma sigma' = = false then assert false
* )