Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Why3
why3
Commits
3dcca8d3
Commit
3dcca8d3
authored
Sep 22, 2012
by
Andrei Paskevich
Browse files
whyml: reuse Mlw_ty.spec in lambdas and Eabstr
parent
6ae9985c
Changes
6
Hide whitespace changes
Inline
Side-by-side
src/whyml/mlw_expr.ml
View file @
3dcca8d3
...
...
@@ -468,7 +468,7 @@ and expr_node =
|
Efor
of
pvsymbol
*
for_bounds
*
invariant
*
expr
|
Eraise
of
xsymbol
*
expr
|
Etry
of
expr
*
(
xsymbol
*
pvsymbol
*
expr
)
list
|
Eabstr
of
expr
*
post
*
xpost
|
Eabstr
of
expr
*
spec
|
Eassert
of
assertion_kind
*
term
|
Eabsurd
...
...
@@ -484,12 +484,9 @@ and fun_defn = {
}
and
lambda
=
{
l_args
:
pvsymbol
list
;
l_variant
:
variant
list
;
(* lexicographic order *)
l_pre
:
pre
;
l_expr
:
expr
;
l_post
:
post
;
l_xpost
:
xpost
;
l_args
:
pvsymbol
list
;
l_expr
:
expr
;
l_spec
:
spec
;
}
(* base tools *)
...
...
@@ -530,29 +527,11 @@ let ps_pvset pvs ps = varmap_pvset pvs ps.ps_varm
let
e_pvset
pvs
e
=
varmap_pvset
pvs
e
.
e_varm
let
spec_of_lambda
lam
=
{
c_pre
=
lam
.
l_pre
;
c_effect
=
lam
.
l_expr
.
e_effect
;
c_post
=
lam
.
l_post
;
c_xpost
=
lam
.
l_xpost
;
c_variant
=
lam
.
l_variant
;
}
let
l_pvset
pvs
lam
=
let
pvs
=
e_pvset
pvs
lam
.
l_expr
in
let
pvs
=
spec_pvset
pvs
(
spec_of_lambda
lam
)
in
let
pvs
=
spec_pvset
pvs
lam
.
l_spec
in
List
.
fold_right
Spv
.
remove
lam
.
l_args
pvs
let
spec_of_abstract
e
q
xq
=
{
c_pre
=
t_true
;
c_post
=
q
;
c_xpost
=
xq
;
c_effect
=
e
.
e_effect
;
c_variant
=
[]
;
}
let
abstr_pvset
pvs
e
q
xq
=
let
pvs
=
e_pvset
pvs
e
in
spec_pvset
pvs
(
spec_of_abstract
e
q
xq
)
(* check admissibility of consecutive events *)
exception
StaleRegion
of
expr
*
ident
...
...
@@ -965,11 +944,13 @@ let e_any spec vty =
vta_check
(
vars_merge
varm
vars_empty
)
vta
;
mk_expr
(
Eany
spec
)
vty
spec
.
c_effect
varm
let
e_abstract
e
q
xq
=
let
spec
=
spec_of_abstract
e
q
xq
in
let
e_abstract
e
spec
=
if
spec
.
c_variant
<>
[]
then
Loc
.
errorm
"variants are not allowed in `abstract'"
;
let
spec
=
{
spec
with
c_effect
=
e
.
e_effect
}
in
spec_check
spec
e
.
e_vty
;
let
varm
=
spec_varmap
e
.
e_varm
spec
in
mk_expr
(
Eabstr
(
e
,
q
,
xq
))
e
.
e_vty
e
.
e_effect
varm
mk_expr
(
Eabstr
(
e
,
spec
))
e
.
e_vty
e
.
e_effect
varm
let
e_assert
ak
f
=
let
varm
=
add_t_vars
f
.
t_vars
Mid
.
empty
in
...
...
@@ -983,7 +964,7 @@ let e_absurd ity =
(* simple functional definitions *)
let
create_fun_defn
id
lam
recsyms
=
let
spec
=
spec_of_lambda
lam
in
let
spec
=
{
lam
.
l_spec
with
c_effect
=
lam
.
l_expr
.
e_effect
}
in
let
varm
=
spec_varmap
lam
.
l_expr
.
e_varm
spec
in
let
del_pv
m
pv
=
Mid
.
remove
pv
.
pv_vs
.
vs_name
m
in
let
varm
=
List
.
fold_left
del_pv
varm
lam
.
l_args
in
...
...
@@ -993,7 +974,7 @@ let create_fun_defn id lam recsyms =
|
vty
->
vty
in
let
vta
=
vty_arrow
lam
.
l_args
~
spec
vty
in
{
fun_ps
=
create_psymbol_poly
id
vta
varm_ps
;
fun_lambda
=
lam
;
fun_lambda
=
{
lam
with
l_spec
=
spec
}
;
fun_varm
=
varm
;
}
let
e_rec
fdl
e
=
...
...
@@ -1062,8 +1043,8 @@ let rec expr_subst psm e = e_label_copy e (match e.e_node with
e_assign_real
(
expr_subst
psm
e
)
pv
|
Eghost
e
->
e_ghost
(
expr_subst
psm
e
)
|
Eabstr
(
e
,
q
,
xq
)
->
e_abstract
(
expr_subst
psm
e
)
q
xq
|
Eabstr
(
e
,
spec
)
->
e_abstract
(
expr_subst
psm
e
)
spec
|
Eraise
(
xs
,
e0
)
->
e_raise
xs
(
expr_subst
psm
e0
)
(
vtv_of_expr
e
)
.
vtv_ity
|
Etry
(
e
,
bl
)
->
...
...
@@ -1103,8 +1084,8 @@ and subst_fd psm fdl =
let
create_rec_defn
defl
=
if
defl
=
[]
then
invalid_arg
"Mlw_expr.create_rec_defn"
;
(* check that the all variants use the same order *)
let
variant1
=
(
snd
(
List
.
hd
defl
))
.
l_variant
in
let
check_variant
(
_
,
{
l_variant
=
vl
})
=
let
variant1
=
(
snd
(
List
.
hd
defl
))
.
l_
spec
.
c_
variant
in
let
check_variant
(
_
,
{
l_
spec
=
{
c_
variant
=
vl
}
})
=
let
res
=
try
List
.
for_all2
(
fun
(
_
,
r1
)
(
_
,
r2
)
->
Util
.
option_eq
ls_equal
r1
r2
)
vl
variant1
with
Invalid_argument
_
->
false
in
...
...
@@ -1126,7 +1107,7 @@ let create_rec_defn defl =
subst_fd
m
fdl
let
create_fun_defn
id
lam
=
if
lam
.
l_variant
<>
[]
then
if
lam
.
l_
spec
.
c_
variant
<>
[]
then
Loc
.
errorm
"variants are not allowed in a non-recursive definition"
;
create_fun_defn
id
lam
Sid
.
empty
...
...
@@ -1146,6 +1127,6 @@ let e_fold fn acc e = match e.e_node with
|
Eif
(
e1
,
e2
,
e3
)
->
fn
(
fn
(
fn
acc
e1
)
e2
)
e3
|
Eapp
(
e
,_,_
)
|
Eassign
(
e
,_,_
)
|
Eghost
e
|
Eloop
(
_
,_,
e
)
|
Efor
(
_
,_,_,
e
)
|
Eraise
(
_
,
e
)
|
Eabstr
(
e
,_
,_
)
->
fn
acc
e
|
Eabstr
(
e
,_
)
->
fn
acc
e
|
Elogic
_
|
Evalue
_
|
Earrow
_
|
Eany
_
|
Eassert
_
|
Eabsurd
->
acc
src/whyml/mlw_expr.mli
View file @
3dcca8d3
...
...
@@ -162,7 +162,7 @@ and expr_node = private
|
Efor
of
pvsymbol
*
for_bounds
*
invariant
*
expr
|
Eraise
of
xsymbol
*
expr
|
Etry
of
expr
*
(
xsymbol
*
pvsymbol
*
expr
)
list
|
Eabstr
of
expr
*
post
*
xpost
|
Eabstr
of
expr
*
spec
|
Eassert
of
assertion_kind
*
term
|
Eabsurd
...
...
@@ -178,17 +178,13 @@ and fun_defn = private {
}
and
lambda
=
{
l_args
:
pvsymbol
list
;
l_variant
:
variant
list
;
(* lexicographic order *)
l_pre
:
pre
;
l_expr
:
expr
;
l_post
:
post
;
l_xpost
:
xpost
;
l_args
:
pvsymbol
list
;
l_expr
:
expr
;
l_spec
:
spec
;
}
val
e_pvset
:
Spv
.
t
->
expr
->
Spv
.
t
val
l_pvset
:
Spv
.
t
->
lambda
->
Spv
.
t
val
abstr_pvset
:
Spv
.
t
->
expr
->
post
->
xpost
->
Spv
.
t
val
e_label
:
?
loc
:
Loc
.
position
->
Slab
.
t
->
expr
->
expr
val
e_label_add
:
label
->
expr
->
expr
...
...
@@ -248,7 +244,7 @@ val e_for :
pvsymbol
->
expr
->
for_direction
->
expr
->
invariant
->
expr
->
expr
val
e_any
:
spec
->
vty
->
expr
val
e_abstract
:
expr
->
post
->
xpost
->
expr
val
e_abstract
:
expr
->
spec
->
expr
val
e_assert
:
assertion_kind
->
term
->
expr
val
e_absurd
:
ity
->
expr
...
...
src/whyml/mlw_ocaml.ml
View file @
3dcca8d3
...
...
@@ -749,7 +749,7 @@ and print_lexpr pri info fmt e =
|
Etry
(
e
,
bl
)
->
fprintf
fmt
"@[(try %a with@
\n
@[<hov>%a@])@]"
(
print_expr
info
)
e
(
print_list
newline
(
print_xbranch
info
))
bl
|
Eabstr
(
e
,_
,_
)
->
|
Eabstr
(
e
,_
)
->
print_lexpr
pri
info
fmt
e
|
Eabsurd
->
fprintf
fmt
"assert false (* absurd *)"
...
...
src/whyml/mlw_pretty.ml
View file @
3dcca8d3
...
...
@@ -311,9 +311,9 @@ and print_enode pri fmt e = match e.e_node with
fprintf
fmt
"absurd"
|
Eassert
(
ak
,
f
)
->
fprintf
fmt
"%a { %a }"
print_ak
ak
print_term
f
|
Eabstr
(
e
,
q
,_
xq
)
->
(* TODO: print_
xpost
*)
fprintf
fmt
"abstract %a@ { %a }"
print_expr
e
print_post
q
|
Eabstr
(
e
,
spec
)
->
(* TODO: print_
spec
*)
fprintf
fmt
"abstract %a@ { %a }"
print_expr
e
print_post
spec
.
c_post
|
Eghost
e
->
fprintf
fmt
"ghost@ %a"
print_expr
e
|
Eany
spec
->
...
...
@@ -333,11 +333,11 @@ and print_rec lr fst fmt { fun_ps = ps ; fun_lambda = lam } =
(
if
fst
then
if
lr
then
"let rec"
else
"let"
else
"with"
)
print_psty
ps
(
print_list
space
print_arg
)
lam
.
l_args
print_term
lam
.
l_pre
print_variant
lam
.
l_variant
print_term
lam
.
l_
spec
.
c_
pre
print_variant
lam
.
l_
spec
.
c_
variant
print_expr
lam
.
l_expr
print_post
lam
.
l_post
(* TODO: print_
xpost
*)
print_post
lam
.
l_
spec
.
c_
post
(* TODO: print_
spec
*)
(*
and print_tl fmt tl =
...
...
src/whyml/mlw_typing.ml
View file @
3dcca8d3
...
...
@@ -721,25 +721,18 @@ let spec_invariant lenv pvs vty spec =
c_post
=
post_inv
ity
spec
.
c_post
;
c_xpost
=
Mexn
.
mapi
xpost_inv
spec
.
c_xpost
}
let
abstr_invariant
lenv
e
q
xq
=
let
ity
=
ity_or_unit
e
.
e_vty
in
let
pvs
=
abstr_pvset
Spv
.
empty
e
q
xq
in
let
rvs
=
reset_vars
e
.
e_effect
pvs
in
let
_
,
qinv
=
env_invariant
lenv
e
.
e_effect
pvs
in
let
post_inv
=
post_invariant
lenv
rvs
qinv
in
let
xpost_inv
xs
q
=
post_inv
xs
.
xs_ity
q
in
post_inv
ity
q
,
Mexn
.
mapi
xpost_inv
xq
let
abstr_invariant
lenv
e
spec0
=
let
pvs
=
e_pvset
Spv
.
empty
e
in
let
spec
=
{
spec0
with
c_effect
=
e
.
e_effect
}
in
let
spec
=
spec_invariant
lenv
pvs
e
.
e_vty
spec
in
(* we do not require invariants on free variables *)
{
spec
with
c_pre
=
spec0
.
c_pre
}
let
lambda_invariant
lenv
pvs
eff
lam
=
let
ity
=
ity_or_unit
lam
.
l_expr
.
e_vty
in
let
pvs
=
List
.
fold_right
Spv
.
add
lam
.
l_args
pvs
in
let
rvs
=
reset_vars
eff
pvs
in
let
pinv
,
qinv
=
env_invariant
lenv
eff
pvs
in
let
post_inv
=
post_invariant
lenv
rvs
qinv
in
let
xpost_inv
xs
q
=
post_inv
xs
.
xs_ity
q
in
{
lam
with
l_pre
=
t_and_simp
lam
.
l_pre
pinv
;
l_post
=
post_inv
ity
lam
.
l_post
;
l_xpost
=
Mexn
.
mapi
xpost_inv
lam
.
l_xpost
}
let
spec
=
{
lam
.
l_spec
with
c_effect
=
eff
}
in
let
spec
=
spec_invariant
lenv
pvs
lam
.
l_expr
.
e_vty
spec
in
{
lam
with
l_spec
=
spec
}
let
rec
dty_of_ty
ty
=
match
ty
.
ty_node
with
|
Ty
.
Tyapp
(
ts
,
tyl
)
->
Denv
.
tyapp
ts
(
List
.
map
dty_of_ty
tyl
)
...
...
@@ -1081,8 +1074,11 @@ and expr_desc lenv loc de = match de.de_desc with
let
e1
=
expr
lenv
de1
in
let
q
=
create_post
lenv
"result"
e1
.
e_vty
q
in
let
xq
=
complete_xpost
lenv
e1
.
e_effect
xq
in
let
q
,
xq
=
abstr_invariant
lenv
e1
q
xq
in
e_abstract
e1
q
xq
let
spec
=
{
c_pre
=
t_true
;
c_post
=
q
;
c_xpost
=
xq
;
c_effect
=
eff_empty
;
c_variant
=
[]
}
in
let
spec
=
abstr_invariant
lenv
e1
spec
in
e_abstract
e1
spec
|
DEassert
(
ak
,
f
)
->
let
ak
=
match
ak
with
|
Ptree
.
Aassert
->
Aassert
...
...
@@ -1162,12 +1158,14 @@ and expr_lam lenv gh pvl (var, p, de, q, xq) =
let
e
=
e_ghostify
gh
(
expr
lenv
de
)
in
if
not
gh
&&
vty_ghost
e
.
e_vty
then
errorm
~
loc
:
de
.
de_loc
"ghost body in a non-ghost function"
;
{
l_args
=
pvl
;
l_variant
=
List
.
map
(
create_variant
lenv
)
var
;
l_pre
=
create_pre
lenv
p
;
l_expr
=
e
;
l_post
=
create_post
lenv
"result"
e
.
e_vty
q
;
l_xpost
=
complete_xpost
lenv
e
.
e_effect
xq
}
let
spec
=
{
c_pre
=
create_pre
lenv
p
;
c_post
=
create_post
lenv
"result"
e
.
e_vty
q
;
c_xpost
=
complete_xpost
lenv
e
.
e_effect
xq
;
c_effect
=
e
.
e_effect
;
c_variant
=
List
.
map
(
create_variant
lenv
)
var
;
}
in
{
l_args
=
pvl
;
l_expr
=
e
;
l_spec
=
spec
}
(** Type declaration *)
...
...
src/whyml/mlw_wp.ml
View file @
3dcca8d3
...
...
@@ -725,10 +725,11 @@ and wp_desc env e q xq = match e.e_node with
let
w
=
wp_and
~
sym
:
false
(
wp_and
~
sym
:
true
d
p
)
w
in
(* FIXME? ~sym? *)
let
q
=
create_unit_post
w
in
wp_expr
env
e1
q
xq
(* FIXME? should (wp_label e) rather be here? *)
|
Eabstr
(
e1
,
c_q
,
c_xq
)
->
let
w1
=
backstep
(
wp_expr
env
e1
)
c_q
c_xq
in
let
w2
=
wp_abstract
env
e1
.
e_effect
c_q
c_xq
q
xq
in
wp_and
~
sym
:
true
(
wp_label
e
w1
)
w2
|
Eabstr
(
e1
,
spec
)
->
let
p
=
wp_label
e
(
wp_expl
expl_pre
spec
.
c_pre
)
in
let
w1
=
backstep
(
wp_expr
env
e1
)
spec
.
c_post
spec
.
c_xpost
in
let
w2
=
wp_abstract
env
e1
.
e_effect
spec
.
c_post
spec
.
c_xpost
q
xq
in
wp_and
~
sym
:
false
p
(
wp_and
~
sym
:
true
(
wp_label
e
w1
)
w2
)
|
Eassign
(
e1
,
reg
,
pv
)
->
let
rec
get_term
d
=
match
d
.
e_node
with
|
Elogic
t
->
t
...
...
@@ -819,23 +820,23 @@ and wp_abstract env c_eff c_q c_xq q xq =
backstep
proceed
c_q
c_xq
and
wp_fun_defn
env
faml
{
fun_ps
=
ps
;
fun_lambda
=
l
}
=
let
lab
=
fresh_mark
()
in
let
lab
=
fresh_mark
()
and
c
=
l
.
l_spec
in
let
add_arg
sbs
pv
=
ity_match
sbs
pv
.
pv_vtv
.
vtv_ity
pv
.
pv_vtv
.
vtv_ity
in
let
subst
=
List
.
fold_left
add_arg
ps
.
ps_subst
l
.
l_args
in
let
regs
=
Mreg
.
map
(
fun
_
->
()
)
subst
.
ity_subst_reg
in
let
args
=
List
.
map
(
fun
pv
->
pv
.
pv_vs
)
l
.
l_args
in
let
env
=
if
l
.
l
_variant
=
[]
then
env
else
let
env
=
if
c
.
c
_variant
=
[]
then
env
else
let
lab
=
t_var
lab
in
let
t_at_lab
(
t
,_
)
=
t_app
fs_at
[
t
;
lab
]
t
.
t_ty
in
let
tl
=
List
.
map
t_at_lab
l
.
l
_variant
in
let
tl
=
List
.
map
t_at_lab
c
.
c
_variant
in
let
add_family
lrv
fam
=
Mint
.
add
fam
tl
lrv
in
let
lrv
=
List
.
fold_left
add_family
env
.
letrec_var
faml
in
{
env
with
letrec_var
=
lrv
}
in
let
q
=
old_mark
lab
(
wp_expl
expl_post
l
.
l
_post
)
in
let
q
=
old_mark
lab
(
wp_expl
expl_post
c
.
c
_post
)
in
let
conv
p
=
old_mark
lab
(
wp_expl
expl_xpost
p
)
in
let
f
=
wp_expr
env
l
.
l_expr
q
(
Mexn
.
map
conv
l
.
l
_xpost
)
in
let
f
=
wp_implies
l
.
l
_pre
(
erase_mark
lab
f
)
in
let
f
=
wp_expr
env
l
.
l_expr
q
(
Mexn
.
map
conv
c
.
c
_xpost
)
in
let
f
=
wp_implies
c
.
c
_pre
(
erase_mark
lab
f
)
in
wp_forall
args
(
quantify
env
regs
f
)
and
wp_rec_defn
env
fdl
=
...
...
@@ -1054,7 +1055,7 @@ and fast_wp_desc env s r e =
let
ok
=
if
kind
=
Aassume
then
t_true
else
f
in
let
ne
=
if
kind
=
Acheck
then
t_true
else
f
in
ok
,
((
ne
,
s
)
,
Mexn
.
empty
)
|
Eabstr
(
_
,
_
,
_
)
->
assert
false
(*TODO*)
|
Eabstr
(
_
,
_
)
->
assert
false
(*TODO*)
|
Etry
(
_
,
_
)
->
assert
false
(*TODO*)
|
Eraise
(
_
,
_
)
->
assert
false
(*TODO*)
|
Efor
(
_
,
_
,
_
,
_
)
->
assert
false
(*TODO*)
...
...
@@ -1084,28 +1085,28 @@ and fast_wp_desc env s r e =
and
fast_wp_fun_defn
env
faml
{
fun_ps
=
ps
;
fun_lambda
=
l
}
=
(* OK: forall bl. pl => ok(e)
NE: true *)
let
lab
=
fresh_mark
()
in
let
lab
=
fresh_mark
()
and
c
=
l
.
l_spec
in
let
add_arg
sbs
pv
=
ity_match
sbs
pv
.
pv_vtv
.
vtv_ity
pv
.
pv_vtv
.
vtv_ity
in
let
subst
=
List
.
fold_left
add_arg
ps
.
ps_subst
l
.
l_args
in
let
regs
=
Mreg
.
map
(
fun
_
->
()
)
subst
.
ity_subst_reg
in
let
args
=
List
.
map
(
fun
pv
->
pv
.
pv_vs
)
l
.
l_args
in
let
env
=
if
l
.
l
_variant
=
[]
then
env
else
let
env
=
if
c
.
c
_variant
=
[]
then
env
else
let
lab
=
t_var
lab
in
let
t_at_lab
(
t
,_
)
=
t_app
fs_at
[
t
;
lab
]
t
.
t_ty
in
let
tl
=
List
.
map
t_at_lab
l
.
l
_variant
in
let
tl
=
List
.
map
t_at_lab
c
.
c
_variant
in
let
add_family
lrv
fam
=
Mint
.
add
fam
tl
lrv
in
let
lrv
=
List
.
fold_left
add_family
env
.
letrec_var
faml
in
{
env
with
letrec_var
=
lrv
}
in
let
q
=
old_mark
lab
(
wp_expl
expl_post
l
.
l
_post
)
in
let
q
=
old_mark
lab
(
wp_expl
expl_post
c
.
c
_post
)
in
let
result
,
_
as
q
=
open_post
q
in
let
conv
p
=
old_mark
lab
(
wp_expl
expl_xpost
p
)
in
let
xq
=
Mexn
.
map
conv
l
.
l
_xpost
in
let
xq
=
Mexn
.
map
conv
c
.
c
_xpost
in
let
xq
=
Mexn
.
map
open_post
xq
in
let
xresult
=
Mexn
.
map
fst
xq
in
let
ok
,
n
=
fast_wp_expr
env
Subst
.
empty
(
result
,
xresult
)
l
.
l_expr
in
let
f
=
wp_and
~
sym
:
true
ok
(
wp_nimplies
n
(
q
,
xq
))
in
let
f
=
wp_implies
l
.
l
_pre
(
erase_mark
lab
f
)
in
let
f
=
wp_implies
c
.
c
_pre
(
erase_mark
lab
f
)
in
wp_forall
args
(
quantify
env
regs
f
)
and
fast_wp_rec_defn
env
fdl
=
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment