Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
pub
frama-c
Commits
b9b4b79e
Commit
b9b4b79e
authored
Jan 14, 2019
by
David Bühler
Browse files
[Ival] New files int_set and int_interval.
They respectively implements the semantics of small integer sets and integer intervals.
parent
fb1d7bf4
Changes
7
Expand all
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
b9b4b79e
...
...
@@ -587,6 +587,8 @@ KERNEL_CMO=\
src/kernel_services/abstract_interp/fc_float.cmo
\
src/kernel_services/abstract_interp/float_interval.cmo
\
src/kernel_services/abstract_interp/fval.cmo
\
src/kernel_services/abstract_interp/int_interval.cmo
\
src/kernel_services/abstract_interp/int_set.cmo
\
src/kernel_services/abstract_interp/ival.cmo
\
src/kernel_services/abstract_interp/base.cmo
\
src/kernel_services/abstract_interp/origin.cmo
\
...
...
@@ -633,6 +635,7 @@ MLI_ONLY+=\
src/kernel_services/abstract_interp/float_sig.mli
\
src/kernel_services/abstract_interp/float_interval_sig.mli
\
src/kernel_services/abstract_interp/lattice_type.mli
\
src/kernel_services/abstract_interp/eva_lattice_type.mli
\
src/kernel_services/abstract_interp/int_Intervals_sig.mli
\
src/kernel_services/abstract_interp/offsetmap_lattice_with_isotropy.mli
\
src/kernel_services/abstract_interp/offsetmap_sig.mli
\
...
...
headers/header_spec.txt
View file @
b9b4b79e
...
...
@@ -412,6 +412,7 @@ src/kernel_services/abstract_interp/base.ml: CEA_LGPL
src/kernel_services/abstract_interp/base.mli: CEA_LGPL
src/kernel_services/abstract_interp/bottom.ml: CEA_LGPL
src/kernel_services/abstract_interp/bottom.mli: CEA_LGPL
src/kernel_services/abstract_interp/eva_lattice_type.mli: CEA_LGPL
src/kernel_services/abstract_interp/fc_float.ml: CEA_LGPL
src/kernel_services/abstract_interp/fc_float.mli: CEA_LGPL
src/kernel_services/abstract_interp/float_sig.mli: CEA_LGPL
...
...
@@ -425,6 +426,10 @@ src/kernel_services/abstract_interp/int_Base.mli: CEA_LGPL
src/kernel_services/abstract_interp/int_Intervals.ml: CEA_LGPL
src/kernel_services/abstract_interp/int_Intervals.mli: CEA_LGPL
src/kernel_services/abstract_interp/int_Intervals_sig.mli: CEA_LGPL
src/kernel_services/abstract_interp/int_interval.ml: CEA_LGPL
src/kernel_services/abstract_interp/int_interval.mli: CEA_LGPL
src/kernel_services/abstract_interp/int_set.ml: CEA_LGPL
src/kernel_services/abstract_interp/int_set.mli: CEA_LGPL
src/kernel_services/abstract_interp/ival.ml: CEA_LGPL
src/kernel_services/abstract_interp/ival.mli: CEA_LGPL
src/kernel_services/abstract_interp/lattice_messages.ml: CEA_LGPL
...
...
src/kernel_services/abstract_interp/eva_lattice_type.mli
0 → 100644
View file @
b9b4b79e
(**************************************************************************)
(* *)
(* This file is part of Frama-C. *)
(* *)
(* Copyright (C) 2007-2019 *)
(* CEA (Commissariat à l'énergie atomique et aux énergies *)
(* alternatives) *)
(* *)
(* you can redistribute it and/or modify it under the terms of the GNU *)
(* Lesser General Public License as published by the Free Software *)
(* Foundation, version 2.1. *)
(* *)
(* It is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Lesser General Public License for more details. *)
(* *)
(* See the GNU Lesser General Public License version 2.1 *)
(* for more details (enclosed in the file licenses/LGPLv2.1). *)
(* *)
(**************************************************************************)
(** Lattice signatures using the Bottom type:
these lattices do not include a bottom element, and return `Bottom instead
when needed. Except that, they are identical to the module signatures in
{!Lattice_type}. *)
open
Bottom
.
Type
module
type
Join_Semi_Lattice
=
Lattice_type
.
Join_Semi_Lattice
module
type
With_Top
=
Lattice_type
.
With_Top
module
type
With_Intersects
=
Lattice_type
.
With_Intersects
module
type
With_Enumeration
=
Lattice_type
.
With_Enumeration
module
type
With_Cardinal_One
=
Lattice_type
.
With_Cardinal_One
module
type
With_Widening
=
Lattice_type
.
With_Widening
module
type
With_Narrow
=
sig
type
t
val
narrow
:
t
->
t
->
t
or_bottom
(** over-approximation of intersection *)
end
module
type
With_Under_Approximation
=
sig
type
t
val
link
:
t
->
t
->
t
(** under-approximation of union *)
val
meet
:
t
->
t
->
t
or_bottom
(** under-approximation of intersection *)
end
module
type
With_Diff
=
sig
type
t
val
diff
:
t
->
t
->
t
or_bottom
(** [diff t1 t2] is an over-approximation of [t1-t2]. [t2] must
be an under-approximation or exact. *)
end
module
type
With_Diff_One
=
sig
type
t
val
diff_if_one
:
t
->
t
->
t
or_bottom
(** [diff_of_one t1 t2] is an over-approximation of [t1-t2].
@return [t1] if [t2] is not a singleton. *)
end
(** {2 Common signatures} *)
(** Signature shared by some functors of module {!Abstract_interp}. *)
module
type
AI_Lattice_with_cardinal_one
=
sig
include
Join_Semi_Lattice
include
With_Top
with
type
t
:=
t
include
With_Widening
with
type
t
:=
t
include
With_Cardinal_One
with
type
t
:=
t
include
With_Narrow
with
type
t
:=
t
include
With_Under_Approximation
with
type
t
:=
t
include
With_Intersects
with
type
t
:=
t
end
(** Most complete lattices: all operations plus widening, notion of cardinal
(including enumeration) and difference. *)
module
type
Full_AI_Lattice_with_cardinality
=
sig
include
AI_Lattice_with_cardinal_one
include
With_Diff
with
type
t
:=
t
include
With_Diff_One
with
type
t
:=
t
include
With_Enumeration
with
type
t
:=
t
end
(*
Local Variables:
compile-command: "make -C ../../.."
End:
*)
src/kernel_services/abstract_interp/int_interval.ml
0 → 100644
View file @
b9b4b79e
This diff is collapsed.
Click to expand it.
src/kernel_services/abstract_interp/int_interval.mli
0 → 100644
View file @
b9b4b79e
(**************************************************************************)
(* *)
(* This file is part of Frama-C. *)
(* *)
(* Copyright (C) 2007-2019 *)
(* CEA (Commissariat à l'énergie atomique et aux énergies *)
(* alternatives) *)
(* *)
(* you can redistribute it and/or modify it under the terms of the GNU *)
(* Lesser General Public License as published by the Free Software *)
(* Foundation, version 2.1. *)
(* *)
(* It is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Lesser General Public License for more details. *)
(* *)
(* See the GNU Lesser General Public License version 2.1 *)
(* for more details (enclosed in the file licenses/LGPLv2.1). *)
(* *)
(**************************************************************************)
open
Bottom
.
Type
include
Datatype
.
S_with_collections
include
Eva_lattice_type
.
Full_AI_Lattice_with_cardinality
with
type
t
:=
t
and
type
widen_hint
=
Integer
.
t
*
Datatype
.
Integer
.
Set
.
t
val
make
:
min
:
Integer
.
t
option
->
max
:
Integer
.
t
option
->
rem
:
Integer
.
t
->
modu
:
Integer
.
t
->
t
val
inject_range
:
Integer
.
t
option
->
Integer
.
t
option
->
t
val
min_and_max
:
t
->
Integer
.
t
option
*
Integer
.
t
option
val
min_max_rem_modu
:
t
->
Integer
.
t
option
*
Integer
.
t
option
*
Integer
.
t
*
Integer
.
t
val
mem
:
Integer
.
t
->
t
->
bool
val
cardinal
:
t
->
Integer
.
t
option
val
add
:
t
->
t
->
t
(** Addition of two integer (ie. not [Float]) ivals. *)
val
add_under
:
t
->
t
->
t
or_bottom
(** Underapproximation of the same operation *)
val
add_singleton_int
:
Integer
.
t
->
t
->
t
(** Addition of an integer ival with an integer. Exact operation. *)
val
neg
:
t
->
t
(** Negation of an integer ival. Exact operation. *)
val
scale
:
Integer
.
t
->
t
->
t
val
scale_div
:
pos
:
bool
->
Integer
.
t
->
t
->
t
val
scale_div_under
:
pos
:
bool
->
Integer
.
t
->
t
->
t
or_bottom
val
scale_rem
:
pos
:
bool
->
Integer
.
t
->
t
->
t
val
mul
:
t
->
t
->
t
val
div
:
t
->
t
->
t
or_bottom
val
c_rem
:
t
->
t
->
t
or_bottom
val
subdivide
:
t
->
t
*
t
val
reduce_sign
:
t
->
bool
->
t
or_bottom
val
reduce_bit
:
int
->
t
->
bool
->
t
or_bottom
val
fold_int
:
(
Integer
.
t
->
'
a
->
'
a
)
->
t
->
'
a
->
'
a
src/kernel_services/abstract_interp/int_set.ml
0 → 100644
View file @
b9b4b79e
(**************************************************************************)
(* *)
(* This file is part of Frama-C. *)
(* *)
(* Copyright (C) 2007-2019 *)
(* CEA (Commissariat à l'énergie atomique et aux énergies *)
(* alternatives) *)
(* *)
(* you can redistribute it and/or modify it under the terms of the GNU *)
(* Lesser General Public License as published by the Free Software *)
(* Foundation, version 2.1. *)
(* *)
(* It is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Lesser General Public License for more details. *)
(* *)
(* See the GNU Lesser General Public License version 2.1 *)
(* for more details (enclosed in the file licenses/LGPLv2.1). *)
(* *)
(**************************************************************************)
open
Abstract_interp
open
Bottom
.
Type
(* Make sure all this is synchronized with the default value of -ilevel *)
let
small_cardinal
=
ref
8
let
set_small_cardinal
i
=
small_cardinal
:=
i
let
debug_cardinal
=
false
let
emitter
=
Lattice_messages
.
register
"Int_set"
;;
let
log_imprecision
s
=
Lattice_messages
.
emit_imprecision
emitter
s
type
set
=
Int
.
t
array
let
bottom
=
Array
.
make
0
Int
.
zero
let
small_nums
=
Array
.
init
33
(
fun
i
->
[
|
(
Integer
.
of_int
i
)
|
])
let
zero
=
small_nums
.
(
0
)
let
one
=
small_nums
.
(
1
)
let
minus_one
=
[
|
Int
.
minus_one
|
]
let
zero_or_one
=
[
|
Int
.
zero
;
Int
.
one
|
]
let
inject_singleton
e
=
if
Int
.
le
Int
.
zero
e
&&
Int
.
le
e
Int
.
thirtytwo
then
small_nums
.
(
Int
.
to_int
e
)
else
[
|
e
|
]
let
unsafe_share_array
a
s
=
let
e
=
a
.
(
0
)
in
if
s
=
1
&&
Int
.
le
Int
.
zero
e
&&
Int
.
le
e
Int
.
thirtytwo
then
small_nums
.
(
Int
.
to_int
e
)
else
if
s
=
2
&&
Int
.
is_zero
e
&&
Int
.
is_one
a
.
(
1
)
then
zero_or_one
else
a
(* TODO: assert s <> 0 *)
let
share_array
a
s
=
if
s
=
0
then
bottom
else
unsafe_share_array
a
s
let
share_array_or_bottom
a
s
=
if
s
=
0
then
`Bottom
else
`Value
(
unsafe_share_array
a
s
)
let
inject_array
=
share_array
let
project_array
t
=
t
(* ------------------------------- Datatype --------------------------------- *)
let
hash
s
=
Array
.
fold_left
(
fun
acc
v
->
1031
*
acc
+
(
Int
.
hash
v
))
17
s
let
rehash
s
=
share_array
s
(
Array
.
length
s
)
exception
Unequal
of
int
let
compare
s1
s2
=
if
s1
==
s2
then
0
else
let
l1
=
Array
.
length
s1
in
let
l2
=
Array
.
length
s2
in
if
l1
<>
l2
then
l1
-
l2
(* no overflow here *)
else
(
try
for
i
=
0
to
l1
-
1
do
let
r
=
Int
.
compare
s1
.
(
i
)
s2
.
(
i
)
in
if
r
<>
0
then
raise
(
Unequal
r
)
done
;
0
with
Unequal
v
->
v
)
let
equal
e1
e2
=
compare
e1
e2
=
0
let
pretty
fmt
s
=
if
Array
.
length
s
=
0
then
Format
.
fprintf
fmt
"BottomMod"
else
begin
Pretty_utils
.
pp_iter
~
pre
:
"@[<hov 1>{"
~
suf
:
"}@]"
~
sep
:
";@ "
Array
.
iter
Int
.
pretty
fmt
s
end
include
Datatype
.
Make_with_collections
(
struct
type
t
=
set
let
name
=
"int_set"
open
Structural_descr
let
structural_descr
=
t_array
(
Descr
.
str
Int
.
descr
)
let
reprs
=
[
zero
]
let
equal
=
equal
let
compare
=
compare
let
hash
=
hash
let
pretty
=
pretty
let
rehash
=
rehash
let
internal_pretty_code
=
Datatype
.
pp_fail
let
mem_project
=
Datatype
.
never_any_project
let
copy
=
Datatype
.
undefined
let
varname
=
Datatype
.
undefined
end
)
(* ---------------------------------- Utils --------------------------------- *)
let
cardinal
=
Array
.
length
let
for_all
f
(
a
:
Integer
.
t
array
)
=
let
l
=
Array
.
length
a
in
let
rec
c
i
=
i
=
l
||
((
f
a
.
(
i
))
&&
c
(
succ
i
))
in
c
0
let
exists
=
Extlib
.
array_exists
let
iter
=
Array
.
iter
let
fold
=
Array
.
fold_left
let
truncate
r
i
=
if
i
=
0
then
`Bottom
else
if
i
=
1
then
`Value
(
inject_singleton
r
.
(
0
))
else
begin
(
Obj
.
truncate
(
Obj
.
repr
r
)
i
);
assert
(
Array
.
length
r
=
i
);
`Value
r
end
exception
Empty
let
map_reduce
(
f
:
'
a
->
'
b
)
(
g
:
'
b
->
'
b
->
'
b
)
(
set
:
'
a
array
)
:
'
b
=
if
Array
.
length
set
<=
0
then
raise
Empty
else
let
acc
=
ref
(
f
set
.
(
0
))
in
for
i
=
1
to
Array
.
length
set
-
1
do
acc
:=
g
!
acc
(
f
set
.
(
i
))
done
;
!
acc
let
filter
(
f
:
Int
.
t
->
bool
)
(
a
:
Int
.
t
array
)
:
t
or_bottom
=
let
l
=
Array
.
length
a
in
let
r
=
Array
.
make
l
Int
.
zero
in
let
j
=
ref
0
in
for
i
=
0
to
l
-
1
do
let
x
=
a
.
(
i
)
in
if
f
x
then
begin
r
.
(
!
j
)
<-
x
;
incr
j
;
end
done
;
truncate
r
!
j
let
mem
v
a
=
let
l
=
Array
.
length
a
in
let
rec
c
i
=
if
i
=
l
then
(
-
1
)
else
let
ae
=
a
.
(
i
)
in
if
Int
.
equal
ae
v
then
i
else
if
Int
.
gt
ae
v
then
(
-
1
)
else
c
(
succ
i
)
in
c
0
(* ------------------------------- Set or top ------------------------------- *)
type
set_or_top
=
[
`Set
of
t
|
`Top
of
Integer
.
t
*
Integer
.
t
*
Integer
.
t
]
module
O
=
FCSet
.
Make
(
Integer
)
type
pre_set
=
|
Pre_set
of
O
.
t
*
int
|
Pre_top
of
Int
.
t
*
Int
.
t
*
Int
.
t
let
empty_ps
=
Pre_set
(
O
.
empty
,
0
)
(* TODO: share this code with ival2.make_itv_from_set? *)
let
make_top_from_set
s
=
if
debug_cardinal
then
assert
(
O
.
cardinal
s
>=
2
);
let
min
=
O
.
min_elt
s
in
let
max
=
O
.
max_elt
s
in
let
modu
=
O
.
fold
(
fun
x
acc
->
if
Int
.
equal
x
min
then
acc
else
Int
.
pgcd
(
Int
.
sub
x
min
)
acc
)
s
Int
.
zero
in
(
min
,
max
,
modu
)
let
add_ps
ps
x
=
match
ps
with
|
Pre_set
(
o
,
s
)
->
if
debug_cardinal
then
assert
(
O
.
cardinal
o
=
s
);
if
O
.
mem
x
o
(* TODO: improve *)
then
ps
else
let
no
=
O
.
add
x
o
in
if
s
<
!
small_cardinal
then
begin
if
debug_cardinal
then
assert
(
O
.
cardinal
no
=
succ
s
);
Pre_set
(
no
,
succ
s
)
end
else
let
min
,
max
,
modu
=
make_top_from_set
no
in
Pre_top
(
min
,
max
,
modu
)
|
Pre_top
(
min
,
max
,
modu
)
->
let
new_modu
=
if
Int
.
equal
x
min
then
modu
else
Int
.
pgcd
(
Int
.
sub
x
min
)
modu
in
let
new_min
=
Int
.
min
min
x
in
let
new_max
=
Int
.
max
max
x
in
Pre_top
(
new_min
,
new_max
,
new_modu
)
let
o_zero
=
O
.
singleton
Int
.
zero
let
o_one
=
O
.
singleton
Int
.
one
let
o_zero_or_one
=
O
.
union
o_zero
o_one
let
share_set
o
s
=
if
s
=
0
then
bottom
else
if
s
=
1
then
begin
let
e
=
O
.
min_elt
o
in
inject_singleton
e
end
else
if
O
.
equal
o
o_zero_or_one
then
zero_or_one
else
let
a
=
Array
.
make
s
Int
.
zero
in
let
i
=
ref
0
in
O
.
iter
(
fun
e
->
a
.
(
!
i
)
<-
e
;
incr
i
)
o
;
assert
(
!
i
=
s
);
a
let
inject_ps
=
function
|
Pre_set
(
o
,
s
)
->
`Set
(
share_set
o
s
)
|
Pre_top
(
min
,
max
,
modu
)
->
`Top
(
min
,
max
,
modu
)
(* Given a set of elements that is an under-approximation, returns an
ival (while maintaining the ival invariants that the "Set"
constructor is used only for small sets of elements. *)
let
set_to_ival_under
set
=
let
card
=
Int
.
Set
.
cardinal
set
in
if
card
<=
!
small_cardinal
then
let
a
=
Array
.
make
card
Int
.
zero
in
ignore
(
Int
.
Set
.
fold
(
fun
elt
i
->
Array
.
set
a
i
elt
;
i
+
1
)
set
0
);
`Set
(
share_array
a
card
)
else
(* If by chance the set is contiguous. *)
if
(
Int
.
equal
(
Int
.
sub
(
Int
.
Set
.
max_elt
set
)
(
Int
.
Set
.
min_elt
set
))
(
Int
.
of_int
(
card
-
1
)))
then
`Top
(
Int
.
Set
.
min_elt
set
,
Int
.
Set
.
max_elt
set
,
Int
.
one
)
(* Else: arbitrarily drop some elements of the under approximation. *)
else
let
a
=
Array
.
make
!
small_cardinal
Int
.
zero
in
log_imprecision
"Ival.set_to_ival_under"
;
try
ignore
(
Int
.
Set
.
fold
(
fun
elt
i
->
if
i
=
!
small_cardinal
then
raise
Exit
;
Array
.
set
a
i
elt
;
i
+
1
)
set
0
);
assert
false
with
Exit
->
`Set
a
(* ------------------------------ Apply and map ----------------------------- *)
let
apply_bin_1_strict_incr
f
x
(
s
:
Integer
.
t
array
)
=
let
l
=
Array
.
length
s
in
let
r
=
Array
.
make
l
Int
.
zero
in
let
rec
c
i
=
if
i
=
l
then
share_array
r
l
else
let
v
=
f
x
s
.
(
i
)
in
r
.
(
i
)
<-
v
;
c
(
succ
i
)
in
c
0
let
apply_bin_1_strict_decr
f
x
(
s
:
Integer
.
t
array
)
=
let
l
=
Array
.
length
s
in
let
r
=
Array
.
make
l
Int
.
zero
in
let
rec
c
i
=
if
i
=
l
then
share_array
r
l
else
let
v
=
f
x
s
.
(
i
)
in
r
.
(
l
-
i
-
1
)
<-
v
;
c
(
succ
i
)
in
c
0
let
apply2_n
f
(
s1
:
Integer
.
t
array
)
(
s2
:
Integer
.
t
array
)
=
let
ps
=
ref
empty_ps
in
let
l1
=
Array
.
length
s1
in
let
l2
=
Array
.
length
s2
in
for
i1
=
0
to
pred
l1
do
let
e1
=
s1
.
(
i1
)
in
for
i2
=
0
to
pred
l2
do
ps
:=
add_ps
!
ps
(
f
e1
s2
.
(
i2
))
done
done
;
inject_ps
!
ps
let
apply2_notzero
f
(
s1
:
Integer
.
t
array
)
s2
=
inject_ps
(
Array
.
fold_left
(
fun
acc
v1
->
Array
.
fold_left
(
fun
acc
v2
->
if
Int
.
is_zero
v2
then
acc
else
add_ps
acc
(
f
v1
v2
))
acc
s2
)
empty_ps
s1
)
let
map_set_decr
f
(
s
:
Integer
.
t
array
)
=
let
l
=
Array
.
length
s
in
if
l
=
0
then
`Bottom
else
let
r
=
Array
.
make
l
Int
.
zero
in
let
rec
c
srcindex
dstindex
last
=
if
srcindex
<
0
then
begin
r
.
(
dstindex
)
<-
last
;
truncate
r
(
succ
dstindex
)
end
else
let
v
=
f
s
.
(
srcindex
)
in
if
Int
.
equal
v
last
then
c
(
pred
srcindex
)
dstindex
last
else
begin
r
.
(
dstindex
)
<-
last
;
c
(
pred
srcindex
)
(
succ
dstindex
)
v
end
in
c
(
l
-
2
)
0
(
f
s
.
(
pred
l
))
let
map_set_strict_decr
f
(
s
:
Integer
.
t
array
)
=
let
l
=
Array
.
length
s
in
let
r
=
Array
.
make
l
Int
.
zero
in
let
rec
c
i
=
if
i
=
l
then
share_array
r
l
else
let
v
=
f
s
.
(
i
)
in
r
.
(
l
-
i
-
1
)
<-
v
;
c
(
succ
i
)
in
c
0
let
map_set_incr
f
(
s
:
Integer
.
t
array
)
=
let
l
=
Array
.
length
s
in
if
l
=
0
then
`Bottom
else
let
r
=
Array
.
make
l
Int
.
zero
in
let
rec
c
srcindex
dstindex
last
=
if
srcindex
=
l
then
begin
r
.
(
dstindex
)
<-
last
;
truncate
r
(
succ
dstindex
)
end
else
let
v
=
f
s
.
(
srcindex
)
in
if
Int
.
equal
v
last
then
c
(
succ
srcindex
)
dstindex
last