diff --git a/Makefile.in b/Makefile.in
index 6ad00dc4c89f88a3dea67d98709ea360a86656e2..37a125f8d380796947774d2c59e2b39fddc272ad 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -181,8 +181,7 @@ LIB_MLW = ity expr dexpr pdecl pmodule
LIB_PARSER = ptree glob parser typing lexer
LIB_TRANSFORM = simplify_formula inlining split_goal induction \
- detect_polymorphism \
- reduction_engine compute \
+ detect_polymorphism reduction_engine compute \
eliminate_definition eliminate_algebraic \
eliminate_inductive eliminate_let eliminate_if \
libencoding discriminate encoding encoding_select \
@@ -193,7 +192,7 @@ LIB_TRANSFORM = simplify_formula inlining split_goal induction \
eliminate_epsilon intro_projections_counterexmp \
intro_vc_vars_counterexmp prepare_for_counterexmp \
eval_match instantiate_predicate smoke_detector \
- induction_pr prop_curry
+ induction_pr prop_curry eliminate_literal
LIB_PRINTER = cntexmp_printer alt_ergo why3printer smtv1 smtv2 coq pvs isabelle \
simplify gappa cvc3 yices mathematica
diff --git a/drivers/alt_ergo_common.drv b/drivers/alt_ergo_common.drv
index 8274543cfe76e6812219916b5165432863b2693b..ffb91d3d7016ea884d3829ad2d989b4e5c136feb 100644
--- a/drivers/alt_ergo_common.drv
+++ b/drivers/alt_ergo_common.drv
@@ -20,13 +20,13 @@ steps "Valid (\\([0-9]+.?[0-9]*\\)) (\\([0-9]+.?[0-9]*\\))" 2
steps "Valid (\\([0-9]+.?[0-9]*\\)) (\\([0-9]+.?[0-9]*\\) steps)" 2
time "why3cpulimit time : %s s"
-(* À discuter *)
transformation "inline_trivial"
transformation "eliminate_builtin"
transformation "eliminate_recursion"
transformation "eliminate_inductive"
transformation "eliminate_algebraic"
+transformation "eliminate_literal"
transformation "eliminate_epsilon"
transformation "eliminate_if"
transformation "eliminate_let"
diff --git a/drivers/coq-common.gen b/drivers/coq-common.gen
index 9460ba9bfa78c0dc96d759a6f7b73c03bc9b681b..539c98e757c5e2a1e3ceb6ebfde2eaf047ce8d07 100644
--- a/drivers/coq-common.gen
+++ b/drivers/coq-common.gen
@@ -4,9 +4,9 @@ unknown "Error: \\(.*\\)$" "\\1"
fail "Syntax error: \\(.*\\)$" "\\1"
time "why3cpulimit time : %s s"
-(* À discuter *)
transformation "eliminate_non_struct_recursion"
transformation "eliminate_if"
+transformation "eliminate_literal"
transformation "eliminate_non_lambda_set_epsilon"
transformation "eliminate_projections"
diff --git a/drivers/cvc3.drv b/drivers/cvc3.drv
index 7de510a32db751da196ce962a5fd0bdbf9844a9e..a818afb8159b00d7b20d1f94d47eafdae3843ded 100644
--- a/drivers/cvc3.drv
+++ b/drivers/cvc3.drv
@@ -14,13 +14,12 @@ outofmemory "Out of memory\\|std::bad_alloc\\|GNU MP: Cannot allocate memory"
timeout "self-timeout"
time "why3cpulimit time : %s s"
-(* À discuter *)
transformation "inline_trivial"
-
transformation "eliminate_builtin"
transformation "eliminate_definition"
transformation "eliminate_inductive"
transformation "eliminate_algebraic"
+transformation "eliminate_literal"
transformation "eliminate_epsilon"
transformation "simplify_formula"
diff --git a/drivers/cvc4.drv b/drivers/cvc4.drv
index 29c3532fca81f72c891912f713921134e130259e..b45834db200e5b641e535d8aaffa72371e12eec2 100644
--- a/drivers/cvc4.drv
+++ b/drivers/cvc4.drv
@@ -16,6 +16,7 @@ transformation "eliminate_builtin"
transformation "eliminate_definition"
transformation "eliminate_inductive"
transformation "eliminate_algebraic"
+transformation "eliminate_literal"
transformation "eliminate_epsilon"
transformation "simplify_formula"
diff --git a/drivers/cvc4_14.drv b/drivers/cvc4_14.drv
index 0d0be3a9f1bc728fe510cba9d3f35ca4c95134d8..fa5ef7ab3a8f048c7df0e662e2013071e60cf75c 100644
--- a/drivers/cvc4_14.drv
+++ b/drivers/cvc4_14.drv
@@ -27,6 +27,7 @@ transformation "eliminate_definition"
*)
transformation "eliminate_inductive"
transformation "eliminate_algebraic_if_poly"
+transformation "eliminate_literal"
transformation "eliminate_epsilon"
transformation "simplify_formula"
diff --git a/drivers/cvc4_bv.gen b/drivers/cvc4_bv.gen
index b28a7bdd8845ff237f1d24eebd6f6465d8ca37c3..861dc3e13794b3fda6013b54369bfdb5e16a72c0 100644
--- a/drivers/cvc4_bv.gen
+++ b/drivers/cvc4_bv.gen
@@ -3,20 +3,20 @@
theory bv.BV64
syntax converter of_int "(_ bv%1 64)"
- syntax function to_uint "(bv2nat %1)"
+ syntax function t'int "(bv2nat %1)"
end
theory bv.BV32
syntax converter of_int "(_ bv%1 32)"
- syntax function to_uint "(bv2nat %1)"
+ syntax function t'int "(bv2nat %1)"
end
theory bv.BV16
syntax converter of_int "(_ bv%1 16)"
- syntax function to_uint "(bv2nat %1)"
+ syntax function t'int "(bv2nat %1)"
end
theory bv.BV8
syntax converter of_int "(_ bv%1 8)"
- syntax function to_uint "(bv2nat %1)"
+ syntax function t'int "(bv2nat %1)"
end
diff --git a/drivers/isabelle-common.gen b/drivers/isabelle-common.gen
index 17a1c82ae54673a96ff8741ab013634eaa9c7f5f..2860cbed9945b734b7fad7e7d68008da430315c3 100644
--- a/drivers/isabelle-common.gen
+++ b/drivers/isabelle-common.gen
@@ -6,6 +6,7 @@ valid "Finished Why3 theory"
fail "\\*\\*\\* \\(.*\\)$" "\\1"
time "why3cpulimit time : %s s"
+transformation "eliminate_literal"
transformation "eliminate_epsilon"
transformation "eliminate_if_fmla"
transformation "eliminate_let_fmla"
diff --git a/drivers/mathsat.drv b/drivers/mathsat.drv
index a3998b42872e1818b33e148e8805887643d20118..ba21f909bc5ac4587dc9381388319886f3bf6590 100644
--- a/drivers/mathsat.drv
+++ b/drivers/mathsat.drv
@@ -12,9 +12,7 @@ outofmemory "(error \".*out of memory\")\\|Cannot allocate memory"
time "why3cpulimit time : %s s"
-(* À discuter *)
transformation "inline_trivial"
-
transformation "eliminate_builtin"
transformation "eliminate_definition"
transformation "eliminate_inductive"
diff --git a/drivers/psyche.drv b/drivers/psyche.drv
index 101b6c99fe9906411cd4e397d0c7ba0f965d2547..6cd7020f2512319673027eba08ea5e6792e75df5 100644
--- a/drivers/psyche.drv
+++ b/drivers/psyche.drv
@@ -10,9 +10,7 @@ invalid "^NOT PROVABLE"
timeout "interrupted by timeout"
time "why3cpulimit time : %s s"
-(* À discuter *)
transformation "inline_trivial"
-
transformation "eliminate_builtin"
transformation "eliminate_definition"
transformation "eliminate_inductive"
diff --git a/drivers/smt-libv2-bv-realization.gen b/drivers/smt-libv2-bv-realization.gen
index 6c3dc18124ebe86181a5fb31a938ab59f0330efe..cc378b90dfc709fcab8d8db2d9f22ae0e7deadb9 100644
--- a/drivers/smt-libv2-bv-realization.gen
+++ b/drivers/smt-libv2-bv-realization.gen
@@ -62,8 +62,10 @@ theory bv.BV_Gen
remove prop to_uint_bounds
remove prop to_uint_of_int
- remove prop Of_int_zeros
- remove prop Of_int_ones
+ remove prop to_uint_size_bv
+ remove prop to_uint_zeros
+ remove prop to_uint_ones
+ remove prop to_uint_one
(** Arithmetic operators *)
diff --git a/drivers/smt-libv2-bv.gen b/drivers/smt-libv2-bv.gen
index fcb56f8db67cd9feb2584a324caf5c272d55a095..49e5215e2f0f0c5f989cd31dbfb948e58f8bd6ee 100644
--- a/drivers/smt-libv2-bv.gen
+++ b/drivers/smt-libv2-bv.gen
@@ -48,8 +48,10 @@ theory bv.BV_Gen
remove prop to_uint_bounds
remove prop to_int_extensionality
- remove prop Of_int_zeros
- remove prop Of_int_ones
+ remove prop to_uint_size_bv
+ remove prop to_uint_zeros
+ remove prop to_uint_ones
+ remove prop to_uint_one
remove prop to_uint_add
remove prop to_uint_add_bounded
@@ -76,40 +78,60 @@ theory bv.BV_Gen
end
theory bv.BV64
+ meta "literal:keep" type t
+
+ syntax literal t "#x%16x"
syntax type t "(_ BitVec 64)"
syntax function zeros "#x0000000000000000"
- syntax function ones "#xFFFFFFFFFFFFFFFF"
+ syntax function one "#x0000000000000001"
+ syntax function ones "#xFFFFFFFFFFFFFFFF"
+ syntax function size_bv "(_ bv64 64)"
syntax function rotate_left_bv "(bvor (bvshl %1 (bvurem %2 (_ bv64 64))) (bvlshr %1 (bvsub (_ bv64 64) (bvurem %2 (_ bv64 64)))))"
syntax function rotate_right_bv "(bvor (bvlshr %1 (bvurem %2 (_ bv64 64))) (bvshl %1 (bvsub (_ bv64 64) (bvurem %2 (_ bv64 64)))))"
end
theory bv.BV32
+ meta "literal:keep" type t
+
+ syntax literal t "#x%8x"
syntax type t "(_ BitVec 32)"
syntax function zeros "#x00000000"
- syntax function ones "#xFFFFFFFF"
+ syntax function one "#x00000001"
+ syntax function ones "#xFFFFFFFF"
+ syntax function size_bv "(_ bv32 32)"
syntax function rotate_left_bv "(bvor (bvshl %1 (bvurem %2 (_ bv32 32))) (bvlshr %1 (bvsub (_ bv32 32) (bvurem %2 (_ bv32 32)))))"
syntax function rotate_right_bv "(bvor (bvlshr %1 (bvurem %2 (_ bv32 32))) (bvshl %1 (bvsub (_ bv32 32) (bvurem %2 (_ bv32 32)))))"
end
theory bv.BV16
+ meta "literal:keep" type t
+
+ syntax literal t "#x%4x"
syntax type t "(_ BitVec 16)"
syntax function zeros "#x0000"
- syntax function ones "#xFFFF"
+ syntax function one "#x0001"
+ syntax function ones "#xFFFF"
+ syntax function size_bv "(_ bv16 16)"
syntax function rotate_left_bv "(bvor (bvshl %1 (bvurem %2 (_ bv16 16))) (bvlshr %1 (bvsub (_ bv16 16) (bvurem %2 (_ bv16 16)))))"
syntax function rotate_right_bv "(bvor (bvlshr %1 (bvurem %2 (_ bv16 16))) (bvshl %1 (bvsub (_ bv16 16) (bvurem %2 (_ bv16 16)))))"
end
theory bv.BV8
+ meta "literal:keep" type t
+
+ syntax literal t (* "#b%8b" *) "#x%2x"
syntax type t "(_ BitVec 8)"
syntax function zeros "#x00"
- syntax function ones "#xFF"
+ syntax function one "#x01"
+ syntax function ones "#xFF"
+ syntax function size_bv "(_ bv8 8)"
syntax function rotate_left_bv "(bvor (bvshl %1 (bvurem %2 (_ bv8 8))) (bvlshr %1 (bvsub (_ bv8 8) (bvurem %2 (_ bv8 8)))))"
syntax function rotate_right_bv "(bvor (bvlshr %1 (bvurem %2 (_ bv8 8))) (bvshl %1 (bvsub (_ bv8 8) (bvurem %2 (_ bv8 8)))))"
diff --git a/drivers/yices.drv b/drivers/yices.drv
index 9c99c6dbaa564878c3ba8dd5b37dcf811e66e847..d1e42fc39b66f314d50beff7c8619e4cb4760fb5 100644
--- a/drivers/yices.drv
+++ b/drivers/yices.drv
@@ -11,9 +11,7 @@ unknown "\\bunknown\\b\\|\\bsat\\b" ""
unknown "feature not supported: non linear problem" "non linear arith"
time "why3cpulimit time : %s s"
-(* À discuter *)
transformation "inline_trivial"
-
transformation "eliminate_builtin"
transformation "eliminate_definition"
transformation "eliminate_inductive"
diff --git a/drivers/z3-realize.drv b/drivers/z3-realize.drv
deleted file mode 100644
index af1d615d330de06012784fcfbeade899f1ffb92c..0000000000000000000000000000000000000000
--- a/drivers/z3-realize.drv
+++ /dev/null
@@ -1,100 +0,0 @@
-(** Why3 driver for Z3 >= 4.3.2 *)
-
-(* Do not set any logic, let z3 choose by itself
- prelude "(set-logic AUFNIRA)"
-*)
-
-(* Counterexamples: set model parser *)
-model_parser "smtv2"
-
-
-import "smt-libv2.drv"
-import "smt-libv2-bv-realization.gen"
-import "discrimination.gen"
-
-transformation "inline_trivial"
-transformation "eliminate_builtin"
-transformation "detect_polymorphism"
-transformation "eliminate_definition"
-(* We could keep more definitions by using
- transformation "eliminate_definition_if_poly"
- instead, but some proofs are lost
- (examples/logic/triangle_inequality.why)
-*)
-transformation "eliminate_inductive"
-transformation "eliminate_algebraic_if_poly"
-transformation "eliminate_epsilon"
-
-transformation "simplify_formula"
-(*transformation "simplify_trivial_quantification"*)
-
-(* Prepare for counter-example query: get rid of some quantifiers (makes it
-possible to query model values of the variables in premises) and introduce
-counter-example projections *)
-transformation "prepare_for_counterexmp"
-
-transformation "discriminate_if_poly"
-transformation "encoding_smt_if_poly"
-
-
-(** Error messages specific to Z3 *)
-
-outofmemory "(error \".*out of memory\")\\|Cannot allocate memory"
-timeout "interrupted by timeout"
-
-(** Extra theories supported by Z3 *)
-
-(* div/mod of Z3 seems to be Euclidean Division *)
-theory int.EuclideanDivision
- syntax function div "(div %1 %2)"
- syntax function mod "(mod %1 %2)"
- remove prop Mod_bound
- remove prop Div_mod
- remove prop Mod_1
- remove prop Div_1
-end
-
-theory real.FromInt
- syntax function from_int "(to_real %1)"
- remove prop Zero
- remove prop One
- remove prop Add
- remove prop Sub
- remove prop Mul
- remove prop Neg
-end
-
-(* does not work: Z3 segfaults
-theory real.Trigonometry
-
- syntax function cos "(cos %1)"
- syntax function sin "(sin %1)"
- syntax function pi "pi"
- syntax function tan "(tan %1)"
- syntax function atan "(atan %1)"
-
-end
-*)
-
-
-(* bitvector modules, is not in smt-libv2.drv since cvc4 and z3 don't
- have the same name for the function to_uint *)
-theory bv.BV64
- syntax converter of_int "((_ int2bv 64) %1)"
- syntax function to_uint "(bv2int %1)"
-end
-
-theory bv.BV32
- syntax converter of_int "((_ int2bv 32) %1)"
- syntax function to_uint "(bv2int %1)"
-end
-
-theory bv.BV16
- syntax converter of_int "((_ int2bv 16) %1)"
- syntax function to_uint "(bv2int %1)"
-end
-
-theory bv.BV8
- syntax converter of_int "((_ int2bv 8) %1)"
- syntax function to_uint "(bv2int %1)"
-end
diff --git a/drivers/z3_432.drv b/drivers/z3_432.drv
index 045298015875b70a76411cff0da4ddb82ee077ca..9bfef9fa1bd580fae09bdcea2327d4a25e148366 100644
--- a/drivers/z3_432.drv
+++ b/drivers/z3_432.drv
@@ -7,7 +7,6 @@
(* Counterexamples: set model parser *)
model_parser "smtv2"
-
import "smt-libv2.drv"
import "no-bv.gen"
import "discrimination.gen"
@@ -23,6 +22,7 @@ transformation "eliminate_definition"
*)
transformation "eliminate_inductive"
transformation "eliminate_algebraic_if_poly"
+transformation "eliminate_literal"
transformation "eliminate_epsilon"
transformation "simplify_formula"
diff --git a/drivers/z3_440.drv b/drivers/z3_440.drv
index f73169df01a80e9a304c025642017f6d4e6264e6..bfbf8fa77f7a190024871bffdf113a127381e57b 100644
--- a/drivers/z3_440.drv
+++ b/drivers/z3_440.drv
@@ -23,6 +23,7 @@ transformation "eliminate_definition"
*)
transformation "eliminate_inductive"
transformation "eliminate_algebraic_if_poly"
+transformation "eliminate_literal"
transformation "eliminate_epsilon"
transformation "simplify_formula"
@@ -81,7 +82,7 @@ end
have the same name for the function to_uint *)
theory bv.BV64
syntax converter of_int "((_ int2bv 64) %1)"
- syntax function to_uint "(bv2int %1)"
+ syntax function t'int "(bv2int %1)"
remove prop Nth_bv_is_nth
remove prop Nth_bv_is_nth2
@@ -89,7 +90,7 @@ end
theory bv.BV32
syntax converter of_int "((_ int2bv 32) %1)"
- syntax function to_uint "(bv2int %1)"
+ syntax function t'int "(bv2int %1)"
remove prop Nth_bv_is_nth
remove prop Nth_bv_is_nth2
@@ -97,7 +98,7 @@ end
theory bv.BV16
syntax converter of_int "((_ int2bv 16) %1)"
- syntax function to_uint "(bv2int %1)"
+ syntax function t'int "(bv2int %1)"
remove prop Nth_bv_is_nth
remove prop Nth_bv_is_nth2
@@ -105,7 +106,7 @@ end
theory bv.BV8
syntax converter of_int "((_ int2bv 8) %1)"
- syntax function to_uint "(bv2int %1)"
+ syntax function t'int "(bv2int %1)"
remove prop Nth_bv_is_nth
remove prop Nth_bv_is_nth2
diff --git a/drivers/z3_smtv1.drv b/drivers/z3_smtv1.drv
index be4fb8ba36b880f826fe831717c69ff5f33b0dd1..a81059a24e42131f3701fd30b6bb3614019619c0 100644
--- a/drivers/z3_smtv1.drv
+++ b/drivers/z3_smtv1.drv
@@ -10,9 +10,7 @@ unknown "^\\(unknown\\|sat\\|Fail\\)" ""
time "why3cpulimit time : %s s"
-(* À discuter *)
transformation "inline_trivial"
-
transformation "eliminate_builtin"
transformation "eliminate_definition"
transformation "eliminate_inductive"
diff --git a/examples/binary_search/why3session.xml b/examples/binary_search/why3session.xml
index de5456ddb815fb2b692681b6e8a861e55a8cd3b9..e566dac0f5a5bdf05e79091de1a3fc62a069b50a 100644
--- a/examples/binary_search/why3session.xml
+++ b/examples/binary_search/why3session.xml
@@ -21,87 +21,87 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
diff --git a/examples/binary_search/why3shapes.gz b/examples/binary_search/why3shapes.gz
index a7a2fbcc3dbc2c0cd59f648d4a3dbeb3c38c8f10..63d1cbb025df5a8dbe3c88d870fa3d86f81ed5a7 100644
Binary files a/examples/binary_search/why3shapes.gz and b/examples/binary_search/why3shapes.gz differ
diff --git a/examples/bitcount.mlw b/examples/bitcount.mlw
index 73e9c423e564e06851214db72ec9a88b4b5d16b7..c5a1bd3d09772a04d04531ad7173bfb39a86093b 100644
--- a/examples/bitcount.mlw
+++ b/examples/bitcount.mlw
@@ -7,7 +7,7 @@ module BitCount8bit_fact
function nth_as_bv (a i : t) : t =
if nth_bv a i
- then (of_int 1)
+ then (1 : t)
else zeros
function nth_as_int (a : t) (i : int) : int =
@@ -16,81 +16,81 @@ module BitCount8bit_fact
else 0
lemma nth_as_bv_is_int : forall a i.
- to_uint (nth_as_bv a i) = nth_as_int a (to_uint i)
+ t'int (nth_as_bv a i) = nth_as_int a (t'int i)
use import int.EuclideanDivision
let ghost step1 (n x1 : t) (i : int) : unit
requires { 0 <= i < 4 }
- requires { x1 = sub n (bw_and (lsr_bv n (of_int 1)) (of_int 0x55)) }
- ensures { to_uint (bw_and (lsr x1 (2*i)) (of_int 0x03))
+ requires { x1 = sub n (bw_and (lsr_bv n (1 : t)) (0x55 : t)) }
+ ensures { t'int (bw_and (lsr x1 (2*i)) (0x03 : t))
= numof (nth n) (2*i) (2*i + 2) }
- ensures { ule (bw_and (lsr x1 (2*i)) (of_int 0x03)) (of_int 2) }
+ ensures { ule (bw_and (lsr x1 (2*i)) (0x03 : t)) (2 : t) }
=
assert { let i' = of_int i in
- let twoi = mul (of_int 2) i' in
- bw_and (lsr_bv x1 twoi) (of_int 0x03)
- = add (nth_as_bv n twoi) (nth_as_bv n (add twoi (of_int 1)))
+ let twoi = mul (2 : t) i' in
+ bw_and (lsr_bv x1 twoi) (0x03 : t)
+ = add (nth_as_bv n twoi) (nth_as_bv n (add twoi (1 : t)))
&&
- to_uint (bw_and (lsr_bv x1 twoi) (of_int 0x03))
- = numof (nth n) (to_uint twoi) (to_uint twoi + 2) }
+ t'int (bw_and (lsr_bv x1 twoi) (0x03 : t))
+ = numof (nth n) (t'int twoi) (t'int twoi + 2) }
let ghost step2 (n x1 x2 : t) (i : int) : unit
requires { 0 <= i < 2 }
- requires { x1 = sub n (bw_and (lsr_bv n (of_int 1)) (of_int 0x55)) }
+ requires { x1 = sub n (bw_and (lsr_bv n (1 : t)) (0x55 : t)) }
requires { x2 = add
- (bw_and x1 (of_int 0x33))
- (bw_and (lsr_bv x1 (of_int 2)) (of_int (0x33))) }
- ensures { to_uint (bw_and (lsr x2 (4*i)) (of_int 0x0F))
+ (bw_and x1 (0x33 : t))
+ (bw_and (lsr_bv x1 (2 : t)) (0x33 : t)) }
+ ensures { t'int (bw_and (lsr x2 (4*i)) (0x0F : t))
= numof (nth n) (4*i) (4*i+4) }
- ensures { ule (bw_and (lsr_bv x2 (of_int (4*i))) (of_int 0x0F))
- (of_int 4) }
+ ensures { ule (bw_and (lsr_bv x2 (of_int (4*i))) (0x0F : t))
+ (4 : t) }
=
step1 n x1 (2*i);
step1 n x1 (2*i+1);
assert { let i' = of_int i in
- ult i' (of_int 2)
+ ult i' (2 : t)
&&
- of_int (4*i) = mul (of_int 4) i'
+ of_int (4*i) = mul (4 : t) i'
&&
- to_uint (bw_and (lsr x2 (4*i)) (of_int 0x0F))
- = to_uint (bw_and (lsr_bv x2 (mul (of_int 4) i')) (of_int 0x0F))
- = to_uint (add (bw_and (lsr_bv x1 (mul (of_int 4) i')) (of_int 0x03))
- (bw_and (lsr_bv x1 (add (mul (of_int 4) i') (of_int 2))) (of_int (0x03))))
- = to_uint (add (bw_and (lsr x1 (4*i)) (of_int 0x03))
- (bw_and (lsr x1 ((4*i)+2)) (of_int (0x03))))}
+ t'int (bw_and (lsr x2 (4*i)) (0x0F : t))
+ = t'int (bw_and (lsr_bv x2 (mul (4 : t) i')) (0x0F : t))
+ = t'int (add (bw_and (lsr_bv x1 (mul (4 : t) i')) (0x03 : t))
+ (bw_and (lsr_bv x1 (add (mul (4 : t) i') (2 : t))) (0x03 : t)))
+ = t'int (add (bw_and (lsr x1 (4*i)) (0x03 : t))
+ (bw_and (lsr x1 ((4*i)+2)) (0x03 : t)))}
let ghost prove (n x1 x2 x3 : t) : unit
- requires { x1 = sub n (bw_and (lsr_bv n (of_int 1)) (of_int 0x55)) }
+ requires { x1 = sub n (bw_and (lsr_bv n (1 : t)) (0x55 : t)) }
requires { x2 = add
- (bw_and x1 (of_int 0x33))
- (bw_and (lsr_bv x1 (of_int 2)) (of_int (0x33))) }
- requires { x3 = bw_and (add x2 (lsr_bv x2 (of_int 4))) (of_int 0x0F) }
- ensures { to_uint x3 = numof (nth n) 0 8 }
+ (bw_and x1 (0x33 : t))
+ (bw_and (lsr_bv x1 (2 : t)) (0x33 : t)) }
+ requires { x3 = bw_and (add x2 (lsr_bv x2 (4 : t))) (0x0F : t) }
+ ensures { t'int x3 = numof (nth n) 0 8 }
=
step2 n x1 x2 0;
step2 n x1 x2 1;
- assert { to_uint (bw_and x2 (of_int 0x0F)) +
- to_uint (bw_and (lsr_bv x2 (of_int 4)) (of_int 0x0F))
- = to_uint (bw_and (lsr x2 0) (of_int 0x0F)) +
- to_uint (bw_and (lsr x2 4) (of_int 0x0F)) }
+ assert { t'int (bw_and x2 (0x0F : t)) +
+ t'int (bw_and (lsr_bv x2 (4 : t)) (0x0F : t))
+ = t'int (bw_and (lsr x2 0) (0x0F : t)) +
+ t'int (bw_and (lsr x2 4) (0x0F : t)) }
let count (n : t) : t
- ensures { to_uint result = numof (nth n) 0 8 }
+ ensures { t'int result = numof (nth n) 0 8 }
=
let x = ref n in
- x := sub !x (bw_and (lsr_bv !x (of_int 1)) (of_int 0x55));
+ x := sub !x (bw_and (lsr_bv !x (1 : t)) (0x55 : t));
let ghost x1 = !x in
x := add
- (bw_and !x (of_int 0x33))
- (bw_and (lsr_bv !x (of_int 2)) (of_int (0x33)));
+ (bw_and !x (0x33 : t))
+ (bw_and (lsr_bv !x (2 : t)) (0x33 : t));
let ghost x2 = !x in
- x := bw_and (add !x (lsr_bv !x (of_int 4))) (of_int 0x0F);
+ x := bw_and (add !x (lsr_bv !x (4 : t))) (0x0F : t);
prove n x1 x2 !x;
@@ -106,75 +106,75 @@ module BitCounting32
use import ref.Ref
predicate step0 (n x1 : t) =
- x1 = sub n (bw_and (lsr_bv n (of_int 1)) (of_int 0x55555555))
+ x1 = sub n (bw_and (lsr_bv n (1 : t)) (0x55555555 : t))
let ghost proof0 (n x1 : t) (i : int) : unit
requires { 0 <= i < 16 }
requires { step0 n x1 }
- ensures { to_uint (bw_and (lsr x1 (2*i)) (of_int 0x03))
+ ensures { t'int (bw_and (lsr x1 (2*i)) (0x03 : t))
= numof (nth n) (2*i) (2*i + 2) }
=
let i' = of_int i in
- let twoi = mul (of_int 2) i' in
- assert { to_uint twoi = 2 * i };
- assert { to_uint (add twoi (of_int 1)) = to_uint twoi + 1 };
- assert { to_uint (bw_and (lsr_bv x1 twoi) (of_int 0x03))
+ let twoi = mul (2 : t) i' in
+ assert { t'int twoi = 2 * i };
+ assert { t'int (add twoi (1 : t)) = t'int twoi + 1 };
+ assert { t'int (bw_and (lsr_bv x1 twoi) (0x03 : t))
= (if nth_bv n twoi then 1 else 0) +
- (if nth_bv n (add twoi (of_int 1)) then 1 else 0)
- = (if nth n (to_uint twoi) then 1 else 0) +
- (if nth n (to_uint twoi + 1) then 1 else 0)
- = numof (nth n) (to_uint twoi) (to_uint twoi + 2) }
+ (if nth_bv n (add twoi (1 : t)) then 1 else 0)
+ = (if nth n (t'int twoi) then 1 else 0) +
+ (if nth n (t'int twoi + 1) then 1 else 0)
+ = numof (nth n) (t'int twoi) (t'int twoi + 2) }
predicate step1 (x1 x2 : t) =
- x2 = add (bw_and x1 (of_int 0x33333333))
- (bw_and (lsr_bv x1 (of_int 2)) (of_int (0x33333333)))
+ x2 = add (bw_and x1 (0x33333333 : t))
+ (bw_and (lsr_bv x1 (2 : t)) (0x33333333 : t))
let ghost proof1 (n x1 x2 : t) (i : int) : unit
requires { 0 <= i < 8 }
requires { step0 n x1 }
requires { step1 x1 x2 }
- ensures { to_uint (bw_and (lsr x2 (4*i)) (of_int 0x07))
+ ensures { t'int (bw_and (lsr x2 (4*i)) (0x07 : t))
= numof (nth n) (4*i) (4*i+4) }
=
proof0 n x1 (2*i);
proof0 n x1 (2*i+1);
let i' = of_int i in
- assert { ult i' (of_int 8) };
- assert { to_uint (mul (of_int 4) i') = 4*i };
- assert { bw_and (lsr x2 (4*i)) (of_int 0x07)
- = bw_and (lsr_bv x2 (mul (of_int 4) i')) (of_int 0x07)
- = add (bw_and (lsr_bv x1 (mul (of_int 4) i')) (of_int 0x03))
- (bw_and (lsr_bv x1 (add (mul (of_int 4) i') (of_int 2)))
- (of_int (0x03)))
- = add (bw_and (lsr x1 (4*i)) (of_int 0x03))
- (bw_and (lsr x1 ((4*i)+2)) (of_int (0x03))) }
+ assert { ult i' (8 : t) };
+ assert { t'int (mul (4 : t) i') = 4*i };
+ assert { bw_and (lsr x2 (4*i)) (0x07 : t)
+ = bw_and (lsr_bv x2 (mul (4 : t) i')) (0x07 : t)
+ = add (bw_and (lsr_bv x1 (mul (4 : t) i')) (0x03 : t))
+ (bw_and (lsr_bv x1 (add (mul (4 : t) i') (2 : t)))
+ (0x03 : t))
+ = add (bw_and (lsr x1 (4*i)) (0x03 : t))
+ (bw_and (lsr x1 ((4*i)+2)) (0x03 : t)) }
predicate step2 (x2:t) (x3:t) =
- x3 = bw_and (add x2 (lsr_bv x2 (of_int 4))) (of_int 0x0F0F0F0F)
+ x3 = bw_and (add x2 (lsr_bv x2 (4 : t))) (0x0F0F0F0F : t)
let ghost proof2 (n x1 x2 x3 : t) (i : int) : unit
requires { 0 <= i < 4 }
requires { step0 n x1 }
requires { step1 x1 x2 }
requires { step2 x2 x3 }
- ensures { to_uint (bw_and (lsr x3 (8*i)) (of_int 0x0F))
+ ensures { t'int (bw_and (lsr x3 (8*i)) (0x0F : t))
= numof (nth n) (8*i) (8*i+8) }
=
proof1 n x1 x2 (2*i);
proof1 n x1 x2 (2*i+1);
let i' = of_int i in
- assert { ult i' (of_int 4) };
- assert { to_uint (mul (of_int 8) i') = 8*i };
- assert { to_uint (add (mul (of_int 8) i') (of_int 4)) = 8*i+4 };
- assert { bw_and (lsr x3 (8*i)) (of_int 0x0F)
- = bw_and (lsr_bv x3 (mul (of_int 8) i')) (of_int 0x0F)
- = add (bw_and (lsr_bv x2 (mul (of_int 8) i')) (of_int 0x07))
- (bw_and (lsr_bv x2 (add (mul (of_int 8) i') (of_int 4))) (of_int (0x07)))
- = add (bw_and (lsr x2 (8*i)) (of_int 0x07))
- (bw_and (lsr x2 ((8*i)+4)) (of_int (0x07))) }
+ assert { ult i' (4 : t) };
+ assert { t'int (mul (8 : t) i') = 8*i };
+ assert { t'int (add (mul (8 : t) i') (4 : t)) = 8*i+4 };
+ assert { bw_and (lsr x3 (8*i)) (0x0F : t)
+ = bw_and (lsr_bv x3 (mul (8 : t) i')) (0x0F : t)
+ = add (bw_and (lsr_bv x2 (mul (8 : t) i')) (0x07 : t))
+ (bw_and (lsr_bv x2 (add (mul (8 : t) i') (4 : t))) (0x07 : t))
+ = add (bw_and (lsr x2 (8*i)) (0x07 : t))
+ (bw_and (lsr x2 ((8*i)+4)) (0x07 : t)) }
predicate step3 (x3:t) (x4:t) =
- x4 = add x3 (lsr_bv x3 (of_int 8))
+ x4 = add x3 (lsr_bv x3 (8 : t))
let ghost proof3 (n x1 x2 x3 x4 : t) (i : int) : unit
requires { 0 <= i < 2 }
@@ -182,24 +182,24 @@ module BitCounting32
requires { step1 x1 x2 }
requires { step2 x2 x3 }
requires { step3 x3 x4 }
- ensures { to_uint (bw_and (lsr x4 (16*i)) (of_int 0x1F))
+ ensures { t'int (bw_and (lsr x4 (16*i)) (0x1F : t))
= numof (nth n) (16*i) (16*i+16) }
=
proof2 n x1 x2 x3 (2*i);
proof2 n x1 x2 x3 (2*i+1);
let i' = of_int i in
- assert { ult i' (of_int 2) };
- assert { to_uint (mul (of_int 16) i') = 16*i };
- assert { to_uint (add (mul (of_int 16) i') (of_int 8)) = 16*i+8 };
- assert { bw_and (lsr x4 (16*i)) (of_int 0x1F)
- = bw_and (lsr_bv x4 (mul (of_int 16) i')) (of_int 0x1F)
- = add (bw_and (lsr_bv x3 (mul (of_int 16) i')) (of_int 0x0F))
- (bw_and (lsr_bv x3 (add (mul (of_int 16) i') (of_int 8))) (of_int (0x0F)))
- = add (bw_and (lsr x3 (16*i)) (of_int 0x0F))
- (bw_and (lsr x3 ((16*i)+8)) (of_int (0x0F))) }
+ assert { ult i' (2 : t) };
+ assert { t'int (mul (16 : t) i') = 16*i };
+ assert { t'int (add (mul (16 : t) i') (8 : t)) = 16*i+8 };
+ assert { bw_and (lsr x4 (16*i)) (0x1F : t)
+ = bw_and (lsr_bv x4 (mul (16 : t) i')) (0x1F : t)
+ = add (bw_and (lsr_bv x3 (mul (16 : t) i')) (0x0F : t))
+ (bw_and (lsr_bv x3 (add (mul (16 : t) i') (8 : t))) (0x0F : t))
+ = add (bw_and (lsr x3 (16*i)) (0x0F : t))
+ (bw_and (lsr x3 ((16*i)+8)) (0x0F : t)) }
predicate step4 (x4:t) (x5:t) =
- x5 = add x4 (lsr_bv x4 (of_int 16))
+ x5 = add x4 (lsr_bv x4 (16 : t))
let ghost prove (n x1 x2 x3 x4 x5 : t) : unit
requires { step0 n x1 }
@@ -207,43 +207,43 @@ module BitCounting32
requires { step2 x2 x3 }
requires { step3 x3 x4 }
requires { step4 x4 x5 }
- ensures { to_uint (bw_and x5 (of_int 0x3F)) = numof (nth n) 0 32 }
+ ensures { t'int (bw_and x5 (0x3F : t)) = numof (nth n) 0 32 }
=
proof3 n x1 x2 x3 x4 0;
proof3 n x1 x2 x3 x4 1;
(* moved to the stdlib
assert { x4 = lsr x4 0 };
*)
- assert { bw_and x5 (of_int 0x3F)
- = add (bw_and x4 (of_int 0x1F)) (bw_and (lsr_bv x4 (of_int 16)) (of_int 0x1F))
- = add (bw_and (lsr x4 0) (of_int 0x1F)) (bw_and (lsr x4 16) (of_int 0x1F)) }
+ assert { bw_and x5 (0x3F : t)
+ = add (bw_and x4 (0x1F : t)) (bw_and (lsr_bv x4 (16 : t)) (0x1F : t))
+ = add (bw_and (lsr x4 0) (0x1F : t)) (bw_and (lsr x4 16) (0x1F : t)) }
function count_logic (n:t) : int = numof (nth n) 0 32
let count (n : t) : t
- ensures { to_uint result = count_logic n }
+ ensures { t'int result = count_logic n }
=
let x = ref n in
(* x = x - ( (x >> 1) & 0x55555555) *)
- x := sub !x (bw_and (lsr_bv !x (of_int 1)) (of_int 0x55555555));
+ x := sub !x (bw_and (lsr_bv !x (1 : t)) (0x55555555 : t));
let ghost x1 = !x in
(* x = (x & 0x33333333) + ((x >> 2) & 0x33333333) *)
- x := add (bw_and !x (of_int 0x33333333))
- (bw_and (lsr_bv !x (of_int 2)) (of_int (0x33333333)));
+ x := add (bw_and !x (0x33333333 : t))
+ (bw_and (lsr_bv !x (2 : t)) (0x33333333 : t));
let ghost x2 = !x in
(* x = (x + (x >> 4)) & 0x0F0F0F0F *)
- x := bw_and (add !x (lsr_bv !x (of_int 4))) (of_int 0x0F0F0F0F);
+ x := bw_and (add !x (lsr_bv !x (4 : t))) (0x0F0F0F0F : t);
let ghost x3 = !x in
(* x = x + (x >> 8) *)
- x := add !x (lsr_bv !x (of_int 8));
+ x := add !x (lsr_bv !x (8 : t));
let ghost x4 = !x in
(* x = x + (x >> 16) *)
- x := add !x (lsr_bv !x (of_int 16));
+ x := add !x (lsr_bv !x (16 : t));
prove n x1 x2 x3 x4 !x;
(* return (x & 0x0000003F) *)
- bw_and !x (of_int 0x0000003F)
+ bw_and !x (0x0000003F : t)
end
@@ -260,7 +260,7 @@ module Hamming
function hammingD_logic (a b : t) : int = NumOf.numof (nth_diff a b) 0 32
let hammingD (a b : t) : t
- ensures { to_uint result = hammingD_logic a b }
+ ensures { t'int result = hammingD_logic a b }
=
assert { forall i. 0 <= i < 32 -> nth (bw_xor a b) i <-> (nth_diff a b i) };
count (bw_xor a b)
@@ -305,7 +305,7 @@ module AsciiCode
use import mach.bv.BVCheck32
use import BitCounting32
- constant one : t = of_int 1
+ constant one : t = 1 : t
constant lastbit : t = sub size_bv one
(* let lastbit () = (sub_check size_bv one) : t *)
@@ -326,14 +326,14 @@ module AsciiCode
predicate validAscii (b : t) = even (count_logic b)
let lemma bv_even (b:t)
- ensures { even (to_uint b) <-> not (nth b 0) }
+ ensures { even (t'int b) <-> not (nth b 0) }
=
- assert { not (nth_bv b zeros) <-> b = mul (of_int 2) (lsr_bv b one) };
- assert { (exists k. b = mul (of_int 2) k) -> not (nth_bv b zeros) };
- assert { (exists k. to_uint b = 2 * k) -> (exists k. b = mul (of_int 2) k) };
- assert { not (nth b 0) <-> to_uint b = 2 * to_uint (lsr b 1) }
+ assert { not (nth_bv b zeros) <-> b = mul (2 : t) (lsr_bv b one) };
+ assert { (exists k. b = mul (2 : t) k) -> not (nth_bv b zeros) };
+ assert { (exists k. t'int b = 2 * k) -> (exists k. b = mul (2 : t) k) };
+ assert { not (nth b 0) <-> t'int b = 2 * t'int (lsr b 1) }
- lemma bv_odd : forall b : t. odd (to_uint b) <-> nth b 0
+ lemma bv_odd : forall b : t. odd (t'int b) <-> nth b 0
(* use Numofbit *)
@@ -371,10 +371,10 @@ module AsciiCode
let c = count b in
let maskbit = lsl_check c lastbit in
assert { bw_and b maskbit = zeros };
- assert { even (to_uint c) ->
+ assert { even (t'int c) ->
not (nth_bv c zeros)
&& count_logic maskbit = 0 };
- assert { odd (to_uint c) ->
+ assert { odd (t'int c) ->
nth_bv c zeros
&& nth maskbit 31
&& (forall i. 0 <= i < 31 -> not (nth maskbit i))
@@ -418,7 +418,7 @@ module GrayCode
use import BitCounting32
use Hamming
- constant one : t = of_int 1
+ constant one : t = 1 : t
constant lastbit : t = sub size_bv one
(** {2 Gray code}
@@ -436,11 +436,11 @@ module GrayCode
bw_xor bv (lsr_bv bv one)
function fromGray (gr : t) : t =
- let b = bw_xor gr (lsr_bv gr (of_int 1)) in
- let b = bw_xor b (lsr_bv b (of_int 2)) in
- let b = bw_xor b (lsr_bv b (of_int 4)) in
- let b = bw_xor b (lsr_bv b (of_int 8)) in
- bw_xor b (lsr_bv b (of_int 16))
+ let b = bw_xor gr (lsr_bv gr (1 : t)) in
+ let b = bw_xor b (lsr_bv b (2 : t)) in
+ let b = bw_xor b (lsr_bv b (4 : t)) in
+ let b = bw_xor b (lsr_bv b (8 : t)) in
+ bw_xor b (lsr_bv b (16 : t))
(** Which define an isomorphism. *)
@@ -458,7 +458,7 @@ module GrayCode
assert { b <> ones -> toGray (add b one) = bw_xor (toGray b) (bw_and (bw_not b) (add b one)) };
assert { b <> ones -> exists k. (bw_and (bw_not b) (add b one)) = lsl one k };
assert { b <> ones -> count_logic (bw_and (bw_not b) (add b one)) = 1 };
- assert { b = ones -> (toGray b) = of_int 0x80000000 /\ (toGray (add b one)) = zeros }
+ assert { b = ones -> (toGray b) = 0x80000000 : t /\ (toGray (add b one)) = zeros }
(** Now, a couple of property between the Gray code and the binary
representation.
diff --git a/examples/bitcount/why3session.xml b/examples/bitcount/why3session.xml
index 55005f6321b71997f53a617c368731d25cf1c359..abfcb287f548f55f065a7bd8e8a9d6e679ca4cb9 100644
--- a/examples/bitcount/why3session.xml
+++ b/examples/bitcount/why3session.xml
@@ -2,114 +2,202 @@
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
+
-
+
+
+
-
+
+
-
+
+
-
+
+
-
+
+
+
-
-
+
+
-
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
-
+
+
+
+
-
-
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
-
+
+
@@ -118,431 +206,792 @@
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
-
+
+
+
-
+
+
-
+
+
+
-
+
+
+
+
-
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
+
-
-
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
-
-
+
+
+
+
+
-
-
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
-
+
+
+
-
-
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
-
+
+
+
+
-
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
-
+
-
+
+
+
-
+
+
+
-
+
+
+
-
+
+
-
+
+
+
-
+
+
+
+
-
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
-
+
-
+
+
+
-
+
+
-
+
+
+
+
+
+
+
+
-
+
+
-
+
+
+
+
-
-
+
+
+
+
-
+
+
-
+
+
+
+
-
+
-
+
-
+
+
+
+
-
-
+
+
+
+
-
+
+
-
+
+
+
-
+
-
+
+
+
-
+
+
-
+
+
+
-
+
-
+
+
+
-
+
+
+
-
+
+
+
+
-
-
+
+
-
+
+
+
+
+
-
+
+
+
+
+
-
+
-
-
+
+
+
+
+
+
-
+
+
+
+
diff --git a/examples/bitcount/why3shapes.gz b/examples/bitcount/why3shapes.gz
index e533c64d6ab1178a7ce7a12cbf5fc00fc6e18528..deda8e75cbb85a0c7395c364b29c72a24a629650 100644
Binary files a/examples/bitcount/why3shapes.gz and b/examples/bitcount/why3shapes.gz differ
diff --git a/examples/bitvector_examples.mlw b/examples/bitvector_examples.mlw
index 83e1896268b190b029286d373004fa4c013abfc7..9a0f8cf42508cb438879f5091325858c78f3f620 100644
--- a/examples/bitvector_examples.mlw
+++ b/examples/bitvector_examples.mlw
@@ -8,13 +8,13 @@ module Test_proofinuse
(* Shift is div example ------------------- *)
let shift_is_div ( x : t ) ( y : t ) : t =
- requires{ 0 <= to_uint y < 32 }
- let res = lsr_bv x ( of_int 1 ) in
- assert{ res = ( udiv x (of_int 2) ) };
- assert{ to_uint res = div (to_uint x) 2 };
- let res = lsr_bv res ( of_int 2 ) in
- assert{ res = ( udiv x (of_int 8) ) };
- assert{ to_uint res = div (to_uint x) 8 };
+ requires{ 0 <= t'int y < 32 }
+ let res = lsr_bv x one in
+ assert{ res = ( udiv x (2:t) ) };
+ assert{ t'int res = div (t'int x) 2 };
+ let res = lsr_bv res (2:t) in
+ assert{ res = ( udiv x (8:t) ) };
+ assert{ t'int res = div (t'int x) 8 };
res
(* Mask example --------------------- *)
@@ -29,14 +29,14 @@ module Test_proofinuse
type bitvec64 = BV64.t
let mask ( x : t ) =
- ensures{ BV8.eq result (BV8.of_int 1) }
+ ensures{ BV8.eq result BV8.one }
(* ensures{ not ( BV8.eq result (BV8.of_int 1) ) } *)
let res = C8_32.toSmall(
bw_and
- ( bw_or
- ( bw_and x (of_int 0xFFFF_FF00) )
- (of_int 1) )
- ( of_int 0x0000_00FF ) )
+ (bw_or
+ (bw_and x (0xFFFF_FF00:t))
+ one)
+ (0x0000_00FF:t))
in res
(* test invariant from frama-c ---------------- *)
@@ -45,7 +45,7 @@ module Test_proofinuse
let testVariant( n : t ) =
let i = ref n in
- let two = of_int 2 in
+ let two = 2:t in
while uge !i two do
variant{ !i with ult }
@@ -54,7 +54,7 @@ module Test_proofinuse
(* testssss *)
- predicate in_range (n : t) = (ule (of_int 0) n) /\ (ule n (of_int 0x0000_00FF))
+ predicate in_range (n : t) = (ule (0:t) n) /\ (ule n (0x0000_00FF:t))
predicate add_over (x y : t) = (uge (add x y) x) /\ (uge (add x y) y)
@@ -76,13 +76,13 @@ theory Hackers_delight
bw_not( bw_or x y ) = bw_and (bw_not x) (bw_not y)
goal DM3: forall x.
- bw_not( add x (of_int 1) ) = sub (bw_not x) (of_int 1)
+ bw_not (add x one) = sub (bw_not x) one
goal DM4: forall x.
- bw_not( sub x (of_int 1) ) = add (bw_not x) (of_int 1)
+ bw_not (sub x one) = add (bw_not x) one
goal DM5: forall x.
- bw_not( neg x ) = sub x (of_int 1)
+ bw_not (neg x) = sub x one
goal DM6: forall x y.
bw_not( bw_xor x y ) = bw_xor (bw_not x) y (* = eq x y *)
@@ -94,7 +94,7 @@ theory Hackers_delight
bw_not( sub x y ) = add (bw_not x) y
goal DMtest: forall x.
- zeros = bw_not( bw_or x (neg( add x (of_int 1))))
+ zeros = bw_not( bw_or x (neg( add x one)))
(* inequality *)
@@ -112,17 +112,17 @@ theory Hackers_delight
(* shift right and arithmetic shift right *)
- goal SR1: forall x n. ( ule zeros n /\ ule n (of_int 31)) ->
- bw_or (lsr_bv x n) (lsl_bv (neg( lsr_bv x (of_int 31) )) (sub (of_int 31) n))
+ goal SR1: forall x n. ( ule zeros n /\ ule n (31:t)) ->
+ bw_or (lsr_bv x n) (lsl_bv (neg( lsr_bv x (31:t) )) (sub (31:t) n))
= asr_bv x n
(* rotate en shift *)
goal RS_left: forall x.
- bw_or (lsl_bv x (of_int 1)) (lsr_bv x (of_int 31)) = rotate_left_bv x (of_int 1)
+ bw_or (lsl_bv x one) (lsr_bv x (31:t)) = rotate_left_bv x one
goal RS_right: forall x.
- bw_or (lsr_bv x (of_int 1)) (lsl_bv x (of_int 31)) = rotate_right_bv x (of_int 1)
+ bw_or (lsr_bv x one) (lsl_bv x (31:t)) = rotate_right_bv x one
(* bound propagation *)
@@ -157,15 +157,15 @@ module Hackers_delight_mod
bw_not( bw_or x y )
let dm3 (x : t) =
- ensures{ result = sub (bw_not x) (of_int 1) }
- bw_not( add x (of_int 1) )
+ ensures{ result = sub (bw_not x) one }
+ bw_not( add x one )
let dm4 (x : t) =
- ensures{ result = add (bw_not x) (of_int 1) }
- bw_not( sub x (of_int 1) )
+ ensures{ result = add (bw_not x) one }
+ bw_not( sub x one )
let dm5 (x : t) =
- ensures{ result = sub x (of_int 1) }
+ ensures{ result = sub x one }
bw_not( neg x )
let dm6 (x : t) (y : t) =
@@ -182,7 +182,7 @@ module Hackers_delight_mod
let dmtest (x : t) =
ensures{ result = zeros }
- bw_not( bw_or x (neg( add x (of_int 1))))
+ bw_not( bw_or x (neg( add x one)))
(* inequality *)
@@ -207,19 +207,19 @@ module Hackers_delight_mod
(* shift right and arithmetic shift right *)
let sr1 (x : t) (n : t) =
- requires{ ule zeros n /\ ule n (of_int 31) }
+ requires{ ule zeros n /\ ule n (31:t) }
ensures{ result = asr_bv x n }
- bw_or (lsr_bv x n) (lsl_bv (neg( lsr_bv x (of_int 31) )) (sub (of_int 31) n))
+ bw_or (lsr_bv x n) (lsl_bv (neg( lsr_bv x (31:t) )) (sub (31:t) n))
(* rotate en shift *)
let rs_left (x : t) =
- ensures{ result = rotate_left_bv x (of_int 1) }
- bw_or (lsl_bv x (of_int 1)) (lsr_bv x (of_int 31))
+ ensures{ result = rotate_left_bv x one }
+ bw_or (lsl_bv x one) (lsr_bv x (31:t))
let rs_right (x : t) =
- ensures{ result = rotate_right_bv x (of_int 1) }
- bw_or (lsr_bv x (of_int 1)) (lsl_bv x (of_int 31))
+ ensures{ result = rotate_right_bv x one }
+ bw_or (lsr_bv x one) (lsl_bv x (31:t))
(* bound propagation *)
@@ -267,31 +267,31 @@ module Test_imperial_violet
forall b. ule zeros b /\ ule b ones
lemma to_int_ule:
- forall b c. ule b c -> to_uint b <= to_uint c
+ forall b c. ule b c -> t'int b <= t'int c
lemma to_int_ult:
- forall b c. ult b c -> to_uint b < to_uint c
+ forall b c. ult b c -> t'int b < t'int c
lemma bv32_bounds_0:
- forall b. 0 <= to_uint b
+ forall b. 0 <= t'int b
lemma bv32_bounds:
- forall b. 0 <= to_uint b < 0x1_0000_0000
+ forall b. 0 <= t'int b < 0x1_0000_0000
(* bounded add of array of t *)
let add (a : array t ) (b : array t) =
requires{ length a = length b }
requires{ forall i. 0 <= i < length a ->
- ult a[i] (of_int 0x8000_0000) }
+ ult a[i] (0x8000_0000:t) }
requires{ forall i. 0 <= i < length b ->
- ult b[i] (of_int 0x8000_0000) }
+ ult b[i] (0x8000_0000:t) }
ensures{ forall i. 0 <= i < length result ->
- to_uint result[i] = to_uint a[i] + to_uint b[i] }
+ t'int result[i] = t'int a[i] + t'int b[i] }
let sum = make (length a) zeros in
for i = 0 to length a - 1 do
invariant{ forall j. 0 <= j < i -> sum[j] = add a[j] b[j] }
- invariant{ forall j. 0 <= j < i -> to_uint sum[j] = to_uint a[j] + to_uint b[j] }
+ invariant{ forall j. 0 <= j < i -> t'int sum[j] = t'int a[j] + t'int b[j] }
sum[i] <- add a[i] b[i]
done;
sum
@@ -304,123 +304,123 @@ module Test_from_bitvector_example
use import bv.BV32
goal Test1:
- let b = bw_and zeros ones in nth_bv b (of_int 1) = False
+ let b = bw_and zeros ones in nth_bv b one = False
goal Test2:
- let b = lsr_bv ones (of_int 16) in nth_bv b (of_int 15) = True
+ let b = lsr_bv ones (16:t) in nth_bv b (15:t) = True
goal Test3:
- let b = lsr_bv ones (of_int 16) in nth_bv b (of_int 16) = False
+ let b = lsr_bv ones (16:t) in nth_bv b (16:t) = False
goal Test4:
- let b = asr_bv ones (of_int 16) in nth_bv b (of_int 15) = True
+ let b = asr_bv ones (16:t) in nth_bv b (15:t) = True
goal Test5:
- let b = asr_bv ones (of_int 16) in nth_bv b (of_int 16) = True
+ let b = asr_bv ones (16:t) in nth_bv b (16:t) = True
goal Test6:
- let b = asr_bv (lsr_bv ones (of_int 1)) (of_int 16) in nth_bv b (of_int 16) = False
+ let b = asr_bv (lsr_bv ones one) (16:t) in nth_bv b (16:t) = False
let lsr31 () =
- ensures{ result = of_int 1 }
- lsr_bv ones (of_int 31)
+ ensures{ result = one }
+ lsr_bv ones (31:t)
let lsr30 () =
- ensures{ result = of_int 3 }
- lsr_bv ones (of_int 30)
+ ensures{ result = (3:t) }
+ lsr_bv ones (30:t)
let lsr29 () =
- ensures{ to_uint result = 7 }
- lsr_bv ones (of_int 29)
+ ensures{ t'int result = 7 }
+ lsr_bv ones (29:t)
let lsr28 () =
- ensures{ to_uint result = 15 }
- lsr_bv ones (of_int 28)
+ ensures{ t'int result = 15 }
+ lsr_bv ones (28:t)
let lsr27 () =
- ensures{ to_uint result = 31 }
- lsr_bv ones (of_int 27)
+ ensures{ t'int result = 31 }
+ lsr_bv ones (27:t)
let lsr26 () =
- ensures{ to_uint result = 63 }
- lsr_bv ones (of_int 26)
+ ensures{ t'int result = 63 }
+ lsr_bv ones (26:t)
let lsr20 () =
- ensures{ to_uint result = 4095 }
- lsr_bv ones (of_int 20)
+ ensures{ t'int result = 4095 }
+ lsr_bv ones (20:t)
let lsr13 () =
- ensures{ to_uint result = 524287 }
- lsr_bv ones (of_int 13)
+ ensures{ t'int result = 524287 }
+ lsr_bv ones (13:t)
let lsr8 () =
- ensures{ to_uint result = 16777215 }
- lsr_bv ones (of_int 8)
+ ensures{ t'int result = 16777215 }
+ lsr_bv ones (8:t)
goal to_int_0x00000001:
- to_uint (lsr_bv ones (of_int 31)) = 1
+ t'int (lsr_bv ones (31:t)) = 1
goal to_int_0x00000003:
- to_uint (lsr_bv ones (of_int 30)) = 3
+ t'int (lsr_bv ones (30:t)) = 3
goal to_int_0x00000007:
- to_uint (lsr_bv ones (of_int 29)) = 7
+ t'int (lsr_bv ones (29:t)) = 7
goal to_int_0x0000000F:
- to_uint (lsr_bv ones (of_int 28)) = 15
+ t'int (lsr_bv ones (28:t)) = 15
goal to_int_0x0000001F:
- to_uint (lsr_bv ones (of_int 27)) = 31
+ t'int (lsr_bv ones (27:t)) = 31
goal to_int_0x0000003F:
- to_uint (lsr_bv ones (of_int 26)) = 63
+ t'int (lsr_bv ones (26:t)) = 63
goal to_int_0x0000007F:
- to_uint (lsr_bv ones (of_int 25)) = 127
+ t'int (lsr_bv ones (25:t)) = 127
goal to_int_0x000000FF:
- to_uint (lsr_bv ones (of_int 24)) = 255
+ t'int (lsr_bv ones (24:t)) = 255
goal to_int_0x000001FF:
- to_uint (lsr_bv ones (of_int 23)) = 511
+ t'int (lsr_bv ones (23:t)) = 511
goal to_int_0x000003FF:
- to_uint (lsr_bv ones (of_int 22)) = 1023
+ t'int (lsr_bv ones (22:t)) = 1023
goal to_int_0x000007FF:
- to_uint (lsr_bv ones (of_int 21)) = 2047
+ t'int (lsr_bv ones (21:t)) = 2047
goal to_int_0x00000FFF:
- to_uint (lsr_bv ones (of_int 20)) = 4095
+ t'int (lsr_bv ones (20:t)) = 4095
goal to_int_0x00001FFF:
- to_uint (lsr_bv ones (of_int 19)) = 8191
+ t'int (lsr_bv ones (19:t)) = 8191
goal to_int_0x00003FFF:
- to_uint (lsr_bv ones (of_int 18)) = 16383
+ t'int (lsr_bv ones (18:t)) = 16383
goal to_int_0x00007FFF:
- to_uint (lsr_bv ones (of_int 17)) = 32767
+ t'int (lsr_bv ones (17:t)) = 32767
goal to_int_0x0000FFFF:
- to_uint (lsr_bv ones (of_int 16)) = 65535
+ t'int (lsr_bv ones (16:t)) = 65535
goal to_int_0x0001FFFF:
- to_uint (lsr_bv ones (of_int 15)) = 131071
+ t'int (lsr_bv ones (15:t)) = 131071
goal to_int_0x0003FFFF:
- to_uint (lsr_bv ones (of_int 14)) = 262143
+ t'int (lsr_bv ones (14:t)) = 262143
goal to_int_0x0007FFFF:
- to_uint (lsr_bv ones (of_int 13)) = 524287
+ t'int (lsr_bv ones (13:t)) = 524287
goal to_int_0x000FFFFF:
- to_uint (lsr_bv ones (of_int 12)) = 1048575
+ t'int (lsr_bv ones (12:t)) = 1048575
goal to_int_0x00FFFFFF:
- to_uint (lsr_bv ones (of_int 8)) = 16777215
+ t'int (lsr_bv ones (8:t)) = 16777215
goal to_int_0xFFFFFFFF:
- to_uint ones = 4294967295
+ t'int ones = 4294967295
end
diff --git a/examples/bitvector_examples/why3session.xml b/examples/bitvector_examples/why3session.xml
index 7c7b0ccdefa3bccbf101ead8b0aee436f9100971..a3e24601d35dedea235cb3b52bc8461ccb1a8443 100644
--- a/examples/bitvector_examples/why3session.xml
+++ b/examples/bitvector_examples/why3session.xml
@@ -2,24 +2,24 @@
-
+
-
+
-
+
-
+
@@ -33,7 +33,7 @@
-
+
@@ -92,7 +92,7 @@
-
+
@@ -154,27 +154,27 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
diff --git a/examples/bitvector_examples/why3shapes.gz b/examples/bitvector_examples/why3shapes.gz
index 061f815dbaed7c452e181aa7af855d5c08d9d634..7763d0f5e773e15329325d53dc1db0b90721a66e 100644
Binary files a/examples/bitvector_examples/why3shapes.gz and b/examples/bitvector_examples/why3shapes.gz differ
diff --git a/examples/bitwalker.mlw b/examples/bitwalker.mlw
index 1f304ae7ab0e6925b80b96f4e2109284e9c5e75a..bec2e314944205cea029b8d9d044b4300f4f7941 100644
--- a/examples/bitwalker.mlw
+++ b/examples/bitwalker.mlw
@@ -31,9 +31,9 @@ module Bitwalker
function maxvalue (len : BV32.t) : BV64.t = BV64.lsl_bv (BV64.of_int 1) (C32_64.toBig len)
let lemma nth_ultpre0 (x:BV64.t) (len:BV32.t)
- requires { BV32.to_uint len < 64}
- ensures { BV64.eq_sub x BV64.zeros (BV32.to_uint len) (64 - BV32.to_uint len)
- <-> BV64.to_uint x < BV64.to_uint (maxvalue len) }
+ requires { BV32.t'int len < 64}
+ ensures { BV64.eq_sub x BV64.zeros (BV32.t'int len) (64 - BV32.t'int len)
+ <-> BV64.t'int x < BV64.t'int (maxvalue len) }
=
assert { BV32.ult len (BV32.of_int 64) };
assert { BV64.eq_sub_bv x BV64.zeros (C32_64.toBig len) (BV64.sub (BV64.of_int 64) (C32_64.toBig len))
@@ -41,10 +41,10 @@ module Bitwalker
(** return [value] with the bit of index [left] from the left set to [flag] *)
let poke_64bit_bv (value : BV64.t) (left : BV32.t) (flag : bool) : BV64.t
- requires { BV32.to_uint left < 64 }
- ensures { forall i. 0 <= i < 64 /\ i <> 63 - BV32.to_uint left ->
+ requires { BV32.t'int left < 64 }
+ ensures { forall i. 0 <= i < 64 /\ i <> 63 - BV32.t'int left ->
BV64.nth result i = BV64.nth value i }
- ensures { flag = BV64.nth result (63 - BV32.to_uint left) }
+ ensures { flag = BV64.nth result (63 - BV32.t'int left) }
=
assert { BV32.ult left (BV32.of_int 64) };
abstract
@@ -95,8 +95,8 @@ module Bitwalker
left *)
let peek_8bit_bv (byte : BV8.t) (left : BV32.t) : bool
- requires { 0 <= BV32.to_uint left < 8 }
- ensures { result = BV8.nth byte (7 - BV32.to_uint left) }
+ requires { 0 <= BV32.t'int left < 8 }
+ ensures { result = BV8.nth byte (7 - BV32.t'int left) }
=
assert {BV32.ult left (BV32.of_int 8)};
abstract
@@ -112,27 +112,27 @@ module Bitwalker
(* return the bit of the [left]/8 element of [addr] at position mod [left] 8 starting from the left *)
let peek_8bit_array (addr : array BV8.t) (left : BV32.t) : bool
requires { 8 * (length addr) < BV32.two_power_size }
- requires { BV32.to_uint left < 8 * length addr }
- ensures { result = nth8_stream addr (BV32.to_uint left) }
+ requires { BV32.t'int left < 8 * length addr }
+ ensures { result = nth8_stream addr (BV32.t'int left) }
=
- peek_8bit_bv (addr[ BV32.to_uint (BV32.udiv_check left (BV32.int_check 8)) ]) (BV32.urem_check left (BV32.int_check 8))
+ peek_8bit_bv (addr[ BV32.t'int (BV32.udiv_check left (BV32.int_check 8)) ]) (BV32.urem_check left (BV32.int_check 8))
(* return a bitvector of 64 bits with its [len] bits of the right
set to the bits between [start] and [start] + [len] of [addr] *)
let peek (start : BV32.t) (len : BV32.t) (addr : array BV8.t) : BV64.t
- requires { BV32.to_uint len <= 64 }
- requires { BV32.to_uint start + BV32.to_uint len < BV32.two_power_size }
+ requires { BV32.t'int len <= 64 }
+ requires { BV32.t'int start + BV32.t'int len < BV32.two_power_size }
requires { 8 * length addr < BV32.two_power_size }
- ensures { BV32.to_uint start + BV32.to_uint len > (8 * length addr) ->
+ ensures { BV32.t'int start + BV32.t'int len > (8 * length addr) ->
result = BV64.zeros }
- ensures { BV32.to_uint start + BV32.to_uint len <= (8 * length addr) ->
- (forall i:int. 0 <= i < BV32.to_uint len ->
+ ensures { BV32.t'int start + BV32.t'int len <= (8 * length addr) ->
+ (forall i:int. 0 <= i < BV32.t'int len ->
BV64.nth result i
- = nth8_stream addr (BV32.to_uint start + BV32.to_uint len - i - 1))
+ = nth8_stream addr (BV32.t'int start + BV32.t'int len - i - 1))
/\
- (forall i:int. BV32.to_uint len <= i < 64 -> BV64.nth result i = False) }
+ (forall i:int. BV32.t'int len <= i < 64 -> BV64.nth result i = False) }
=
- if (BV32.to_uint (BV32.add_check start len) > ( 8 *length addr ))
+ if (BV32.t'int (BV32.add_check start len) > ( 8 *length addr ))
then
BV64.zeros
else
@@ -142,14 +142,14 @@ module Bitwalker
let lstart = BV32.sub_check (BV32.of_int 64) len in
while BV32.ult !i len do variant{ !i with BV32.ugt }
- invariant {0 <= BV32.to_uint !i <= BV32.to_uint len}
- invariant {forall j:int. BV32.to_uint len - BV32.to_uint !i <= j < BV32.to_uint len ->
+ invariant {0 <= BV32.t'int !i <= BV32.t'int len}
+ invariant {forall j:int. BV32.t'int len - BV32.t'int !i <= j < BV32.t'int len ->
BV64.nth !retval j
- = nth8_stream addr (BV32.to_uint start + BV32.to_uint len - j - 1)}
- invariant {forall j:int. 0 <= j < BV32.to_uint len - BV32.to_uint !i ->
+ = nth8_stream addr (BV32.t'int start + BV32.t'int len - j - 1)}
+ invariant {forall j:int. 0 <= j < BV32.t'int len - BV32.t'int !i ->
BV64.nth !retval j
= False}
- invariant {forall j:int. BV32.to_uint len <= j < 64 ->
+ invariant {forall j:int. BV32.t'int len <= j < 64 ->
BV64.nth !retval j
= False}
@@ -163,8 +163,8 @@ module Bitwalker
!retval
let peek_64bit (value : BV64.t) (left : BV32.t) : bool
- requires {BV32.to_uint left < 64}
- ensures {result = BV64.nth value (63 - BV32.to_uint left)}
+ requires {BV32.t'int left < 64}
+ ensures {result = BV64.nth value (63 - BV32.t'int left)}
=
assert {BV32.ult left (BV32.of_int 64)};
abstract
@@ -186,10 +186,10 @@ module Bitwalker
(* return [byte] with the bit at index [left] from the left set to [flag] *)
let poke_8bit (byte : BV8.t) (left : BV32.t) (flag : bool) : BV8.t
- requires { BV32.to_uint left < 8 }
- ensures { forall i:int. 0 <= i < 8 -> i <> 7 - BV32.to_uint left ->
+ requires { BV32.t'int left < 8 }
+ ensures { forall i:int. 0 <= i < 8 -> i <> 7 - BV32.t'int left ->
BV8.nth result i = BV8.nth byte i }
- ensures { BV8.nth result (7 - BV32.to_uint left) = flag }
+ ensures { BV8.nth result (7 - BV32.t'int left) = flag }
=
assert { BV32.ult left (BV32.of_int 8) };
abstract
@@ -209,38 +209,38 @@ module Bitwalker
let poke_8bit_array (addr : array BV8.t) (left : BV32.t) (flag : bool)
writes {addr}
requires { 8 * (length addr) < BV32.two_power_size }
- requires { BV32.to_uint left < 8 * length addr }
- ensures { forall i:int. 0 <= i < 8 * length addr -> i <> BV32.to_uint left ->
+ requires { BV32.t'int left < 8 * length addr }
+ ensures { forall i:int. 0 <= i < 8 * length addr -> i <> BV32.t'int left ->
nth8_stream addr i = nth8_stream (old addr) i}
- ensures { nth8_stream addr (BV32.to_uint left) = flag }
+ ensures { nth8_stream addr (BV32.t'int left) = flag }
=
let i = BV32.udiv_check left (BV32.int_check 8) in
let k = BV32.urem_check left (BV32.int_check 8) in
- addr[BV32.to_uint i] <- poke_8bit addr[BV32.to_uint i] k flag
+ addr[BV32.t'int i] <- poke_8bit addr[BV32.t'int i] k flag
let poke (start : BV32.t) (len : BV32.t) (addr : array BV8.t) (value : BV64.t)
writes { addr }
- requires{ BV32.to_uint len < 64 } (* could be lower or equal if maxvalue and the condition to return -2 is corrected *)
- requires{ BV32.to_uint start + BV32.to_uint len < BV32.two_power_size }
+ requires{ BV32.t'int len < 64 } (* could be lower or equal if maxvalue and the condition to return -2 is corrected *)
+ requires{ BV32.t'int start + BV32.t'int len < BV32.two_power_size }
requires{ 8 * length addr < BV32.two_power_size }
ensures { -2 <= result <= 0 }
- ensures { result = -1 <-> BV32.to_uint start + BV32.to_uint len > 8 * length addr }
- ensures { result = -2 <-> BV64.to_uint (maxvalue len) <= BV64.to_uint value /\ BV32.to_uint start + BV32.to_uint len <= 8 * length addr }
- ensures { result = 0 <-> BV64.to_uint (maxvalue len) > BV64.to_uint value /\ BV32.to_uint start + BV32.to_uint len <= 8 * length addr }
+ ensures { result = -1 <-> BV32.t'int start + BV32.t'int len > 8 * length addr }
+ ensures { result = -2 <-> BV64.t'int (maxvalue len) <= BV64.t'int value /\ BV32.t'int start + BV32.t'int len <= 8 * length addr }
+ ensures { result = 0 <-> BV64.t'int (maxvalue len) > BV64.t'int value /\ BV32.t'int start + BV32.t'int len <= 8 * length addr }
ensures { result = 0 ->
- (forall i:int. 0 <= i < BV32.to_uint start ->
+ (forall i:int. 0 <= i < BV32.t'int start ->
nth8_stream (old addr) i
= nth8_stream addr i)
/\
- (forall i:int. BV32.to_uint start <= i < BV32.to_uint start + BV32.to_uint len ->
+ (forall i:int. BV32.t'int start <= i < BV32.t'int start + BV32.t'int len ->
nth8_stream addr i
- = BV64.nth value (BV32.to_uint len - i - 1 + BV32.to_uint start))
+ = BV64.nth value (BV32.t'int len - i - 1 + BV32.t'int start))
/\
- (forall i:int. BV32.to_uint start + BV32.to_uint len <= i < 8 * length addr ->
+ (forall i:int. BV32.t'int start + BV32.t'int len <= i < 8 * length addr ->
nth8_stream addr i
= nth8_stream (old addr) i) }
=
- if BV32.to_uint (BV32.add_check start len) > 8 * length addr
+ if BV32.t'int (BV32.add_check start len) > 8 * length addr
then
-1 (*error: invalid_bit_sequence*)
else
@@ -255,14 +255,14 @@ module Bitwalker
'Init:
while BV32.ult !i len do variant { !i with BV32.ugt }
- invariant {0 <= BV32.to_uint !i <= BV32.to_uint len}
- invariant {forall j:int. 0 <= j < BV32.to_uint start ->
+ invariant {0 <= BV32.t'int !i <= BV32.t'int len}
+ invariant {forall j:int. 0 <= j < BV32.t'int start ->
nth8_stream (at addr 'Init) j
= nth8_stream addr j}
- invariant {forall j:int. BV32.to_uint start <= j < BV32.to_uint start + BV32.to_uint !i ->
+ invariant {forall j:int. BV32.t'int start <= j < BV32.t'int start + BV32.t'int !i ->
nth8_stream addr j
- = BV64.nth value (BV32.to_uint len - j - 1 + BV32.to_uint start) }
- invariant {forall j:int. BV32.to_uint start + BV32.to_uint !i <= j < 8 * length addr ->
+ = BV64.nth value (BV32.t'int len - j - 1 + BV32.t'int start) }
+ invariant {forall j:int. BV32.t'int start + BV32.t'int !i <= j < 8 * length addr ->
nth8_stream addr j
= nth8_stream (at addr 'Init) j }
@@ -270,13 +270,13 @@ module Bitwalker
poke_8bit_array addr (BV32.add_check start !i) flag;
- assert {nth8_stream addr (BV32.to_uint start + BV32.to_uint !i)
- = BV64.nth value ((BV32.to_uint len - BV32.to_uint !i - 1))};
- assert { forall k. BV32.to_uint start <= k < BV32.to_uint start + BV32.to_uint !i ->
- k <> BV32.to_uint start + BV32.to_uint !i &&
+ assert {nth8_stream addr (BV32.t'int start + BV32.t'int !i)
+ = BV64.nth value ((BV32.t'int len - BV32.t'int !i - 1))};
+ assert { forall k. BV32.t'int start <= k < BV32.t'int start + BV32.t'int !i ->
+ k <> BV32.t'int start + BV32.t'int !i &&
0 <= k < 8 * length addr &&
nth8_stream addr k
- = BV64.nth value (BV32.to_uint start + BV32.to_uint len - k - 1)};
+ = BV64.nth value (BV32.t'int start + BV32.t'int len - k - 1)};
i := BV32.add_check !i (BV32.int_check 1);
done;
@@ -285,8 +285,8 @@ module Bitwalker
let peekthenpoke (start len : BV32.t) (addr : array BV8.t)
requires {8 * length addr < BV32.two_power_size}
- requires {0 <= BV32.to_uint len < 64}
- requires {BV32.to_uint start + BV32.to_uint len <= 8 * length addr}
+ requires {0 <= BV32.t'int len < 64}
+ requires {BV32.t'int start + BV32.t'int len <= 8 * length addr}
ensures {result = 0}
ensures {forall i. 0 <= i < 8 * length addr ->
nth8_stream addr i = nth8_stream (old addr) i}
@@ -297,7 +297,7 @@ module Bitwalker
assert {res = 0};
- assert {forall i. BV32.to_uint start <= i < BV32.to_uint start + BV32.to_uint len ->
+ assert {forall i. BV32.t'int start <= i < BV32.t'int start + BV32.t'int len ->
nth8_stream addr i
= nth8_stream (at addr 'Init) i};
@@ -306,12 +306,12 @@ module Bitwalker
let pokethenpeek (start len : BV32.t) (addr : array BV8.t) (value : BV64.t)
writes {addr}
requires {8 * length addr < BV32.two_power_size}
- requires {0 <= BV32.to_uint len < 64}
- requires {BV32.to_uint start + BV32.to_uint len <= 8 * length addr}
- requires {BV64.to_uint value < BV64.to_uint (maxvalue len)}
+ requires {0 <= BV32.t'int len < 64}
+ requires {BV32.t'int start + BV32.t'int len <= 8 * length addr}
+ requires {BV64.t'int value < BV64.t'int (maxvalue len)}
ensures {result = value}
=
- assert { forall i:int. BV32.to_uint len <= i < 64 -> BV64.nth value i = False };
+ assert { forall i:int. BV32.t'int len <= i < 64 -> BV64.nth value i = False };
let poke_result = poke start len addr value in
assert {poke_result = 0};
let peek_result = peek start len addr in
diff --git a/examples/bitwalker/why3session.xml b/examples/bitwalker/why3session.xml
index 878b603e46ef0956581abf59afab26eb451bb505..692e81270e3a5c64c7d91397d018eea9db385918 100644
--- a/examples/bitwalker/why3session.xml
+++ b/examples/bitwalker/why3session.xml
@@ -11,43 +11,44 @@
+
-
+
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
+
-
+
@@ -63,25 +64,25 @@
-
-
+
+
-
-
+
+
-
+
-
+
-
+
@@ -96,161 +97,163 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
-
+
+
-
-
+
+
+
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
-
+
-
+
-
-
+
-
+
+
-
-
+
+
+
+
-
+
-
-
-
+
+
-
+
-
+
-
+
-
-
+
+
-
+
@@ -262,21 +265,21 @@
-
+
-
+
-
+
-
+
@@ -284,28 +287,28 @@
-
+
-
+
-
+
-
+
-
+
-
+
@@ -322,51 +325,51 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
@@ -375,71 +378,75 @@
-
+
-
-
-
-
-
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
-
-
+
-
-
-
+
+
-
-
-
+
+
+
-
+
-
+
-
-
-
+
+
+
+
+
-
-
+
+
+
+
-
-
-
+
+
+
-
+
-
+
@@ -447,37 +454,38 @@
-
-
+
-
-
+
+
+
+
-
+
+
-
+
-
+
-
-
+
-
+
-
+
@@ -485,77 +493,76 @@
-
+
-
+
-
+
-
-
-
+
+
-
+
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
-
-
+
+
+
-
+
-
+
-
+
-
+
-
+
@@ -564,32 +571,32 @@
-
+
-
-
+
+
-
+
-
+
-
-
+
+
-
+
@@ -597,15 +604,15 @@
-
+
-
+
-
+
@@ -616,46 +623,46 @@
-
+
-
-
-
+
+
+
-
+
-
+
-
+
-
-
-
+
+
+
-
+
-
+
-
+
diff --git a/examples/bitwalker/why3shapes.gz b/examples/bitwalker/why3shapes.gz
index c268f6dec0e4c893b188486e1bcedbf0eb12e4d5..cb78a7b194deb91c7a1dd5ca4aa92f6ea01c8ee7 100644
Binary files a/examples/bitwalker/why3shapes.gz and b/examples/bitwalker/why3shapes.gz differ
diff --git a/examples/esterel/why3session.xml b/examples/esterel/why3session.xml
index 5a36baf300b54688e6d7dabf3dca738977da24d8..0600866135efe9ccff2856f05687528a923dd6a6 100644
--- a/examples/esterel/why3session.xml
+++ b/examples/esterel/why3session.xml
@@ -4,66 +4,65 @@
-
+
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
-
+
+
-
-
+
+
-
+
-
-
+
+
-
+
-
-
+
+
-
+
-
-
+
+
-
-
-
-
+
+
+
-
-
-
+
+
+
-
-
-
+
+
+
-
-
-
+
+
+
diff --git a/examples/esterel/why3shapes.gz b/examples/esterel/why3shapes.gz
index e61834e88d177324dae9ac4fecf5e812742476a5..a661846e856032a9498c298c4c18d461071034b5 100644
Binary files a/examples/esterel/why3shapes.gz and b/examples/esterel/why3shapes.gz differ
diff --git a/examples/hackers-delight.mlw b/examples/hackers-delight.mlw
index 5c737f78b64140c193d2936954abcd6fadad65fb..4a5d2c20639e19f1d58b5240f6e33658dd66e6ab 100644
--- a/examples/hackers-delight.mlw
+++ b/examples/hackers-delight.mlw
@@ -10,8 +10,8 @@ theory Utils
use import bv.BV32
- constant one : t = of_int 1
- constant two : t = of_int 2
+ constant one : t = 1
+ constant two : t = 2
constant lastbit : t = sub size_bv one
function max (x y : t) : t = (if ult x y then y else x)
@@ -21,14 +21,14 @@ theory Utils
1-bit in a bitvector (p.82) *)
function count (bv : t) : t =
- let x = sub bv (bw_and (lsr_bv bv one) (of_int 0x55555555)) in
- let x = add (bw_and x (of_int 0x33333333))
- (bw_and (lsr_bv x (of_int 2)) (of_int (0x33333333))) in
- let x = bw_and (add x (lsr_bv x (of_int 4)))
- (of_int 0x0F0F0F0F) in
- let x = add x (lsr_bv x (of_int 8)) in
- let x = add x (lsr_bv x (of_int 16)) in
- bw_and x (of_int 0x0000003F)
+ let x = sub bv (bw_and (lsr_bv bv one) (0x55555555:t)) in
+ let x = add (bw_and x (0x33333333:t))
+ (bw_and (lsr_bv x two) (0x33333333:t)) in
+ let x = bw_and (add x (lsr_bv x (4:t)))
+ (0x0F0F0F0F:t) in
+ let x = add x (lsr_bv x (8:t)) in
+ let x = add x (lsr_bv x (16:t)) in
+ bw_and x (0x0000003F:t)
(** We then define the associated notion of distance, namely
"Hamming distance", that counts the number of bits that differ
@@ -76,7 +76,7 @@ module Utils_Spec
let rec lemma countSpec_Aux (bv : t) : unit
variant {bv with ult}
- ensures {to_uint (count bv) = NumOf.numof (nth bv) 0 32}
+ ensures {t'int (count bv) = NumOf.numof (nth bv) 0 32}
=
if bv = zeros then ()
else
@@ -97,7 +97,7 @@ module Utils_Spec
(** With these lemmas, we can now prove the correctness property of
count: *)
- lemma countSpec: forall b. to_uint (count b) = NumOf.numof
+ lemma countSpec: forall b. t'int (count b) = NumOf.numof
(nth b) 0 32
(** {6 hammingD correctness } *)
@@ -108,7 +108,7 @@ module Utils_Spec
(** The correctness property can be express as the following: *)
let lemma hamming_spec (a b : t) : unit
- ensures {to_uint (hammingD a b) = NumOf.numof (nth_diff a b) 0 32}
+ ensures {t'int (hammingD a b) = NumOf.numof (nth_diff a b) 0 32}
=
assert { forall i. 0 <= i < 32 -> nth (bw_xor a b) i <-> (nth_diff a b i) }
@@ -129,7 +129,7 @@ module Utils_Spec
numof_or p q a (b-1)
let lemma triangleInequalityInt (a b c : t) : unit
- ensures {to_uint (hammingD a b) + to_uint (hammingD b c) >= to_uint (hammingD a c)}
+ ensures {t'int (hammingD a b) + t'int (hammingD b c) >= t'int (hammingD a c)}
=
assert {numof (fun_or (nth_diff a b) (nth_diff b c)) 0 32 >= numof (nth_diff a c) 0 32
by
@@ -198,11 +198,11 @@ module Hackers_delight
bw_xor bv (lsr_bv bv one)
function fromGray (gr : t) : t =
- let b = bw_xor gr (lsr_bv gr (of_int 1)) in
- let b = bw_xor b (lsr_bv b (of_int 2)) in
- let b = bw_xor b (lsr_bv b (of_int 4)) in
- let b = bw_xor b (lsr_bv b (of_int 8)) in
- bw_xor b (lsr_bv b (of_int 16))
+ let b = bw_xor gr (lsr_bv gr one) in
+ let b = bw_xor b (lsr_bv b (2:t)) in
+ let b = bw_xor b (lsr_bv b (4:t)) in
+ let b = bw_xor b (lsr_bv b (8:t)) in
+ bw_xor b (lsr_bv b (16:t))
(** Which define an isomorphism. *)
@@ -261,13 +261,13 @@ module Hackers_delight
bw_not( bw_or x y ) = bw_and (bw_not x) (bw_not y)
lemma DM3: forall x.
- bw_not( add x (of_int 1) ) = sub (bw_not x) (of_int 1)
+ bw_not (add x one) = sub (bw_not x) one
lemma DM4: forall x.
- bw_not( sub x (of_int 1) ) = add (bw_not x) (of_int 1)
+ bw_not( sub x one) = add (bw_not x) one
lemma DM5: forall x.
- bw_not( neg x ) = sub x (of_int 1)
+ bw_not( neg x ) = sub x one
lemma DM6: forall x y.
bw_not( bw_xor x y ) = bw_xor (bw_not x) y
@@ -279,7 +279,7 @@ module Hackers_delight
bw_not( sub x y ) = add (bw_not x) y
lemma DMtest: forall x.
- zeros = bw_not( bw_or x (neg( add x (of_int 1))))
+ zeros = bw_not( bw_or x (neg(add x one)))
(** {6 Addition Combined with Logical Operations (p.16)} *)
@@ -343,16 +343,16 @@ module Hackers_delight
(** shift right and arithmetic shift right (p.20)*)
lemma SR1: forall x n. ult n size_bv ->
- bw_or (lsr_bv x n) (lsl_bv (neg( lsr_bv x (of_int 31) )) (sub (of_int 31) n))
+ bw_or (lsr_bv x n) (lsl_bv (neg( lsr_bv x (31:t) )) (sub (31:t) n))
= asr_bv x n
(** rotate vs shift (p.37)*)
lemma RS_left: forall x.
- bw_or (lsl_bv x (of_int 1)) (lsr_bv x (of_int 31)) = rotate_left_bv x one
+ bw_or (lsl_bv x one) (lsr_bv x (31:t)) = rotate_left_bv x one
lemma RS_right: forall x.
- bw_or (lsr_bv x (of_int 1)) (lsl_bv x (of_int 31)) = rotate_right_bv x one
+ bw_or (lsr_bv x one) (lsl_bv x (31:t)) = rotate_right_bv x one
(** {6 bound propagation (p.73)} *)
diff --git a/examples/hackers-delight/why3session.xml b/examples/hackers-delight/why3session.xml
index 64526c70678ea035f01d40b3ff5784b9f5d61298..2196cb4beffa4ec9d7538e914f5fca383f9493aa 100644
--- a/examples/hackers-delight/why3session.xml
+++ b/examples/hackers-delight/why3session.xml
@@ -2,59 +2,63 @@
-
+
-
-
-
+
+
+
+
+
+
-
+
-
+
-
+
-
-
+
+
-
+
-
+
-
+
-
+
-
+
-
+
+
-
+
@@ -62,7 +66,8 @@
-
+
+
@@ -73,39 +78,39 @@
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
-
+
-
-
+
+
-
+
-
+
@@ -114,7 +119,7 @@
-
+
@@ -156,13 +161,13 @@
-
+
-
+
diff --git a/examples/hackers-delight/why3shapes.gz b/examples/hackers-delight/why3shapes.gz
index 30c0eed5dfa3356d546417e4a74c7a70a5ba9e47..400c412df8e781600ab3fc881425d1d02091a4fd 100644
Binary files a/examples/hackers-delight/why3shapes.gz and b/examples/hackers-delight/why3shapes.gz differ
diff --git a/examples/in_progress/gmp_square_root.mlw b/examples/in_progress/gmp_square_root.mlw
index 4d5ff506d7bb59774cdb7baba0e304581c50dbcd..6c8452de41d353e2ff937ae582ab99d5137c31ec 100644
--- a/examples/in_progress/gmp_square_root.mlw
+++ b/examples/in_progress/gmp_square_root.mlw
@@ -21,7 +21,7 @@ module GmpModel
use export array.Array
constant beta' : int
- axiom beta'_gt_1: 1 < beta'
+ axiom one_lt_beta' : 1 < beta'
constant beta : int = 2 * beta'
type memory = array int
@@ -154,7 +154,7 @@ module GmpAuxiliaryfunctions
if (nat_eq_bool !l !h) then
c := !c - !b
else
- begin
+ begin
(mpn_sub_1 (plus np (mult (S (S O)) !l))
(plus np (mult (S (S O)) !l))
(S O) !b);
diff --git a/examples/logic/bitvectors.why b/examples/logic/bitvectors.why
index 73f66f3f26bcdbe79ca42b143af0c16499d60852..5070af768995b3e92095ab1ace77f049077c33ac 100644
--- a/examples/logic/bitvectors.why
+++ b/examples/logic/bitvectors.why
@@ -45,8 +45,8 @@ theory TestBV
goal g5aa : asr b0111 2 = b0001
goal g5bb : asr ones 31 = ones
- goal g6a : to_uint b11100 = 28
- goal g6b : to_uint ones = 0xFFFFFFFF
+ goal g6a : t'int b11100 = 28
+ goal g6b : t'int ones = 0xFFFFFFFF
goal g7a : to_int b11100 = 28
goal g7b : to_int ones = -1
@@ -57,8 +57,8 @@ theory TestBV
goal g8aa : nth b0110 2 = True
goal g8bb : nth b0110 3 = False
- goal gtt : to_uint (lsl_bv (of_int 3) (of_int 30)) > 0 (* = 0xC0000000 *)
- goal gttt : to_uint (lsl (of_int 3) 30) > 0 (* = 0xC0000000 *)
+ goal gtt : t'int (lsl_bv (of_int 3) (of_int 30)) > 0 (* = 0xC0000000 *)
+ goal gttt : t'int (lsl (of_int 3) 30) > 0 (* = 0xC0000000 *)
goal not_not : forall v:t. bw_not (bw_not v) = v
diff --git a/examples/logic/bitvectors/why3session.xml b/examples/logic/bitvectors/why3session.xml
index 0f342d5c8809a1b8e206e0e27c3116d16063886f..f94aa191e85eb9aaca4913f4b9318508ea680591 100644
--- a/examples/logic/bitvectors/why3session.xml
+++ b/examples/logic/bitvectors/why3session.xml
@@ -6,7 +6,7 @@
-
+
@@ -62,12 +62,12 @@
-
+
-
+
@@ -100,12 +100,12 @@
-
+
-
+
@@ -129,14 +129,14 @@
-
+
-
+
diff --git a/examples/logic/bitvectors/why3shapes.gz b/examples/logic/bitvectors/why3shapes.gz
index 2beae1a8326d2ebbf7fe4a2ab4e15bf565b47f92..28358128cd1b2e3c63f23983a5f27561225018c1 100644
Binary files a/examples/logic/bitvectors/why3shapes.gz and b/examples/logic/bitvectors/why3shapes.gz differ
diff --git a/examples/queens_bv.mlw b/examples/queens_bv.mlw
index b23a07870ae9c8351785cc0d5b7f58746c74575d..1355fd5b1ddd3bafb6e4553b5ffd7aa6114faa38 100644
--- a/examples/queens_bv.mlw
+++ b/examples/queens_bv.mlw
@@ -130,8 +130,8 @@ module BitsSpec
use bv.BV32
val below (n: BV32.t) : t
- requires { BV32.ule n (BV32.of_int 32) }
- ensures { result.mdl = interval 0 (BV32.to_uint n) }
+ requires { BV32.ule n (32:BV32.t) }
+ ensures { result.mdl = interval 0 (BV32.t'int n) }
end
module Bits "the 1-bits of an integer, as a set of integers"
@@ -182,12 +182,12 @@ module Bits "the 1-bits of an integer, as a set of integers"
let mul2 (a: t) : t
ensures { result.mdl = remove size (succ a.mdl) }
=
- { bv = lsl_bv a.bv (of_int 1); mdl = remove size (succ a.mdl) }
+ { bv = lsl_bv a.bv (1:BV32.t); mdl = remove size (succ a.mdl) }
let div2 (a: t) : t
ensures { result.mdl = pred a.mdl }
=
- { bv = lsr_bv a.bv (of_int 1); mdl = pred a.mdl }
+ { bv = lsr_bv a.bv (1:BV32.t); mdl = pred a.mdl }
let diff (a b: t) : t
ensures { result.mdl = diff a.mdl b.mdl }
@@ -218,17 +218,17 @@ module Bits "the 1-bits of an integer, as a set of integers"
assert {nth_bv (neg a.bv) n_bv};
let res = bw_and a.bv (neg a.bv) in
assert {forall i. 0 <= i < n -> not (nth res i)};
- assert {bits_interval_is_zeros_bv res (add n_bv (of_int 1)) (sub (of_int 31) n_bv )};
+ assert {bits_interval_is_zeros_bv res (add n_bv (1:BV32.t)) (sub (31:BV32.t) n_bv )};
assert {bits_interval_is_zeros res (n + 1) (31 - n)};
{ bv = res;
mdl = singleton n }
let below (n: BV32.t) : t
- requires { BV32.ule n (BV32.of_int 32) }
- ensures { result.mdl = interval 0 (to_uint n) }
+ requires { BV32.ule n (32:BV32.t) }
+ ensures { result.mdl = interval 0 (t'int n) }
=
{ bv = bw_not (lsl_bv ones n);
- mdl = interval 0 (to_uint n) }
+ mdl = interval 0 (t'int n) }
end
@@ -331,7 +331,7 @@ module NQueensBits
end
let queens (q: BV32.t)
- requires { BV32.to_uint q = n }
+ requires { BV32.t'int q = n }
requires { BV32.ule q BV32.size_bv }
requires { !s = 0 }
ensures { result = !s }
diff --git a/examples/queens_bv/why3session.xml b/examples/queens_bv/why3session.xml
index e1a2ae9feaae242efee9109797ba6fd6b1e2793d..afa6ebbc05a358142d30e7b311cd7b50cecc20bf 100644
--- a/examples/queens_bv/why3session.xml
+++ b/examples/queens_bv/why3session.xml
@@ -4,10 +4,8 @@
-
-
@@ -23,15 +21,15 @@
-
+
-
+
-
+
-
+
@@ -41,7 +39,7 @@
-
+
@@ -50,7 +48,7 @@
-
+
@@ -58,10 +56,10 @@
-
+
-
+
@@ -69,24 +67,24 @@
-
+
-
+
-
+
-
+
@@ -95,7 +93,7 @@
-
+
@@ -108,7 +106,7 @@
-
+
@@ -131,19 +129,19 @@
-
-
-
-
@@ -154,1198 +152,1193 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
@@ -1354,436 +1347,439 @@
-
-
-
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
+
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
+
+
@@ -1975,103 +1971,97 @@
-
-
-
-
-
-
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
@@ -2083,27 +2073,18 @@
-
+
-
+
-
+
-
+
-
-
-
-
-
-
-
-
-
@@ -2173,7 +2154,7 @@
-
+
@@ -2277,7 +2258,7 @@
-
+
@@ -2329,10 +2310,10 @@
-
+
-
+
diff --git a/examples/queens_bv/why3shapes.gz b/examples/queens_bv/why3shapes.gz
index ae6c3e2bb7a417e70b00282fc8fdcd25e4e213ec..04242a638676917dcec8ab0851ea0872aaf106f9 100644
Binary files a/examples/queens_bv/why3shapes.gz and b/examples/queens_bv/why3shapes.gz differ
diff --git a/examples/rightmostbittrick.mlw b/examples/rightmostbittrick.mlw
index 0a9f75c6c3537fd82be5720399ba5ffaf81401bf..56d3ef0aa986a2175958f52f5e5bbee0b4d36e95 100644
--- a/examples/rightmostbittrick.mlw
+++ b/examples/rightmostbittrick.mlw
@@ -5,15 +5,15 @@ module Rmbt
let ghost rightmost_position_set (a : t) : t
requires { a <> zeros }
- ensures { ult result (of_int 64) }
+ ensures { ult result (64:t) }
ensures { eq_sub_bv a zeros zeros result }
ensures { nth_bv a result }
=
let i = ref zeros in
- while ult !i (of_int 64) && not (nth_bv a !i) do
- variant {64 - to_uint !i}
+ while ult !i (64:t) && not (nth_bv a !i) do
+ variant {64 - t'int !i}
invariant {eq_sub_bv a zeros zeros !i}
- i := add !i (of_int 1)
+ i := add !i one
done;
!i
@@ -28,7 +28,7 @@ module Rmbt
ensures { nth result !p }
=
let ghost p_bv = rightmost_position_set x in
- ghost p := to_uint p_bv;
+ ghost p := t'int p_bv;
assert { nth_bv (neg x) p_bv };
bw_and x (neg x)
diff --git a/examples/rightmostbittrick/why3session.xml b/examples/rightmostbittrick/why3session.xml
index 5906a523d714a72e769f92aee76ca75d9f2ea919..789b1df62da32167a4923b502c5e2f44ff3a5c3a 100644
--- a/examples/rightmostbittrick/why3session.xml
+++ b/examples/rightmostbittrick/why3session.xml
@@ -2,100 +2,100 @@
-
+
+
-
+
-
+
-
+
-
+
-
+
-
-
+
+
+
-
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
-
-
+
-
+
-
+
-
+
+
-
-
+
-
+
-
+
-
-
+
-
+
-
+
-
+
-
+
diff --git a/examples/rightmostbittrick/why3shapes.gz b/examples/rightmostbittrick/why3shapes.gz
index 11242f1aeaabe65551be408b2f137de366a9c50c..d2b7a38ab331ae249b765aa159dfe67ecc3c6894 100644
Binary files a/examples/rightmostbittrick/why3shapes.gz and b/examples/rightmostbittrick/why3shapes.gz differ
diff --git a/examples/tests-provers/bv.why b/examples/tests-provers/bv.why
index 4b9eb1729b76ce178fffcd8601e714dc6f85ae93..fcb47c3af239accbf808e3dfe45cf1fe852ec5ab 100644
--- a/examples/tests-provers/bv.why
+++ b/examples/tests-provers/bv.why
@@ -11,8 +11,8 @@ theory CheckBV64
goal ok_zero : zeros = (of_int 0)
goal ok_ones : ones = (of_int mx)
- goal ok_zero2 : to_uint zeros = 0
- goal ok_ones2 : to_uint ones = mx
+ goal ok_zero2 : t'int zeros = 0
+ goal ok_ones2 : t'int ones = mx
goal ok_size : size = sz
goal ok_max : max_int = mx
goal ok_tpsize : two_power_size = md
@@ -88,8 +88,8 @@ theory CheckBV64
goal g5a : asr_bv b0111 (of_int 2) = b0001
goal g5b : asr_bv ones (of_int (Int.(-) size 1)) = ones
- goal g7 : to_uint b11100 = 28
- goal f7 : to_uint ones = Int.(-_) 1
+ goal g7 : t'int b11100 = 28
+ goal f7 : t'int ones = Int.(-_) 1
goal g8a : nth_bv b0110 (of_int 2) = True
goal g8b : nth_bv b0110 (of_int 3) = False
@@ -154,8 +154,8 @@ theory CheckBV32
goal ok_zero : zeros = (of_int 0)
goal ok_ones : ones = (of_int mx)
- goal ok_zero2 : to_uint zeros = 0
- goal ok_ones2 : to_uint ones = mx
+ goal ok_zero2 : t'int zeros = 0
+ goal ok_ones2 : t'int ones = mx
goal ok_size : size = sz
goal ok_max : max_int = mx
goal ok_tpsize : two_power_size = md
@@ -212,8 +212,8 @@ theory CheckBV16
goal ok_zero : zeros = (of_int 0)
goal ok_ones : ones = (of_int mx)
- goal ok_zero2 : to_uint zeros = 0
- goal ok_ones2 : to_uint ones = mx
+ goal ok_zero2 : t'int zeros = 0
+ goal ok_ones2 : t'int ones = mx
goal ok_size : size = sz
goal ok_max : max_int = mx
goal ok_tpsize : two_power_size = md
@@ -270,8 +270,8 @@ theory CheckBV8
goal ok_zero : zeros = (of_int 0)
goal ok_ones : ones = (of_int mx)
- goal ok_zero2 : to_uint zeros = 0
- goal ok_ones2 : to_uint ones = mx
+ goal ok_zero2 : t'int zeros = 0
+ goal ok_ones2 : t'int ones = mx
goal ok_size : size = sz
goal ok_max : max_int = mx
goal ok_tpsize : two_power_size = md
diff --git a/examples/tests-provers/bv/why3session.xml b/examples/tests-provers/bv/why3session.xml
index 21c8ba4d43b4d56304b5c4b9b3c4fa003a6e7ab0..6b2e72db62f80260f55920b10d9c9e0cdd7d0b96 100644
--- a/examples/tests-provers/bv/why3session.xml
+++ b/examples/tests-provers/bv/why3session.xml
@@ -9,47 +9,47 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
@@ -69,7 +69,7 @@
-
+
@@ -89,13 +89,13 @@
-
+
-
+
@@ -197,21 +197,20 @@
-
+
-
+
-
-
+
@@ -236,7 +235,7 @@
-
+
@@ -266,7 +265,7 @@
-
+
@@ -282,13 +281,13 @@
-
+
-
+
@@ -302,7 +301,7 @@
-
+
@@ -324,25 +323,25 @@
-
-
+
+
-
+
-
+
-
+
@@ -359,15 +358,15 @@
-
+
-
+
-
+
@@ -386,47 +385,47 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
@@ -446,7 +445,7 @@
-
+
@@ -466,13 +465,13 @@
-
+
-
+
@@ -483,7 +482,7 @@
-
+
@@ -582,14 +581,13 @@
-
-
+
@@ -609,47 +607,47 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
@@ -669,7 +667,7 @@
-
+
@@ -689,13 +687,13 @@
-
+
-
+
@@ -706,7 +704,7 @@
-
+
@@ -805,14 +803,13 @@
-
-
+
@@ -832,47 +829,47 @@
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
@@ -892,7 +889,7 @@
-
+
@@ -912,13 +909,13 @@
-
+
-
+
@@ -929,7 +926,7 @@
-
+
@@ -1028,14 +1025,13 @@
-
-
+
diff --git a/examples/tests-provers/bv/why3shapes.gz b/examples/tests-provers/bv/why3shapes.gz
index d0a5985e41d5a7211eaa02524de1eae2da64bcce..757b02cab677443cb94deee42b886f363fbddc2e 100644
Binary files a/examples/tests-provers/bv/why3shapes.gz and b/examples/tests-provers/bv/why3shapes.gz differ
diff --git a/examples/tests/bv-smtlib-realization.why b/examples/tests/bv-smtlib-realization.why
index 5a98f0b24217ea4dcb6da4733b78bbc986e8ded5..421cfd7cd10997016c30fa57c29db734c8d4298a 100644
--- a/examples/tests/bv-smtlib-realization.why
+++ b/examples/tests/bv-smtlib-realization.why
@@ -22,15 +22,15 @@ theory BV_Check
lemma max_int_val : max_int = two_power_size - 1
lemma to_uint_extensionality :
- forall v,v':t. to_uint v = to_uint v' -> v = v'
+ forall v,v':t. t'int v = t'int v' -> v = v'
lemma to_int_extensionality:
forall v,v':t. to_int v = to_int v' -> v = v'
- lemma to_uint_bounds : forall v:t. 0 <= to_uint v < two_power_size
+ lemma to_uint_bounds : forall v:t. 0 <= t'int v < two_power_size
lemma to_uint_of_int :
- forall i. 0 <= i < two_power_size -> to_uint (of_int i) = i
+ forall i. 0 <= i < two_power_size -> t'int (of_int i) = i
lemma Of_int_zero: zeros = of_int 0
@@ -106,13 +106,13 @@ theory BV_Check
(* comparison operators *)
- goal ult_spec: forall x y. ult x y <-> Int.(<) (to_uint x) (to_uint y)
+ goal ult_spec: forall x y. ult x y <-> Int.(<) (t'int x) (t'int y)
- goal ule_spec: forall x y. ule x y <-> Int.(<=) (to_uint x) (to_uint y)
+ goal ule_spec: forall x y. ule x y <-> Int.(<=) (t'int x) (t'int y)
- goal ugt_spec: forall x y. ugt x y <-> Int.(>) (to_uint x) (to_uint y)
+ goal ugt_spec: forall x y. ugt x y <-> Int.(>) (t'int x) (t'int y)
- goal uge_spec: forall x y. uge x y <-> Int.(>=) (to_uint x) (to_uint y)
+ goal uge_spec: forall x y. uge x y <-> Int.(>=) (t'int x) (t'int y)
goal slt_spec: forall x y. slt x y <-> Int.(<) (to_int x) (to_int y)
@@ -125,47 +125,47 @@ theory BV_Check
(** Arithmetic operators *)
goal to_uint_add:
- forall v1 v2. to_uint (add v1 v2) = mod (Int.(+) (to_uint v1) (to_uint v2)) two_power_size
+ forall v1 v2. t'int (add v1 v2) = mod (Int.(+) (t'int v1) (t'int v2)) two_power_size
goal to_uint_add_bounded:
forall v1 v2.
- to_uint v1 + to_uint v2 < two_power_size ->
- to_uint (add v1 v2) = to_uint v1 + to_uint v2
+ t'int v1 + t'int v2 < two_power_size ->
+ t'int (add v1 v2) = t'int v1 + t'int v2
goal to_uint_sub:
- forall v1 v2. to_uint (sub v1 v2) = mod (Int.(-) (to_uint v1) (to_uint v2)) two_power_size
+ forall v1 v2. t'int (sub v1 v2) = mod (Int.(-) (t'int v1) (t'int v2)) two_power_size
goal to_uint_sub_bounded:
forall v1 v2.
- 0 <= to_uint v1 - to_uint v2 < two_power_size ->
- to_uint (sub v1 v2) = to_uint v1 - to_uint v2
+ 0 <= t'int v1 - t'int v2 < two_power_size ->
+ t'int (sub v1 v2) = t'int v1 - t'int v2
goal to_uint_neg:
- forall v. to_uint (neg v) = mod (Int.(-_) (to_uint v)) two_power_size
+ forall v. t'int (neg v) = mod (Int.(-_) (t'int v)) two_power_size
goal to_uint_mul:
- forall v1 v2. to_uint (mul v1 v2) = mod (Int.( * ) (to_uint v1) (to_uint v2)) two_power_size
+ forall v1 v2. t'int (mul v1 v2) = mod (Int.( * ) (t'int v1) (t'int v2)) two_power_size
goal to_uint_mul_bounded:
forall v1 v2.
- to_uint v1 * to_uint v2 < two_power_size ->
- to_uint (mul v1 v2) = to_uint v1 * to_uint v2
+ t'int v1 * t'int v2 < two_power_size ->
+ t'int (mul v1 v2) = t'int v1 * t'int v2
goal to_uint_udiv:
- forall v1 v2. to_uint (udiv v1 v2) = div (to_uint v1) (to_uint v2)
+ forall v1 v2. t'int (udiv v1 v2) = div (t'int v1) (t'int v2)
goal to_uint_urem:
- forall v1 v2. to_uint (urem v1 v2) = mod (to_uint v1) (to_uint v2)
+ forall v1 v2. t'int (urem v1 v2) = mod (t'int v1) (t'int v2)
goal to_uint_lsr:
forall v n : t.
- to_uint (lsr_bv v n) = div (to_uint v) (pow2 ( to_uint n ))
+ t'int (lsr_bv v n) = div (t'int v) (pow2 ( t'int n ))
goal to_uint_lsl:
forall v n : t.
- to_uint (lsl_bv v n) = mod (Int.( * ) (to_uint v) (pow2 (to_uint n))) two_power_size
+ t'int (lsl_bv v n) = mod (Int.( * ) (t'int v) (pow2 (t'int n))) two_power_size
(* equality goals *)
goal eq_sub_equiv: forall a b i n:t.
- eq_sub a b (to_uint i) (to_uint n)
+ eq_sub a b (t'int i) (t'int n)
<-> eq_sub_bv a b i n
goal Extensionality: forall x y : t [eq x y]. eq x y -> x = y
@@ -177,9 +177,9 @@ theory BVConverter_Check
use import bv.BVConverter_32_64
goal toSmall_to_uint :
- forall x. in_range x -> BV64.to_uint x = BV32.to_uint (toSmall x)
+ forall x. in_range x -> BV64.t'int x = BV32.t'int (toSmall x)
goal toBig_to_uint :
- forall x. BV32.to_uint x = BV64.to_uint (toBig x)
+ forall x. BV32.t'int x = BV64.t'int (toBig x)
end
diff --git a/examples/use_api/logic.ml b/examples/use_api/logic.ml
index e3357d62d4e5db8123746783b6c66869970cccce..a01286ecca8f92243446af6d1515a75a865e1bf0 100644
--- a/examples/use_api/logic.ml
+++ b/examples/use_api/logic.ml
@@ -120,12 +120,14 @@ An arithmetic goal: 2+2 = 4
*)
-let two : Term.term = Term.t_const (Number.ConstInt (Number.int_const_dec "2"))
-let four : Term.term = Term.t_const (Number.ConstInt (Number.int_const_dec "4"))
-let int_theory : Theory.theory =
- Env.read_theory env ["int"] "Int"
+let two : Term.term = Term.t_nat_const 2
+let four : Term.term = Term.t_nat_const 4
+
+let int_theory : Theory.theory = Env.read_theory env ["int"] "Int"
+
let plus_symbol : Term.lsymbol =
Theory.ns_find_ls int_theory.Theory.th_export ["infix +"]
+
let two_plus_two : Term.term = Term.fs_app plus_symbol [two;two] Ty.ty_int
let two_plus_two : Term.term = Term.t_app_infer plus_symbol [two;two]
let fmla3 : Term.term = Term.t_equ two_plus_two four
@@ -150,19 +152,20 @@ let () = printf "@[On task 3, alt-ergo answers %a@."
Call_provers.print_prover_result result3
(* quantifiers: let's build "forall x:int. x*x >= 0" *)
-let zero : Term.term = Term.t_const (Number.ConstInt (Number.int_const_dec "0"))
+let zero : Term.term = Term.t_nat_const 0
+
let mult_symbol : Term.lsymbol =
Theory.ns_find_ls int_theory.Theory.th_export ["infix *"]
+
let ge_symbol : Term.lsymbol =
Theory.ns_find_ls int_theory.Theory.th_export ["infix >="]
let var_x : Term.vsymbol =
Term.create_vsymbol (Ident.id_fresh "x") Ty.ty_int
+
let x : Term.term = Term.t_var var_x
-let x_times_x : Term.term =
- Term.t_app_infer mult_symbol [x;x]
-let fmla4_aux : Term.term =
- Term.ps_app ge_symbol [x_times_x;zero]
+let x_times_x : Term.term = Term.t_app_infer mult_symbol [x;x]
+let fmla4_aux : Term.term = Term.ps_app ge_symbol [x_times_x;zero]
let fmla4 : Term.term = Term.t_forall_close [var_x] [] fmla4_aux
let task4 = None
@@ -275,9 +278,9 @@ let d =
}
in
let body =
- let c6 = Term.t_const (Number.ConstInt (Number.int_const_dec "6")) in
- let c7 = Term.t_const (Number.ConstInt (Number.int_const_dec "7")) in
- let c42 = Term.t_const (Number.ConstInt (Number.int_const_dec "42")) in
+ let c6 = Term.t_nat_const 6 in
+ let c7 = Term.t_nat_const 7 in
+ let c42 = Term.t_nat_const 42 in
let p =
Term.t_equ (Term.t_app_infer mul_int [c6;c7]) c42
in
@@ -344,7 +347,8 @@ let d2 =
(* e1 : the appropriate instance of "ref" *)
let e1 = Mlw_expr.e_arrow ref_fun [Mlw_ty.ity_int] ity in
(* we apply it to 0 *)
- let c0 = Mlw_expr.e_const (Number.ConstInt (Number.int_const_dec "0")) in
+ let c0 = Mlw_expr.e_const
+ (Number.ConstInt (Number.int_const_dec "0")) Mlw_ty.ity_int in
Mlw_expr.e_app e1 [c0]
in
(* building the first part of the let x = ref 0 *)
diff --git a/examples/use_api/mlw.ml b/examples/use_api/mlw.ml
index 14e2d5e5e29ab6e5a2f59ad90bb4bfece04fb6be..4ec0b3e332ee2f6a2b3d3beb95aa4510e77ce1d1 100644
--- a/examples/use_api/mlw.ml
+++ b/examples/use_api/mlw.ml
@@ -11,7 +11,7 @@
(*******************
-This file builds some MLW modules using the API
+This file builds some MLW modules using the API
******************)
@@ -64,9 +64,9 @@ let d =
}
in
let body =
- let c6 = Term.t_const (Number.ConstInt (Number.int_const_dec "6")) in
- let c7 = Term.t_const (Number.ConstInt (Number.int_const_dec "7")) in
- let c42 = Term.t_const (Number.ConstInt (Number.int_const_dec "42")) in
+ let c6 = Term.t_nat_const 6 in
+ let c7 = Term.t_nat_const 7 in
+ let c42 = Term.t_nat_const 42 in
let p =
Term.t_equ (Term.t_app_infer mul_int [c6;c7]) c42
in
@@ -134,7 +134,8 @@ let d2 =
(* e1 : the appropriate instance of "ref" *)
let e1 = Mlw_expr.e_arrow ref_fun [Mlw_ty.ity_int] ity in
(* we apply it to 0 *)
- let c0 = Mlw_expr.e_const (Number.ConstInt (Number.int_const_dec "0")) in
+ let c0 = Mlw_expr.e_const
+ (Number.ConstInt (Number.int_const_dec "0")) Mlw_ty.ity_int in
Mlw_expr.e_app e1 [c0]
in
(* building the first part of the let x = ref 0 *)
diff --git a/lib/coq/bv/BV_Gen.v.COQ84 b/lib/coq/bv/BV_Gen.v.COQ84
index d344a38ec48cbb19e3cf795562321584419f41f4..b56f67d7e0560b2999ca4806404d2055a6e0f380 100644
--- a/lib/coq/bv/BV_Gen.v.COQ84
+++ b/lib/coq/bv/BV_Gen.v.COQ84
@@ -11,15 +11,15 @@ Require bv.Pow2int.
Definition last_bit : nat.
Admitted.
-Definition size_bv: nat := S last_bit.
+Definition size_nat: nat := S last_bit.
(* Why3 goal *)
Definition size: Z.
- exact (Z.of_nat size_bv).
+ exact (Z.of_nat size_nat).
Defined.
Lemma size_int_S : size = Z.succ (Z.of_nat last_bit).
- unfold size, size_bv.
+ unfold size, size_nat.
rewrite Nat2Z.inj_succ; trivial.
Qed.
@@ -32,7 +32,7 @@ Require Import Bool.Bvector.
(* Why3 goal *)
Definition t : Type.
- exact (Bvector size_bv).
+ exact (Bvector size_nat).
Defined.
Fixpoint nth_aux {l} (v : Vector.t bool l) (m : Z) : bool :=
@@ -228,13 +228,22 @@ Lemma Nth_zeros : forall (n:Z), ((nth zeros n) = false).
intros n; apply Nth_zeros_aux.
Qed.
+Definition one_aux l : Vector.t bool (S l).
+ exact (Vector.cons bool true l (Vector.const false l)).
+Defined.
+
+(* Why3 goal *)
+Definition one: t.
+ exact (one_aux last_bit).
+Defined.
+
Definition ones_aux l : Vector.t bool l.
exact (Vector.const true l).
Defined.
(* Why3 goal *)
Definition ones: t.
- exact (ones_aux size_bv).
+ exact (ones_aux size_nat).
Defined.
(* Why3 goal *)
@@ -415,7 +424,7 @@ Lemma BshiftRa_iter_nth_low : forall (b:t) (s:nat) (n:Z),
rewrite <- Zplus_succ_r_reverse, <- Z.add_succ_l.
apply IHs; omega.
omega.
- fold size_bv; fold size; omega.
+ fold size_nat; fold size; omega.
Qed.
(* Why3 goal *)
@@ -461,7 +470,7 @@ Lemma BhiftRa_iter_nth_high : forall (b:t) (s:nat) (n:Z),
intro; rewrite nth_aux_shiftin_low.
apply IHs; omega.
omega.
- fold size_bv; fold size; omega.
+ fold size_nat; fold size; omega.
Qed.
(* Why3 goal *)
@@ -1057,7 +1066,7 @@ Lemma Nth_rotate_right : forall (v:t) (n:Z) (i:Z), ((0%Z <= i)%Z /\
revert H0.
pattern i.
apply Z_of_nat_prop; auto.
- unfold nth, rotate_right, size, size_bv.
+ unfold nth, rotate_right, size, size_nat.
intro n.
rewrite Nat2Z.inj_succ.
intros. rewrite Nat2Z.id.
@@ -1080,7 +1089,7 @@ Lemma Nth_rotate_left : forall (v:t) (n:Z) (i:Z), ((0%Z <= i)%Z /\
revert H0.
pattern i.
apply Z_of_nat_prop; auto.
- unfold nth, rotate_left, size, size_bv.
+ unfold nth, rotate_left, size, size_nat.
intro n.
rewrite Nat2Z.inj_succ.
intros. rewrite Nat2Z.id.
@@ -1109,12 +1118,12 @@ Qed.
(* Why3 goal *)
Definition to_int: t -> Z.
- exact (twos_complement size_bv).
+ exact (twos_complement size_nat).
Defined.
(* Why3 goal *)
Definition to_uint: t -> Z.
- exact (fun x => Z.of_nat (bvec_to_nat size_bv x)).
+ exact (fun x => Z.of_nat (bvec_to_nat size_nat x)).
Defined.
Lemma max_int_S : (two_power_size = max_int + 1)%Z.
@@ -1123,7 +1132,7 @@ Qed.
(* Why3 goal *)
Definition of_int: Z -> t.
- exact (fun x => nat_to_bvec size_bv (Z.to_nat x)).
+ exact (fun x => nat_to_bvec size_nat (Z.to_nat x)).
Defined.
(* Why3 goal *)
@@ -1155,7 +1164,7 @@ Lemma to_uint_bounds : forall (v:t), (0%Z <= (to_uint v))%Z /\
rewrite Z2Nat.id.
easy.
unfold two_power_size, size.
- transitivity (Pow2int.pow2 (Z.of_nat size_bv) - 1);[apply max_int_nat|omega].
+ transitivity (Pow2int.pow2 (Z.of_nat size_nat) - 1);[apply max_int_nat|omega].
rewrite H.
apply inj_lt.
apply bvec_to_nat_range.
@@ -1230,7 +1239,7 @@ Lemma to_uint_lsl_aux : forall (v:t) (n:nat), ((to_uint (lsl v
unfold BshiftL, Bcons, to_uint.
simpl BshiftL_iter.
rewrite <- Nat2Z.id with (n := n).
- change (Z.of_nat (2 * bvec_to_nat last_bit (Vector.shiftout (lsl v (Z.of_nat n)))) = (Z.of_nat (bvec_to_nat size_bv v) * Pow2int.pow2 (Z.of_nat (S (Z.to_nat (Z.of_nat n))))) mod two_power_size)%Z.
+ change (Z.of_nat (2 * bvec_to_nat last_bit (Vector.shiftout (lsl v (Z.of_nat n)))) = (Z.of_nat (bvec_to_nat size_nat v) * Pow2int.pow2 (Z.of_nat (S (Z.to_nat (Z.of_nat n))))) mod two_power_size)%Z.
rewrite Nat2Z.id.
rewrite Nat2Z.inj_mul.
rewrite bvec_to_nat_shiftout_mod1.
@@ -1260,15 +1269,68 @@ Lemma to_uint_of_int : forall (i:Z), ((0%Z <= i)%Z /\
Qed.
(* Why3 goal *)
-Lemma Of_int_zeros : (zeros = (of_int 0%Z)).
+Definition size_bv: t.
+ exact (of_int size).
+Defined.
+
+(* Why3 goal *)
+Lemma to_uint_size_bv : ((to_uint size_bv) = size).
+ apply to_uint_of_int.
+ rewrite max_int_S.
+ destruct size_in_range; auto with zarith.
+Qed.
+
+Lemma Of_int_zeros: zeros = of_int 0.
apply Nat_to_bvec_zeros.
Qed.
(* Why3 goal *)
-Lemma Of_int_ones : (ones = (of_int max_int)).
+Lemma to_uint_zeros : ((to_uint zeros) = 0%Z).
+ rewrite Of_int_zeros.
+ apply to_uint_of_int; easy.
+Qed.
+
+Lemma to_uint_one_aux : forall {l}, bvec_to_nat (S l) (one_aux l) = 1%nat.
+ intro l.
+ simpl.
+ rewrite bvec_to_nat_zeros.
+ auto with zarith.
+Qed.
+
+Lemma Of_int_one_aux : forall {l}, one_aux l = nat_to_bvec (S l) 1%nat.
+ intro l.
+ apply bvec_to_nat_extensionality.
+ rewrite bvec_to_nat_nat_to_bvec.
+ apply to_uint_one_aux.
+ pose proof (id_lt_pow2 l).
+ zify.
+ auto with zarith.
+Qed.
+
+(* Why3 goal *)
+Lemma to_uint_one : ((to_uint one) = 1%Z).
+ unfold to_uint, one.
+ simpl.
+ rewrite bvec_to_nat_zeros.
+ auto with zarith.
+Qed.
+
+Lemma Of_int_one : one = of_int 1.
+ apply Of_int_one_aux.
+Qed.
+
+Lemma Of_int_ones: ones = of_int max_int.
apply Nat_to_bvec_ones.
Qed.
+(* Why3 goal *)
+Lemma to_uint_ones : ((to_uint ones) = max_int).
+ rewrite Of_int_ones.
+ apply to_uint_of_int.
+ rewrite max_int_S.
+ destruct size_in_range; auto with zarith.
+Qed.
+
(* Why3 assumption *)
Definition ult (x:t) (y:t): Prop := ((to_uint x) < (to_uint y))%Z.
@@ -1507,8 +1569,9 @@ Lemma and_zeros : forall {l} (x:Vector.t bool l),
Qed.
Lemma nth_bv_def_aux : forall {l} (x:Vector.t bool (S l)) (i:Z),
- nth_aux x 0 = true <-> (Vector.map2 (fun a b => a && b) x (nat_to_bvec (S l) 1)) <> zeros_aux.
+ nth_aux x 0 = true <-> (Vector.map2 (fun a b => a && b) x (one_aux l)) <> zeros_aux.
intros.
+ rewrite Of_int_one_aux.
destruct x.
simpl.
split; [easy|auto].
@@ -1523,7 +1586,7 @@ Qed.
(* Why3 goal *)
Lemma nth_bv_def : forall (x:t) (i:t), ((nth_bv x i) = true) <->
- ~ ((bw_and (lsr_bv x i) (of_int 1%Z)) = zeros).
+ ~ ((bw_and (lsr_bv x i) one) = zeros).
intros; unfold nth_bv.
case (Z_lt_ge_dec (to_uint i) size); intro.
rewrite <-(Zplus_0_l (to_uint i)).
@@ -1579,8 +1642,9 @@ Defined.
(* Why3 goal *)
Lemma eq_sub_bv_def : forall (a:t) (b:t) (i:t) (n:t), let mask :=
- (lsl_bv (sub (lsl_bv (of_int 1%Z) n) (of_int 1%Z)) i) in ((eq_sub_bv a b i
- n) <-> ((bw_and b mask) = (bw_and a mask))).
+ (lsl_bv (sub (lsl_bv one n) one) i) in ((eq_sub_bv a b i n) <-> ((bw_and b
+ mask) = (bw_and a mask))).
+ rewrite Of_int_one.
easy.
Qed.
@@ -1793,6 +1857,23 @@ Lemma nth_bit_pred_high :
apply IHn; rewrite <-H1; rewrite Nat2Z.inj_succ in H0; omega.
Qed.
+ Lemma one_nth: forall {l},
+ nat_to_bvec (S l) 1
+ = Vector.cons bool true l (Vector.const false _).
+ intro.
+ change (Bcons (Z.odd (Z.of_nat 1)) l (nat_to_bvec l (Div2.div2 1)) = true :: Vector.const false l).
+ assert (Z.odd (Z.of_nat 1) = true) by auto with zarith.
+ rewrite H.
+ assert (Div2.div2 1 = 0%nat) by auto with zarith.
+ rewrite H0.
+ assert (nat_to_bvec l 0 = Vector.const false l).
+ induction l.
+ auto.
+ change (Bcons (Z.odd (Z.of_nat 0)) l (nat_to_bvec l (Div2.div2 0)) = false :: Vector.const false l).
+ rewrite <-IHl; auto.
+ rewrite H1; trivial.
+ Qed.
+
Lemma nth_bit_pred_low :
forall n i,
to_uint i >= Z.of_nat n ->
@@ -1831,23 +1912,7 @@ Lemma nth_bit_pred_low :
apply IHn.
rewrite <-H0; omega.
assert (to_uint i > 0) by omega.
- Lemma one_nth: forall {l},
- nat_to_bvec (S l) 1
- = Vector.cons bool true l (Vector.const false _).
- intro.
- change (Bcons (Z.odd (Z.of_nat 1)) l (nat_to_bvec l (Div2.div2 1)) = true :: Vector.const false l).
- assert (Z.odd (Z.of_nat 1) = true) by auto with zarith.
- rewrite H.
- assert (Div2.div2 1 = 0%nat) by auto with zarith.
- rewrite H0.
- assert (nat_to_bvec l 0 = Vector.const false l).
- induction l.
- auto.
- change (Bcons (Z.odd (Z.of_nat 0)) l (nat_to_bvec l (Div2.div2 0)) = false :: Vector.const false l).
- rewrite <-IHl; auto.
- rewrite H1; trivial.
- Qed.
- unfold of_int, size, size_bv.
+ unfold of_int, size, size_nat.
rewrite one_nth.
rewrite nth_cons_pred by auto with zarith.
apply Nth_zeros_aux.
@@ -1936,7 +2001,7 @@ Lemma eq_sub_equiv : forall (a:t) (b:t) (i:t) (n:t), (eq_sub a b (to_uint i)
case (Z_lt_ge_dec j size); intro.
pose (to_uint_bounds i) as u; unfold uint_in_range in u.
- assert (0 <= j < Z.of_nat size_bv) by auto with zarith.
+ assert (0 <= j < Z.of_nat size_nat) by auto with zarith.
pose (H j H1).
fold nth in e; rewrite Nth_bw_and, Nth_bw_and in e by auto.
destruct H0.
diff --git a/lib/coq/bv/BV_Gen.v.COQ85 b/lib/coq/bv/BV_Gen.v.COQ85
index ce74d62b42329e71b436ba63be288d46baacf4b3..493d0f662235b2c4d394bec1ba805c3f8287a9e0 100644
--- a/lib/coq/bv/BV_Gen.v.COQ85
+++ b/lib/coq/bv/BV_Gen.v.COQ85
@@ -205,7 +205,6 @@ unfold nth.
rewrite nth_aux_out_of_bound; auto with zarith.
Qed.
-
Definition zeros_aux {l} : Vector.t bool l.
exact (Vector.const false l).
Defined.
@@ -227,6 +226,15 @@ Lemma Nth_zeros : forall (n:Z), ((nth zeros n) = false).
intros n; apply Nth_zeros_aux.
Qed.
+Definition one_aux l : Vector.t bool (S l).
+ exact (Vector.cons bool true l (Vector.const false l)).
+Defined.
+
+(* Why3 goal *)
+Definition one: t.
+ exact (one_aux last_bit).
+Defined.
+
Definition ones_aux l : Vector.t bool l.
exact (Vector.const true l).
Defined.
@@ -1259,15 +1267,68 @@ Lemma to_uint_of_int : forall (i:Z), ((0%Z <= i)%Z /\
Qed.
(* Why3 goal *)
-Lemma Of_int_zeros : (zeros = (of_int 0%Z)).
+Definition size_bv: t.
+ exact (of_int size).
+Defined.
+
+(* Why3 goal *)
+Lemma to_uint_size_bv : ((to_uint size_bv) = size).
+ apply to_uint_of_int.
+ rewrite max_int_S.
+ destruct size_in_range; auto with zarith.
+Qed.
+
+Lemma Of_int_zeros: zeros = of_int 0.
apply Nat_to_bvec_zeros.
Qed.
(* Why3 goal *)
-Lemma Of_int_ones : (ones = (of_int max_int)).
+Lemma to_uint_zeros : ((to_uint zeros) = 0%Z).
+ rewrite Of_int_zeros.
+ apply to_uint_of_int; easy.
+Qed.
+
+Lemma to_uint_one_aux : forall {l}, bvec_to_nat (S l) (one_aux l) = 1%nat.
+ intro l.
+ simpl.
+ rewrite bvec_to_nat_zeros.
+ auto with zarith.
+Qed.
+
+Lemma Of_int_one_aux : forall {l}, one_aux l = nat_to_bvec (S l) 1%nat.
+ intro l.
+ apply bvec_to_nat_extensionality.
+ rewrite bvec_to_nat_nat_to_bvec.
+ apply to_uint_one_aux.
+ pose proof (id_lt_pow2 l).
+ zify.
+ auto with zarith.
+Qed.
+
+(* Why3 goal *)
+Lemma to_uint_one : ((to_uint one) = 1%Z).
+ unfold to_uint, one.
+ simpl.
+ rewrite bvec_to_nat_zeros.
+ auto with zarith.
+Qed.
+
+Lemma Of_int_one : one = of_int 1.
+ apply Of_int_one_aux.
+Qed.
+
+Lemma Of_int_ones: ones = of_int max_int.
apply Nat_to_bvec_ones.
Qed.
+(* Why3 goal *)
+Lemma to_uint_ones : ((to_uint ones) = max_int).
+ rewrite Of_int_ones.
+ apply to_uint_of_int.
+ rewrite max_int_S.
+ destruct size_in_range; auto with zarith.
+Qed.
+
(* Why3 assumption *)
Definition ult (x:t) (y:t): Prop := ((to_uint x) < (to_uint y))%Z.
@@ -1506,8 +1567,9 @@ Lemma and_zeros : forall {l} (x:Vector.t bool l),
Qed.
Lemma nth_bv_def_aux : forall {l} (x:Vector.t bool (S l)) (i:Z),
- nth_aux x 0 = true <-> (Vector.map2 (fun a b => a && b) x (nat_to_bvec (S l) 1)) <> zeros_aux.
+ nth_aux x 0 = true <-> (Vector.map2 (fun a b => a && b) x (one_aux l)) <> zeros_aux.
intros.
+ rewrite Of_int_one_aux.
destruct x.
simpl.
split; [easy|auto].
@@ -1522,7 +1584,7 @@ Qed.
(* Why3 goal *)
Lemma nth_bv_def : forall (x:t) (i:t), ((nth_bv x i) = true) <->
- ~ ((bw_and (lsr_bv x i) (of_int 1%Z)) = zeros).
+ ~ ((bw_and (lsr_bv x i) one) = zeros).
intros; unfold nth_bv.
case (Z_lt_ge_dec (to_uint i) size); intro.
rewrite <-(Zplus_0_l (to_uint i)).
@@ -1578,8 +1640,9 @@ Defined.
(* Why3 goal *)
Lemma eq_sub_bv_def : forall (a:t) (b:t) (i:t) (n:t), let mask :=
- (lsl_bv (sub (lsl_bv (of_int 1%Z) n) (of_int 1%Z)) i) in ((eq_sub_bv a b i
- n) <-> ((bw_and b mask) = (bw_and a mask))).
+ (lsl_bv (sub (lsl_bv one n) one) i) in ((eq_sub_bv a b i n) <-> ((bw_and b
+ mask) = (bw_and a mask))).
+ rewrite Of_int_one.
easy.
Qed.
diff --git a/lib/coq/bv/BV_Gen.v.COQ86 b/lib/coq/bv/BV_Gen.v.COQ86
index ce74d62b42329e71b436ba63be288d46baacf4b3..4451b6726ca63c5afdd9702fbd694c0a2b57361b 100644
--- a/lib/coq/bv/BV_Gen.v.COQ86
+++ b/lib/coq/bv/BV_Gen.v.COQ86
@@ -227,6 +227,15 @@ Lemma Nth_zeros : forall (n:Z), ((nth zeros n) = false).
intros n; apply Nth_zeros_aux.
Qed.
+Definition one_aux l : Vector.t bool (S l).
+ exact (Vector.cons bool true l (Vector.const false l)).
+Defined.
+
+(* Why3 goal *)
+Definition one: t.
+ exact (one_aux last_bit).
+Defined.
+
Definition ones_aux l : Vector.t bool l.
exact (Vector.const true l).
Defined.
@@ -1259,15 +1268,68 @@ Lemma to_uint_of_int : forall (i:Z), ((0%Z <= i)%Z /\
Qed.
(* Why3 goal *)
-Lemma Of_int_zeros : (zeros = (of_int 0%Z)).
+Definition size_bv: t.
+ exact (of_int size).
+Defined.
+
+(* Why3 goal *)
+Lemma to_uint_size_bv : ((to_uint size_bv) = size).
+ apply to_uint_of_int.
+ rewrite max_int_S.
+ destruct size_in_range; auto with zarith.
+Qed.
+
+Lemma Of_int_zeros: zeros = of_int 0.
apply Nat_to_bvec_zeros.
Qed.
(* Why3 goal *)
-Lemma Of_int_ones : (ones = (of_int max_int)).
+Lemma to_uint_zeros : ((to_uint zeros) = 0%Z).
+ rewrite Of_int_zeros.
+ apply to_uint_of_int; easy.
+Qed.
+
+Lemma to_uint_one_aux : forall {l}, bvec_to_nat (S l) (one_aux l) = 1%nat.
+ intro l.
+ simpl.
+ rewrite bvec_to_nat_zeros.
+ auto with zarith.
+Qed.
+
+Lemma Of_int_one_aux : forall {l}, one_aux l = nat_to_bvec (S l) 1%nat.
+ intro l.
+ apply bvec_to_nat_extensionality.
+ rewrite bvec_to_nat_nat_to_bvec.
+ apply to_uint_one_aux.
+ pose proof (id_lt_pow2 l).
+ zify.
+ auto with zarith.
+Qed.
+
+(* Why3 goal *)
+Lemma to_uint_one : ((to_uint one) = 1%Z).
+ unfold to_uint, one.
+ simpl.
+ rewrite bvec_to_nat_zeros.
+ auto with zarith.
+Qed.
+
+Lemma Of_int_one : one = of_int 1.
+ apply Of_int_one_aux.
+Qed.
+
+Lemma Of_int_ones: ones = of_int max_int.
apply Nat_to_bvec_ones.
Qed.
+(* Why3 goal *)
+Lemma to_uint_ones : ((to_uint ones) = max_int).
+ rewrite Of_int_ones.
+ apply to_uint_of_int.
+ rewrite max_int_S.
+ destruct size_in_range; auto with zarith.
+Qed.
+
(* Why3 assumption *)
Definition ult (x:t) (y:t): Prop := ((to_uint x) < (to_uint y))%Z.
@@ -1506,8 +1568,9 @@ Lemma and_zeros : forall {l} (x:Vector.t bool l),
Qed.
Lemma nth_bv_def_aux : forall {l} (x:Vector.t bool (S l)) (i:Z),
- nth_aux x 0 = true <-> (Vector.map2 (fun a b => a && b) x (nat_to_bvec (S l) 1)) <> zeros_aux.
+ nth_aux x 0 = true <-> (Vector.map2 (fun a b => a && b) x (one_aux l)) <> zeros_aux.
intros.
+ rewrite Of_int_one_aux.
destruct x.
simpl.
split; [easy|auto].
@@ -1522,7 +1585,7 @@ Qed.
(* Why3 goal *)
Lemma nth_bv_def : forall (x:t) (i:t), ((nth_bv x i) = true) <->
- ~ ((bw_and (lsr_bv x i) (of_int 1%Z)) = zeros).
+ ~ ((bw_and (lsr_bv x i) one) = zeros).
intros; unfold nth_bv.
case (Z_lt_ge_dec (to_uint i) size); intro.
rewrite <-(Zplus_0_l (to_uint i)).
@@ -1578,8 +1641,9 @@ Defined.
(* Why3 goal *)
Lemma eq_sub_bv_def : forall (a:t) (b:t) (i:t) (n:t), let mask :=
- (lsl_bv (sub (lsl_bv (of_int 1%Z) n) (of_int 1%Z)) i) in ((eq_sub_bv a b i
- n) <-> ((bw_and b mask) = (bw_and a mask))).
+ (lsl_bv (sub (lsl_bv one n) one) i) in ((eq_sub_bv a b i n) <-> ((bw_and b
+ mask) = (bw_and a mask))).
+ rewrite Of_int_one.
easy.
Qed.
diff --git a/modules/mach/bv.mlw b/modules/mach/bv.mlw
index d7b527d4608639d8ddf7c637c478f91954d26940..7cee6846f6d1f2d2c214140971f28ac831e85c7a 100644
--- a/modules/mach/bv.mlw
+++ b/modules/mach/bv.mlw
@@ -148,7 +148,7 @@ module BVCheck8
constant size = size,
function two_power_size = two_power_size,
function zeros = zeros,
- function to_uint = to_uint,
+ function to_uint = t'int,
function of_int = of_int,
function add = add,
function sub = sub,
@@ -176,7 +176,7 @@ module BVCheck16
constant size = size,
function two_power_size = two_power_size,
function zeros = zeros,
- function to_uint = to_uint,
+ function to_uint = t'int,
function of_int = of_int,
function add = add,
function sub = sub,
@@ -204,7 +204,7 @@ module BVCheck32
constant size = size,
function two_power_size = two_power_size,
function zeros = zeros,
- function to_uint = to_uint,
+ function to_uint = t'int,
function of_int = of_int,
function add = add,
function sub = sub,
@@ -232,7 +232,7 @@ module BVCheck64
constant size = size,
function two_power_size = two_power_size,
function zeros = zeros,
- function to_uint = to_uint,
+ function to_uint = t'int,
function of_int = of_int,
function add = add,
function sub = sub,
diff --git a/plugins/tptp/tptp_printer.ml b/plugins/tptp/tptp_printer.ml
index 644044db8218273b474151dd88a5ea8f11c488e1..a5af74712fcb5e66cc6df2ded1a690dd8e2dc311 100644
--- a/plugins/tptp/tptp_printer.ml
+++ b/plugins/tptp/tptp_printer.ml
@@ -62,7 +62,7 @@ type info = {
let complex_type = Wty.memoize 3 (fun ty ->
let s = Pp.string_of_wnl Pretty.print_ty ty in
- create_tysymbol (id_fresh s) [] None)
+ create_tysymbol (id_fresh s) [] NoDef)
let rec print_type info fmt ty = match ty.ty_node with
| Tyvar _ when info.info_fmt = TFF0 ->
@@ -200,7 +200,7 @@ let print_fmla info fmt f =
let print_decl info fmt d = match d.d_node with
| Dtype _ when info.info_fmt = FOF -> ()
- | Dtype { ts_def = Some _ } -> ()
+ | Dtype { ts_def = Alias _ } -> ()
| Dtype { ts_args = _::_ } when info.info_fmt = TFF0 -> ()
| Dtype ts when query_syntax info.info_syn ts.ts_name <> None -> ()
| Dtype ts ->
diff --git a/plugins/tptp/tptp_typing.ml b/plugins/tptp/tptp_typing.ml
index 51f071e9e911bbce15beb3952edb28cbef136eea..ffc6cb40d9305eacd0402493b589f165a7a63e25 100644
--- a/plugins/tptp/tptp_typing.ml
+++ b/plugins/tptp/tptp_typing.ml
@@ -231,7 +231,7 @@ let find_ts ~loc env impl s args =
try Hstr.find impl s with Not_found ->
let args = List.map (fun _ -> create_tvsymbol (id_fresh "a")) args in
let ss = if s = "int" || s = "real" then "_" ^ s else s in
- let ts = SType (create_tysymbol (id_user ss loc) args None) in
+ let ts = SType (create_tysymbol (id_user ss loc) args NoDef) in
Hstr.add impl s ts;
ts in
match ts with
@@ -284,7 +284,9 @@ let rec ty denv env impl { e_loc = loc; e_node = n } = match n with
| Elet _ | Eite _ | Eqnt _ | Ebin _
| Enot _ | Eequ _ | Edob _ | Enum _ -> error ~loc TypeExpected
-let t_int_const s = t_const (Number.ConstInt (Number.int_const_dec s))
+let t_int_const s =
+ t_const (Number.ConstInt (Number.int_const_dec s)) ty_int
+
(* unused
let t_real_const r = t_const (Number.ConstReal r)
*)
@@ -307,7 +309,7 @@ let rec term denv env impl { e_loc = loc; e_node = n } = match n with
| Enum (Nint s) -> t_int_const s
| Enum (Nreal (i,f,e)) ->
t_const (Number.ConstReal
- (Number.real_const_dec i (Opt.get_def "0" f) e))
+ (Number.real_const_dec i (Opt.get_def "0" f) e)) ty_real
| Enum (Nrat (n,d)) ->
let n = t_int_const n and d = t_int_const d in
let frac = ns_find_ls denv.th_rat.th_export ["frac"] in
@@ -371,7 +373,7 @@ and fmla denv env impl pol tvl { e_loc = loc; e_node = n } = match n with
| Some false, Qexists (* premises *) ->
let _,ln,cn,_ = Loc.get loc in
let sk = Format.sprintf "_%s_%d_%d" s ln cn in
- let ts = create_tysymbol (id_user sk loc) tvl None in
+ let ts = create_tysymbol (id_user sk loc) tvl NoDef in
let tv = ty_app ts (List.map ty_var tvl) in
Hstr.add impl sk (SType ts);
Mstr.add s (STSko tv) env, pol, tvl, vl, true
@@ -537,7 +539,7 @@ let typedecl denv env impl loc s (tvl,(el,e)) =
| _ -> error ~loc DependentTy
in
let ss = if s = "int" || s = "real" then "_" ^ s else s in
- let ts = create_tysymbol (id_user ss loc) (List.map ntv el) None in
+ let ts = create_tysymbol (id_user ss loc) (List.map ntv el) NoDef in
Hstr.add impl s (SType ts)
else
(* function/predicate symbol *)
diff --git a/src/coq-tactic/why3tac.ml4 b/src/coq-tactic/why3tac.ml4
index f8d88132e7c1035885c787d7e6087929fd620293..f7e6a76e4f699020dd31225dd0fedc6b29af70e8 100644
--- a/src/coq-tactic/why3tac.ml4
+++ b/src/coq-tactic/why3tac.ml4
@@ -527,6 +527,7 @@ let rec tr_positive p = match kind_of_term p with
let const_of_big_int b =
Term.t_const
(Number.ConstInt (Number.int_const_dec (Big_int.string_of_big_int b)))
+ ty_int
(* translates a closed Coq term t:Z or R into a FOL term of type int or real *)
let rec tr_arith_constant dep t = match kind_of_term t with
@@ -539,8 +540,10 @@ let rec tr_arith_constant dep t = match kind_of_term t with
Term.fs_app fs [t] Ty.ty_int
| Const _ when is_global coq_R0 t ->
Term.t_const (Number.ConstReal (Number.real_const_dec "0" "0" None))
+ ty_real
| Const _ when is_global coq_R1 t ->
Term.t_const (Number.ConstReal (Number.real_const_dec "1" "0" None))
+ ty_real
(* | App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> *)
(* let ta = tr_arith_constant a in *)
(* let tb = tr_arith_constant b in *)
@@ -620,7 +623,7 @@ and tr_global_ts dep env evd (r : global_reference) =
let (_,vars), _, t = decomp_type_quantifiers env ty in
if not (is_Set t) && not (is_Type t) then raise NotFO;
let id = preid_of_id id in
- let ts = Ty.create_tysymbol id vars None in
+ let ts = Ty.create_tysymbol id vars NoDef in
let decl = Decl.create_ty_decl ts in
add_table global_ts r (Some ts);
add_new_decl dep !dep' decl;
@@ -636,11 +639,11 @@ and tr_global_ts dep env evd (r : global_reference) =
| Some b ->
let b = force b in
let tvm, env, t = decomp_type_lambdas Idmap.empty env vars b in
- let def = Some (tr_type dep' tvm env evd t) in
+ let def = Alias (tr_type dep' tvm env evd t) in
Ty.create_tysymbol id vars def
(* FIXME: is it correct to use None when NotFO? *)
| None ->
- Ty.create_tysymbol id vars None
+ Ty.create_tysymbol id vars NoDef
in
let decl = Decl.create_ty_decl ts in
add_table global_ts r (Some ts);
@@ -655,7 +658,7 @@ and tr_global_ts dep env evd (r : global_reference) =
let (_,vars), _, t = decomp_type_quantifiers env ty in
if not (is_Set t) && not (is_Type t) then raise NotFO;
let id = preid_of_id (Nametab.basename_of_global r) in
- let ts = Ty.create_tysymbol id vars None in
+ let ts = Ty.create_tysymbol id vars NoDef in
add_table global_ts r (Some ts)
in
Array.iteri make_one_ts mib.mind_packets;
diff --git a/src/core/decl.ml b/src/core/decl.ml
index 361fa3d9e27df8dd3d73011748499070a63d6a85..acade4efe9129ec01f874aa84257864d76a70860 100644
--- a/src/core/decl.ml
+++ b/src/core/decl.ml
@@ -413,7 +413,7 @@ let syms_ty s ty = ty_s_fold syms_ts s ty
let syms_term s t = t_s_fold syms_ty syms_ls s t
let create_ty_decl ts =
- let syms = Opt.fold syms_ty Sid.empty ts.ts_def in
+ let syms = type_def_fold syms_ty Sid.empty ts.ts_def in
let news = Sid.singleton ts.ts_name in
mk_decl (Dtype ts) syms news
@@ -454,7 +454,7 @@ let create_data_decl tdl =
let check_decl (syms,news) (ts,cl) =
let cll = List.length cl in
if cl = [] then raise (EmptyAlgDecl ts);
- if ts.ts_def <> None then raise (IllegalTypeAlias ts);
+ if ts.ts_def <> NoDef then raise (IllegalTypeAlias ts);
let news = news_id news ts.ts_name in
let pjs = List.fold_left (fun s (_,pl) -> List.fold_left
(Opt.fold (fun s ls -> Sls.add ls s)) s pl) Sls.empty cl in
@@ -716,7 +716,7 @@ let check_foundness kn d =
| _ -> ()
let rec ts_extract_pos kn sts ts =
- assert (ts.ts_def = None);
+ assert (not (is_alias_type_def ts.ts_def));
if ts_equal ts ts_func then [false;true] else
if ts_equal ts ts_pred then [false] else
if Sts.mem ts sts then List.map Util.ttrue ts.ts_args else
diff --git a/src/core/dterm.ml b/src/core/dterm.ml
index 54af0853b8d8627eb464fdbc257046ff76e0dda5..3dfb62eb5d2c617fc0673d6e7755dff2014cb18e 100644
--- a/src/core/dterm.ml
+++ b/src/core/dterm.ml
@@ -73,8 +73,6 @@ let rec dty_unify dty1 dty2 = match dty1,dty2 with
List.iter2 dty_unify dl1 dl2
| _ -> raise Exit
-let dty_int = Duty ty_int
-let dty_real = Duty ty_real
let dty_bool = Duty ty_bool
let protect_on x s = if x then "(" ^^ s ^^ ")" else s
@@ -175,7 +173,7 @@ type dterm = {
and dterm_node =
| DTvar of string * dty
| DTgvar of vsymbol
- | DTconst of Number.constant
+ | DTconst of Number.constant * ty
| DTapp of lsymbol * dterm list
| DTfapp of dterm * dterm
| DTif of dterm * dterm * dterm
@@ -296,10 +294,8 @@ let dterm ?loc node =
Some dty
| DTgvar vs ->
Some (dty_of_ty vs.vs_ty)
- | DTconst (Number.ConstInt _) ->
- Some dty_int
- | DTconst (Number.ConstReal _) ->
- Some dty_real
+ | DTconst (_,ty) ->
+ Some (dty_of_ty ty)
| DTapp (ls,dtl) ->
let dtyl, dty = specialize_ls ls in
dty_unify_app ls dterm_expected_type dtl dtyl;
@@ -475,8 +471,8 @@ and try_term strict keep_loc uloc env prop dty node =
t_var (Mstr.find_exn (UnboundVar n) n env)
| DTgvar vs ->
t_var vs
- | DTconst c ->
- t_const c
+ | DTconst (c,ty) ->
+ t_const c ty
| DTapp (ls,[]) when ls_equal ls fs_bool_true ->
if prop then t_true else t_bool_true
| DTapp (ls,[]) when ls_equal ls fs_bool_false ->
diff --git a/src/core/dterm.mli b/src/core/dterm.mli
index 68b19969e997a62be753d6b48dc49a2b07b80d52..1994efbb6ad67afb8b9dd32df6cd7484e086d9dd 100644
--- a/src/core/dterm.mli
+++ b/src/core/dterm.mli
@@ -56,7 +56,7 @@ type dterm = private {
and dterm_node =
| DTvar of string * dty
| DTgvar of vsymbol
- | DTconst of Number.constant
+ | DTconst of Number.constant * ty
| DTapp of lsymbol * dterm list
| DTfapp of dterm * dterm
| DTif of dterm * dterm * dterm
diff --git a/src/core/env.mli b/src/core/env.mli
index fb1397e16960c0dadd05b620459a8a5364c8f240..f1955f4d2de84d9115ab0cb4a92b460670f65a95 100644
--- a/src/core/env.mli
+++ b/src/core/env.mli
@@ -145,7 +145,7 @@ val locate_library : env -> pathname -> filename
(** [locate_library env path] returns the location of the library
file specified by [path].
- This is a low-level function that allows to accees a library file
+ This is a low-level function that allows to access a library file
without parsing it. Do not use it without a good reason.
@raise LibraryNotFound [path] if the library file was not found
diff --git a/src/core/pretty.ml b/src/core/pretty.ml
index 3993a92f40ec2874e4eaee1c3526132562e40922..59e2f6928c3ba1fd27dc4bc625b2ae51f22571cb 100644
--- a/src/core/pretty.ml
+++ b/src/core/pretty.ml
@@ -12,7 +12,6 @@
open Format
open Pp
open Stdlib
-open Number
open Ident
open Ty
open Term
@@ -133,16 +132,6 @@ let rec print_ty_node pri fmt ty = match ty.ty_node with
let print_ty fmt ty = print_ty_node 0 fmt ty
-let print_const fmt = function
- | ConstInt (IConstDec s) -> fprintf fmt "%s" s
- | ConstInt (IConstHex s) -> fprintf fmt "0x%s" s
- | ConstInt (IConstOct s) -> fprintf fmt "0o%s" s
- | ConstInt (IConstBin s) -> fprintf fmt "0b%s" s
- | ConstReal (RConstDec (i,f,None)) -> fprintf fmt "%s.%s" i f
- | ConstReal (RConstDec (i,f,Some e)) -> fprintf fmt "%s.%se%s" i f e
- | ConstReal (RConstHex (i,f,Some e)) -> fprintf fmt "0x%s.%sp%s" i f e
- | ConstReal (RConstHex (i,f,None)) -> fprintf fmt "0x%s.%s" i f
-
(* can the type of a value be derived from the type of the arguments? *)
let unambig_fs fs =
let rec lookup v ty = match ty.ty_node with
@@ -244,7 +233,7 @@ and print_tnode pri fmt t = match t.t_node with
| Tvar v ->
print_vs fmt v
| Tconst c ->
- print_const fmt c
+ Number.print_constant fmt c
| Tapp (fs, tl) when is_fs_tuple fs ->
fprintf fmt "(%a)" (print_list comma print_term) tl
| Tapp (fs, tl) when unambig_fs fs ->
@@ -328,8 +317,10 @@ let print_constr fmt (cs,pjl) =
let print_ty_decl fmt ts =
let print_def fmt = function
- | None -> ()
- | Some ty -> fprintf fmt " =@ %a" print_ty ty
+ | NoDef -> ()
+ | Alias ty -> fprintf fmt " =@ %a" print_ty ty
+ | Range _ -> fprintf fmt " =@ " (* TODO *)
+ | Float _ -> fprintf fmt " =@ " (* TODO *)
in
fprintf fmt "@[type %a%a%a%a@]"
print_ts ts print_id_labels ts.ts_name
@@ -532,6 +523,12 @@ let () = Exn_printer.register
fprintf fmt "Unbound type variable: %a" print_tv tv
| Ty.UnexpectedProp ->
fprintf fmt "Unexpected propositional type"
+ | Ty.EmptyRange ->
+ fprintf fmt "Empty integer range"
+ | Ty.BadFloatSpec ->
+ fprintf fmt "Invalid floating point format"
+ | Ty.IllegalTypeParameters ->
+ fprintf fmt "This type cannot have type parameters"
| Term.BadArity ({ls_args = []} as ls, _) ->
fprintf fmt "%s %a expects no arguments"
(if ls.ls_value = None then "Predicate" else "Function") print_ls ls
@@ -557,6 +554,8 @@ let () = Exn_printer.register
fprintf fmt "Not a term: %a" print_term t
| Term.FmlaExpected t ->
fprintf fmt "Not a formula: %a" print_term t
+ | Term.InvalidLiteralType ty ->
+ fprintf fmt "Type %a cannot be used for a numeric literal" print_ty ty
| Pattern.ConstructorExpected (ls,ty) ->
fprintf fmt "%s %a is not a constructor of type %a"
(if ls.ls_value = None then "Predicate" else "Function") print_ls ls
diff --git a/src/core/pretty.mli b/src/core/pretty.mli
index a3fa03ebb8ba5af9e1002806218376f25ab1f09f..cf046cdeb8486b4c7a701798ea87654cec65cddd 100644
--- a/src/core/pretty.mli
+++ b/src/core/pretty.mli
@@ -37,7 +37,6 @@ val print_vsty : formatter -> vsymbol -> unit (* variable : type *)
val print_quant : formatter -> quant -> unit (* quantifier *)
val print_binop : asym:bool -> formatter -> binop -> unit (* binary operator *)
-val print_const : formatter -> Number.constant -> unit (* int/real constant *)
val print_pat : formatter -> pattern -> unit (* pattern *)
val print_term : formatter -> term -> unit (* term *)
diff --git a/src/core/printer.ml b/src/core/printer.ml
index 9335f58a9106afd2ef8c5a9e96918925a6f3ef27..75a328ad63b482892016d17992f6334f4d08c562 100644
--- a/src/core/printer.ml
+++ b/src/core/printer.ml
@@ -110,24 +110,34 @@ let opt_search_forward s pos =
None
with Exit -> Some(!b,!i)
-(*
-let _ = opt_search_forward "%1 + %2" 0
-let _ = opt_search_forward "%1 + %2" 2
-let _ = opt_search_forward "%1 + %2" 7
-let _ = opt_search_forward "%t1 + %v42" 0
-let _ = opt_search_forward "%t1 + %v42" 2
-
-let s = "%1%2"
-let Some(b,e) = opt_search_forward s 0
-let t = String.sub s b (e-b)
-
-open Format
-*)
+let opt_search_forward_literal_format s pos =
+ let l = String.length s in
+ let b = ref pos in
+ let i = ref pos in
+ try
+ while !i < l-1 do
+ if s.[!i] = '%' then begin
+ incr i;
+ b := !i;
+ begin match s.[!i] with
+ | 's' | 'e' | 'm' -> incr i; (* float literals *)
+ | _ -> ()
+ end;
+ while !i < l && is_digit s.[!i] do incr i done;
+ begin match s.[!i] with
+ | 'b' | 'x' | 'o' | 'd' -> incr i; raise Exit
+ | _ -> ()
+ end;
+ end;
+ incr i
+ done;
+ None
+ with Exit -> Some(!b,!i)
-let global_substitute_fmt repl_fun text fmt =
+let global_substitute_fmt search_fun repl_fun text fmt =
let len = String.length text in
let rec replace start =
- match opt_search_forward text start with
+ match search_fun text start with
| None ->
pp_print_string fmt (String.sub text start (len - start))
| Some(pos,end_pos) ->
@@ -137,19 +147,11 @@ let global_substitute_fmt repl_fun text fmt =
in
replace 0
-(*
-let repl s e b fmt = fprintf fmt "A"
-
-let () =
- global_substitute_fmt repl "(LAMBDA (x:%v0): %1)" std_formatter;
- fprintf std_formatter "@."
-*)
-
-let iter_group iter_fun text =
+let iter_group search_fun iter_fun text =
let rec iter start last_was_empty =
let startpos = if last_was_empty then start + 1 else start in
if startpos < String.length text then
- match opt_search_forward text startpos with
+ match search_fun text startpos with
| None -> ()
| Some (pos,end_pos) ->
iter_fun text pos end_pos;
@@ -157,11 +159,6 @@ let iter_group iter_fun text =
in
iter 0 false
-(*
-let regexp_arg_pos = Str.regexp "%\\([0-9]+\\)"
-let regexp_arg_pos_typed = Str.regexp "%\\([tv]?[0-9]+\\)"
-*)
-
exception BadSyntaxIndex of int
exception BadSyntaxArity of int * int
@@ -178,7 +175,7 @@ let check_syntax s len =
if i > len then raise (BadSyntaxArity (len,i));
()
in
- iter_group (*regexp_arg_pos*) arg s
+ iter_group opt_search_forward arg s
let check_syntax_logic ls s =
let len = List.length ls.ls_args in
@@ -201,14 +198,24 @@ let check_syntax_logic ls s =
if i > len then raise (BadSyntaxArity (len,i));
end
in
- iter_group (*regexp_arg_pos_typed*) arg s
+ iter_group opt_search_forward arg s
+
+let check_syntax_literal _ts s =
+ let count = ref 0 in
+ let arg _s _b _e =
+ incr count;
+ (* nothing else to check ?! *)
+ in
+ iter_group opt_search_forward_literal_format arg s
+ (* if !count <> 1 then *)
+ (* raise (BadSyntaxArity (1,!count)) *)
let syntax_arguments s print fmt l =
let args = Array.of_list l in
let repl_fun s b e fmt =
let i = int_of_string (String.sub s b (e-b)) in
print fmt args.(i-1) in
- global_substitute_fmt (*regexp_arg_pos*) repl_fun s fmt
+ global_substitute_fmt opt_search_forward repl_fun s fmt
(* return the type arguments of a symbol application, sorted according
to their (formal) names *)
@@ -240,11 +247,55 @@ let gen_syntax_arguments_typed ty_of tys_of s print_arg print_type t fmt l =
let grp = String.sub s b (e-b) in
let i = int_of_string grp in
print_arg fmt args.(i-1) in
- global_substitute_fmt (*regexp_arg_pos_typed*) repl_fun s fmt
+ global_substitute_fmt opt_search_forward repl_fun s fmt
let syntax_arguments_typed =
gen_syntax_arguments_typed t_type get_type_arguments
+let syntax_range_literal s fmt c =
+ let f s b e fmt =
+ let base = match s.[e-1] with
+ | 'x' -> 16
+ | 'd' -> 10
+ | 'o' -> 8
+ | 'b' -> 2
+ | _ -> assert false
+ in
+ let digits =
+ if e > b + 1 then
+ Some (int_of_string (String.sub s b (e-b-1)))
+ else
+ None
+ in
+ let v = Number.compute_int c in
+ Number.print_in_base base digits fmt v
+ in
+ global_substitute_fmt opt_search_forward_literal_format f s fmt
+
+let syntax_float_literal s fp fmt c =
+ let f s b e fmt =
+ let base = match s.[e-1] with
+ | 'x' -> 16
+ | 'd' -> 10
+ | 'o' -> 8
+ | 'b' -> 2
+ | _ -> assert false
+ in
+ let digits =
+ if e > b + 2 then
+ Some (int_of_string (String.sub s (b+1) (e-b-2)))
+ else
+ None
+ in
+ let e,m = Number.compute_float c fp in
+ match s.[b] with
+ | 's' -> Number.print_in_base base digits fmt BigInt.zero
+ | 'e' -> Number.print_in_base base digits fmt e
+ | 'm' -> Number.print_in_base base digits fmt m
+ | _ -> assert false
+ in
+ global_substitute_fmt opt_search_forward_literal_format f s fmt
+
(** {2 use printers} *)
let print_prelude fmt pl =
@@ -298,6 +349,11 @@ let meta_syntax_converter = register_meta "syntax_converter" [MTlsymbol; MTstrin
Can@ be@ specified@ in@ the@ driver@ with@ the@ 'syntax converter'@ \
rules."
+let meta_syntax_literal = register_meta "syntax_literal" [MTtysymbol; MTstring; MTint]
+ ~desc:"Specify@ the@ syntax@ used@ to@ pretty-print@ a@ range@ literal.@ \
+ Can@ be@ specified@ in@ the@ driver@ with@ the@ 'syntax literal'@ \
+ rules."
+
let meta_remove_prop = register_meta "remove_prop" [MTprsymbol]
~desc:"Remove@ a@ logical@ proposition@ from@ proof@ obligations.@ \
Can@ be@ specified@ in@ the@ driver@ with@ the@ 'remove prop'@ rule."
@@ -328,6 +384,10 @@ let syntax_converter ls s b =
check_syntax_logic ls s;
create_meta meta_syntax_converter [MAls ls; MAstr s; MAint (if b then 1 else 0)]
+let syntax_literal ts s b =
+ check_syntax_literal ts s;
+ create_meta meta_syntax_literal [MAts ts; MAstr s; MAint (if b then 1 else 0)]
+
let remove_prop pr =
create_meta meta_remove_prop [MApr pr]
@@ -386,15 +446,27 @@ let get_syntax_map task =
let get_converter_map task =
Task.on_meta meta_syntax_converter cm_add_ls Mls.empty task
+let get_rliteral_map task =
+ Task.on_meta meta_syntax_literal sm_add_ts Mid.empty task
+
let add_syntax_map td sm = match td.td_node with
- | Meta (m, args) when meta_equal m meta_syntax_type -> sm_add_ts sm args
- | Meta (m, args) when meta_equal m meta_syntax_logic -> sm_add_ls sm args
- | Meta (m, args) when meta_equal m meta_remove_prop -> sm_add_pr sm args
+ | Meta (m, args) when meta_equal m meta_syntax_type ->
+ sm_add_ts sm args
+ | Meta (m, args) when meta_equal m meta_syntax_logic ->
+ sm_add_ls sm args
+ | Meta (m, args) when meta_equal m meta_remove_prop ->
+ sm_add_pr sm args
| _ -> sm
-let add_converter_map td cm = match td.td_node with
- | Meta (m, args) when meta_equal m meta_syntax_converter -> cm_add_ls cm args
- | _ -> cm
+(*let add_converter_map td cm = match td.td_node with
+ | Meta (m, args) when meta_equal m meta_syntax_converter ->
+ cm_add_ls cm args
+ | _ -> cm*)
+
+let add_rliteral_map td sm = match td.td_node with
+ | Meta (m, args) when meta_equal m meta_syntax_literal ->
+ sm_add_ts sm args
+ | _ -> sm
let query_syntax sm id =
try Some (fst (Mid.find id sm)) with Not_found -> None
diff --git a/src/core/printer.mli b/src/core/printer.mli
index bf924c8009aff92f6316df91d5aa1ebbfb0ae567..ae8d3c46bf2fceabb01726d36e2608ff9dc03f56 100644
--- a/src/core/printer.mli
+++ b/src/core/printer.mli
@@ -61,6 +61,7 @@ val print_th_prelude : task -> prelude_map pp
val meta_syntax_type : meta
val meta_syntax_logic : meta
val meta_syntax_converter : meta
+val meta_syntax_literal : meta
val meta_remove_prop : meta
val meta_remove_logic : meta
val meta_remove_type : meta
@@ -69,6 +70,7 @@ val meta_realized_theory : meta
val syntax_type : tysymbol -> string -> bool -> tdecl
val syntax_logic : lsymbol -> string -> bool -> tdecl
val syntax_converter : lsymbol -> string -> bool -> tdecl
+val syntax_literal : tysymbol -> string -> bool -> tdecl
val remove_prop : prsymbol -> tdecl
val check_syntax_type: tysymbol -> string -> unit
@@ -83,7 +85,9 @@ val add_syntax_map : tdecl -> syntax_map -> syntax_map
(* interprets a declaration as a syntax rule, if any *)
val get_converter_map : task -> converter_map
-val add_converter_map : tdecl -> converter_map -> converter_map
+
+val get_rliteral_map : task -> syntax_map
+val add_rliteral_map : tdecl -> syntax_map -> syntax_map
val query_syntax : syntax_map -> ident -> string option
val query_converter : converter_map -> lsymbol -> string option
@@ -100,7 +104,13 @@ val syntax_arguments_typed :
(** (syntax_arguments templ print_arg fmt l) prints in the formatter fmt
the list l using the template templ and the printer print_arg *)
-(** {2 Pretty-printing transformations (useful for caching)} *)
+val syntax_range_literal :
+ string -> Number.integer_constant pp
+
+val syntax_float_literal :
+ string -> Number.float_format -> Number.real_constant pp
+
+(** {2 pretty-printing transformations (useful for caching)} *)
val on_syntax_map : (syntax_map -> 'a Trans.trans) -> 'a Trans.trans
diff --git a/src/core/term.ml b/src/core/term.ml
index 940864e45efdf11397de46a7f924257a34c5bb4d..0f491d1c8827ac93139113af6b462cef77a1ebf3 100644
--- a/src/core/term.ml
+++ b/src/core/term.ml
@@ -822,12 +822,29 @@ let t_app ls tl ty = ignore (ls_app_inst ls tl ty); t_app ls tl ty
let fs_app fs tl ty = t_app fs tl (Some ty)
let ps_app ps tl = t_app ps tl None
-let t_const c = match c with
- | Number.ConstInt _ -> t_const c ty_int
- | Number.ConstReal _ -> t_const c ty_real
-
let t_nat_const n =
- t_const (Number.ConstInt (Number.int_const_dec (string_of_int n)))
+ t_const (Number.ConstInt (Number.int_const_dec (string_of_int n))) ty_int
+
+exception InvalidLiteralType of ty
+
+let t_const c ty =
+ let ts = match ty.ty_node with
+ | Tyapp (ts,[]) -> ts
+ | _ -> raise (InvalidLiteralType ty) in
+ begin match c with
+ | Number.ConstInt c when not (ts_equal ts ts_int) ->
+ begin match ts.ts_def with
+ | Range ir -> Number.check_range c ir
+ | _ -> raise (InvalidLiteralType ty)
+ end
+ | Number.ConstReal c when not (ts_equal ts ts_real) ->
+ begin match ts.ts_def with
+ | Float fp -> Number.check_float c fp
+ | _ -> raise (InvalidLiteralType ty)
+ end
+ | _ -> ()
+ end;
+ t_const c ty
let t_if f t1 t2 =
t_ty_check t2 t1.t_ty;
diff --git a/src/core/term.mli b/src/core/term.mli
index 7b58cac0302bcc07cfaa50d16b667057471b2fed..d3ab3d50d0561bd7d358a49a2efc8fdffe68bb17 100644
--- a/src/core/term.mli
+++ b/src/core/term.mli
@@ -71,6 +71,7 @@ exception BadArity of lsymbol * int
exception FunctionSymbolExpected of lsymbol
exception PredicateSymbolExpected of lsymbol
exception ConstructorExpected of lsymbol
+exception InvalidLiteralType of ty
(** {2 Patterns} *)
@@ -202,7 +203,7 @@ val ls_arg_inst : lsymbol -> term list -> ty Mtv.t
val ls_app_inst : lsymbol -> term list -> ty option -> ty Mtv.t
val t_var : vsymbol -> term
-val t_const : Number.constant -> term
+val t_const : Number.constant -> ty -> term
val t_if : term -> term -> term -> term
val t_let : term -> term_bound -> term
val t_case : term -> term_branch list -> term
diff --git a/src/core/theory.ml b/src/core/theory.ml
index 14cfb7970fdbb490b4a424ff31e6c8200820285a..ce9bc53c231372453796e92ac353b69656ccef78 100644
--- a/src/core/theory.ml
+++ b/src/core/theory.ml
@@ -147,6 +147,12 @@ let lookup_meta s = Hstr.find_exn meta_table (UnknownMeta s) s
let list_metas () = Hstr.fold (fun _ v acc -> v::acc) meta_table []
+let meta_range = register_meta "range_type" [MTtysymbol; MTlsymbol]
+ ~desc:"Projection@ of@ a@ range@ type."
+
+let meta_float = register_meta "float_type" [MTtysymbol; MTlsymbol; MTlsymbol]
+ ~desc:"Projection@ and@ finiteness@ of@ a@ floating-point@ type."
+
(** Theory *)
type theory = {
@@ -311,8 +317,8 @@ let close_namespace uc import =
(* Base constructors *)
let known_ts kn ts = match ts.ts_def with
- | Some ty -> ty_s_fold (fun () ts -> known_id kn ts.ts_name) () ty
- | None -> known_id kn ts.ts_name
+ | Alias ty -> ty_s_fold (fun () ts -> known_id kn ts.ts_name) () ty
+ | NoDef | Range _ | Float _ -> known_id kn ts.ts_name
let known_clone kn sm =
Mts.iter (fun _ ts -> known_ts kn ts) sm.sm_ts;
@@ -375,24 +381,9 @@ let add_symbol add id v uc =
uc_export = add true id.id_string v e0 :: ste }
| _ -> assert false
-let add_data uc (ts,csl) =
- let add_proj uc = function
- | Some pj -> add_symbol add_ls pj.ls_name pj uc
- | None -> uc in
- let add_constr uc (fs,pl) =
- let uc = add_symbol add_ls fs.ls_name fs uc in
- List.fold_left add_proj uc pl in
- let uc = add_symbol add_ts ts.ts_name ts uc in
- List.fold_left add_constr uc csl
-
-let add_logic uc (ls,_) = add_symbol add_ls ls.ls_name ls uc
-
-let add_ind uc (ps,la) =
- let uc = add_symbol add_ls ps.ls_name ps uc in
- let add uc (pr,_) = add_symbol add_pr pr.pr_name pr uc in
- List.fold_left add uc la
-
-let add_prop uc (_,pr,_) = add_symbol add_pr pr.pr_name pr uc
+let add_symbol_ts uc ts = add_symbol add_ts ts.ts_name ts uc
+let add_symbol_ls uc ls = add_symbol add_ls ls.ls_name ls uc
+let add_symbol_pr uc pr = add_symbol add_pr pr.pr_name pr uc
let create_decl d = mk_tdecl (Decl d)
@@ -435,8 +426,7 @@ let warn_dubious_axiom uc k p syms =
(fun id ->
if Sid.mem id uc.uc_local then
match (Ident.Mid.find id uc.uc_known).d_node with
- | Dtype { ts_def = None } | Dparam _ ->
- raise Exit
+ | Dtype { ts_def = NoDef } | Dparam _ -> raise Exit
| _ -> ())
syms;
Warning.emit ?loc:p.id_loc "axiom %s does not contain any local abstract symbol"
@@ -453,16 +443,35 @@ let add_decl ?(warn=true) uc d =
check_decl_opacity d; (* we don't care about tasks *)
let uc = add_tdecl uc (create_decl d) in
match d.d_node with
- | Dtype ts -> add_symbol add_ts ts.ts_name ts uc
- | Ddata dl -> List.fold_left add_data uc dl
- | Dparam ls -> add_symbol add_ls ls.ls_name ls uc
- | Dlogic dl -> List.fold_left add_logic uc dl
- | Dind (_, dl) -> List.fold_left add_ind uc dl
- | Dprop ((k,pr,_) as p) ->
+ | Dtype ts ->
+ add_symbol_ts uc ts
+ | Ddata dl ->
+ let add_field uc = function
+ | Some pj -> add_symbol_ls uc pj
+ | None -> uc in
+ let add_constr uc (cs,pl) =
+ let uc = add_symbol_ls uc cs in
+ List.fold_left add_field uc pl in
+ let add_data uc (ts,csl) =
+ let uc = add_symbol_ts uc ts in
+ List.fold_left add_constr uc csl in
+ List.fold_left add_data uc dl
+ | Dparam ls ->
+ add_symbol_ls uc ls
+ | Dlogic dl ->
+ let add_logic uc (ls,_) = add_symbol_ls uc ls in
+ List.fold_left add_logic uc dl
+ | Dind (_, dl) ->
+ let add_ind uc (ps,la) =
+ let uc = add_symbol_ls uc ps in
+ let add uc (pr,_) = add_symbol_pr uc pr in
+ List.fold_left add uc la in
+ List.fold_left add_ind uc dl
+ | Dprop (k,pr,_) ->
if warn && should_be_conservative uc.uc_name &&
- should_be_conservative pr.pr_name
+ should_be_conservative pr.pr_name
then warn_dubious_axiom uc k pr.pr_name d.d_syms;
- add_prop uc p
+ add_symbol_pr uc pr
(** Declaration constructors + add_decl *)
@@ -531,13 +540,18 @@ let empty_clones s = {
let rec cl_find_ts cl ts =
if not (Sid.mem ts.ts_name cl.cl_local) then
- let td = Opt.map (cl_trans_ty cl) ts.ts_def in
- if Opt.equal ty_equal ts.ts_def td then ts else
- create_tysymbol (id_clone ts.ts_name) ts.ts_args td
+ match ts.ts_def with
+ | Alias ty ->
+ let td = cl_trans_ty cl ty in
+ if ty_equal td ty then ts else
+ let id = id_clone ts.ts_name in
+ create_tysymbol id ts.ts_args (Alias td)
+ | NoDef | Range _ | Float _ -> ts
else try Mts.find ts cl.ts_table
with Not_found ->
- let td' = Opt.map (cl_trans_ty cl) ts.ts_def in
- let ts' = create_tysymbol (id_clone ts.ts_name) ts.ts_args td' in
+ let id' = id_clone ts.ts_name in
+ let td' = type_def_map (cl_trans_ty cl) ts.ts_def in
+ let ts' = create_tysymbol id' ts.ts_args td' in
cl.ts_table <- Mts.add ts ts' cl.ts_table;
ts'
@@ -615,7 +629,7 @@ let cl_init th inst =
let cl_type cl inst ts =
if Mts.mem ts inst.inst_ts then
- if ts.ts_def = None then raise EmptyDecl
+ if ts.ts_def = NoDef then raise EmptyDecl
else raise (CannotInstantiate ts.ts_name);
create_ty_decl (cl_find_ts cl ts)
@@ -715,7 +729,7 @@ let warn_clone_not_abstract loc th =
List.iter (fun d -> match d.td_node with
| Decl d ->
begin match d.d_node with
- | Dtype { ts_def = None }
+ | Dtype { ts_def = NoDef }
| Dparam _ -> raise Exit
| Dprop(Paxiom, _,_) -> raise Exit
| _ -> ()
@@ -897,7 +911,7 @@ let tuple_theory = Hint.memo 17 (fun n ->
let unit_theory =
let uc = empty_theory (id_fresh "Unit") ["why3";"Unit"] in
- let ts = create_tysymbol (id_fresh "unit") [] (Some (ty_tuple [])) in
+ let ts = create_tysymbol (id_fresh "unit") [] (Alias (ty_tuple [])) in
let uc = use_export uc (tuple_theory 0) in
let uc = add_ty_decl uc ts in
close_theory uc
diff --git a/src/core/theory.mli b/src/core/theory.mli
index 18fb1cc94943d711ffde151a9c632be71768c202..3dbca27227bf8af0b4fbbf5d37859f314865695f 100644
--- a/src/core/theory.mli
+++ b/src/core/theory.mli
@@ -78,6 +78,9 @@ val register_meta_excl :
val lookup_meta : string -> meta
val list_metas : unit -> meta list
+val meta_range : meta
+val meta_float : meta
+
(** {2 Theories} *)
type theory = private {
@@ -226,4 +229,3 @@ exception KnownMeta of meta
exception UnknownMeta of string
exception BadMetaArity of meta * int
exception MetaTypeMismatch of meta * meta_arg_type * meta_arg_type
-
diff --git a/src/core/ty.ml b/src/core/ty.ml
index b4f27b4c83cc14bbc61565ee302632ae1cb98576..2e273139e9f2bd01473bd03185684e3e89fe6395 100644
--- a/src/core/ty.ml
+++ b/src/core/ty.ml
@@ -42,10 +42,16 @@ let tv_of_string =
(* type symbols and types *)
+type 'a type_def =
+ | NoDef
+ | Alias of 'a
+ | Range of Number.int_range
+ | Float of Number.float_format
+
type tysymbol = {
- ts_name : ident;
- ts_args : tvsymbol list;
- ts_def : ty option;
+ ts_name : ident;
+ ts_args : tvsymbol list;
+ ts_def : ty type_def;
}
and ty = {
@@ -77,9 +83,9 @@ let ts_compare ts1 ts2 = id_compare ts1.ts_name ts2.ts_name
let ty_compare ty1 ty2 = Pervasives.compare (ty_hash ty1) (ty_hash ty2)
let mk_ts name args def = {
- ts_name = id_register name;
- ts_args = args;
- ts_def = def;
+ ts_name = id_register name;
+ ts_args = args;
+ ts_def = def;
}
module Hsty = Hashcons.Make (struct
@@ -129,6 +135,26 @@ let ty_fold fn acc ty = match ty.ty_node with
let ty_all pr ty = Util.all ty_fold pr ty
let ty_any pr ty = Util.any ty_fold pr ty
+let type_def_map fn = function
+ | Alias ty -> Alias (fn ty)
+ | td -> td
+
+let type_def_fold fn acc = function
+ | Alias ty -> fn acc ty
+ | _ -> acc
+
+let is_alias_type_def = function
+ | Alias _ -> true
+ | _ -> false
+
+let is_range_type_def = function
+ | Range _ -> true
+ | _ -> false
+
+let is_float_type_def = function
+ | Float _ -> true
+ | _ -> false
+
(* traversal functions on type variables *)
let rec ty_v_map fn ty = match ty.ty_node with
@@ -151,20 +177,36 @@ let ty_closed ty = ty_v_all Util.ffalse ty
exception BadTypeArity of tysymbol * int
exception DuplicateTypeVar of tvsymbol
exception UnboundTypeVar of tvsymbol
+exception IllegalTypeParameters
+exception BadFloatSpec
+exception EmptyRange
let create_tysymbol name args def =
let add s v = Stv.add_new (DuplicateTypeVar v) v s in
let s = List.fold_left add Stv.empty args in
let check v = Stv.mem v s || raise (UnboundTypeVar v) in
- ignore (Opt.map (ty_v_all check) def);
+ begin match def with
+ | NoDef -> ()
+ | Alias def ->
+ ignore (ty_v_all check def)
+ | Range ir ->
+ if args <> [] then raise IllegalTypeParameters;
+ if BigInt.lt ir.Number.ir_upper ir.Number.ir_lower
+ then raise EmptyRange
+ | Float fp ->
+ if args <> [] then raise IllegalTypeParameters;
+ if fp.Number.fp_exponent_digits < 1 ||
+ fp.Number.fp_significand_digits < 1
+ then raise BadFloatSpec
+ end;
mk_ts name args def
let ty_app s tl = match s.ts_def with
- | Some ty ->
+ | Alias ty ->
let mv = try List.fold_right2 Mtv.add s.ts_args tl Mtv.empty with
| Invalid_argument _ -> raise (BadTypeArity (s, List.length tl)) in
ty_full_inst mv ty
- | None ->
+ | NoDef | Range _ | Float _ ->
if List.length s.ts_args <> List.length tl then
raise (BadTypeArity (s, List.length tl));
ty_app s tl
@@ -208,9 +250,9 @@ let ty_match s ty1 ty2 =
(* built-in symbols *)
-let ts_int = create_tysymbol (id_fresh "int") [] None
-let ts_real = create_tysymbol (id_fresh "real") [] None
-let ts_bool = create_tysymbol (id_fresh "bool") [] None
+let ts_int = create_tysymbol (id_fresh "int") [] NoDef
+let ts_real = create_tysymbol (id_fresh "real") [] NoDef
+let ts_bool = create_tysymbol (id_fresh "bool") [] NoDef
let ty_int = ty_app ts_int []
let ty_real = ty_app ts_real []
@@ -219,13 +261,13 @@ let ty_bool = ty_app ts_bool []
let ts_func =
let tv_a = create_tvsymbol (id_fresh "a") in
let tv_b = create_tvsymbol (id_fresh "b") in
- create_tysymbol (id_fresh "func") [tv_a;tv_b] None
+ create_tysymbol (id_fresh "func") [tv_a;tv_b] NoDef
let ty_func ty_a ty_b = ty_app ts_func [ty_a;ty_b]
let ts_pred =
let tv_a = create_tvsymbol (id_fresh "a") in
- let def = Some (ty_func (ty_var tv_a) ty_bool) in
+ let def = Alias (ty_func (ty_var tv_a) ty_bool) in
create_tysymbol (id_fresh "pred") [tv_a] def
let ty_pred ty_a = ty_app ts_pred [ty_a]
@@ -235,7 +277,7 @@ let ts_tuple_ids = Hid.create 17
let ts_tuple = Hint.memo 17 (fun n ->
let vl = ref [] in
for _i = 1 to n do vl := create_tvsymbol (id_fresh "a") :: !vl done;
- let ts = create_tysymbol (id_fresh ("tuple" ^ string_of_int n)) !vl None in
+ let ts = create_tysymbol (id_fresh ("tuple" ^ string_of_int n)) !vl NoDef in
Hid.add ts_tuple_ids ts.ts_name n;
ts)
diff --git a/src/core/ty.mli b/src/core/ty.mli
index f8f4fdf32ee73bcbdb7c7a40ad707f8e13c90b00..0caf736015f17091390cb8b8d511c4d687917455 100644
--- a/src/core/ty.mli
+++ b/src/core/ty.mli
@@ -33,10 +33,16 @@ val tv_of_string : string -> tvsymbol
(** {2 Type symbols and types} *)
+type 'a type_def =
+ | NoDef
+ | Alias of 'a
+ | Range of Number.int_range
+ | Float of Number.float_format
+
type tysymbol = private {
- ts_name : ident;
- ts_args : tvsymbol list;
- ts_def : ty option;
+ ts_name : ident;
+ ts_args : tvsymbol list;
+ ts_def : ty type_def;
}
and ty = private {
@@ -70,12 +76,24 @@ val ty_hash : ty -> int
exception BadTypeArity of tysymbol * int
exception DuplicateTypeVar of tvsymbol
exception UnboundTypeVar of tvsymbol
+exception IllegalTypeParameters
+exception BadFloatSpec
+exception EmptyRange
-val create_tysymbol : preid -> tvsymbol list -> ty option -> tysymbol
+val create_tysymbol : preid -> tvsymbol list -> ty type_def -> tysymbol
val ty_var : tvsymbol -> ty
val ty_app : tysymbol -> ty list -> ty
+(** {2 Type definition utilities} *)
+
+val type_def_map : ('a -> 'a) -> 'a type_def -> 'a type_def
+val type_def_fold : ('a -> 'b -> 'a) -> 'a -> 'b type_def -> 'a
+
+val is_alias_type_def : 'a type_def -> bool
+val is_range_type_def : 'a type_def -> bool
+val is_float_type_def : 'a type_def -> bool
+
(** {2 Generic traversal functions} *)
(** traverse only one level of constructor, if you want full traversal
diff --git a/src/driver/driver.ml b/src/driver/driver.ml
index d5ece169311c4a4c90d424ac8cfd7ac16cfac6fd..d851bb7e61c0549ae667e6c542098edfb7f9a4ff 100644
--- a/src/driver/driver.ml
+++ b/src/driver/driver.ml
@@ -163,6 +163,9 @@ let load_driver = let driver_tag = ref (-1) in fun env file extra_files ->
| Rconverter (q,s,b) ->
let cs = syntax_converter (find_ls th q) s b in
add_meta th cs meta
+ | Rliteral (q,s,b) ->
+ let cs = syntax_literal (find_ts th q) s b in
+ add_meta th cs meta
| Rmeta (s,al) ->
let rec ty_of_pty = function
| PTyvar x ->
diff --git a/src/driver/driver_ast.ml b/src/driver/driver_ast.ml
index a0609054b59b88fb6ce1940a3daf44fac8df0018..b2ceea0c7073d0955d1183201d8c077dad358ed7 100644
--- a/src/driver/driver_ast.ml
+++ b/src/driver/driver_ast.ml
@@ -32,6 +32,7 @@ type th_rule =
| Rsyntaxfs of qualid * string * bool
| Rsyntaxps of qualid * string * bool
| Rconverter of qualid * string * bool
+ | Rliteral of qualid * string * bool
| Rremovepr of qualid
| Rremoveall
| Rmeta of string * metarg list
diff --git a/src/driver/driver_lexer.mll b/src/driver/driver_lexer.mll
index cb0306c05148c5ed1d2a33d4fd8d7900d6c896a5..17ed87ae2bedbac9795b0246f04109dc2a370aaa 100644
--- a/src/driver/driver_lexer.mll
+++ b/src/driver/driver_lexer.mll
@@ -57,6 +57,7 @@
"exception", EXCEPTION;
"val", VAL;
"converter", CONVERTER;
+ "literal", LITERAL;
]
}
diff --git a/src/driver/driver_parser.mly b/src/driver/driver_parser.mly
index cc7e166c56c7ad3163ebc8acefa54bbca291454e..9da42302ad032644e76e00940aeb891ed88065ed 100644
--- a/src/driver/driver_parser.mly
+++ b/src/driver/driver_parser.mly
@@ -27,7 +27,7 @@
%token TIMEOUT OUTOFMEMORY STEPLIMITEXCEEDED TIME STEPS
%token UNDERSCORE LEFTPAR RIGHTPAR DOT QUOTE EOF
%token BLACKLIST
-%token MODULE EXCEPTION VAL CONVERTER
+%token MODULE EXCEPTION VAL CONVERTER LITERAL
%token FUNCTION PREDICATE TYPE PROP ALL FILENAME TRANSFORM PLUGIN
%token LEFTPAR_STAR_RIGHTPAR COMMA CONSTANT
%token LEFTSQ RIGHTSQ LARROW
@@ -89,6 +89,7 @@ trule:
| syntax FUNCTION qualid STRING { Rsyntaxfs ($3, $4, $1) }
| syntax PREDICATE qualid STRING { Rsyntaxps ($3, $4, $1) }
| syntax CONVERTER qualid STRING { Rconverter ($3, $4, $1) }
+| syntax LITERAL qualid STRING { Rliteral ($3, $4, $1) }
| REMOVE PROP qualid { Rremovepr ($3) }
| REMOVE ALL { Rremoveall }
| META ident meta_args { Rmeta ($2, $3) }
diff --git a/src/mlw/expr.ml b/src/mlw/expr.ml
index 13bb682d6e1a38514dc4152459da7f70a8f6f774..c928e02fb00a818948080a9589a266bc41554c64 100644
--- a/src/mlw/expr.ml
+++ b/src/mlw/expr.ml
@@ -183,7 +183,7 @@ let mfield_of_rs s = match s.rs_cty.cty_args, s.rs_field with
let create_constructor ~constr id s fl =
let exn = Invalid_argument "Expr.create_constructor" in
let fs = List.fold_right (Spv.add_new exn) fl Spv.empty in
- if s.its_privmut || s.its_def <> None then raise exn;
+ if s.its_privmut || s.its_def <> NoDef then raise exn;
if s.its_mfields <> [] then begin
if constr <> 1 then raise exn;
let mfs = Spv.of_list s.its_mfields in
@@ -1005,7 +1005,7 @@ and print_cexp exec pri fmt {c_node = n; c_cty = c} = match n with
and print_enode pri fmt e = match e.e_node with
| Evar v -> print_pv fmt v
- | Econst c -> print_const fmt c
+ | Econst c -> Number.print_constant fmt c
| Eexec c -> print_cexp true pri fmt c
| Elet (LDvar (v,e1), e2)
when v.pv_vs.vs_name.id_string = "_" && ity_equal v.pv_ity ity_unit ->
diff --git a/src/mlw/ity.ml b/src/mlw/ity.ml
index 0e8cd440531552e4ee2b340e80e10a2452c60f6e..f424acdc1db3d90386c34c7ff95322efdca14b36 100644
--- a/src/mlw/ity.ml
+++ b/src/mlw/ity.ml
@@ -27,7 +27,7 @@ type itysymbol = {
its_arg_frz : bool list; (** irreplaceable type parameters *)
its_reg_vis : bool list; (** non-ghost shareable components *)
its_reg_frz : bool list; (** irreplaceable shareable components *)
- its_def : ity option; (** type alias *)
+ its_def : ity type_def; (** type definition *)
}
and ity = {
@@ -117,14 +117,14 @@ let reg_compare reg1 reg2 = id_compare reg1.reg_name reg2.reg_name
let pv_compare pv1 pv2 = id_compare pv1.pv_vs.vs_name pv2.pv_vs.vs_name
let its_mutable s = s.its_privmut || s.its_mfields <> [] ||
- match s.its_def with Some {ity_node = Ityreg _} -> true | _ -> false
+ match s.its_def with Alias {ity_node = Ityreg _} -> true | _ -> false
let its_impure s = its_mutable s || s.its_regions <> []
exception NonUpdatable of itysymbol * ity
let check_its_args s tl =
- assert (s.its_def = None);
+ assert (not (is_alias_type_def s.its_def));
let check_imm acc imm ity =
if imm && not ity.ity_pure then raise (NonUpdatable (s,ity));
acc && ity.ity_pure in
@@ -408,17 +408,17 @@ let ity_pur s tl =
(* compute the substitution even for non-aliases to verify arity *)
let sbs = its_match_args s tl in
match s.its_def with
- | Some ity ->
+ | Alias ity ->
ity_full_inst sbs (ity_purify ity)
- | None ->
+ | _ ->
ity_pur_unsafe s tl
let create_region sbs id s tl rl = match s.its_def with
- | Some { ity_node = Ityreg r } ->
+ | Alias { ity_node = Ityreg r } ->
let tl = List.map (ity_full_inst sbs) r.reg_args in
let rl = List.map (reg_full_inst sbs) r.reg_regs in
mk_reg id r.reg_its tl rl
- | None when its_mutable s ->
+ | _ when its_mutable s ->
mk_reg id s tl rl
| _ -> invalid_arg "Ity.create_region"
@@ -426,11 +426,11 @@ let ity_app sbs s tl rl =
if its_mutable s then
ity_reg (create_region sbs (id_fresh "rho") s tl rl)
else match s.its_def with
- | Some ity ->
+ | Alias ity ->
ity_full_inst sbs ity
- | None when rl = [] ->
+ | _ when rl = [] ->
ity_pur_unsafe s tl
- | None ->
+ | _ ->
ity_app_unsafe s tl rl
let rec ity_inst_fresh sbs ity = match ity.ity_node with
@@ -498,15 +498,20 @@ let rec ity_of_ty ty = match ty.ty_node with
let its_of_ts ts imm =
let tl = List.map Util.ttrue ts.ts_args in
let il = if imm then tl else List.map Util.ffalse ts.ts_args in
+ let def = match ts.ts_def with
+ | Alias ty -> Alias (ity_of_ty ty)
+ | Range ir -> Range ir
+ | Float fp -> Float fp
+ | NoDef -> NoDef in
create_its ~ts ~pm:false ~mfld:[] ~regs:[] ~aimm:il ~aexp:tl ~avis:tl
- ~afrz:tl ~rvis:[] ~rfrz:[] ~def:(Opt.map ity_of_ty ts.ts_def)
+ ~afrz:tl ~rvis:[] ~rfrz:[] ~def
let create_itysymbol_pure id args =
- its_of_ts (create_tysymbol id args None) true
+ its_of_ts (create_tysymbol id args NoDef) true
let create_itysymbol_alias id args def =
(* FIXME? should we compute [arg|reg]_[imm|exp|vis|frz]? *)
- let ts = create_tysymbol id args (Some (ty_of_ity def)) in
+ let ts = create_tysymbol id args (Alias (ty_of_ity def)) in
let regs = Sreg.elements (let add_r s r = Sreg.add r s in
match def.ity_node with
| Ityreg reg -> reg_r_fold add_r Sreg.empty reg
@@ -514,12 +519,12 @@ let create_itysymbol_alias id args def =
let tl = List.map Util.ttrue args in
let rl = List.map Util.ttrue regs in
create_its ~ts ~pm:false ~mfld:[] ~regs ~aimm:tl ~aexp:tl
- ~avis:tl ~afrz:tl ~rvis:rl ~rfrz:rl ~def:(Some def)
+ ~avis:tl ~afrz:tl ~rvis:rl ~rfrz:rl ~def:(Alias def)
exception ImpureField of ity
let create_itysymbol_rich id args pm flds =
- let ts = create_tysymbol id args None in
+ let ts = create_tysymbol id args NoDef in
let collect_vis fn acc =
Mpv.fold (fun f _ a -> if f.pv_ghost then a else fn a f.pv_ity) flds acc in
let collect_imm fn acc =
@@ -536,7 +541,7 @@ let create_itysymbol_rich id args pm flds =
Mpv.iter (fun {pv_vs = v; pv_ity = i} _ -> if not i.ity_pure
then Loc.error ?loc:v.vs_name.id_loc (ImpureField i)) flds;
create_its ~ts ~pm ~mfld ~regs:[] ~aimm:tl ~aexp:tl ~avis:tl
- ~afrz:tl ~rvis:[] ~rfrz:[] ~def:None
+ ~afrz:tl ~rvis:[] ~rfrz:[] ~def:NoDef
end else (* non-private updatable type *)
let top_regs ity = ity_r_fold (fun s r -> Sreg.add r s) ity in
let regs = Sreg.elements (collect_all top_regs Sreg.empty) in
@@ -549,7 +554,7 @@ let create_itysymbol_rich id args pm flds =
let afrz = check_args (collect_imm ity_freevars Stv.empty) in
let rfrz = check_regs (collect_imm ity_freeregs Sreg.empty) in
create_its ~ts ~pm ~mfld ~regs ~aimm ~aexp ~avis ~afrz ~rvis
- ~rfrz ~def:None
+ ~rfrz ~def:NoDef
(** pvsymbol creation *)
diff --git a/src/mlw/ity.mli b/src/mlw/ity.mli
index 2aafc1df3b7167695e0bcdfb8592d03b76179e9b..d903a607ad658957215cafa6390f9535c785e6e3 100644
--- a/src/mlw/ity.mli
+++ b/src/mlw/ity.mli
@@ -26,7 +26,7 @@ type itysymbol = private {
its_arg_frz : bool list; (** irreplaceable type parameters *)
its_reg_vis : bool list; (** non-ghost shareable components *)
its_reg_frz : bool list; (** irreplaceable shareable components *)
- its_def : ity option; (** type alias *)
+ its_def : ity type_def; (** type definition *)
}
and ity = private {
diff --git a/src/mlw/pdecl.ml b/src/mlw/pdecl.ml
index c502972627ed639a295d828dbc941450615f118d..9fec59253c18ec192d203830e097e7a53f8d5260 100644
--- a/src/mlw/pdecl.ml
+++ b/src/mlw/pdecl.ml
@@ -57,7 +57,7 @@ let check_pure_its s = not s.its_privmut &&
List.for_all (fun x -> x) s.its_arg_vis &&
List.for_all (fun x -> x) s.its_arg_frz &&
s.its_reg_vis = [] && s.its_reg_frz = [] &&
- s.its_def = None
+ s.its_def = NoDef
let create_semi_constructor id s fl pjl invl =
let ity = ity_app s (List.map ity_var s.its_ts.ts_args) s.its_regions in
@@ -272,7 +272,7 @@ let get_syms node pure =
| PDtype dl ->
let syms_itd syms d =
(* the syms of the invariants are already in [pure] *)
- let syms = Opt.fold syms_ity syms d.itd_its.its_def in
+ let syms = type_def_fold syms_ity syms d.itd_its.its_def in
let add_fd syms s = syms_ity syms s.rs_cty.cty_result in
let add_cs syms s = List.fold_left syms_pv syms s.rs_cty.cty_args in
let syms = List.fold_left add_fd syms d.itd_fields in
diff --git a/src/parser/lexer.mll b/src/parser/lexer.mll
index ee0e0873873b971cbd553feebcc5da55537ae1ba..28559f90b325430e6f5ba09ad327b2a6474cdbd6 100644
--- a/src/parser/lexer.mll
+++ b/src/parser/lexer.mll
@@ -36,6 +36,7 @@
"exists", EXISTS;
"export", EXPORT;
"false", FALSE;
+ "float", FLOAT;
"forall", FORALL;
"function", FUNCTION;
"goal", GOAL;
@@ -51,6 +52,7 @@
"not", NOT;
"predicate", PREDICATE;
"prop", PROP;
+ "range", RANGE;
"so", SO;
"then", THEN;
"theory", THEORY;
@@ -101,8 +103,13 @@ let lalpha = ['a'-'z' '_']
let ualpha = ['A'-'Z']
let alpha = lalpha | ualpha
let digit = ['0'-'9']
-let lident = lalpha (alpha | digit | '\'')*
-let uident = ualpha (alpha | digit | '\'')*
+let digit_or_us = ['0'-'9' '_']
+let alpha_no_us = ['a'-'z' 'A'-'Z']
+let suffix = (alpha_no_us | '\''* digit_or_us)* '\''*
+let lident = lalpha suffix
+let uident = ualpha suffix
+let lident_quote = lident ('\'' alpha_no_us suffix)+
+let uident_quote = uident ('\'' alpha_no_us suffix)+
let hexadigit = ['0'-'9' 'a'-'f' 'A'-'F']
let op_char_1 = ['=' '<' '>' '~']
@@ -133,8 +140,12 @@ rule token = parse
{ UNDERSCORE }
| lident as id
{ try Hashtbl.find keywords id with Not_found -> LIDENT id }
+ | lident_quote as id
+ { LIDENT_QUOTE id }
| uident as id
{ UIDENT id }
+ | uident_quote as id
+ { UIDENT_QUOTE id }
| ['0'-'9'] ['0'-'9' '_']* as s
{ INTEGER (Number.int_const_dec (Lexlib.remove_underscores s)) }
| '0' ['x' 'X'] (['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* as s)
@@ -146,14 +157,14 @@ rule token = parse
| (digit+ as i) ("" as f) ['e' 'E'] (['-' '+']? digit+ as e)
| (digit+ as i) '.' (digit* as f) (['e' 'E'] (['-' '+']? digit+ as e))?
| (digit* as i) '.' (digit+ as f) (['e' 'E'] (['-' '+']? digit+ as e))?
- { FLOAT (Number.real_const_dec i f
+ { REAL (Number.real_const_dec i f
(Opt.map Lexlib.remove_leading_plus e)) }
| '0' ['x' 'X'] (hexadigit+ as i) ("" as f) ['p' 'P'] (['-' '+']? digit+ as e)
| '0' ['x' 'X'] (hexadigit+ as i) '.' (hexadigit* as f)
(['p' 'P'] (['-' '+']? digit+ as e))?
| '0' ['x' 'X'] (hexadigit* as i) '.' (hexadigit+ as f)
(['p' 'P'] (['-' '+']? digit+ as e))?
- { FLOAT (Number.real_const_hex i f
+ { REAL (Number.real_const_hex i f
(Opt.map Lexlib.remove_leading_plus e)) }
| "(*)"
{ LEFTPAR_STAR_RIGHTPAR }
@@ -201,10 +212,14 @@ rule token = parse
{ DOTDOT }
| "|"
{ BAR }
- | "="
- { EQUAL }
+ | "<"
+ { LT }
+ | ">"
+ { GT }
| "<>"
{ LTGT }
+ | "="
+ { EQUAL }
| "["
{ LEFTSQ }
| "]"
@@ -244,10 +259,3 @@ rule token = parse
let () = Env.register_format Env.base_language "why" ["why"] read_channel
~desc:"WhyML@ logical@ language"
}
-
-(*
-Local Variables:
-compile-command: "unset LANG; make -C ../.. test"
-End:
-*)
-
diff --git a/src/parser/parser.mly b/src/parser/parser.mly
index d36695c2349fe03fd5856dc7135e6e957d3b7f24..32d932be6633ac997c618a9c7c6592c8be5d0464 100644
--- a/src/parser/parser.mly
+++ b/src/parser/parser.mly
@@ -148,10 +148,10 @@ end
(* Tokens *)
-%token LIDENT UIDENT
+%token LIDENT LIDENT_QUOTE UIDENT UIDENT_QUOTE
%token INTEGER
%token OP1 OP2 OP3 OP4 OPPREF
-%token FLOAT
+%token REAL
%token STRING
%token POSITION
%token QUOTE_UIDENT QUOTE_LIDENT OPAQUE_QUOTE_LIDENT
@@ -159,9 +159,9 @@ end
(* keywords *)
%token AS AXIOM BY CLONE COINDUCTIVE CONSTANT
-%token ELSE END EPSILON EXISTS EXPORT FALSE FORALL FUNCTION
+%token ELSE END EPSILON EXISTS EXPORT FALSE FLOAT FORALL FUNCTION
%token GOAL IF IMPORT IN INDUCTIVE LEMMA
-%token LET MATCH META NAMESPACE NOT PROP PREDICATE
+%token LET MATCH META NAMESPACE NOT PROP PREDICATE RANGE
%token SO THEN THEORY TRUE TYPE USE WITH
(* program keywords *)
@@ -177,7 +177,7 @@ end
%token AND ARROW
%token BAR
%token COLON COMMA
-%token DOT DOTDOT EQUAL LAMBDA LTGT
+%token DOT DOTDOT EQUAL LAMBDA LT GT LTGT
%token LEFTPAR LEFTPAR_STAR_RIGHTPAR LEFTSQ
%token LARROW LRARROW OR
%token RIGHTPAR RIGHTSQ
@@ -205,7 +205,7 @@ end
%right OR BARBAR
%right AND AMPAMP
%nonassoc NOT
-%left EQUAL LTGT OP1
+%left EQUAL LTGT LT GT OP1
%nonassoc LARROW
%nonassoc RIGHTSQ (* stronger than <- for e1[e2 <- e3] *)
%left OP2
@@ -241,10 +241,10 @@ theory_or_module:
| module_head module_decl* END { Increment.close_module () }
theory_head:
-| THEORY labels(uident) { Increment.open_theory $2 }
+| THEORY labels(uident_nq) { Increment.open_theory $2 }
module_head:
-| MODULE labels(uident) { Increment.open_module $2 }
+| MODULE labels(uident_nq) { Increment.open_module $2 }
theory_decl:
| decl { Increment.new_decl (floc $startpos $endpos) $1 }
@@ -260,7 +260,7 @@ module_decl:
{ Increment.close_namespace (floc $startpos($1) $endpos($1)) $1 }
namespace_head:
-| NAMESPACE boption(IMPORT) uident
+| NAMESPACE boption(IMPORT) uident_nq
{ Increment.open_namespace $3.id_str; $2 }
(* Use and clone *)
@@ -302,9 +302,9 @@ decl:
| PREDICATE predicate_decl with_logic_decl* { Dlogic ($2::$3) }
| INDUCTIVE with_list1(inductive_decl) { Dind (Decl.Ind, $2) }
| COINDUCTIVE with_list1(inductive_decl) { Dind (Decl.Coind, $2) }
-| AXIOM labels(ident) COLON term { Dprop (Decl.Paxiom, $2, $4) }
-| LEMMA labels(ident) COLON term { Dprop (Decl.Plemma, $2, $4) }
-| GOAL labels(ident) COLON term { Dprop (Decl.Pgoal, $2, $4) }
+| AXIOM labels(ident_nq) COLON term { Dprop (Decl.Paxiom, $2, $4) }
+| LEMMA labels(ident_nq) COLON term { Dprop (Decl.Plemma, $2, $4) }
+| GOAL labels(ident_nq) COLON term { Dprop (Decl.Pgoal, $2, $4) }
| META sident comma_list1(meta_arg) { Dmeta ($2, $3) }
meta_arg:
@@ -319,7 +319,7 @@ meta_arg:
(* Type declarations *)
type_decl:
-| labels(lident) ty_var* typedefn
+| labels(lident_nq) ty_var* typedefn
{ let model, vis, def, inv = $3 in
let vis = if model then Abstract else vis in
{ td_ident = $1; td_params = $2;
@@ -327,7 +327,7 @@ type_decl:
td_inv = inv; td_loc = floc $startpos $endpos } }
late_invariant:
-| labels(lident) ty_var* invariant+
+| labels(lident_nq) ty_var* invariant+
{ { td_ident = $1; td_params = $2;
td_model = false; td_vis = Public; td_def = TDabstract;
td_inv = $3; td_loc = floc $startpos $endpos } }
@@ -344,6 +344,13 @@ typedefn:
{ $1, $2, TDrecord $4, $6 }
| model abstract ty invariant*
{ $1, $2, TDalias $3, $4 }
+(* FIXME: allow negative bounds *)
+| EQUAL LT RANGE INTEGER INTEGER GT
+ { false, Public,
+ TDrange (Number.compute_int $4, Number.compute_int $5), [] }
+| EQUAL LT FLOAT INTEGER INTEGER GT
+ { false, Public,
+ TDfloat (small_integer $4, small_integer $5), [] }
model:
| EQUAL { false }
@@ -355,7 +362,7 @@ abstract:
| ABSTRACT { Abstract }
type_field:
-| field_modifiers labels(lident) cast
+| field_modifiers labels(lident_nq) cast
{ { f_ident = $2; f_mutable = fst $1; f_ghost = snd $1;
f_pty = $3; f_loc = floc $startpos $endpos } }
@@ -367,7 +374,7 @@ field_modifiers:
| MUTABLE GHOST { true, true }
type_case:
-| labels(uident) params { floc $startpos $endpos, $1, $2 }
+| labels(uident_nq) params { floc $startpos $endpos, $1, $2 }
(* Logic declarations *)
@@ -403,7 +410,7 @@ ind_defn:
| EQUAL bar_list1(ind_case) { $2 }
ind_case:
-| labels(ident) COLON term { floc $startpos $endpos, $1, $3 }
+| labels(ident_nq) COLON term { floc $startpos $endpos, $1, $3 }
(* Type expressions *)
@@ -516,11 +523,11 @@ binder_vars_head:
| _ -> Loc.error ~loc:(floc $startpos $endpos) Error }
binder_var:
-| labels(lident) { floc $startpos $endpos, Some $1 }
-| anon_binder { $1 }
+| labels(lident_nq) { floc $startpos $endpos, Some $1 }
+| anon_binder { $1 }
anon_binder:
-| UNDERSCORE { floc $startpos $endpos, None }
+| UNDERSCORE { floc $startpos $endpos, None }
(* Logical terms *)
@@ -635,7 +642,7 @@ quant:
numeral:
| INTEGER { Number.ConstInt $1 }
-| FLOAT { Number.ConstReal $1 }
+| REAL { Number.ConstReal $1 }
(* Program declarations *)
@@ -644,8 +651,8 @@ pdecl:
| LET top_ghost labels(lident_rich) fun_defn { Dfun ($3, $2, $4) }
| LET top_ghost labels(lident_rich) EQUAL fun_expr { Dfun ($3, $2, $5) }
| LET REC with_list1(rec_defn) { Drec $3 }
-| EXCEPTION labels(uident) { Dexn ($2, PTtuple []) }
-| EXCEPTION labels(uident) ty { Dexn ($2, $3) }
+| EXCEPTION labels(uident_nq) { Dexn ($2, PTtuple []) }
+| EXCEPTION labels(uident_nq) ty { Dexn ($2, $3) }
top_ghost:
| (* epsilon *) { Gnone }
@@ -736,7 +743,7 @@ expr_:
Ematch (e, [$3, $7]) }
| LET top_ghost labels(lident_op_id) EQUAL seq_expr IN seq_expr
{ Elet ($3, $2, $5, $7) }
-| LET top_ghost labels(lident) fun_defn IN seq_expr
+| LET top_ghost labels(lident_nq) fun_defn IN seq_expr
{ Efun ($3, $2, $4, $6) }
| LET top_ghost labels(lident_op_id) fun_defn IN seq_expr
{ Efun ($3, $2, $4, $6) }
@@ -910,12 +917,12 @@ pat_conj_:
pat_uni_:
| pat_arg_ { $1 }
| uqualid pat_arg+ { Papp ($1,$2) }
-| mk_pat(pat_uni_) AS labels(lident) { Pas ($1,$3) }
+| mk_pat(pat_uni_) AS labels(lident_nq) { Pas ($1,$3) }
| mk_pat(pat_uni_) cast { Pcast($1,$2) }
pat_arg_:
| UNDERSCORE { Pwild }
-| labels(lident) { Pvar $1 }
+| labels(lident_nq) { Pvar $1 }
| uqualid { Papp ($1,[]) }
| LEFTPAR RIGHTPAR { Ptuple [] }
| LEFTPAR pattern_ RIGHTPAR { $2 }
@@ -927,15 +934,34 @@ ident:
| uident { $1 }
| lident { $1 }
+ident_nq:
+| uident_nq { $1 }
+| lident_nq { $1 }
+
uident:
| UIDENT { mk_id $1 $startpos $endpos }
+| UIDENT_QUOTE { mk_id $1 $startpos $endpos }
+
+uident_nq:
+| UIDENT { mk_id $1 $startpos $endpos }
+| UIDENT_QUOTE { let loc = floc $startpos($1) $endpos($1) in
+ Loc.errorm ~loc "Symbol %s cannot be user-defined" $1 }
lident:
| LIDENT { mk_id $1 $startpos $endpos }
| lident_keyword { mk_id $1 $startpos $endpos }
+| LIDENT_QUOTE { mk_id $1 $startpos $endpos }
+
+lident_nq:
+| LIDENT { mk_id $1 $startpos $endpos }
+| lident_keyword { mk_id $1 $startpos $endpos }
+| LIDENT_QUOTE { let loc = floc $startpos($1) $endpos($1) in
+ Loc.errorm ~loc "Symbol %s cannot be user-defined" $1 }
lident_keyword:
| MODEL { "model" }
+| RANGE { "range" }
+| FLOAT { "float" }
quote_uident:
| QUOTE_UIDENT { mk_id ("'" ^ $1) $startpos $endpos }
@@ -948,12 +974,8 @@ opaque_quote_lident:
(* Idents + symbolic operation names *)
-ident_rich:
-| uident { $1 }
-| lident_rich { $1 }
-
lident_rich:
-| lident { $1 }
+| lident_nq { $1 }
| lident_op_id { $1 }
lident_op_id:
@@ -977,6 +999,8 @@ op_symbol:
| OP2 { $1 }
| OP3 { $1 }
| OP4 { $1 }
+| LT { "<" }
+| GT { ">" }
%inline oppref:
| o = OPPREF { mk_id (prefix o) $startpos $endpos }
@@ -991,16 +1015,24 @@ prefix_op:
| o = OP4 { mk_id (infix o) $startpos $endpos }
| EQUAL { mk_id (infix "=") $startpos $endpos }
| LTGT { mk_id (infix "<>") $startpos $endpos }
+| LT { mk_id (infix "<") $startpos $endpos }
+| GT { mk_id (infix ">") $startpos $endpos }
(* Qualified idents *)
qualid:
-| ident_rich { Qident $1 }
-| uqualid DOT ident_rich { Qdot ($1, $3) }
+| uident { Qident $1 }
+| lident { Qident $1 }
+| lident_op_id { Qident $1 }
+| uqualid DOT uident { Qdot ($1, $3) }
+| uqualid DOT lident { Qdot ($1, $3) }
+| uqualid DOT lident_op_id { Qdot ($1, $3) }
lqualid_rich:
-| lident_rich { Qident $1 }
-| uqualid DOT lident_rich { Qdot ($1, $3) }
+| lident { Qident $1 }
+| lident_op_id { Qident $1 }
+| uqualid DOT lident { Qdot ($1, $3) }
+| uqualid DOT lident_op_id { Qdot ($1, $3) }
lqualid:
| lident { Qident $1 }
diff --git a/src/parser/ptree.ml b/src/parser/ptree.ml
index 2839dc7fd819ade012252ecfbf12d2b332f1a0d1..da588ae5ad80ed95a2cb871c5a7f04a05eec5e58 100644
--- a/src/parser/ptree.ml
+++ b/src/parser/ptree.ml
@@ -126,6 +126,8 @@ type type_def =
| TDalias of pty
| TDalgebraic of (loc * ident * param list) list
| TDrecord of field list
+ | TDrange of BigInt.t * BigInt.t
+ | TDfloat of int * int
type visibility = Public | Private | Abstract
diff --git a/src/parser/typing.ml b/src/parser/typing.ml
index 60fdee6d3470a32436190c6e90112ed210bac12c..dea4f1b523f75e1ef3ef612e8328c47f56b20996 100644
--- a/src/parser/typing.ml
+++ b/src/parser/typing.ml
@@ -290,8 +290,10 @@ let rec dterm uc gvars denv {term_desc = desc; term_loc = loc} =
let e1, ch = if chainable_op uc op2
then get_chain e12 ch else e12, ch in
make_chain (dterm uc gvars denv e1) ch
- | Ptree.Tconst c ->
- DTconst c
+ | Ptree.Tconst (Number.ConstInt _ as c) ->
+ DTconst (c, ty_int)
+ | Ptree.Tconst (Number.ConstReal _ as c) ->
+ DTconst (c, ty_real)
| Ptree.Tlet (x, e1, e2) ->
let id = create_user_id x in
let e1 = dterm uc gvars denv e1 in
@@ -366,7 +368,12 @@ let rec dterm uc gvars denv {term_desc = desc; term_loc = loc} =
| Ptree.Tnamed (Lstr lab, e1) ->
DTlabel (dterm uc gvars denv e1, Slab.singleton lab)
| Ptree.Tcast (e1, ty) ->
- DTcast (dterm uc gvars denv e1, ty_of_pty uc ty))
+ (* FIXME: accepts and silently ignores double casts: ((0:ty1):ty2) *)
+ let e1 = dterm uc gvars denv e1 in
+ let ty = ty_of_pty uc ty in
+ match e1.dt_node with
+ | DTconst (c,_) -> DTconst (c, ty)
+ | _ -> DTcast (e1, ty))
(** Export for program parsing *)
@@ -397,10 +404,9 @@ let add_types dl th =
let tysymbols = Hstr.create 17 in
let rec visit x =
let d = Mstr.find x def in
- try
- match Hstr.find tysymbols x with
- | None -> Loc.errorm ~loc:d.td_loc "Cyclic type definition"
- | Some ts -> ts
+ try match Hstr.find tysymbols x with
+ | None -> Loc.errorm ~loc:d.td_loc "Cyclic type definition"
+ | Some ts -> ts
with Not_found ->
Hstr.add tysymbols x None;
let vars = Hstr.create 17 in
@@ -436,9 +442,17 @@ let add_types dl th =
| PTparen ty ->
apply ty
in
- create_tysymbol id vl (Some (apply ty))
+ create_tysymbol id vl (Alias (apply ty))
+ | TDrange (lo,hi) ->
+ let ir = { Number.ir_lower = lo;
+ Number.ir_upper = hi } in
+ Loc.try2 ~loc:d.td_loc create_tysymbol id vl (Range ir)
+ | TDfloat (eb,sb) ->
+ let fp = { Number.fp_exponent_digits = eb;
+ Number.fp_significand_digits = sb } in
+ Loc.try2 ~loc:d.td_loc create_tysymbol id vl (Float fp)
| TDabstract | TDalgebraic _ ->
- create_tysymbol id vl None
+ create_tysymbol id vl NoDef
| TDrecord _ ->
assert false
in
@@ -448,7 +462,8 @@ let add_types dl th =
let th' =
let add_ts (abstr,alias) d =
let ts = visit d.td_ident.id_str in
- if ts.ts_def = None then ts::abstr, alias else abstr, ts::alias in
+ if is_alias_type_def ts.ts_def then
+ abstr, ts::alias else ts::abstr, alias in
let abstr,alias = List.fold_left add_ts ([],[]) dl in
try
let th = List.fold_left add_ty_decl th abstr in
@@ -466,8 +481,10 @@ let add_types dl th =
ts
in
match d.td_def with
- | TDabstract -> ts::abstr, algeb, alias
- | TDalias _ -> abstr, algeb, ts::alias
+ | TDabstract | TDrange _ | TDfloat _ ->
+ ts::abstr, algeb, alias
+ | TDalias _ ->
+ abstr, algeb, ts::alias
| TDalgebraic cl ->
let ht = Hstr.create 17 in
let constr = List.length cl in
@@ -499,6 +516,30 @@ let add_types dl th =
assert false
in
let abstr,algeb,alias = List.fold_right decl dl ([],[],[]) in
+ let add_ty_decl uc ts =
+ let uc = add_ty_decl uc ts in
+ match ts.ts_def with
+ | NoDef | Alias _ -> uc
+ | Range _ ->
+ (* FIXME: "t'to_int" is probably better *)
+ let nm = ts.ts_name.id_string ^ "'int" in
+ let id = id_derive nm ts.ts_name in
+ let pj = create_fsymbol id [ty_app ts []] ty_int in
+ let uc = add_param_decl uc pj in
+ add_meta uc meta_range [MAts ts; MAls pj]
+ | Float _ ->
+ (* FIXME: "t'to_real" is probably better *)
+ let nm = ts.ts_name.id_string ^ "'real" in
+ let id = id_derive nm ts.ts_name in
+ let pj = create_fsymbol id [ty_app ts []] ty_real in
+ let uc = add_param_decl uc pj in
+ (* FIXME: "t'is_finite" is probably better *)
+ let nm = ts.ts_name.id_string ^ "'isFinite" in
+ let id = id_derive nm ts.ts_name in
+ let iF = create_psymbol id [ty_app ts []] in
+ let uc = add_param_decl uc iF in
+ add_meta uc meta_float [MAts ts; MAls pj; MAls iF]
+ in
try
let th = List.fold_left add_ty_decl th abstr in
let th = if algeb = [] then th else add_data_decl th algeb in
@@ -520,7 +561,7 @@ let prepare_typedef td =
if td.td_inv <> [] then
Loc.errorm ~loc:td.td_loc "pure types cannot have invariants";
match td.td_def with
- | TDabstract | TDalgebraic _ | TDalias _ ->
+ | TDabstract | TDrange _ | TDfloat _ | TDalgebraic _ | TDalias _ ->
td
| TDrecord fl ->
let field { f_loc = loc; f_ident = id; f_pty = ty;
@@ -676,7 +717,7 @@ let rec clone_ns kn sl path ns2 ns1 s =
| Some ts2 when ts_equal ts1 ts2 -> acc
| Some _ when not (Sid.mem ts1.ts_name sl) ->
raise (NonLocal ts1.ts_name)
- | Some _ when ts1.ts_def <> None ->
+ | Some _ when ts1.ts_def <> NoDef ->
raise (CannotInstantiate ts1.ts_name)
| Some ts2 ->
begin match (Mid.find ts1.ts_name kn).d_node with
@@ -684,7 +725,7 @@ let rec clone_ns kn sl path ns2 ns1 s =
| _ -> raise (CannotInstantiate ts1.ts_name)
end
| None when not (Sid.mem ts1.ts_name sl) -> acc
- | None when ts1.ts_def <> None -> acc
+ | None when ts1.ts_def <> NoDef -> acc
| None ->
begin match (Mid.find ts1.ts_name kn).d_node with
| Decl.Dtype _ -> Loc.errorm
@@ -759,7 +800,7 @@ let type_inst th t s =
let ts1 = find_tysymbol_ns t.th_export p in
let id = id_user (ts1.ts_name.id_string ^ "_subst") loc in
let tvl = List.map (fun id -> tv_of_string id.id_str) tvl in
- let def = Some (ty_of_pty th pty) in
+ let def = Alias (ty_of_pty th pty) in
let ts2 = Loc.try3 ~loc create_tysymbol id tvl def in
if Mts.mem ts1 s.inst_ts
then Loc.error ~loc (ClashSymbol ts1.ts_name.id_string);
diff --git a/src/printer/alt_ergo.ml b/src/printer/alt_ergo.ml
index bbf88c527b034c2bceb599d44c5c7e98e7339a7d..2cf07fe02de927ec79f469fdd349cd5aed27d47b 100644
--- a/src/printer/alt_ergo.ml
+++ b/src/printer/alt_ergo.ml
@@ -307,7 +307,7 @@ let print_enum_decl info fmt ts csl =
(print_list alt2 print_cs) csl
let print_ty_decl info fmt ts =
- if ts.ts_def <> None then () else
+ if is_alias_type_def ts.ts_def then () else
if Mid.mem ts.ts_name info.info_syn then () else
(fprintf fmt "%a@\n@\n" (print_type_decl info) ts; forget_tvs info)
diff --git a/src/printer/coq.ml b/src/printer/coq.ml
index d5a473f152b41266e47ea19f283c86b7979aa0e8..9bdc927dd0a19178f1a4698cecc745cbedd23305 100644
--- a/src/printer/coq.ml
+++ b/src/printer/coq.ml
@@ -674,7 +674,7 @@ let print_previous_proof def info fmt previous =
let print_type_decl ~prev info fmt ts =
if is_ts_tuple ts then () else
match ts.ts_def with
- | None ->
+ | NoDef | Range _ | Float _ ->
if info.realization then
match prev with
| Some (Query (_,Notation,c)) ->
@@ -700,7 +700,7 @@ let print_type_decl ~prev info fmt ts =
end;
fprintf fmt "@\n"
end
- | Some ty ->
+ | Alias ty ->
fprintf fmt "(* Why3 assumption *)@\n@[Definition %a%a :=@ %a.@]@\n@\n"
print_ts ts
(print_list_pre space
diff --git a/src/printer/cvc3.ml b/src/printer/cvc3.ml
index fe1320a3545d5c78af0c5eda810a3a7034cf6395..90eaea30bf6265707886ccd31ddaeb8e9b6c6c1a 100644
--- a/src/printer/cvc3.ml
+++ b/src/printer/cvc3.ml
@@ -55,7 +55,7 @@ type info = {
(** type *)
let complex_type = Wty.memoize 3 (fun ty ->
let s = Pp.string_of_wnl Pretty.print_ty ty in
- create_tysymbol (id_fresh s) [] None)
+ create_tysymbol (id_fresh s) [] NoDef)
let rec print_type info fmt ty = match ty.ty_node with
| Tyvar _ -> unsupported "cvc3: you must encode the polymorphism"
@@ -202,7 +202,7 @@ and print_triggers info fmt = function
(print_triggers info) l
let print_type_decl info fmt ts =
- if ts.ts_args = [] && ts.ts_def = None then
+ if ts.ts_args = [] && not (is_alias_type_def ts.ts_def) then
if not (Mid.mem ts.ts_name info.info_syn) then
fprintf fmt "%a : TYPE;@\n@\n" print_ident ts.ts_name
diff --git a/src/printer/isabelle.ml b/src/printer/isabelle.ml
index d98441c6921e94f42717a9542cd6cda85074608e..1c441da12ee2999c38dce118117760b1c158579f 100644
--- a/src/printer/isabelle.ml
+++ b/src/printer/isabelle.ml
@@ -389,9 +389,10 @@ let print_ind_decls info s fmt tl =
let print_type_decl info fmt ts =
if not (Mid.mem ts.ts_name info.info_syn || is_ts_tuple ts) then
+ let def = match ts.ts_def with Alias ty -> Some ty | _ -> None in
(elem "typedecl" (print_ts info)
(pair print_tparams (print_option (print_ty info)))
- fmt (ts, (ts.ts_args, ts.ts_def));
+ fmt (ts, (ts.ts_args, def));
forget_tvs ())
let print_param_decl info fmt ls =
diff --git a/src/printer/pvs.ml b/src/printer/pvs.ml
index b8571dc68d668a274c697766c39ca1686cb3cd39..de6a3a298f69c9f13e109a1b71e9497cc2b51095 100644
--- a/src/printer/pvs.ml
+++ b/src/printer/pvs.ml
@@ -625,12 +625,12 @@ let print_type_decl ~prev info fmt ts = ignore (prev);
if not (is_ts_tuple ts) then begin
print_name fmt ts.ts_name;
match ts.ts_def with
- | None ->
+ | NoDef | Range _ | Float _ ->
fprintf fmt "@[%a%a: TYPE+"
print_ts ts print_params_list ts.ts_args;
realization fmt info prev;
fprintf fmt "@]@\n@\n"
- | Some ty ->
+ | Alias ty ->
fprintf fmt "@[%a%a: TYPE+ =@ %a@]@\n@\n"
print_ts ts print_params_list ts.ts_args
(print_ty info) ty
diff --git a/src/printer/smtv1.ml b/src/printer/smtv1.ml
index 9790fb8fd2cef76f3ffabcca4d1f1c0f6eb3d6d7..427e322ee5f8ab6c83f389b1255704cd08681526 100644
--- a/src/printer/smtv1.ml
+++ b/src/printer/smtv1.ml
@@ -48,7 +48,7 @@ type info = {
let complex_type = Wty.memoize 3 (fun ty ->
let s = Pp.string_of_wnl Pretty.print_ty ty in
- create_tysymbol (id_fresh s) [] None)
+ create_tysymbol (id_fresh s) [] NoDef)
let rec print_type info fmt ty = match ty.ty_node with
| Tyvar _ -> unsupported "smtv1: you must encode the polymorphism"
@@ -172,7 +172,7 @@ let _print_logic_binder info fmt v =
*)
let print_type_decl info fmt ts =
- if ts.ts_args = [] && ts.ts_def = None then
+ if ts.ts_args = [] && not (is_alias_type_def ts.ts_def) then
if not (Mid.mem ts.ts_name info.info_syn) then
fprintf fmt ":extrasorts (%a)@\n@\n" print_ident ts.ts_name
diff --git a/src/printer/smtv2.ml b/src/printer/smtv2.ml
index 33f3932faf921bf53d7c17a9102803c377125f99..e9a7dc4c402f9e9fdf54cf2b130477dc3da848a8 100644
--- a/src/printer/smtv2.ml
+++ b/src/printer/smtv2.ml
@@ -81,6 +81,7 @@ let ident_printer () =
type info = {
info_syn : syntax_map;
info_converters : converter_map;
+ info_rliteral : syntax_map;
mutable info_model : S.t;
mutable info_in_goal : bool;
info_vc_term : vc_term_info;
@@ -138,6 +139,21 @@ let collect_model_ls info ls =
add_model_element
(t_label ?loc:ls.ls_name.id_loc ls.ls_name.id_label t) info.info_model
+let number_format = {
+ Number.long_int_support = true;
+ Number.extra_leading_zeros_support = false;
+ Number.dec_int_support = Number.Number_default;
+ Number.hex_int_support = Number.Number_unsupported;
+ Number.oct_int_support = Number.Number_unsupported;
+ Number.bin_int_support = Number.Number_unsupported;
+ Number.def_int_support = Number.Number_unsupported;
+ Number.dec_real_support = Number.Number_unsupported;
+ Number.hex_real_support = Number.Number_unsupported;
+ Number.frac_real_support = Number.Number_custom
+ (Number.PrintFracReal ("%s.0", "(* %s.0 %s.0)", "(/ %s.0 %s.0)"));
+ Number.def_real_support = Number.Number_unsupported;
+}
+
(** expr *)
let rec print_term info fmt t =
debug_print_term "Printing term: " t;
@@ -149,21 +165,24 @@ let rec print_term info fmt t =
let () = match t.t_node with
| Tconst c ->
- let number_format = {
- Number.long_int_support = true;
- Number.extra_leading_zeros_support = false;
- Number.dec_int_support = Number.Number_default;
- Number.hex_int_support = Number.Number_unsupported;
- Number.oct_int_support = Number.Number_unsupported;
- Number.bin_int_support = Number.Number_unsupported;
- Number.def_int_support = Number.Number_unsupported;
- Number.dec_real_support = Number.Number_unsupported;
- Number.hex_real_support = Number.Number_unsupported;
- Number.frac_real_support = Number.Number_custom
- (Number.PrintFracReal ("%s.0", "(* %s.0 %s.0)", "(/ %s.0 %s.0)"));
- Number.def_real_support = Number.Number_unsupported;
- } in
- Number.print number_format fmt c
+ let ts = match t.t_ty with
+ | Some { ty_node = Tyapp (ts, []) } -> ts
+ | _ -> assert false (* impossible *) in
+ (* look for syntax literal ts in driver *)
+ begin match query_syntax info.info_rliteral ts.ts_name, c with
+ | Some st, Number.ConstInt c ->
+ syntax_range_literal st fmt c
+ | Some st, Number.ConstReal c ->
+ let fp = match ts.ts_def with
+ | Float fp -> fp
+ | _ -> assert false in
+ syntax_float_literal st fp fmt c
+ | None, _ -> Number.print number_format fmt c
+ (* TODO/FIXME: we must assert here that the type is either
+ ty_int or ty_real, otherwise it makes no sense to print
+ the literal. Do we ensure that preserved literal types
+ are exactly those that have a dedicated syntax? *)
+ end
| Tvar v -> print_var info fmt v
| Tapp (ls, tl) ->
(* let's check if a converter applies *)
@@ -376,7 +395,7 @@ and print_triggers info fmt = function
(print_triggers info) l
let print_type_decl info fmt ts =
- if ts.ts_def <> None then () else
+ if is_alias_type_def ts.ts_def then () else
if Mid.mem ts.ts_name info.info_syn then () else
fprintf fmt "(declare-sort %a %i)@\n@\n"
(print_ident info) ts.ts_name (List.length ts.ts_args)
@@ -478,20 +497,21 @@ let print_data_decl info fmt (ts,cl) =
(print_ident info) ts.ts_name
(print_list space (print_constructor_decl info)) cl
-let print_decl vc_loc cntexample args info fmt d = match d.d_node with
+let print_decl vc_loc cntexample args info fmt d =
+ match d.d_node with
| Dtype ts ->
print_type_decl info fmt ts
| Ddata [(ts,_)] when query_syntax info.info_syn ts.ts_name <> None -> ()
| Ddata dl ->
- fprintf fmt "@[(declare-datatypes ()@ (%a))@]@\n"
- (print_list space (print_data_decl info)) dl
+ fprintf fmt "@[(declare-datatypes ()@ (%a))@]@\n"
+ (print_list space (print_data_decl info)) dl
| Dparam ls ->
collect_model_ls info ls;
print_param_decl info fmt ls
| Dlogic dl ->
print_list nothing (print_logic_decl info) fmt dl
| Dind _ -> unsupportedDecl d
- "smtv2 : inductive definition are not supported"
+ "smtv2: inductive definitions are not supported"
| Dprop (k,pr,f) ->
if Mid.mem pr.pr_name info.info_syn then () else
print_prop_decl vc_loc cntexample args info fmt k pr f
@@ -507,6 +527,7 @@ let print_task args ?old:_ fmt task =
let info = {
info_syn = Discriminate.get_syntax_map task;
info_converters = Printer.get_converter_map task;
+ info_rliteral = Printer.get_rliteral_map task;
info_model = S.empty;
info_in_goal = false;
info_vc_term = vc_info;
diff --git a/src/printer/why3printer.ml b/src/printer/why3printer.ml
index 2d783e41ca26846f2bb120676297ce6513b42e95..bb82ae7f3926e96db5e711d51062b39bb5ac8229 100644
--- a/src/printer/why3printer.ml
+++ b/src/printer/why3printer.ml
@@ -137,7 +137,6 @@ let print_pat = print_pat_node 0
let print_vsty fmt v =
fprintf fmt "%a:@,%a" print_vs v print_ty v.vs_ty
-let print_const = Pretty.print_const
let print_quant = Pretty.print_quant
let print_binop = Pretty.print_binop
@@ -174,7 +173,7 @@ and print_tnode pri fmt t = match t.t_node with
| Tvar v ->
print_vs fmt v
| Tconst c ->
- print_const fmt c
+ Number.print_constant fmt c
| Tapp (fs, tl) when unambig_fs fs ->
print_app pri fs fmt tl
| Tapp (fs, tl) ->
@@ -247,14 +246,22 @@ let print_constr fmt (cs,pjl) =
(List.fold_right2 add_pj pjl cs.ls_args [])
let print_type_decl fmt ts = match ts.ts_def with
- | None ->
+ | NoDef ->
fprintf fmt "@[type %a%a%a@]@\n@\n"
print_ts ts print_ident_labels ts.ts_name
(print_list nothing print_tv_arg) ts.ts_args
- | Some ty ->
+ | Alias ty ->
fprintf fmt "@[type %a%a%a =@ %a@]@\n@\n"
print_ts ts print_ident_labels ts.ts_name
(print_list nothing print_tv_arg) ts.ts_args print_ty ty
+ | Range _ir -> (* TODO *)
+ fprintf fmt "@[type %a%a%a =@ @]@\n@\n"
+ print_ts ts print_ident_labels ts.ts_name
+ (print_list nothing print_tv_arg) ts.ts_args
+ | Float _fp -> (* TODO *)
+ fprintf fmt "@[type %a%a%a =@ @]@\n@\n"
+ print_ts ts print_ident_labels ts.ts_name
+ (print_list nothing print_tv_arg) ts.ts_args
let print_type_decl fmt ts =
if not (query_remove ts.ts_name) then
diff --git a/src/printer/yices.ml b/src/printer/yices.ml
index 2781113aad69eafe4d9ad6849a0e213946d29564..43cc26b3fb81de39d39a52ebaaa7a7905e876df4 100644
--- a/src/printer/yices.ml
+++ b/src/printer/yices.ml
@@ -60,7 +60,7 @@ type info = {
(** type *)
let complex_type = Wty.memoize 3 (fun ty ->
let s = Pp.string_of_wnl Pretty.print_ty ty in
- create_tysymbol (id_fresh s) [] None)
+ create_tysymbol (id_fresh s) [] NoDef)
let rec print_type info fmt ty = match ty.ty_node with
| Tyvar _ -> unsupported "cvc3: you must encode the polymorphism"
@@ -210,7 +210,7 @@ let print_logic_binder info fmt v =
*)
let print_type_decl info fmt ts =
- if ts.ts_args = [] && ts.ts_def = None then
+ if ts.ts_args = [] && not (is_alias_type_def ts.ts_def) then
if not (Mid.mem ts.ts_name info.info_syn) then
fprintf fmt "(define-type %a)@\n@\n" print_ident ts.ts_name
diff --git a/src/session/session.ml b/src/session/session.ml
index 2022a5da95ebf21fae6ce3900a887c6c4b003f61..93cd701cd676a2cb0c2abb4e487405fd4da9635b 100644
--- a/src/session/session.ml
+++ b/src/session/session.ml
@@ -1361,7 +1361,7 @@ and load_metas ctxt mg a =
let tvs = Util.foldi (fun l _ ->
(create_tvsymbol (Ident.id_fresh "a"))::l)
[] 0 arity in
- let ts = Ty.create_tysymbol (Ident.id_fresh name) tvs None in
+ let ts = Ty.create_tysymbol (Ident.id_fresh name) tvs NoDef in
Hint.add hts intid ts;
let idpos_ts = Mts.add ts pos idpos.idpos_ts in
{ idpos with idpos_ts = idpos_ts }
diff --git a/src/session/termcode.ml b/src/session/termcode.ml
index 1d29a139ca3f52e6bd713919aff9583ab86abb81..ea6ea809a114bf4c19f3743d40b4201c84effb7f 100644
--- a/src/session/termcode.ml
+++ b/src/session/termcode.ml
@@ -282,7 +282,7 @@ let ident_shape ~push id acc =
id_string_shape ~push id.Ident.id_string acc
let const_shape ~push acc c =
- Format.fprintf Format.str_formatter "%a" Pretty.print_const c;
+ Format.fprintf Format.str_formatter "%a" Number.print_constant c;
push (Format.flush_str_formatter ()) acc
let rec pat_shape ~(push:string->'a->'a) c m (acc:'a) p : 'a =
@@ -457,10 +457,15 @@ module Checksum = struct
| CV1 -> ident_v1 b id
| CV2 -> ident_v2 b id
+ let _integer_constant b c =
+ Number.print_integer_constant Format.str_formatter c;
+ let s = Format.flush_str_formatter () in
+ string b s
+
let const b c =
- Format.fprintf Format.str_formatter "%a" Pretty.print_const c;
- let s = Format.flush_str_formatter () in
- string b s
+ Number.print_constant Format.str_formatter c;
+ let s = Format.flush_str_formatter () in
+ string b s
let tvsymbol b tv = ident b tv.Ty.tv_name
@@ -520,7 +525,11 @@ module Checksum = struct
let tysymbol b ts =
ident b ts.Ty.ts_name;
list tvsymbol b ts.Ty.ts_args;
- option ty b ts.Ty.ts_def
+ match ts.Ty.ts_def with
+ | Ty.NoDef -> char b 'n'
+ | Ty.Alias x -> char b 's'; ty b x
+ | Ty.Range _ -> char b 'r' (* FIXME *)
+ | Ty.Float _ -> char b 'f' (* FIXME *)
let lsymbol b ls =
ident b ls.ls_name;
@@ -529,7 +538,7 @@ module Checksum = struct
list tvsymbol b (Ty.Stv.elements ls.ls_opaque);
int b ls.ls_constr
- (* start: T D R L I P (C M) *)
+ (* start: T G F D R L I P (C M) *)
let decl b d = match d.Decl.d_node with
| Decl.Dtype ts ->
char b 'T'; tysymbol b ts
diff --git a/src/transform/eliminate_literal.ml b/src/transform/eliminate_literal.ml
new file mode 100644
index 0000000000000000000000000000000000000000..590636deff5c945faefa97857143d659af17dd4c
--- /dev/null
+++ b/src/transform/eliminate_literal.ml
@@ -0,0 +1,160 @@
+(********************************************************************)
+(* *)
+(* The Why3 Verification Platform / The Why3 Development Team *)
+(* Copyright 2010-2016 -- INRIA - CNRS - Paris-Sud University *)
+(* *)
+(* This software is distributed under the terms of the GNU Lesser *)
+(* General Public License version 2.1, with the special exception *)
+(* on linking described in file LICENSE. *)
+(* *)
+(********************************************************************)
+
+open Ident
+open Ty
+open Term
+open Decl
+open Theory
+
+let meta_keep_lit = register_meta "literal:keep" [MTtysymbol]
+ ~desc:"Preserve@ literals@ of@ a@ given@ type."
+
+let add_literal (known_lit, decl as acc) t c ls_proj fin =
+ try acc, Mterm.find t known_lit with Not_found ->
+ (* TODO: pretty-print the constant to have a readable name *)
+ let litname =
+ match fin with None -> "rliteral" | _ -> "fliteral" in
+ let ls = create_lsymbol (id_fresh litname) [] t.t_ty in
+ let ls_decl = create_param_decl ls in
+ let pr = create_prsymbol (id_fresh (litname^"_axiom")) in
+ let ls_t = t_app ls [] t.t_ty in
+ let f = t_app ls_proj [ls_t] ls_proj.ls_value in
+ let f = t_equ f (t_const c (Opt.get f.t_ty)) in
+ let f = match fin with
+ | None -> f
+ | Some isF -> t_and (t_app isF [ls_t] None) f in
+ let ax_decl = create_prop_decl Paxiom pr f in
+ let decl = ax_decl::ls_decl::decl in
+ (Mterm.add t ls_t known_lit, decl), ls_t
+
+(* TODO: remove int and real literals if not supported.
+ NOTE: in this case, [add_literal] above is incorrect. *)
+let rec abstract_terms kn range_metas float_metas type_kept acc t =
+ match t.t_node, t.t_ty with
+ | Tconst (Number.ConstInt _ as c), Some {ty_node = Tyapp (ts,[])}
+ when not (ts_equal ts ts_int || Sts.mem ts type_kept) ->
+ let to_int = Mts.find ts range_metas in
+ add_literal acc t c to_int None
+ | Tconst (Number.ConstReal _ as c), Some {ty_node = Tyapp (ts,[])}
+ when not (ts_equal ts ts_real || Sts.mem ts type_kept) ->
+ let to_real,isF = Mts.find ts float_metas in
+ add_literal acc t c to_real (Some isF)
+ | _ ->
+ t_map_fold (abstract_terms kn range_metas float_metas type_kept) acc t
+
+let elim le_int le_real abs_real type_kept kn
+ range_metas float_metas d (known_lit,task) =
+ match d.d_node with
+ | Dtype ts when Mts.exists (fun ts' _ -> ts_equal ts ts') range_metas
+ && not (Sts.mem ts type_kept) ->
+ let to_int = Mts.find ts range_metas in
+ let ir = match ts.ts_def with Range ir -> ir | _ -> assert false in
+ let lo = Number.int_const_dec (BigInt.to_string ir.Number.ir_lower) in
+ let hi = Number.int_const_dec (BigInt.to_string ir.Number.ir_upper) in
+ let ty_decl = create_ty_decl ts in
+ let ls_decl = create_param_decl to_int in
+ let pr = create_prsymbol (id_fresh (ts.ts_name.id_string ^ "'axiom")) in
+ let v = create_vsymbol (id_fresh "i") (ty_app ts []) in
+ let v_term = t_app to_int [t_var v] (Some ty_int) in
+ let a_term = t_const (Number.ConstInt lo) ty_int in
+ let b_term = t_const (Number.ConstInt hi) ty_int in
+ let f = t_and (t_app le_int [a_term; v_term] None)
+ (t_app le_int [v_term; b_term] None)
+ in
+ let f = t_forall_close [v] [] f in
+ let ax_decl = create_prop_decl Paxiom pr f in
+ (known_lit, List.fold_left Task.add_decl task [ty_decl; ls_decl; ax_decl])
+ | Dtype ts when Mts.exists (fun ts' _ -> ts_equal ts ts') float_metas
+ && not (Sts.mem ts type_kept) ->
+ let to_real,is_finite = Mts.find ts float_metas in
+ let fp = match ts.ts_def with Float fp -> fp | _ -> assert false in
+ let eb = BigInt.of_int fp.Number.fp_exponent_digits in
+ let sb = BigInt.of_int fp.Number.fp_significand_digits in
+ (* declare abstract type [t] *)
+ let ty_decl = create_ty_decl ts in
+ (* declare projection to_real *)
+ let proj_decl = create_param_decl to_real in
+ (* declare predicate is_finite *)
+ let isFinite_decl = create_param_decl is_finite in
+ (* create defining axiom *)
+ (* [forall v:t. is_finite v -> | to_real v | <= max] *)
+ let pr = create_prsymbol (id_fresh (ts.ts_name.id_string ^ "'axiom")) in
+ let v = create_vsymbol (id_fresh "x") (ty_app ts []) in
+ let v_term = t_app to_real [t_var v] (Some ty_real) in
+ (* compute max *)
+ let emax = BigInt.pow_int_pos_bigint 2 (BigInt.pred eb) in
+ let m = BigInt.pred (BigInt.pow_int_pos_bigint 2 sb) in
+ let e = BigInt.sub emax sb in
+ Number.print_in_base 16 None Format.str_formatter m;
+ let m_string = Format.flush_str_formatter () in
+ Number.print_in_base 10 None Format.str_formatter e;
+ let e_string = Format.flush_str_formatter () in
+ let term = t_const
+ (Number.ConstReal
+ (Number.real_const_hex m_string "" (Some e_string))) ty_real in
+ (* compose axiom *)
+ let f = t_app le_real [t_app abs_real [v_term] (Some ty_real); term] None in
+ let f = t_implies (t_app is_finite [t_var v] None) f in
+ let f = t_forall_close [v] [] f in
+ let ax_decl = create_prop_decl Paxiom pr f in
+ (known_lit, List.fold_left Task.add_decl task
+ [ty_decl; proj_decl; isFinite_decl; ax_decl])
+ | _ ->
+ let (known_lit, local_decl), d =
+ decl_map_fold
+ (abstract_terms kn range_metas float_metas type_kept)
+ (known_lit,[]) d in
+ let t = List.fold_left Task.add_decl task (List.rev local_decl) in
+ (known_lit, Task.add_decl t d)
+
+let eliminate le_int le_real abs_real type_kept
+ range_metas float_metas t (known_lit, acc) =
+ match t.Task.task_decl.td_node with
+ | Decl d ->
+ elim le_int le_real abs_real type_kept
+ t.Task.task_known range_metas float_metas d (known_lit, acc)
+ | Meta (m, [MAts ts]) when meta_equal m meta_keep_lit ->
+ let td = create_meta Libencoding.meta_kept [MAty (ty_app ts [])] in
+ let acc = Task.add_tdecl acc t.Task.task_decl in
+ known_lit, Task.add_tdecl acc td
+ | Use _ | Clone _ | Meta _ ->
+ known_lit, Task.add_tdecl acc t.Task.task_decl
+
+let eliminate_literal env =
+ (* FIXME: int.Int.le_sym should be imported in the task *)
+ let th = Env.read_theory env ["int"] "Int" in
+ let le_int = ns_find_ls th.th_export ["infix <="] in
+ let th = Env.read_theory env ["real"] "Real" in
+ let le_real = ns_find_ls th.th_export ["infix <="] in
+ let th = Env.read_theory env ["real"] "Abs" in
+ let abs_real = ns_find_ls th.th_export ["abs"] in
+ Trans.on_meta meta_range (fun range_metas ->
+ Trans.on_meta meta_float (fun float_metas ->
+ let range_metas = List.fold_left (fun acc meta_arg ->
+ match meta_arg with
+ | [MAts ts; MAls to_int] -> Mts.add ts to_int acc
+ | _ -> assert false) Mts.empty range_metas in
+ let float_metas = List.fold_left (fun acc meta_arg ->
+ match meta_arg with
+ | [MAts ts; MAls to_real; MAls is_finite] ->
+ Mts.add ts (to_real,is_finite) acc
+ | _ -> assert false) Mts.empty float_metas in
+ Trans.on_tagged_ts meta_keep_lit
+ (fun type_kept ->
+ Trans.fold_map
+ (eliminate le_int le_real abs_real type_kept
+ range_metas float_metas)
+ Mterm.empty None)))
+
+let () =
+ Trans.register_env_transform "eliminate_literal" eliminate_literal
+ ~desc:"Eliminate@ unsupported@ literals."
diff --git a/src/transform/eliminate_literal.mli b/src/transform/eliminate_literal.mli
new file mode 100644
index 0000000000000000000000000000000000000000..e162cf92c49d593ddf7d3c5f3b5d74643e2c5b03
--- /dev/null
+++ b/src/transform/eliminate_literal.mli
@@ -0,0 +1,12 @@
+(********************************************************************)
+(* *)
+(* The Why3 Verification Platform / The Why3 Development Team *)
+(* Copyright 2010-2016 -- INRIA - CNRS - Paris-Sud University *)
+(* *)
+(* This software is distributed under the terms of the GNU Lesser *)
+(* General Public License version 2.1, with the special exception *)
+(* on linking described in file LICENSE. *)
+(* *)
+(********************************************************************)
+
+val meta_keep_lit : Theory.meta
diff --git a/src/transform/encoding_guards.ml b/src/transform/encoding_guards.ml
index d63c1ac85ebbee55e8cf556e3b34cdf6caddf27f..32f952ad0fc4db63898b055a48ea52b3476370ed 100644
--- a/src/transform/encoding_guards.ml
+++ b/src/transform/encoding_guards.ml
@@ -114,9 +114,8 @@ let ls_desc info ls =
[create_prop_decl Paxiom pr (t_type_close (expl_term info true) f)]
let decl info d = match d.d_node with
- | Dtype { ts_def = Some _ } -> []
- | Dtype ts ->
- [d; lsdecl_of_ts ts]
+ | Dtype { ts_def = Alias _ } -> []
+ | Dtype ts -> [d; lsdecl_of_ts ts]
| Ddata _ -> Printer.unsupportedDecl d
"Algebraic types are not supported, run eliminate_algebraic"
| Dparam ls ->
diff --git a/src/transform/encoding_guards_full.ml b/src/transform/encoding_guards_full.ml
index 6bf16e0520e08853092cf828467f1d78b945b861..a10e3aea8abd1d5eb5b43cf246d480bc18851cdf 100644
--- a/src/transform/encoding_guards_full.ml
+++ b/src/transform/encoding_guards_full.ml
@@ -269,7 +269,7 @@ end
(** {2 main part} *)
let decl kept d = match d.d_node with
- | Dtype { ts_def = Some _ } -> []
+ | Dtype { ts_def = Alias _ } -> []
| Dtype ts -> d :: Lib.lsdecl_of_ts_select ts
| Ddata _ -> Printer.unsupportedDecl d
"Algebraic types are not supported, run eliminate_algebraic"
diff --git a/src/transform/encoding_sort.ml b/src/transform/encoding_sort.ml
index 2fe2e6c442820d005bad1975128e5bbb6c104f8a..212c8718e233303b5d966f2ee5795debe1004a0e 100644
--- a/src/transform/encoding_sort.ml
+++ b/src/transform/encoding_sort.ml
@@ -32,7 +32,7 @@ let conv_ts tenv undefined name ty =
try
Hty.find tenv.specials ty
with Not_found ->
- let ts = create_tysymbol (id_clone name) [] None in
+ let ts = create_tysymbol (id_clone name) [] NoDef in
Hty.add tenv.specials ty ts;
ts in
Hts.replace undefined ts ();
@@ -128,7 +128,7 @@ let fold tenv taskpre task =
match taskpre.task_decl.td_node with
| Decl d ->
begin match d.d_node with
- | Dtype { ts_def = Some _ }
+ | Dtype { ts_def = Alias _ }
| Dtype { ts_args = _::_ } -> task
| Dtype ts -> add_ty_decl task ts
| Ddata _ ->
@@ -151,9 +151,9 @@ let fold tenv taskpre task =
let ud = Hts.create 3 in
let map = function
| MAty ty -> MAty (conv_ty tenv ud ty)
- | MAts {ts_name = name; ts_args = []; ts_def = Some ty} ->
- MAts (conv_ts tenv ud name ty)
- | MAts {ts_args = []; ts_def = None} as x -> x
+ | MAts {ts_name = name; ts_args = []; ts_def = Alias ty} ->
+ MAts (conv_ts tenv ud name ty)
+ | MAts {ts_args = []} as x -> x
| MAts _ -> raise Exit
| MAls ls -> MAls (conv_ls tenv ud ls)
| MApr _ -> raise Exit
diff --git a/src/transform/encoding_tags.ml b/src/transform/encoding_tags.ml
index 570f38e18a5f8a6d7a5176321340492bb5f26430..763f0b72a8e4b08d5b8f9c8d7d373467980eb178 100644
--- a/src/transform/encoding_tags.ml
+++ b/src/transform/encoding_tags.ml
@@ -115,9 +115,8 @@ let ls_desc info ls =
[create_prop_decl Paxiom pr (t_type_close (expl_term info true) f)]
let decl info d = match d.d_node with
- | Dtype { ts_def = Some _ } -> []
- | Dtype ts ->
- [d; lsdecl_of_ts ts]
+ | Dtype { ts_def = Alias _ } -> []
+ | Dtype ts -> [d; lsdecl_of_ts ts]
| Ddata _ -> Printer.unsupportedDecl d
"Algebraic types are not supported, run eliminate_algebraic"
| Dparam ls ->
diff --git a/src/transform/encoding_tags_full.ml b/src/transform/encoding_tags_full.ml
index ec7d7675d06961c48f73b7e4361d47c5c225f3e8..85e7934618cb9c3986e31949340873095cdf6ea5 100644
--- a/src/transform/encoding_tags_full.ml
+++ b/src/transform/encoding_tags_full.ml
@@ -61,7 +61,7 @@ let deco_term kept tvar =
deco
let deco_decl kept d = match d.d_node with
- | Dtype { ts_def = Some _ } -> []
+ | Dtype { ts_def = Alias _ } -> []
| Dtype ts -> [d; lsdecl_of_ts ts]
| Ddata _ -> Printer.unsupportedDecl d
"Algebraic types are not supported, run eliminate_algebraic"
@@ -87,10 +87,10 @@ let deco kept = Trans.decl (deco_decl kept) deco_init
(** Monomorphisation *)
-let ts_base = create_tysymbol (id_fresh "uni") [] None
+let ts_base = create_tysymbol (id_fresh "uni") [] NoDef
let ty_base = ty_app ts_base []
-let ts_deco = create_tysymbol (id_fresh "deco") [] None
+let ts_deco = create_tysymbol (id_fresh "deco") [] NoDef
let ty_deco = ty_app ts_deco []
let ls_deco = create_fsymbol (id_fresh "sort") [ty_type;ty_base] ty_deco
diff --git a/src/transform/intro_vc_vars_counterexmp.ml b/src/transform/intro_vc_vars_counterexmp.ml
index 0077a25bad3ed0a1b5399221c6de7f07f9d249d6..508aa6d2801ba6ca1c37f2841892078fa2698f1c 100644
--- a/src/transform/intro_vc_vars_counterexmp.ml
+++ b/src/transform/intro_vc_vars_counterexmp.ml
@@ -299,7 +299,7 @@ let do_intro_vc_vars_counterexmp info vc_loc pr t =
let vc_map = Hprid.create 100 in
let vc_var = Hvs.create 100 in
let tvs = t_ty_freevars Stv.empty t in
- let mk_ts tv () = create_tysymbol (id_clone tv.tv_name) [] None in
+ let mk_ts tv () = create_tysymbol (id_clone tv.tv_name) [] NoDef in
let tvm = Mtv.mapi mk_ts tvs in
let decls = Mtv.map create_ty_decl tvm in
let subst = Mtv.map (fun ts -> ty_app ts []) tvm in
diff --git a/src/transform/introduction.ml b/src/transform/introduction.ml
index a49d5de14ac946a7fb8a258cddf724549beb48e1..906b7a4e07ec7e9a558eac2b57948866c1d76f60 100644
--- a/src/transform/introduction.ml
+++ b/src/transform/introduction.ml
@@ -59,7 +59,7 @@ let rec intros pr f =
let intros pr f =
let tvs = t_ty_freevars Stv.empty f in
- let mk_ts tv () = create_tysymbol (id_clone tv.tv_name) [] None in
+ let mk_ts tv () = create_tysymbol (id_clone tv.tv_name) [] NoDef in
let tvm = Mtv.mapi mk_ts tvs in
let decls = Mtv.map create_ty_decl tvm in
let subst = Mtv.map (fun ts -> ty_app ts []) tvm in
diff --git a/src/transform/libencoding.ml b/src/transform/libencoding.ml
index e46996405adfb7f2586acfdacf5ae4460fc2592e..a305079257d1588b77400b2cce66774d88e5a2ff 100644
--- a/src/transform/libencoding.ml
+++ b/src/transform/libencoding.ml
@@ -28,7 +28,7 @@ let meta_base = register_meta_excl "encoding : base" [MTty]
polymorphism@ encoding@ (`int'@ or@ `real'@ only)."
(* sort symbol of the default base type *)
-let ts_base = create_tysymbol (id_fresh "uni") [] None
+let ts_base = create_tysymbol (id_fresh "uni") [] NoDef
(* default base type *)
let ty_base = ty_app ts_base []
@@ -37,7 +37,7 @@ let ty_base = ty_app ts_base []
let d_ts_base = create_ty_decl ts_base
(* sort symbol of (polymorphic) types *)
-let ts_type = create_tysymbol (id_fresh "ty") [] None
+let ts_type = create_tysymbol (id_fresh "ty") [] NoDef
(* sort of (polymorphic) types *)
let ty_type = ty_app ts_type []
@@ -162,7 +162,7 @@ let d_monomorph ty_base kept lsmap d =
let consts = ref Sls.empty in
let t_mono = t_monomorph ty_base kept lsmap consts in
let dl = match d.d_node with
- | Dtype { ts_def = Some _ } -> []
+ | Dtype { ts_def = Alias _ } -> []
| Dtype ts when not (Sty.exists (ty_s_any (ts_equal ts)) kept) -> []
| Dtype ts ->
[create_ty_decl ts]
@@ -242,7 +242,7 @@ let monomorphise_task =
(* replace type variables in a goal with fresh type constants *)
let ts_of_tv = Htv.memo 63 (fun tv ->
- create_tysymbol (id_clone tv.tv_name) [] None)
+ create_tysymbol (id_clone tv.tv_name) [] NoDef)
let monomorphise_goal = Trans.goal (fun pr f ->
let stv = t_ty_freevars Stv.empty f in
diff --git a/src/transform/reduction_engine.ml b/src/transform/reduction_engine.ml
index abe49f326d013f91510e3a94fad11aa8146a0582..5b1d42ee368081302e90569a8de101354cca7bc3 100644
--- a/src/transform/reduction_engine.ml
+++ b/src/transform/reduction_engine.ml
@@ -23,7 +23,8 @@ let v_label_copy orig v =
| Term t -> Term (t_label_copy orig t)
let const_of_positive n =
- t_const (Number.ConstInt (Number.int_const_dec (BigInt.to_string n)))
+ t_const (Number.ConstInt (Number.int_const_dec (BigInt.to_string n)))
+ Ty.ty_int
let ls_minus = ref ps_equ (* temporary *)
@@ -47,7 +48,7 @@ let big_int_of_const c =
let big_int_of_value v =
match v with
| Int n -> n
- | Term {t_node = Tconst c } -> big_int_of_const c
+ | Term { t_node = Tconst c } -> big_int_of_const c
| Term { t_node = Tapp (ls,[{ t_node = Tconst c }]) }
when ls_compare ls !ls_minus = 0 -> BigInt.minus (big_int_of_const c)
| _ -> raise NotNum
diff --git a/src/util/bigInt.ml b/src/util/bigInt.ml
index 6537afeba4b4f5bf04c60c2a1ccd008836d6a507..2de06c295348dd5ddde7346b3644d528ed98c18a 100644
--- a/src/util/bigInt.ml
+++ b/src/util/bigInt.ml
@@ -59,9 +59,11 @@ let min = min_big_int
let max = max_big_int
let abs = abs_big_int
+let num_digits = num_digits_big_int
+
let pow_int_pos = power_int_positive_int
+let pow_int_pos_bigint = power_int_positive_big_int
let to_string = string_of_big_int
let of_string = big_int_of_string
let to_int = int_of_big_int
-
diff --git a/src/util/bigInt.mli b/src/util/bigInt.mli
index 31047571cbfae4df89bb2260430a18538a30873b..ebfc27017f8f5d62f716c13c38d356fed94f9eb0 100644
--- a/src/util/bigInt.mli
+++ b/src/util/bigInt.mli
@@ -58,8 +58,12 @@ val min : t -> t -> t
val max : t -> t -> t
val abs : t -> t
+(** number of digits *)
+val num_digits : t -> int
+
(** power of small integers. Second arg must be non-negative *)
val pow_int_pos : int -> int -> t
+val pow_int_pos_bigint : int -> t -> t
(** conversions *)
val of_string : string -> t
diff --git a/src/util/number.ml b/src/util/number.ml
index 7b045e58b7695b9bb4b411697d81be59cf216208..da20a8306f6ac649f88134ca08ae57641fdec9ee 100644
--- a/src/util/number.ml
+++ b/src/util/number.ml
@@ -74,9 +74,6 @@ let real_const_hex i f e =
Opt.iter check_exp e;
RConstHex (i,f,e)
-(** Printing *)
-
-
let compute_any radix s =
let n = String.length s in
let rec compute acc i =
@@ -93,6 +90,8 @@ let compute_any radix s =
end in
(compute BigInt.zero 0)
+(** Printing *)
+
let compute_int c =
match c with
| IConstDec s -> compute_any 10 s
@@ -257,15 +256,216 @@ let print support fmt = function
| ConstReal (RConstDec (i, f, e)) -> print_dec_real support fmt i f e
| ConstReal (RConstHex (i, f, e)) -> print_hex_real support fmt i f e
-let () = Exn_printer.register
- begin fun fmt exn -> match exn with
- | InvalidConstantLiteral (n,s) ->
- fprintf fmt "Invalid constant literal in base %d: '%s'" n s
- | _ -> raise exn
+let char_of_int i =
+ if i < 10 then
+ Char.chr (i + Char.code '0')
+ else
+ Char.chr (i + Char.code 'A' - 10)
+
+open BigInt
+
+let print_zeros fmt n =
+ for _i = 0 to n - 1 do
+ pp_print_char fmt '0'
+ done
+
+let rec print_in_base_aux radix digits fmt i =
+ if lt i radix then begin
+ begin match digits with
+ | Some n -> print_zeros fmt (n - 1)
+ | None -> ()
+ end;
+ fprintf fmt "%c" (char_of_int (to_int i))
end
+ else
+ let d,m = computer_div_mod i radix in
+ let digits = Opt.map ((+) (-1)) digits in
+ print_in_base_aux radix digits fmt d;
+ fprintf fmt "%c" (char_of_int (to_int m))
+
+let print_in_base radix digits fmt i =
+ print_in_base_aux (of_int radix) digits fmt i
+
+(** Range checks *)
+
+type int_range = {
+ ir_lower : BigInt.t;
+ ir_upper : BigInt.t;
+}
+
+exception OutOfRange of integer_constant
-(*
-Local Variables:
-compile-command: "unset LANG; make -C ../.. byte"
-End:
-*)
+let check_range c {ir_lower = lo; ir_upper = hi} =
+ let cval = compute_int c in
+ if BigInt.lt cval lo || BigInt.gt cval hi then raise (OutOfRange c)
+
+(** Float checks *)
+
+type float_format = {
+ fp_exponent_digits : int;
+ fp_significand_digits : int; (* counting the hidden bit *)
+}
+
+exception NonRepresentableFloat of real_constant
+
+let debug_float = Debug.register_info_flag "float"
+ ~desc:"Avoid@ catching@ exceptions@ in@ order@ to@ get@ \
+ float@ literal@ checks@ messages."
+
+let float_parser c =
+ let exp_parser e = match e.[0] with
+ | '-' -> minus (compute_any 10 (String.sub e 1 (String.length e - 1)))
+ | _ -> compute_any 10 e
+ in
+
+ (* get the value s and e such that c = s * 2 ^ e *)
+ let s, e =
+ match c with
+ (* c = a.b * 10 ^ e *)
+ | RConstDec (a,b,e) ->
+ let b_length = String.length b in
+ let s = ref (compute_any 10 (a ^ b)) in
+ let e = sub (match e with
+ | None -> Debug.dprintf debug_float "c = %s.%s" a b;
+ zero
+ | Some e -> Debug.dprintf debug_float "c = %s.%se%s" a b e;
+ exp_parser e)
+ (of_int b_length)
+ in
+ (* transform c = s * 10 ^ i into c = s' * 2 ^ i' *)
+ let s =
+ if lt e zero then begin
+ let efive = pow_int_pos_bigint 5 (minus e) in
+ let dv, rem = euclidean_div_mod !s efive in
+ if not (eq rem zero) then begin
+ raise (NonRepresentableFloat c);
+ end else
+ dv
+ end else
+ mul !s (pow_int_pos_bigint 5 e)
+ in
+ Debug.dprintf debug_float " = %s * 2 ^ %s" (to_string s) (to_string e);
+ ref s, ref e
+
+ (* c = a.b * 2 ^ e *)
+ | RConstHex (a,b,e) ->
+ let b_length = String.length b in
+ ref (compute_any 16 (a ^ b)),
+ ref (sub (match e with
+ | None -> Debug.dprintf debug_float "c = %s.%s" a b;
+ zero
+ | Some e -> Debug.dprintf debug_float "c = %s.%sp%s" a b e;
+ exp_parser e)
+ (of_int (b_length * 4)))
+ in
+ s, e
+
+let compute_float c fp =
+ let eb = BigInt.of_int fp.fp_exponent_digits in
+ let sb = BigInt.of_int fp.fp_significand_digits in
+ (* 2 ^ (sb - 1) min representable normalized significand*)
+ let smin = pow_int_pos_bigint 2 (sub sb one) in
+ (* (2 ^ sb) - 1 max representable normalized significand*)
+ let smax = sub (pow_int_pos_bigint 2 sb) one in
+ (* 2 ^ (eb - 1) exponent of the infinities *)
+ let emax = pow_int_pos_bigint 2 (sub eb one) in
+ (* 1 - emax exponent of the denormalized *)
+ let eden = sub one emax in
+ (* 3 - emax - sb smallest denormalized' exponent *)
+ let emin = sub (add (of_int 2) eden) sb in
+
+ (* get [s] and [e] such that "c = s * 2 ^ e" *)
+ let s, e = float_parser c in
+
+ (* if s = 0 stop now *)
+ if eq !s zero then
+ zero, zero
+
+ else begin
+
+ (* if s is too big or e is too small, try to remove trailing zeros
+ in s and incr e *)
+ while gt !s smax || lt !e emin do
+ let new_s, rem = euclidean_div_mod !s (of_int 2) in
+ if not (eq rem zero) then begin
+ Debug.dprintf debug_float "Too many digits in significand.";
+ raise (NonRepresentableFloat c);
+ end else begin
+ s := new_s;
+ e := succ !e
+ end
+ done;
+
+ (* if s is too small and e is too big, add trailing zeros in s and
+ decr e *)
+ while lt !s smin && gt !e emin do
+ s := mul_int 2 !s;
+ e := pred !e
+ done;
+
+ Debug.dprintf debug_float " = %s * 2 ^ %s@." (to_string !s) (to_string !e);
+
+ if lt !s smin then begin
+ (* denormal case *)
+
+ Debug.dprintf debug_float "final: c = 0.[%s] * 2 ^ ([0] - bias + 1); bias=%s, i.e, 0[%a][%a]@."
+ (to_string !s) (to_string (sub emax one)) (print_in_base 2 (Some (to_int eb))) zero
+ (print_in_base 2 (Some (to_int (sub sb one)))) !s;
+
+ !s, zero
+
+ end else begin
+ (* normal case *)
+
+ (* normalize the exponent *)
+ let fe = add !e (sub sb one) in
+
+ (* now that s and e are in shape, check that e is not too big *)
+ if ge fe emax then begin
+ Debug.dprintf debug_float "Exponent too big.";
+ raise (NonRepresentableFloat c)
+ end;
+
+ (* add the exponent bia to e *)
+ let fe = add fe (sub emax one) in
+ let fs = sub !s smin in
+
+ Debug.dprintf debug_float "final: c = 1.[%s] * 2 ^ ([%s] - bias); bias=%s, i.e, 0[%a][%a]@."
+ (to_string fs) (to_string fe) (to_string (sub emax one))
+ (print_in_base 2 (Some (to_int eb))) fe
+ (print_in_base 2 (Some (to_int (sub sb one)))) fs;
+
+ assert (le zero fs && lt fs (pow_int_pos_bigint 2 (sub sb one))
+ && le zero fe && lt fe (sub (pow_int_pos_bigint 2 eb) one));
+
+ fe, fs
+ end
+ end
+
+let check_float c fp = ignore (compute_float c fp)
+
+let print_integer_constant fmt = function
+ | IConstDec s -> fprintf fmt "%s" s
+ | IConstHex s -> fprintf fmt "0x%s" s
+ | IConstOct s -> fprintf fmt "0o%s" s
+ | IConstBin s -> fprintf fmt "0b%s" s
+
+let print_real_constant fmt = function
+ | RConstDec (i,f,None) -> fprintf fmt "%s.%s" i f
+ | RConstDec (i,f,Some e) -> fprintf fmt "%s.%se%s" i f e
+ | RConstHex (i,f,Some e) -> fprintf fmt "0x%s.%sp%s" i f e
+ | RConstHex (i,f,None) -> fprintf fmt "0x%s.%s" i f
+
+let print_constant fmt = function
+ | ConstInt c -> print_integer_constant fmt c
+ | ConstReal c -> print_real_constant fmt c
+
+let () = Exn_printer.register (fun fmt exn -> match exn with
+ | InvalidConstantLiteral (n,s) ->
+ fprintf fmt "Invalid integer literal in base %d: '%s'" n s
+ | NonRepresentableFloat c ->
+ fprintf fmt "Invalid floating point literal: '%a'"
+ print_real_constant c
+ | OutOfRange c ->
+ fprintf fmt "Integer literal %a is out of range" print_integer_constant c
+ | _ -> raise exn)
diff --git a/src/util/number.mli b/src/util/number.mli
index 9ef4becfdb89b0e1a5ec7e2c840572c990ce359d..2981e34b0a19ecdc38240d9406ebdfee9c93f7fd 100644
--- a/src/util/number.mli
+++ b/src/util/number.mli
@@ -43,7 +43,13 @@ val compute_int : integer_constant -> BigInt.t
val real_const_dec : string -> string -> string option -> real_constant
val real_const_hex : string -> string -> string option -> real_constant
-(** Printing *)
+(** Pretty-printing *)
+
+val print_integer_constant : formatter -> integer_constant -> unit
+val print_real_constant : formatter -> real_constant -> unit
+val print_constant : formatter -> constant -> unit
+
+(** Pretty-printing with conversion *)
type integer_format =
(string -> unit, Format.formatter, unit) format
@@ -82,3 +88,40 @@ type number_support = {
}
val print : number_support -> formatter -> constant -> unit
+
+val print_in_base : int -> int option -> formatter -> BigInt.t -> unit
+(** [print_in_base radix digits fmt i] prints the value of [i] in base
+ [radix]. If digits is not [None] adds leading 0s to have [digits]
+ characters. *)
+
+(** Range checking *)
+
+type int_range = {
+ ir_lower : BigInt.t;
+ ir_upper : BigInt.t;
+}
+
+exception OutOfRange of integer_constant
+
+val check_range : integer_constant -> int_range -> unit
+(** [check_range c ir] checks that [c] is in the range described
+ by [ir], and raises [OutOfRange c] if not. *)
+
+(** Float checking *)
+
+type float_format = {
+ fp_exponent_digits : int;
+ fp_significand_digits : int; (* counting the hidden bit *)
+}
+
+exception NonRepresentableFloat of real_constant
+
+val compute_float : real_constant -> float_format -> BigInt.t * BigInt.t
+(** [compute_float c fp] checks that [c] is a float literal
+ representable in the format [fp]. Returns a pair [e,s] with
+ [s] the significand (without the hidden bit), and [e] the biased
+ exponent. Raises [NonRepresentableFloat c] exception otherwise. *)
+
+val check_float : real_constant -> float_format -> unit
+(** [check_float c fp] is the same as [compute_float c fp]
+ but does not return any value. *)
diff --git a/src/whyml/mlw_decl.ml b/src/whyml/mlw_decl.ml
index dde74541b23bff55b00ddd0c5f6b3477840544b2..976868ab5203c24fee275b2d47df4fcf13c84ffe 100644
--- a/src/whyml/mlw_decl.ml
+++ b/src/whyml/mlw_decl.ml
@@ -39,7 +39,7 @@ and pdecl_node =
let pd_equal : pdecl -> pdecl -> bool = (==)
-let ts_mark = create_tysymbol (id_fresh "'mark") [] None
+let ts_mark = create_tysymbol (id_fresh "'mark") [] NoDef
let ty_mark = ty_app ts_mark []
let ity_mark = ity_pur ts_mark []
diff --git a/src/whyml/mlw_dexpr.ml b/src/whyml/mlw_dexpr.ml
index 021ef01f2d5972311dbcf7debfc61c2e94454db3..62603d075fbe878e6aa4015f0f9f65892a1d27bd 100644
--- a/src/whyml/mlw_dexpr.ml
+++ b/src/whyml/mlw_dexpr.ml
@@ -77,12 +77,9 @@ let ity_of_dity dity =
ity dity
let dity_int = Dpur (ts_int, [])
-let dity_real = Dpur (ts_real, [])
let dity_bool = Dpur (ts_bool, [])
let dity_unit = Dpur (ts_unit, [])
-let dvty_int = [], dity_int
-let dvty_real = [], dity_real
let dvty_bool = [], dity_bool
let dvty_unit = [], dity_unit
@@ -398,7 +395,7 @@ and dexpr_node =
| DEplapp of plsymbol * dexpr list
| DElsapp of lsymbol * dexpr list
| DEapply of dexpr * dexpr
- | DEconst of Number.constant
+ | DEconst of Number.constant * ity
| DElam of dbinder list * dexpr * dspec later
| DElet of dlet_defn * dexpr
| DEfun of dfun_defn * dexpr
@@ -676,10 +673,7 @@ let dexpr ?loc node =
let argl, res = specialize_ls fs_func_app in
dity_unify_app fs_func_app dexpr_expected_type [de1;de2] argl;
[], res
- | DEconst (Number.ConstInt _) ->
- dvty_int
- | DEconst (Number.ConstReal _) ->
- dvty_real
+ | DEconst (_, ity) -> [], dity_of_ity ity
| DEfun ((_,_,[],_,_),_) ->
invalid_arg "Mlw_dexpr.dexpr: empty argument list in DEfun"
| DElet (_,de)
@@ -1203,8 +1197,8 @@ and try_expr keep_loc uloc env ({de_dvty = argl,res} as de0) =
e_app e1 [e_ghostify gh (get env de2)]
| DEapply (de1,de2) ->
e_lapp fs_func_app [get env de1; get env de2] (ity_of_dity res)
- | DEconst c ->
- e_const c
+ | DEconst (c,ity) ->
+ e_const c ity
| DElet ((id,gh,de1),de2) ->
let e1 = get env de1 in
let mk_expr e1 =
diff --git a/src/whyml/mlw_dexpr.mli b/src/whyml/mlw_dexpr.mli
index 8026ea3f36513c77d266948e0485643b2487602c..ab8bef45259cb12097c38efc3fcc4f7a7efcb85e 100644
--- a/src/whyml/mlw_dexpr.mli
+++ b/src/whyml/mlw_dexpr.mli
@@ -106,7 +106,7 @@ and dexpr_node =
| DEplapp of plsymbol * dexpr list
| DElsapp of lsymbol * dexpr list
| DEapply of dexpr * dexpr
- | DEconst of Number.constant
+ | DEconst of Number.constant * ity
| DElam of dbinder list * dexpr * dspec later
| DElet of dlet_defn * dexpr
| DEfun of dfun_defn * dexpr
diff --git a/src/whyml/mlw_driver.ml b/src/whyml/mlw_driver.ml
index d1957d996826a6d18dee9bfdcb2ce4d7dd60ff56..61742cfedca2c9691b6b5bf81e0c6c4e3300fa02 100644
--- a/src/whyml/mlw_driver.ml
+++ b/src/whyml/mlw_driver.ml
@@ -115,14 +115,16 @@ let load_driver env file extra_files =
add_syntax ps.ls_name s b
| Rconverter _ ->
Loc.errorm "Syntax converter cannot be used in pure theories"
+ | Rliteral _ ->
+ Loc.errorm "Syntax literal cannot be used in pure theories"
| Rremovepr (q) ->
- ignore (find_pr th q)
+ ignore (find_pr th q)
| Rremoveall ->
- let it key _ = match (Mid.find key th.th_known).Decl.d_node with
- | Decl.Dprop (_,symb,_) -> ignore symb
- | _ -> ()
- in
- Mid.iter it th.th_local
+ let it key _ = match (Mid.find key th.th_known).Decl.d_node with
+ | Decl.Dprop (_,symb,_) -> ignore symb
+ | _ -> ()
+ in
+ Mid.iter it th.th_local
| Rmeta (s,al) ->
let rec ty_of_pty = function
| PTyvar x ->
diff --git a/src/whyml/mlw_expr.ml b/src/whyml/mlw_expr.ml
index 6e022119d4fdc7420ac044f74e89b00733f3fc8a..844385b97e80ddd2494d411cb6148a13f3292030 100644
--- a/src/whyml/mlw_expr.ml
+++ b/src/whyml/mlw_expr.ml
@@ -690,10 +690,10 @@ let e_assign pls e0 e1 = on_value (e_assign_real pls e0) e1
(* numeric constants *)
-let e_const t =
+let e_from_t t =
mk_expr (Elogic t) (VTvalue (ity_of_ty_opt t.t_ty)) false eff_empty syms_empty
-let e_const c = e_const (t_const c)
+let e_const c ity = e_from_t (t_const c (ty_of_ity ity))
(* boolean expressions *)
diff --git a/src/whyml/mlw_expr.mli b/src/whyml/mlw_expr.mli
index 71cd00f04905dfe85d79d0b5953872c473acd47c..5e414f64aeee687a90c5cd90cdcde6f4bb05fa24 100644
--- a/src/whyml/mlw_expr.mli
+++ b/src/whyml/mlw_expr.mli
@@ -232,7 +232,7 @@ val fs_void : lsymbol
val t_void : term
val e_void : expr
-val e_const : Number.constant -> expr
+val e_const : Number.constant -> ity -> expr
val e_lazy_and : expr -> expr -> expr
val e_lazy_or : expr -> expr -> expr
val e_not : expr -> expr
diff --git a/src/whyml/mlw_ocaml.ml b/src/whyml/mlw_ocaml.ml
index 2b6a9872c075a7c60e62e76b95da3da338d64c6c..9c917cd97d3e20b669ada022005d6bc6b8c893f9 100644
--- a/src/whyml/mlw_ocaml.ml
+++ b/src/whyml/mlw_ocaml.ml
@@ -199,9 +199,10 @@ module Translate = struct
[]
let type_decl info ts = match ts.ts_def with
- | None ->
+ | NoDef | Range _ | Float _ ->
+ (* FIXME: how should we extract Range and Float? *)
ML.Dabstract
- | Some ty ->
+ | Alias ty ->
ML.Dalias (type_ info ty)
let type_args = List.map (fun tv -> tv.tv_name)
diff --git a/src/whyml/mlw_ty.ml b/src/whyml/mlw_ty.ml
index 9e3b32fef0377b6d13988c183d0b27343aed99de..d8c6d00b4adcbbab511a8bbf7c90431369075b04 100644
--- a/src/whyml/mlw_ty.ml
+++ b/src/whyml/mlw_ty.ml
@@ -411,8 +411,8 @@ let ity_pur s tl =
let sub = { ity_subst_tv = mv; ity_subst_reg = Mreg.empty } in
(* every top region in def is guaranteed to be in mr *)
match s.ts_def with
- | Some ty -> ity_full_inst sub (ity_of_ty ty)
- | None -> ity_pur_unsafe s tl
+ | Alias ty -> ity_full_inst sub (ity_of_ty ty)
+ | _ -> ity_pur_unsafe s tl
(* itysymbol creation *)
@@ -435,7 +435,9 @@ let create_itysymbol_unsafe, restore_its =
let create_itysymbol name
?(abst=false) ?(priv=false) ?(inv=false) ?(ghost_reg=Sreg.empty)
args regs def =
- let puredef = Opt.map ty_of_ity def in
+ let puredef = match def with
+ | Some def -> Alias (ty_of_ity def)
+ | None -> NoDef in
let purets = create_tysymbol name args puredef in
(* all regions *)
let add s r = Sreg.add_new (DuplicateRegion r) r s in
@@ -471,6 +473,7 @@ let ts_unit = ts_tuple 0
let ty_unit = ty_tuple []
let ity_int = ity_of_ty Ty.ty_int
+let ity_real = ity_of_ty Ty.ty_real
let ity_bool = ity_of_ty Ty.ty_bool
let ity_unit = ity_of_ty ty_unit
diff --git a/src/whyml/mlw_ty.mli b/src/whyml/mlw_ty.mli
index 4a9469a54621c3ce9cc542b23930ed46d1c9bdf4..35912cd6983f12739c92d967a805389ba7351f95 100644
--- a/src/whyml/mlw_ty.mli
+++ b/src/whyml/mlw_ty.mli
@@ -147,7 +147,8 @@ val lookup_nonghost_reg : Sreg.t -> ity -> bool
val ts_unit : tysymbol (** the same as [Ty.ts_tuple 0] *)
val ty_unit : ty
-val ity_int : ity
+val ity_int : ity
+val ity_real : ity
val ity_bool : ity
val ity_unit : ity
diff --git a/src/whyml/mlw_typing.ml b/src/whyml/mlw_typing.ml
index 7775af0fa146704da9a43f820be48174206edb74..78c7a76ce8636845f6c17fada1fa80feaf9bcc42 100644
--- a/src/whyml/mlw_typing.ml
+++ b/src/whyml/mlw_typing.ml
@@ -484,7 +484,8 @@ let rec dexpr ({uc = uc} as lenv) denv {expr_desc = desc; expr_loc = loc} =
let e1, ch = if chainable_op uc denv op2
then get_chain e12 ch else e12, ch in
make_chain "q1 " "q2 " (dexpr lenv denv e1) ch
- | Ptree.Econst c -> DEconst c
+ | Ptree.Econst (Number.ConstInt _ as c) -> DEconst (c, ity_int)
+ | Ptree.Econst (Number.ConstReal _ as c) -> DEconst (c, ity_real)
| Ptree.Erecord [] -> raise Decl.EmptyRecord
| Ptree.Erecord ((q,_)::_ as fl) ->
let prog_val cs pj = function
@@ -624,7 +625,12 @@ let rec dexpr ({uc = uc} as lenv) denv {expr_desc = desc; expr_loc = loc} =
| Ptree.Enamed (Lstr lab, e1) ->
DElabel (dexpr lenv denv e1, Slab.singleton lab)
| Ptree.Ecast (e1, pty) ->
- DEcast (dexpr lenv denv e1, ity_of_pty uc pty))
+ (* FIXME: accepts and silently ignores double casts: ((0:ty1):ty2) *)
+ let e1 = dexpr lenv denv e1 in
+ let ity = ity_of_pty uc pty in
+ match e1.de_node with
+ | DEconst (c, _) -> DEconst (c, ity)
+ | _ -> DEcast (e1, ity))
and drec_defn ~top lenv denv fdl =
let prep (id, gh, (bl, pty, e, sp)) =
@@ -683,7 +689,7 @@ let look_for_loc tdl s =
let look loc d =
let loc = look_id loc d.td_ident in
match d.td_def with
- | TDabstract | TDalias _ -> loc
+ | TDabstract | TDalias _ | TDrange _ | TDfloat _ -> loc
| TDalgebraic csl -> List.fold_left look_cs loc csl
| TDrecord fl -> List.fold_left look_fl loc fl
in
@@ -713,7 +719,8 @@ let add_types ~wp uc tdl =
| PTtyapp (q,tyl) -> List.fold_left check (ts_seen seen q) tyl
| PTtuple tyl -> List.fold_left check seen tyl in
let seen = match d.td_def with
- | TDabstract | TDalgebraic _ | TDrecord _ -> seen
+ | TDabstract | TDrange _ | TDfloat _ | TDalgebraic _ | TDrecord _ ->
+ seen
| TDalias ty -> check (Mstr.add x false seen) ty in
Mstr.add x true seen in
ignore (Mstr.fold cyc_visit def Mstr.empty);
@@ -741,7 +748,7 @@ let add_types ~wp uc tdl =
let imp =
let td = Mstr.find x def in
match td.td_def with
- | TDabstract -> false
+ | TDabstract | TDrange _ | TDfloat _ -> false
| TDalias ty -> check ty
| TDalgebraic csl ->
let check (_,_,gh,ty) = gh || check ty in
@@ -780,7 +787,7 @@ let add_types ~wp uc tdl =
let mut =
let td = Mstr.find x def in
match td.td_def with
- | TDabstract -> false
+ | TDabstract | TDrange _ | TDfloat _ -> false
| TDalias ty -> check ty
| TDalgebraic csl ->
let check (_,_,_,ty) = check ty in
@@ -860,7 +867,7 @@ let add_types ~wp uc tdl =
~abst ~priv ~inv:false ~ghost_reg vl rl (Some def))
| TDalias ty ->
let def = ty_of_ity (parse ty) in
- TS (create_tysymbol id vl (Some def))
+ TS (create_tysymbol id vl (Alias def))
| TDalgebraic csl when Hstr.find mutables x ->
let projs = Hstr.create 5 in
let nogh = ref Sreg.empty in
@@ -925,7 +932,15 @@ let add_types ~wp uc tdl =
| TDalgebraic _ | TDrecord _ when Hstr.find impures x ->
PT (create_itysymbol id ~abst ~priv ~inv:false vl [] None)
| TDalgebraic _ | TDrecord _ | TDabstract ->
- TS (create_tysymbol id vl None)
+ TS (create_tysymbol id vl NoDef)
+ | TDrange (lo,hi) ->
+ let ir = { Number.ir_lower = lo;
+ Number.ir_upper = hi } in
+ TS (Loc.try2 ~loc:d.td_loc create_tysymbol id vl (Range ir))
+ | TDfloat (eb,sb) ->
+ let fp = { Number.fp_exponent_digits = eb;
+ Number.fp_significand_digits = sb } in
+ TS (Loc.try2 ~loc:d.td_loc create_tysymbol id vl (Float fp))
in
Hstr.add tysymbols x (Some ts);
ts
@@ -968,7 +983,7 @@ let add_types ~wp uc tdl =
parse ty
in
match d.td_def with
- | TDabstract ->
+ | TDabstract | TDrange _ | TDfloat _ ->
ts :: abstr, algeb, alias
| TDalias _ ->
abstr, algeb, ts :: alias
@@ -1037,9 +1052,33 @@ let add_types ~wp uc tdl =
(* add type declarations *)
+ let add_pure_type_decl uc ts =
+ let uc = add_decl_with_tuples uc (Decl.create_ty_decl ts) in
+ match ts.ts_def with
+ | NoDef | Alias _ -> uc
+ | Range _ ->
+ (* FIXME: "t'to_int" is probably better *)
+ let nm = ts.ts_name.id_string ^ "'int" in
+ let id = id_derive nm ts.ts_name in
+ let pj = create_fsymbol id [ty_app ts []] ty_int in
+ let uc = add_decl uc (Decl.create_param_decl pj) in
+ add_meta uc meta_range [MAts ts; MAls pj]
+ | Float _ ->
+ (* FIXME: "t'to_real" is probably better *)
+ let nm = ts.ts_name.id_string ^ "'real" in
+ let id = id_derive nm ts.ts_name in
+ let pj = create_fsymbol id [ty_app ts []] ty_real in
+ let uc = add_decl uc (Decl.create_param_decl pj) in
+ (* FIXME: "t'is_finite" is probably better *)
+ let nm = ts.ts_name.id_string ^ "'isFinite" in
+ let id = id_derive nm ts.ts_name in
+ let iF = Term.create_psymbol id [ty_app ts []] in
+ let uc = add_decl uc (Decl.create_param_decl iF) in
+ add_meta uc meta_float [MAts ts; MAls pj; MAls iF]
+ in
let add_type_decl uc = function
| PT ts -> add_pdecl_with_tuples ~wp uc (create_ty_decl ts)
- | TS ts -> add_decl_with_tuples uc (Decl.create_ty_decl ts)
+ | TS ts -> add_pure_type_decl uc ts
in
let add_invariant uc d = if d.td_inv = [] then uc else
add_type_invariant d.td_loc uc d.td_ident d.td_params d.td_inv in
diff --git a/tests/test_range.mlw b/tests/test_range.mlw
new file mode 100644
index 0000000000000000000000000000000000000000..8926b273bea4c485d3a95e6325074dc811c440f8
--- /dev/null
+++ b/tests/test_range.mlw
@@ -0,0 +1,48 @@
+theory T
+ use import int.Int
+
+ type q
+
+ type t is range t2int: 0 .. 42
+
+ (* meta "range:keep" type t *)
+
+ goal g : forall x:t. x = (12 : t)
+end
+
+theory U
+ use import bv.BV8
+
+ type q
+
+ (* meta "range:keep" type t *)
+
+ goal g : forall x:t. x = (12 : t)
+end
+
+module M
+ use import bv.BV16
+ use import int.Int
+
+ let f (x : t) : t
+ ensures { ule result (12 : t) }
+ = bw_and x (12 : t)
+
+end
+
+module N
+ use import bv.BV8
+ use import int.Int
+
+ use import int.NumOf
+
+ meta "encoding : kept" type t
+
+ let ghost step1 (n x1 : t) (i : int) : unit
+ =
+ assert { let i' = of_int i in
+ let twoi = mul (2 : t) i' in
+ to_uint (bw_and (lsr_bv x1 twoi) (0x03 : t))
+ = numof (nth n) (to_uint twoi) (to_uint twoi + 2) }
+
+end
\ No newline at end of file
diff --git a/theories/bv.why b/theories/bv.why
index 23715fea524a8df54ef4bad7507b821cd80ca762..bb4406dcdf036729397f1f4a647a579f65a9cdac 100644
--- a/theories/bv.why
+++ b/theories/bv.why
@@ -120,6 +120,8 @@ theory BV_Gen
axiom Nth_zeros:
forall n:int. nth zeros n = False
+ constant one : t
+
constant ones : t
axiom Nth_ones:
forall n. 0 <= n < size -> nth ones n = True
@@ -241,13 +243,12 @@ theory BV_Gen
axiom to_uint_of_int :
forall i. 0 <= i < two_power_size -> to_uint (of_int i) = i
- constant size_bv : t = of_int size
-
- axiom Of_int_zeros:
- zeros = of_int 0
+ constant size_bv : t
- axiom Of_int_ones:
- ones = of_int max_int
+ axiom to_uint_size_bv : to_uint size_bv = size
+ axiom to_uint_zeros : to_uint zeros = 0
+ axiom to_uint_one : to_uint one = 1
+ axiom to_uint_ones : to_uint ones = max_int
(* comparison operators *)
@@ -360,7 +361,7 @@ theory BV_Gen
axiom nth_bv_def:
forall x i.
- nth_bv x i = not (bw_and (lsr_bv x i) (of_int 1) = zeros)
+ nth_bv x i = not (bw_and (lsr_bv x i) one = zeros)
axiom Nth_bv_is_nth:
forall x i.
@@ -375,7 +376,7 @@ theory BV_Gen
predicate eq_sub_bv t t t t
axiom eq_sub_bv_def: forall a b i n.
- let mask = lsl_bv (sub (lsl_bv (of_int 1) n) (of_int 1)) i in
+ let mask = lsl_bv (sub (lsl_bv one n) one) i in
eq_sub_bv a b i n = (bw_and b mask = bw_and a mask)
predicate eq_sub (a b:t) (i n:int) =
@@ -399,7 +400,13 @@ theory BV64
constant two_power_size : int = 0x1_0000_0000_0000_0000
constant max_int : int = 0xFFFF_FFFF_FFFF_FFFF
+ use int.Int (* needed to use range types *)
+
+ type t = < range 0x0000_0000_0000_0000 0xFFFF_FFFF_FFFF_FFFF >
+
clone export BV_Gen with
+ type t = t,
+ function to_uint = t'int,
constant size = size,
constant two_power_size = two_power_size,
constant max_int = max_int,
@@ -414,7 +421,13 @@ theory BV32
constant two_power_size : int = 0x1_0000_0000
constant max_int : int = 0xFFFF_FFFF
+ use int.Int (* needed to use range types *)
+
+ type t = < range 0x0000_0000 0xFFFF_FFFF >
+
clone export BV_Gen with
+ type t = t,
+ function to_uint = t'int,
constant size = size,
constant two_power_size = two_power_size,
constant max_int = max_int,
@@ -429,7 +442,13 @@ theory BV16
constant two_power_size : int = 0x1_0000
constant max_int : int = 0xFFFF
+ use int.Int (* needed to use range types *)
+
+ type t = < range 0x0000 0xFFFF >
+
clone export BV_Gen with
+ type t = t,
+ function to_uint = t'int,
constant size = size,
constant two_power_size = two_power_size,
constant max_int = max_int,
@@ -444,7 +463,13 @@ theory BV8
constant two_power_size : int = 0x1_00
constant max_int : int = 0xFF
+ use int.Int (* needed to use range types *)
+
+ type t = < range 0x00 0xFF >
+
clone export BV_Gen with
+ type t = t,
+ function to_uint = t'int,
constant size = size,
constant two_power_size = two_power_size,
constant max_int = max_int,
@@ -485,82 +510,82 @@ theory BVConverter_32_64
use BV32
use BV64
- predicate in_range (b : BV64.t) = BV64.ule b (BV64.of_int BV32.max_int)
+ predicate in_range (b : BV64.t) = BV64.ule b (0xFFFF_FFFF:BV64.t)
clone export BVConverter_Gen with
type bigBV = BV64.t,
type smallBV = BV32.t,
predicate in_small_range = in_range,
- function to_uint_small = BV32.to_uint,
- function to_uint_big = BV64.to_uint
+ function to_uint_small = BV32.t'int,
+ function to_uint_big = BV64.t'int
end
theory BVConverter_16_64
use BV16
use BV64
- predicate in_range (b : BV64.t) = BV64.ule b (BV64.of_int BV16.max_int)
+ predicate in_range (b : BV64.t) = BV64.ule b (0xFFFF:BV64.t)
clone export BVConverter_Gen with
type bigBV = BV64.t,
type smallBV = BV16.t,
predicate in_small_range = in_range,
- function to_uint_small = BV16.to_uint,
- function to_uint_big = BV64.to_uint
+ function to_uint_small = BV16.t'int,
+ function to_uint_big = BV64.t'int
end
theory BVConverter_8_64
use BV8
use BV64
- predicate in_range (b : BV64.t) = BV64.ule b (BV64.of_int BV8.max_int)
+ predicate in_range (b : BV64.t) = BV64.ule b (0xFF:BV64.t)
clone export BVConverter_Gen with
type bigBV = BV64.t,
type smallBV = BV8.t,
predicate in_small_range = in_range,
- function to_uint_small = BV8.to_uint,
- function to_uint_big = BV64.to_uint
+ function to_uint_small = BV8.t'int,
+ function to_uint_big = BV64.t'int
end
theory BVConverter_16_32
use BV16
use BV32
- predicate in_range (b : BV32.t) = BV32.ule b (BV32.of_int BV16.max_int)
+ predicate in_range (b : BV32.t) = BV32.ule b (0xFFFF:BV32.t)
clone export BVConverter_Gen with
type bigBV = BV32.t,
type smallBV = BV16.t,
predicate in_small_range = in_range,
- function to_uint_small = BV16.to_uint,
- function to_uint_big = BV32.to_uint
+ function to_uint_small = BV16.t'int,
+ function to_uint_big = BV32.t'int
end
theory BVConverter_8_32
use BV8
use BV32
- predicate in_range (b : BV32.t) = BV32.ule b (BV32.of_int BV8.max_int)
+ predicate in_range (b : BV32.t) = BV32.ule b (0xFF:BV32.t)
clone export BVConverter_Gen with
type bigBV = BV32.t,
type smallBV = BV8.t,
predicate in_small_range = in_range,
- function to_uint_small = BV8.to_uint,
- function to_uint_big = BV32.to_uint
+ function to_uint_small = BV8.t'int,
+ function to_uint_big = BV32.t'int
end
theory BVConverter_8_16
use BV8
use BV16
- predicate in_range (b : BV16.t) = BV16.ule b (BV16.of_int BV8.max_int)
+ predicate in_range (b : BV16.t) = BV16.ule b (0xFF:BV16.t)
clone export BVConverter_Gen with
type bigBV = BV16.t,
type smallBV = BV8.t,
predicate in_small_range = in_range,
- function to_uint_small = BV8.to_uint,
- function to_uint_big = BV16.to_uint
+ function to_uint_small = BV8.t'int,
+ function to_uint_big = BV16.t'int
end