Skip to content
Snippets Groups Projects
Commit be0cc43c authored by Fonenantsoa Maurica's avatar Fonenantsoa Maurica
Browse files

Addresses Julien's review no.3:

  - No superfluous patterns
  - Using Cil.charPtrType
  - call_for_unsupported_constructs as closure given to mmodel_call_with_ranges
  - Style:
    - Indendation
    - No superfluous begin..end
    - Parentheses
    - Spaces
parent 995e6b5a
No related branches found
No related tags found
No related merge requests found
...@@ -79,10 +79,6 @@ let eliminate_ranges_from_index_of_term ~loc t = ...@@ -79,10 +79,6 @@ let eliminate_ranges_from_index_of_term ~loc t =
let lv = Cil_const.make_logic_var_kind name LVQuant Linteger in let lv = Cil_const.make_logic_var_kind name LVQuant Linteger in
let tlv = Logic_const.tvar ~loc lv in let tlv = Logic_const.tvar ~loc lv in
tlv, (n1, lv, n2) tlv, (n1, lv, n2)
| TBinOp(PlusA, _, {term_node = Trange _}) ->
(* t[n + (0..3)] results in a typing error:
arithmetic conversion between non arithmetic types int and set<ℤ> *)
assert false
| _ -> | _ ->
raise Range_elimination_exception raise Range_elimination_exception
...@@ -92,13 +88,6 @@ let eliminate_ranges_from_index_of_term ~loc t = ...@@ -92,13 +88,6 @@ let eliminate_ranges_from_index_of_term ~loc t =
if we don't support the construction yet. *) if we don't support the construction yet. *)
let rec eliminate_ranges_from_index_of_toffset ~loc toffset quantifiers = let rec eliminate_ranges_from_index_of_toffset ~loc toffset quantifiers =
match toffset with match toffset with
| TIndex(t, TNoOffset) ->
if Misc.is_range_free t then
toffset, quantifiers
else
(* Attempt Range Elimination on [t] *)
let t', q = eliminate_ranges_from_index_of_term ~loc t in
TIndex(t', TNoOffset), q :: quantifiers
| TIndex(t, toffset') -> | TIndex(t, toffset') ->
if Misc.is_range_free t then if Misc.is_range_free t then
let toffset', quantifiers' = let toffset', quantifiers' =
...@@ -668,8 +657,7 @@ and mk_ptr_sizeof typ loc = ...@@ -668,8 +657,7 @@ and mk_ptr_sizeof typ loc =
(* \valid, \offset and \initialized annotations *) (* \valid, \offset and \initialized annotations *)
and mmodel_call_with_size ~loc kf name ctx env t = and mmodel_call_with_size ~loc kf name ctx env t =
mmodel_call_with_ranges ~loc kf name ctx env t let call_for_unsupported_constructs ~loc kf name ctx env t =
begin fun ~loc kf name ctx env t ->
let e, env = term_to_exp kf (Env.rte env true) t in let e, env = term_to_exp kf (Env.rte env true) t in
let _, res, env = let _, res, env =
Env.new_var Env.new_var
...@@ -685,16 +673,17 @@ and mmodel_call_with_size ~loc kf name ctx env t = ...@@ -685,16 +673,17 @@ and mmodel_call_with_size ~loc kf name ctx env t =
[ Misc.mk_call ~loc ~result:(Cil.var v) fname [ e; sizeof ] ]) [ Misc.mk_call ~loc ~result:(Cil.var v) fname [ e; sizeof ] ])
in in
res, env res, env
end in
mmodel_call_with_ranges
~loc kf name ctx env t call_for_unsupported_constructs
and mmodel_call_valid ~loc kf name ctx env t = and mmodel_call_valid ~loc kf name ctx env t =
mmodel_call_with_ranges ~loc kf name ctx env t let call_for_unsupported_constructs ~loc kf name ctx env t =
begin fun ~loc kf name ctx env t ->
let e, env = term_to_exp kf (Env.rte env true) t in let e, env = term_to_exp kf (Env.rte env true) t in
let base, _ = Misc.ptr_index ~loc e in let base, _ = Misc.ptr_index ~loc e in
let base_addr = match base.enode with let base_addr = match base.enode with
| AddrOf _ | Const _ -> Cil.zero ~loc | AddrOf _ | Const _ -> Cil.zero ~loc
| Lval(lv) | StartOf(lv) -> Cil.mkAddrOrStartOf ~loc lv | Lval lv | StartOf lv -> Cil.mkAddrOrStartOf ~loc lv
| _ -> assert false | _ -> assert false
in in
let _, res, env = let _, res, env =
...@@ -712,7 +701,9 @@ and mmodel_call_valid ~loc kf name ctx env t = ...@@ -712,7 +701,9 @@ and mmodel_call_valid ~loc kf name ctx env t =
[ Misc.mk_call ~loc ~result:(Cil.var v) fname args ]) [ Misc.mk_call ~loc ~result:(Cil.var v) fname args ])
in in
res, env res, env
end in
mmodel_call_with_ranges
~loc kf name ctx env t call_for_unsupported_constructs
(* [mmodel_call_with_ranges] handles ranges in [t] when calling builtin [name]. (* [mmodel_call_with_ranges] handles ranges in [t] when calling builtin [name].
It only supports the following cases for the time being: It only supports the following cases for the time being:
...@@ -735,7 +726,7 @@ and mmodel_call_valid ~loc kf name ctx env t = ...@@ -735,7 +726,7 @@ and mmodel_call_valid ~loc kf name ctx env t =
NON-contiguous locations -> multiple calls (3) to [__e_acsl_valid] *) NON-contiguous locations -> multiple calls (3) to [__e_acsl_valid] *)
and mmodel_call_with_ranges ~loc kf name ctx env t mmodel_call_default = and mmodel_call_with_ranges ~loc kf name ctx env t mmodel_call_default =
match t.term_node with match t.term_node with
| TBinOp((PlusPI | IndexPI), p, ({term_node = Trange _} as r)) -> | TBinOp((PlusPI | IndexPI), p, ({ term_node = Trange _ } as r)) ->
if Misc.is_set_of_ptr_or_array p.term_type then if Misc.is_set_of_ptr_or_array p.term_type then
not_yet env "arithmetic over set of pointers or arrays" not_yet env "arithmetic over set of pointers or arrays"
else else
...@@ -747,48 +738,47 @@ and mmodel_call_with_ranges ~loc kf name ctx env t mmodel_call_default = ...@@ -747,48 +738,47 @@ and mmodel_call_with_ranges ~loc kf name ctx env t mmodel_call_default =
let lty_noset = Logic_const.type_of_element t.term_type in let lty_noset = Logic_const.type_of_element t.term_type in
let p = Logic_const.taddrof ~loc (TVar lv, TNoOffset) lty_noset in let p = Logic_const.taddrof ~loc (TVar lv, TNoOffset) lty_noset in
mmodel_call_memory_block ~loc kf name ctx env p r mmodel_call_memory_block ~loc kf name ctx env p r
| TAddrOf(TVar ({lv_type = Ctype (TArray _)} as lv), toffset) -> | TAddrOf(TVar ({ lv_type = Ctype (TArray _) } as lv), toffset) ->
if has_set_as_index toffset then if has_set_as_index toffset then
(* Case B *) (* Case B *)
begin try try
let toffset', quantifiers = let toffset', quantifiers =
eliminate_ranges_from_index_of_toffset ~loc toffset [] eliminate_ranges_from_index_of_toffset ~loc toffset []
in
let lty_noset =
if Logic_const.is_set_type t.term_type then
Logic_const.type_of_element t.term_type
else
t.term_type
in
let t' = Logic_const.taddrof ~loc (TVar lv, toffset') lty_noset in
let p_quantified =
(* [loc] prevents a type error with eta-expansion and label *)
let loc = Some loc in
let call f = f ?loc (Logic_const.here_label, t') in
match name with
| "valid" -> call Logic_const.pvalid
| "initialized" -> call Logic_const.pinitialized
| "valid_read" -> call Logic_const.pvalid_read
| _ -> Options.fatal "[mmodel_call_with_ranges] unexpected builtin"
in in
let p_quantified = List.fold_left let lty_noset =
(fun p (tmin, lv, tmax) -> if Logic_const.is_set_type t.term_type then
(* \forall integer tlv; tmin <= tlv <= tmax ==> p *) Logic_const.type_of_element t.term_type
let tlv = Logic_const.tvar ~loc lv in else
let lower_bound = Logic_const.prel ~loc (Rle, tmin, tlv) in t.term_type
let upper_bound = Logic_const.prel ~loc (Rle, tlv, tmax) in in
let bound = Logic_const.pand ~loc (lower_bound, upper_bound) in let t' = Logic_const.taddrof ~loc (TVar lv, toffset') lty_noset in
let bound_imp_p = Logic_const.pimplies ~loc (bound, p) in let p_quantified =
Logic_const.pforall ~loc ([lv], bound_imp_p)) (* [loc] prevents a type error with eta-expansion and label *)
p_quantified let loc = Some loc in
quantifiers let call f = f ?loc (Logic_const.here_label, t') in
in match name with
Typing.type_named_predicate ~must_clear:true p_quantified; | "valid" -> call Logic_const.pvalid
named_predicate_to_exp kf env p_quantified | "initialized" -> call Logic_const.pinitialized
with Range_elimination_exception -> | "valid_read" -> call Logic_const.pvalid_read
(* Case C *) | _ -> Options.fatal "[mmodel_call_with_ranges] unexpected builtin"
mmodel_call_default ~loc kf name ctx env t in
end let p_quantified = List.fold_left
(fun p (tmin, lv, tmax) ->
(* \forall integer tlv; tmin <= tlv <= tmax ==> p *)
let tlv = Logic_const.tvar ~loc lv in
let lower_bound = Logic_const.prel ~loc (Rle, tmin, tlv) in
let upper_bound = Logic_const.prel ~loc (Rle, tlv, tmax) in
let bound = Logic_const.pand ~loc (lower_bound, upper_bound) in
let bound_imp_p = Logic_const.pimplies ~loc (bound, p) in
Logic_const.pforall ~loc ([lv], bound_imp_p))
p_quantified
quantifiers
in
Typing.type_named_predicate ~must_clear:true p_quantified;
named_predicate_to_exp kf env p_quantified
with Range_elimination_exception ->
(* Case C *)
mmodel_call_default ~loc kf name ctx env t
else else
(* Case C *) (* Case C *)
mmodel_call_default ~loc kf name ctx env t mmodel_call_default ~loc kf name ctx env t
...@@ -815,7 +805,7 @@ and mmodel_call_memory_block ~loc kf name ctx env p r = ...@@ -815,7 +805,7 @@ and mmodel_call_memory_block ~loc kf name ctx env p r =
in in
let s = Logic_const.term ~loc (TSizeOf ty) Linteger in let s = Logic_const.term ~loc (TSizeOf ty) Linteger in
(* ptr *) (* ptr *)
let typ_charptr = TPtr(TInt(IChar, []), []) in let typ_charptr = Cil.charPtrType in
let ptr = Logic_const.term let ptr = Logic_const.term
~loc ~loc
(TBinOp( (TBinOp(
...@@ -845,7 +835,7 @@ and mmodel_call_memory_block ~loc kf name ctx env p r = ...@@ -845,7 +835,7 @@ and mmodel_call_memory_block ~loc kf name ctx env p r =
let base, _ = Misc.ptr_index ~loc ptr in let base, _ = Misc.ptr_index ~loc ptr in
let base_addr = match base.enode with let base_addr = match base.enode with
| AddrOf _ | Const _ -> Cil.zero ~loc | AddrOf _ | Const _ -> Cil.zero ~loc
| Lval(lv) | StartOf(lv) -> Cil.mkAddrOrStartOf ~loc lv | Lval lv | StartOf lv -> Cil.mkAddrOrStartOf ~loc lv
| _ -> assert false | _ -> assert false
in in
(* generating env *) (* generating env *)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment