Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Why3
why3
Commits
fcb44a61
Commit
fcb44a61
authored
Aug 20, 2014
by
MARCHE Claude
Browse files
trans compute: more robust protection against non termination
parent
e3447b63
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/transform/compute.ml
View file @
fcb44a61
...
...
@@ -14,338 +14,8 @@ open Decl
open
Task
open
Theory
(* obsolete
type env = {
tknown : Decl.known_map;
vsenv : term Mvs.t;
}
let bind_vs v t env =
{ env with vsenv = Mvs.add v t env.vsenv }
let multibind_vs l tl env =
try
List.fold_right2 bind_vs l tl env
with Invalid_argument _ -> assert false
let get_vs env vs =
try Mvs.find vs env.vsenv
with Not_found ->
Format.eprintf "[Compute] logic variable %s not found in env@." vs.vs_name.Ident.id_string;
raise Not_found
exception NoMatch
exception Undetermined
exception CannotCompute
let rec matching env t p =
match p.pat_node with
| Pwild -> env
| Pvar v -> bind_vs v t env
| Por(p1,p2) ->
begin
try matching env t p1
with NoMatch -> matching env t p2
end
| Pas(p,v) -> matching (bind_vs v t env) t p
| Papp(ls1,pl) ->
match t.t_node with
| Tapp(ls2,tl) ->
if ls_equal ls1 ls2 then
List.fold_left2 matching env tl pl
else
if ls2.ls_constr > 0 then raise NoMatch
else raise Undetermined
| _ -> raise Undetermined
(* builtin symbols *)
let builtins = Hls.create 17
let ls_minus = ref ps_equ (* temporary *)
(* all builtin functions *)
let const_equality c1 c2 =
match c1,c2 with
| Number.ConstInt i1, Number.ConstInt i2 ->
BigInt.eq (Number.compute_int i1) (Number.compute_int i2)
| _ -> raise Undetermined
let value_equality t1 t2 =
match (t1.t_node,t2.t_node) with
| Tconst c1, Tconst c2 -> const_equality c1 c2
| _ -> raise Undetermined
let to_bool b = if b then t_true else t_false
let eval_equ _ls l _ty =
match l with
| [t1;t2] ->
begin
try to_bool (value_equality t1 t2)
with Undetermined -> t_equ t1 t2
end
| _ -> assert false
let eval_true _ls _l _ty = t_true
let eval_false _ls _l _ty = t_false
exception NotNum
let big_int_of_const c =
match c with
| Number.ConstInt i -> Number.compute_int i
| _ -> raise NotNum
let const_of_big_int n =
t_const (Number.ConstInt (Number.int_const_dec (BigInt.to_string n)))
let eval_int_op op ls l ty =
match l with
| [{t_node = Tconst c1};{t_node = Tconst c2}] ->
begin
try const_of_big_int (op (big_int_of_const c1) (big_int_of_const c2))
with NotNum | Division_by_zero ->
t_app ls l ty
end
| _ -> t_app ls l ty
let built_in_theories =
[ ["bool"],"Bool", [],
[ "True", None, eval_true ;
"False", None, eval_false ;
] ;
["int"],"Int", [],
[ "infix +", None, eval_int_op BigInt.add;
"infix -", None, eval_int_op BigInt.sub;
"infix *", None, eval_int_op BigInt.mul;
(*
"prefix -", Some ls_minus, eval_int_uop BigInt.minus;
"infix <", None, eval_int_rel BigInt.lt;
"infix <=", None, eval_int_rel BigInt.le;
"infix >", None, eval_int_rel BigInt.gt;
"infix >=", None, eval_int_rel BigInt.ge;
*)
] ;
(*
["int"],"MinMax", [],
[ "min", None, eval_int_op BigInt.min;
"max", None, eval_int_op BigInt.max;
] ;
["int"],"ComputerDivision", [],
[ "div", None, eval_int_op BigInt.computer_div;
"mod", None, eval_int_op BigInt.computer_mod;
] ;
["int"],"EuclideanDivision", [],
[ "div", None, eval_int_op BigInt.euclidean_div;
"mod", None, eval_int_op BigInt.euclidean_mod;
] ;
["map"],"Map", ["map", builtin_map_type],
[ "const", Some ls_map_const, eval_map_const;
"get", Some ls_map_get, eval_map_get;
"set", Some ls_map_set, eval_map_set;
] ;
*)
]
let add_builtin_th env (l,n,t,d) =
try
let th = Env.find_theory env l n in
List.iter
(fun (id,r) ->
let ts = Theory.ns_find_ts th.Theory.th_export [id] in
r ts)
t;
List.iter
(fun (id,r,f) ->
let ls = Theory.ns_find_ls th.Theory.th_export [id] in
Hls.add builtins ls f;
match r with
| None -> ()
| Some r -> r := ls)
d
with Not_found ->
Format.eprintf "[Compute] theory %s not found@." n
let get_builtins env =
Hls.clear builtins;
Hls.add builtins ps_equ eval_equ;
List.iter (add_builtin_th env) built_in_theories
(* computation in terms *)
let rec compute_in_term env t =
let eval_rec = compute_in_term env in
match t.t_node with
| Ttrue | Tfalse | Tconst _ -> t
| Tbinop(Tand,t1,t2) ->
t_and_simp (eval_rec t1) (eval_rec t2)
| Tbinop(Tor,t1,t2) ->
t_or_simp (eval_rec t1) (eval_rec t2)
| Tbinop(Timplies,t1,t2) ->
t_implies_simp (eval_rec t1) (eval_rec t2)
| Tbinop(Tiff,t1,t2) ->
t_iff_simp (eval_rec t1) (eval_rec t2)
| Tnot(t1) -> t_not_simp (eval_rec t1)
| Tvar vs ->
begin
try get_vs env vs
with Not_found -> t
end
| Tapp(ls,tl) ->
compute_app env ls (List.map eval_rec tl) t.t_ty
| Tif(t1,t2,t3) ->
let u1 = eval_rec t1 in
begin match u1.t_node with
| Ttrue -> eval_rec t2
| Tfalse -> eval_rec t3
| _ -> t_if u1 t2 t3
end
| Tlet(t1,tb) ->
let u1 = eval_rec t1 in
let v,t2 = t_open_bound tb in
let u2 = compute_in_term (bind_vs v u1 env) t2 in
t_let_close_simp v u1 u2
| Tcase(t1,tbl) ->
let u1 = eval_rec t1 in
compute_match env u1 tbl
| Teps _ -> t
| Tquant _ -> t
and compute_match env u tbl =
let rec iter tbl =
match tbl with
| [] ->
Format.eprintf "[Compute] fatal error: pattern matching not exhaustive in evaluation.@.";
assert false
| b::rem ->
let p,t = t_open_branch b in
try
let env' = matching env u p in
compute_in_term env' t
with NoMatch -> iter rem
in
try iter tbl with Undetermined ->
t_case u tbl
and compute_app env ls tl ty =
try
let f = Hls.find builtins ls in
f ls tl ty
with Not_found ->
try
let d = Ident.Mid.find ls.ls_name env.tknown in
match d.Decl.d_node with
| Decl.Dtype _ | Decl.Dprop _ -> assert false
| Decl.Dlogic dl ->
(* regular definition *)
let d = List.assq ls dl in
let l,t = Decl.open_ls_defn d in
let env' = multibind_vs l tl env in
compute_in_term env' t
| Decl.Dparam _ | Decl.Dind _ ->
t_app ls tl ty
| Decl.Ddata dl ->
(* constructor or projection *)
match tl with
| [ { t_node = Tapp(ls1,tl1) } ] ->
(* if ls is a projection and ls1 is a constructor,
we should compute that projection *)
let rec iter dl =
match dl with
| [] -> t_app ls tl ty
| (_,csl) :: rem ->
let rec iter2 csl =
match csl with
| [] -> iter rem
| (cs,prs) :: rem2 ->
if ls_equal cs ls1
then
(* we found the right constructor *)
let rec iter3 prs tl1 =
match prs,tl1 with
| (Some pr)::prs, t::tl1 ->
if ls_equal ls pr
then (* projection found! *) t
else
iter3 prs tl1
| None::prs, _::tl1 ->
iter3 prs tl1
| _ -> t_app ls tl ty
in iter3 prs tl1
else iter2 rem2
in iter2 csl
in iter dl
| _ -> t_app ls tl ty
with Not_found ->
Format.eprintf "[Compute] definition of logic symbol %s not found@."
ls.ls_name.Ident.id_string;
t_app ls tl ty
let compute_in_decl km d =
match d.d_node with
| Dprop(k,pr,f) ->
let t = compute_in_term { tknown = km; vsenv = Mvs.empty } f in
create_prop_decl k pr t
| _ -> d
let compute_in_tdecl km d =
match d.td_node with
| Decl d -> create_decl (compute_in_decl km d)
| _ -> d
let rec compute_in_task task =
match task with
| Some d ->
add_tdecl
(compute_in_task d.task_prev)
(compute_in_tdecl d.task_known d.task_decl)
| None -> None
let compute env task =
let task = compute_in_task task in
match task with
| Some
{ task_decl =
{ td_node = Decl { d_node = Dprop (Pgoal, _, f) }}
} ->
get_builtins env;
begin match f.t_node with
| Ttrue -> []
| _ -> [task]
end
| _ -> assert false
let () =
Trans.register_env_transform_l "compute"
(fun env -> Trans.store (compute env))
~desc:"Compute@ as@ much@ as@ possible"
*)
(* compute with rewrite rules *)
let
meta
=
Theory
.
register_meta
"rewrite"
[
Theory
.
MTprsymbol
]
~
desc
:
"Declares@ the@ given@ proposition@ as@ a@ rewrite@ rule."
let
collect_rule_decl
prs
e
d
=
match
d
.
Decl
.
d_node
with
...
...
@@ -356,7 +26,7 @@ let collect_rule_decl prs e d =
try
Reduction_engine
.
add_rule
t
e
with
Reduction_engine
.
NotARewriteRule
msg
->
Warning
.
emit
"prop %a cannot be turned into a rewrite rule: %s"
Warning
.
emit
"prop
osition
%a cannot be turned into a rewrite rule: %s"
Pretty
.
print_pr
pr
msg
;
e
else
e
...
...
@@ -387,9 +57,6 @@ let normalize_goal env (prs : Decl.Spr.t) task =
|
_
->
assert
false
let
meta
=
Theory
.
register_meta
"rewrite"
[
Theory
.
MTprsymbol
]
~
desc
:
"Declares@ the@ given@ prop@ as@ a@ rewrite@ rule."
let
normalize_transf
env
=
Trans
.
on_tagged_pr
meta
(
fun
prs
->
Trans
.
store
(
normalize_goal
env
prs
))
...
...
src/transform/reduction_engine.ml
View file @
fcb44a61
...
...
@@ -379,6 +379,12 @@ let rec matching ((mt,mv) as sigma) t p =
|
_
->
raise
Undetermined
let
rec
extract_first
n
acc
l
=
if
n
=
0
then
acc
,
l
else
match
l
with
|
x
::
r
->
extract_first
(
n
-
1
)
(
x
::
acc
)
r
|
[]
->
assert
false
let
rec
reduce
engine
c
=
...
...
@@ -477,10 +483,7 @@ and reduce_match st u tbl sigma cont =
with
NoMatch
->
iter
rem
in
try
iter
tbl
with
Undetermined
->
{
(* value_stack = Term (t_case u tbl) :: st; *)
(* FIXME: apply (t_subst sigma) on each branch of tbl !! *)
value_stack
=
Term
(
t_subst
sigma
(
t_case
u
tbl
))
::
st
;
(* DONE? *)
{
value_stack
=
Term
(
t_subst
sigma
(
t_case
u
tbl
))
::
st
;
cont_stack
=
cont
;
}
...
...
@@ -549,13 +552,6 @@ and reduce_app engine st ls ty rem_cont =
|
t2
::
t1
::
rem_st
->
reduce_equ
rem_st
t1
t2
rem_cont
|
_
->
assert
false
else
let
rec
extract_first
n
acc
l
=
if
n
=
0
then
acc
,
l
else
match
l
with
|
x
::
r
->
extract_first
(
n
-
1
)
(
x
::
acc
)
r
|
[]
->
assert
false
in
let
arity
=
List
.
length
ls
.
ls_args
in
let
args
,
rem_st
=
extract_first
arity
[]
st
in
try
...
...
@@ -736,20 +732,90 @@ and reduce_term_equ st t1 t2 cont =
let
rec
many_steps
engine
c
n
=
let
rec
reconstruct
c
=
match
c
.
value_stack
,
c
.
cont_stack
with
|
[
Term
t
]
,
[]
->
t
|
_
,
[]
->
assert
false
|
_
->
if
n
=
0
then
assert
false
else
let
c
=
reduce
engine
c
in
many_steps
engine
c
(
n
-
1
)
|
st
,
Keval
(
t
,
sigma
)
::
rem
->
reconstruct
{
value_stack
=
(
Term
(
t_subst
sigma
t
))
::
st
;
cont_stack
=
rem
;
}
|
[]
,
Kif
_
::
_
->
assert
false
|
v
::
st
,
Kif
(
t2
,
t3
,
sigma
)
::
rem
->
reconstruct
{
value_stack
=
Term
(
t_if
(
term_of_value
v
)
(
t_subst
sigma
t2
)
(
t_subst
sigma
t3
))
::
st
;
cont_stack
=
rem
;
}
|
[]
,
Klet
_
::
_
->
assert
false
|
t1
::
st
,
Klet
(
v
,
t2
,
sigma
)
::
rem
->
reconstruct
{
value_stack
=
Term
(
t_let_close
v
(
term_of_value
t1
)
(
t_subst
sigma
t2
))
::
st
;
cont_stack
=
rem
;
}
|
[]
,
Kcase
_
::
_
->
assert
false
|
v
::
st
,
Kcase
(
tbl
,
sigma
)
::
rem
->
reconstruct
{
value_stack
=
Term
(
t_subst
sigma
(
t_case
(
term_of_value
v
)
tbl
))
::
st
;
cont_stack
=
rem
;
}
|
([]
|
[
_
])
,
Kbinop
_
::
_
->
assert
false
|
t1
::
t2
::
st
,
Kbinop
op
::
rem
->
reconstruct
{
value_stack
=
Term
(
t_binary_simp
op
(
term_of_value
t1
)
(
term_of_value
t2
))
::
st
;
cont_stack
=
rem
;
}
|
[]
,
Knot
::
_
->
assert
false
|
t
::
st
,
Knot
::
rem
->
reconstruct
{
value_stack
=
Term
(
t_not
(
term_of_value
t
))
::
st
;
cont_stack
=
rem
;
}
|
st
,
Kapp
(
ls
,
ty
)
::
rem
->
let
args
,
rem_st
=
extract_first
(
List
.
length
ls
.
ls_args
)
[]
st
in
let
args
=
List
.
map
term_of_value
args
in
reconstruct
{
value_stack
=
Term
(
t_app
ls
args
ty
)
::
rem_st
;
cont_stack
=
rem
;
}
|
[]
,
Keps
_
::
_
->
assert
false
|
t
::
st
,
Keps
v
::
rem
->
reconstruct
{
value_stack
=
Term
(
t_eps_close
v
(
term_of_value
t
))
::
st
;
cont_stack
=
rem
;
}
|
[]
,
Kquant
_
::
_
->
assert
false
|
t
::
st
,
Kquant
(
q
,
vl
,
tr
)
::
rem
->
reconstruct
{
value_stack
=
Term
(
t_quant_close
q
vl
tr
(
term_of_value
t
))
::
st
;
cont_stack
=
rem
;
}
let
normalize
engine
t
=
(** iterated reductions *)
let
normalize
?
(
limit
=
1000
)
engine
t0
=
let
rec
many_steps
c
n
=
match
c
.
value_stack
,
c
.
cont_stack
with
|
[
Term
t
]
,
[]
->
t
|
_
,
[]
->
assert
false
|
_
->
if
n
=
limit
then
begin
Warning
.
emit
"reduction of term %a takes more than %d steps, aborted.@."
Pretty
.
print_term
t0
limit
;
reconstruct
c
end
else
let
c
=
reduce
engine
c
in
many_steps
c
(
n
+
1
)
in
let
c
=
{
value_stack
=
[]
;
cont_stack
=
[
Keval
(
t
,
Mvs
.
empty
)]
;
cont_stack
=
[
Keval
(
t
0
,
Mvs
.
empty
)]
;
}
in
many_steps
engine
c
100
0
many_steps
c
0
...
...
src/transform/reduction_engine.mli
View file @
fcb44a61
...
...
@@ -10,11 +10,7 @@
(********************************************************************)
(*********************
{1 A reduction engine for Why3 terms}
*************************)
(** A reduction engine for Why3 terms *)
(*
terms are normalized with respect to
...
...
@@ -98,10 +94,11 @@ val add_rule : Term.term -> engine -> engine
*)
val
normalize
:
engine
->
Term
.
term
->
Term
.
term
val
normalize
:
?
limit
:
int
->
engine
->
Term
.
term
->
Term
.
term
(** [normalize e t] normalizes the term [t] with respect to the engine
[e]
TODO: specify the behavior when non-termination...
Optional parameter [limit] provides a maximum number of steps for execution.
(default 1000). When limit is reached, the partially reduced term is returned.
*)
tests/test_compute.why
View file @
fcb44a61
...
...
@@ -198,6 +198,50 @@ theory Rgroup
end
theory NonTerm
type t
constant c : t
function f t : t
axiom a: f c = f (f c)
meta "rewrite" prop a
goal g: f c = f c
use import int.Int
type nat = O | S nat
function plus (n m:nat) : nat =
match n with
| O -> m
| S k -> S (plus k m)
end
function fib (n:nat) : nat =
match n with
| O -> O
| S O -> S O
| S (S n as m) -> plus (fib n) (fib m)
end
constant x : nat
goal g3 : fib (S (S (S O))) = x
goal g4 : fib (S (S (S (S O)))) = x
goal g5 : fib (S (S (S (S (S O))))) = x
goal g6 : fib (S (S (S (S (S (S O)))))) = x
goal g7 : fib (S (S (S (S (S (S (S O))))))) = x
goal g8 : fib (S (S (S (S (S (S (S (S O)))))))) = x
goal g9 : fib (S (S (S (S (S (S (S (S (S O))))))))) = x
goal g10 : fib (S (S (S (S (S (S (S (S (S (S O)))))))))) = x
end
theory Rinteger
use export int.Int
...
...
tests/test_compute/why3session.xml
View file @
fcb44a61
...
...
@@ -57,7 +57,7 @@
</transf>
</goal>
</theory>
<theory
name=
"TestList"
expanded=
"true"
>
<theory
name=
"TestList"
>
<goal
name=
"g1"
sum=
"0ddd0eeb3a391ca74d03f68832a092a6"
>
<transf
name=
"compute_in_goal"
>
</transf>
...
...
@@ -70,18 +70,18 @@
<transf
name=
"compute_in_goal"
>
</transf>
</goal>
<goal
name=
"h1"
sum=
"e2022f7025813c0922b8d8d9143180b9"
expanded=
"true"
>
<transf
name=
"compute_in_goal"
expanded=
"true"
>
<goal
name=
"h1"
sum=
"e2022f7025813c0922b8d8d9143180b9"
>
<transf
name=
"compute_in_goal"
>
<goal
name=
"h1.1"
expl=
"1."
sum=
"d8bcddc97984d451ccfe8ca384a80ccb"
>
</goal>
</transf>
</goal>
<goal
name=
"h2"
sum=
"23bc457ed3671d19bf68aacaceb560ac"
expanded=
"true"
>
<goal
name=
"h2"
sum=
"23bc457ed3671d19bf68aacaceb560ac"
>
<transf
name=
"compute_in_goal"
>
</transf>
</goal>
<goal
name=
"h3"
sum=
"554dc390f63c85050856d58aeb5c9928"
expanded=
"true"
>
<transf
name=
"compute_in_goal"
expanded=
"true"
>
<goal
name=
"h3"
sum=
"554dc390f63c85050856d58aeb5c9928"
>
<transf
name=
"compute_in_goal"
>
<goal
name=
"h3.1"
expl=
"1."
sum=
"16656d9cb10c34b8dfa06a7f65f5004a"
>
</goal>
</transf>
...
...
@@ -89,55 +89,55 @@
</theory>
<theory
name=
"Rstandard"
expanded=
"true"
>
</theory>
<theory
name=
"TestStandard"
expanded=
"true"
>
<goal
name=
"g00"
sum=
"0ceddda03e7e96cda00c67eebccb8ce2"
expanded=
"true"
>
<transf
name=
"compute_in_goal"
expanded=
"true"
>
<theory
name=
"TestStandard"
>
<goal
name=
"g00"
sum=
"0ceddda03e7e96cda00c67eebccb8ce2"
>
<transf
name=
"compute_in_goal"
>
<goal
name=
"g00.1"
expl=
"1."
sum=
"72e859206601f617bc9e8d202f1736c7"
>
</goal>
</transf>
</goal>
<goal
name=
"g01"
sum=
"033e36efdc75e7ebee7089bb79aae621"
expanded=
"true"
>
<transf
name=
"compute_in_goal"
expanded=
"true"
>
<goal
name=
"g01"
sum=
"033e36efdc75e7ebee7089bb79aae621"
>
<transf
name=
"compute_in_goal"
>
<goal
name=
"g01.1"
expl=
"1."
sum=
"d6d954e45cea3cfb507006372f300730"
>
</goal>
</transf>
</goal>
<goal
name=
"g02"
sum=
"e9fe9f1ccbd8b3e9306f10125f9884fe"
expanded=
"true"
>
<transf
name=
"compute_in_goal"
expanded=
"true"
>
<goal
name=
"g02"
sum=
"e9fe9f1ccbd8b3e9306f10125f9884fe"
>
<transf
name=
"compute_in_goal"
>
<goal
name=
"g02.1"
expl=
"1."
sum=
"bf81b44246d2030307c2cbbc6036407a"
>
</goal>
</transf>