Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
why3
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
123
Issues
123
List
Boards
Labels
Service Desk
Milestones
Merge Requests
15
Merge Requests
15
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Why3
why3
Commits
2d0fb535
Commit
2d0fb535
authored
Feb 03, 2013
by
Andrei Paskevich
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
whyml: remove vty_value type, work directly with ity
parent
4aee41ca
Changes
14
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
14 changed files
with
188 additions
and
268 deletions
+188
-268
examples/use_api/use_api.ml
examples/use_api/use_api.ml
+5
-13
src/jessie/ACSLtoWhy3.ml
src/jessie/ACSLtoWhy3.ml
+10
-22
src/whyml/mlw_decl.ml
src/whyml/mlw_decl.ml
+10
-10
src/whyml/mlw_dty.ml
src/whyml/mlw_dty.ml
+9
-13
src/whyml/mlw_expr.ml
src/whyml/mlw_expr.ml
+81
-111
src/whyml/mlw_expr.mli
src/whyml/mlw_expr.mli
+3
-3
src/whyml/mlw_module.ml
src/whyml/mlw_module.ml
+2
-3
src/whyml/mlw_ocaml.ml
src/whyml/mlw_ocaml.ml
+9
-11
src/whyml/mlw_pretty.ml
src/whyml/mlw_pretty.ml
+6
-9
src/whyml/mlw_pretty.mli
src/whyml/mlw_pretty.mli
+0
-1
src/whyml/mlw_ty.ml
src/whyml/mlw_ty.ml
+25
-36
src/whyml/mlw_ty.mli
src/whyml/mlw_ty.mli
+3
-10
src/whyml/mlw_typing.ml
src/whyml/mlw_typing.ml
+17
-18
src/whyml/mlw_wp.ml
src/whyml/mlw_wp.ml
+8
-8
No files found.
examples/use_api/use_api.ml
View file @
2d0fb535
...
...
@@ -259,8 +259,7 @@ let unit_type = Ty.ty_tuple []
*)
let
d
=
let
args
=
[
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
(
Mlw_ty
.
vty_value
Mlw_ty
.
ity_unit
)]
[
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
Mlw_ty
.
ity_unit
]
in
let
result
=
Term
.
create_vsymbol
(
Ident
.
id_fresh
"result"
)
unit_type
in
let
spec
=
{
...
...
@@ -337,8 +336,7 @@ let get_fun : Mlw_expr.psymbol =
let
d2
=
let
args
=
[
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
(
Mlw_ty
.
vty_value
Mlw_ty
.
ity_unit
)]
[
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
Mlw_ty
.
ity_unit
]
in
let
result
=
Term
.
create_vsymbol
(
Ident
.
id_fresh
"result"
)
Ty
.
ty_int
in
let
spec
=
{
...
...
@@ -356,14 +354,11 @@ let d2 =
(* recall that "ref" has type "(v:'a) -> ref 'a". We need to build an
instance of it *)
(* we first built a dummy effective parameter v of type int *)
let
pv
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"v"
)
(
Mlw_ty
.
vty_value
Mlw_ty
.
ity_int
)
in
let
pv
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"v"
)
Mlw_ty
.
ity_int
in
(* we build "ref int" with a *fresh* region *)
let
ity
=
Mlw_ty
.
ity_app_fresh
ref_type
[
Mlw_ty
.
ity_int
]
in
(* we build the type "(v:int) -> ref <fresh region> int)" *)
let
vta
=
Mlw_ty
.
vty_arrow
[
pv
]
(
Mlw_ty
.
VTvalue
(
Mlw_ty
.
vty_value
ity
)
)
in
let
vta
=
Mlw_ty
.
vty_arrow
[
pv
]
(
Mlw_ty
.
VTvalue
ity
)
in
(* e1 : the appropriate instance of "ref" *)
let
e1
=
Mlw_expr
.
e_arrow
ref_fun
vta
in
(* we apply it to 0 *)
...
...
@@ -381,10 +376,7 @@ let d2 =
let
bang_x
=
(* recall that "!" as type "ref 'a -> 'a" *)
(* we build a dummy parameter r of the same type as x *)
let
vta
=
Mlw_ty
.
vty_arrow
[
var_x
]
(
Mlw_ty
.
VTvalue
(
Mlw_ty
.
vty_value
Mlw_ty
.
ity_int
))
in
let
vta
=
Mlw_ty
.
vty_arrow
[
var_x
]
(
Mlw_ty
.
VTvalue
Mlw_ty
.
ity_int
)
in
let
e1
=
Mlw_expr
.
e_arrow
get_fun
vta
in
Mlw_expr
.
e_app
e1
[
Mlw_expr
.
e_value
var_x
]
in
...
...
src/jessie/ACSLtoWhy3.ml
View file @
2d0fb535
...
...
@@ -194,28 +194,21 @@ let any _ty =
let
mk_ref
ty
=
let
pv
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"a"
)
(
Mlw_ty
.
vty_value
ty
)
in
let
pv
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"a"
)
ty
in
let
ity
=
Mlw_ty
.
ity_app_fresh
ref_type
[
ty
]
in
let
vta
=
Mlw_ty
.
vty_arrow
[
pv
]
(
Mlw_ty
.
VTvalue
(
Mlw_ty
.
vty_value
ity
)
)
in
let
vta
=
Mlw_ty
.
vty_arrow
[
pv
]
(
Mlw_ty
.
VTvalue
ity
)
in
Mlw_expr
.
e_arrow
ref_fun
vta
let
mk_get
ref_ty
ty
=
let
pv
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"r"
)
ref_ty
in
let
vta
=
Mlw_ty
.
vty_arrow
[
pv
]
(
Mlw_ty
.
VTvalue
(
Mlw_ty
.
vty_value
ty
)
)
in
let
vta
=
Mlw_ty
.
vty_arrow
[
pv
]
(
Mlw_ty
.
VTvalue
ty
)
in
Mlw_expr
.
e_arrow
get_fun
vta
let
mk_set
ref_ty
ty
=
(* (:=) has type (r:ref 'a) (v:'a) unit *)
let
pv1
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"r"
)
ref_ty
in
let
pv2
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"v"
)
(
Mlw_ty
.
vty_value
ty
)
in
let
vta
=
Mlw_ty
.
vty_arrow
[
pv1
;
pv2
]
(
Mlw_ty
.
VTvalue
(
Mlw_ty
.
vty_value
Mlw_ty
.
ity_unit
))
in
let
pv2
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"v"
)
ty
in
let
vta
=
Mlw_ty
.
vty_arrow
[
pv1
;
pv2
]
(
Mlw_ty
.
VTvalue
Mlw_ty
.
ity_unit
)
in
Mlw_expr
.
e_arrow
set_fun
vta
...
...
@@ -613,7 +606,7 @@ let lval (host,offset) =
if
is_mutable
then
begin
try
Mlw_expr
.
e_app
(
mk_get
v
.
Mlw_ty
.
pv_
vtv
ty
)
(
mk_get
v
.
Mlw_ty
.
pv_
ity
ty
)
[
Mlw_expr
.
e_value
v
]
with
e
->
Self
.
fatal
"Exception raised during application of !@ %a@."
...
...
@@ -735,7 +728,7 @@ let assignment (lhost,offset) e _loc =
let
v
,
is_mutable
,
ty
=
get_var
v
in
if
is_mutable
then
Mlw_expr
.
e_app
(
mk_set
v
.
Mlw_ty
.
pv_
vtv
ty
)
(
mk_set
v
.
Mlw_ty
.
pv_
ity
ty
)
[
Mlw_expr
.
e_value
v
;
expr
e
]
else
Self
.
not_yet_implemented
"mutation of formal parameters"
...
...
@@ -796,8 +789,7 @@ let rec stmt s =
let
annots
=
Annotations
.
code_annot
s
in
let
inv
,
var
=
loop_annot
annots
in
let
v
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
(
Mlw_ty
.
vty_value
Mlw_ty
.
ity_unit
)
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
Mlw_ty
.
ity_unit
in
Mlw_expr
.
e_try
(
Mlw_expr
.
e_loop
inv
var
(
block
body
))
...
...
@@ -879,16 +871,12 @@ let fundecl fdec =
let
args
=
match
Kernel_function
.
get_formals
kf
with
|
[]
->
[
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
(
Mlw_ty
.
vty_value
Mlw_ty
.
ity_unit
)
]
[
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
"_dummy"
)
Mlw_ty
.
ity_unit
]
|
l
->
List
.
map
(
fun
v
->
let
ity
=
ctype
v
.
vtype
in
let
vs
=
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
v
.
vname
)
(
Mlw_ty
.
vty_value
ity
)
Mlw_ty
.
create_pvsymbol
(
Ident
.
id_fresh
v
.
vname
)
ity
in
Hashtbl
.
add
program_vars
v
.
vid
(
vs
,
false
,
ity
);
vs
)
...
...
src/whyml/mlw_decl.ml
View file @
2d0fb535
...
...
@@ -84,18 +84,18 @@ let rec syms_type_c s tyc =
syms_type_v s tyc.c_result
and syms_type_v s = function
| SpecV
vtv -> syms_ity s vtv.vtv_
ity
| SpecV
ity -> syms_ity s
ity
| SpecA (pvl,tyc) ->
let add_pv s pv = syms_ity s pv.pv_
vtv.vtv_
ity in
let add_pv s pv = syms_ity s pv.pv_ity in
List.fold_left add_pv (syms_type_c s tyc) pvl
let rec syms_vta s a =
let s = syms_ity s a.vta_arg
.vtv_ity
in
let s = syms_ity s a.vta_arg in
let s = syms_effect s a.vta_effect in
syms_vty s a.vta_result
and syms_vty s = function
| VTvalue
vtv -> syms_ity s vtv.vtv_
ity
| VTvalue
ity -> syms_ity s
ity
| VTarrow vta -> syms_vta s vta
let syms_expr s _e = s (* TODO *)
...
...
@@ -199,7 +199,7 @@ let check_vars vars =
raise
(
UnboundTypeVar
(
Stv
.
choose
vars
.
vars_tv
))
let
letvar_news
=
function
|
LetV
pv
->
check_vars
pv
.
pv_vars
;
Sid
.
singleton
pv
.
pv_vs
.
vs_name
|
LetV
pv
->
check_vars
pv
.
pv_
ity
.
ity_
vars
;
Sid
.
singleton
pv
.
pv_vs
.
vs_name
|
LetA
ps
->
check_vars
ps
.
ps_vars
;
Sid
.
singleton
ps
.
ps_name
let
new_regs
old_vars
news
vars
=
...
...
@@ -214,7 +214,7 @@ let create_let_decl ld =
let
news
=
letvar_news
ld
.
let_sym
in
let
news
=
match
ld
.
let_sym
with
|
LetA
ps
->
new_regs
vars
news
ps
.
ps_vars
|
LetV
pv
->
new_regs
vars
news
pv
.
pv_vars
in
|
LetV
pv
->
new_regs
vars
news
pv
.
pv_
ity
.
ity_
vars
in
let
syms
=
Mid
.
map
(
fun
_
->
()
)
ld
.
let_expr
.
e_varm
in
(*
let syms = syms_varmap Sid.empty ld.let_expr.e_vars in
...
...
@@ -247,7 +247,7 @@ let create_rec_decl fdl =
let
create_val_decl
lv
=
let
news
=
letvar_news
lv
in
let
news
,
syms
=
match
lv
with
|
LetV
pv
->
new_regs
vars_empty
news
pv
.
pv_vars
,
Sid
.
empty
|
LetV
pv
->
new_regs
vars_empty
news
pv
.
pv_
ity
.
ity_
vars
,
Sid
.
empty
|
LetA
ps
->
news
,
Mid
.
map
(
fun
_
->
()
)
ps
.
ps_varm
in
(*
let syms = syms_type_v Sid.empty vd.val_spec in
...
...
@@ -330,8 +330,8 @@ let find_invariant kn its =
let
check_match
lkn
_kn
d
=
let
rec
checkE
()
e
=
match
e
.
e_node
with
|
Ecase
(
e1
,
bl
)
->
let
typ
=
ty_of_ity
(
vtv_of_expr
e1
)
.
vtv_ity
in
let
tye
=
ty_of_ity
(
vtv_of_expr
e
)
.
vtv_ity
in
let
typ
=
ty_of_ity
(
ity_of_expr
e1
)
in
let
tye
=
ty_of_ity
(
ity_of_expr
e
)
in
let
t_p
=
t_var
(
create_vsymbol
(
id_fresh
"x"
)
typ
)
in
let
t_e
=
t_var
(
create_vsymbol
(
id_fresh
"y"
)
tye
)
in
let
bl
=
List
.
map
(
fun
(
pp
,_
)
->
[
pp
.
ppat_pattern
]
,
t_e
)
bl
in
...
...
@@ -395,7 +395,7 @@ let check_ghost lkn kn d =
let
pvs
=
List
.
fold_right
Spv
.
add
vta
.
vta_args
pvs
in
let
test
pv
=
if
pv
.
pv_ghost
then
()
else
access
eff
.
eff_ghostw
pv
.
pv_
vtv
.
vtv_
ity
access
eff
.
eff_ghostw
pv
.
pv_ity
in
Spv
.
iter
test
pvs
;
match
vta
.
vta_result
with
...
...
src/whyml/mlw_dty.ml
View file @
2d0fb535
...
...
@@ -196,9 +196,9 @@ let unify d1 d2 = unify ~weak:false d1 d2
type
dvty
=
dity
list
*
dity
(* A -> B -> C == ([A;B],C) *)
let
vty_of_dvty
(
argl
,
res
)
=
let
vt
v
=
VTvalue
(
vty_value
(
ity_of_dity
res
)
)
in
let
conv
a
=
create_pvsymbol
(
id_fresh
"x"
)
(
vty_value
(
ity_of_dity
a
)
)
in
if
argl
=
[]
then
vt
v
else
VTarrow
(
vty_arrow
(
List
.
map
conv
argl
)
vtv
)
let
vt
y
=
VTvalue
(
ity_of_dity
res
)
in
let
conv
a
=
create_pvsymbol
(
id_fresh
"x"
)
(
ity_of_dity
a
)
in
if
argl
=
[]
then
vt
y
else
VTarrow
(
vty_arrow
(
List
.
map
conv
argl
)
vty
)
type
tvars
=
dity
list
...
...
@@ -274,25 +274,21 @@ and dreg_of_reg htv hreg vars r =
Hreg
.
add
hreg
r
dreg
;
dreg
let
dity_of_vtv
htv
hreg
vars
v
=
dity_of_ity
htv
hreg
vars
v
.
vtv_ity
let
specialize_vtvalue
vtv
=
let
specialize_ity
ity
=
let
htv
=
Htv
.
create
3
and
hreg
=
Hreg
.
create
3
in
dity_of_
vtv
htv
hreg
vtv
.
vtv_ity
.
ity_vars
vtv
dity_of_
ity
htv
hreg
ity
.
ity_vars
ity
let
specialize_pvsymbol
pv
=
specialize_vtvalue
pv
.
pv_vtv
let
specialize_pvsymbol
pv
=
specialize_ity
pv
.
pv_ity
let
specialize_xsymbol
xs
=
specialize_vtvalue
(
vty_value
xs
.
xs_ity
)
let
specialize_xsymbol
xs
=
specialize_ity
xs
.
xs_ity
let
specialize_vtarrow
vars
vta
=
let
htv
=
Htv
.
create
3
and
hreg
=
Hreg
.
create
3
in
let
conv
pv
=
dity_of_
vtv
htv
hreg
vars
pv
.
pv_vtv
in
let
conv
pv
=
dity_of_
ity
htv
hreg
vars
pv
.
pv_ity
in
let
rec
specialize
a
=
let
argl
=
List
.
map
conv
a
.
vta_args
in
let
narg
,
res
=
match
a
.
vta_result
with
|
VTvalue
v
->
[]
,
dity_of_
vtv
htv
hreg
vars
v
|
VTvalue
v
->
[]
,
dity_of_
ity
htv
hreg
vars
v
|
VTarrow
a
->
specialize
a
in
argl
@
narg
,
res
...
...
src/whyml/mlw_expr.ml
View file @
2d0fb535
This diff is collapsed.
Click to expand it.
src/whyml/mlw_expr.mli
View file @
2d0fb535
...
...
@@ -61,7 +61,7 @@ val pl_clone : Theory.symbol_map -> symbol_map
type
ppattern
=
private
{
ppat_pattern
:
pattern
;
ppat_
vtv
:
vty_value
;
ppat_
ity
:
ity
;
ppat_ghost
:
bool
;
ppat_effect
:
effect
;
}
...
...
@@ -75,7 +75,7 @@ type pre_ppattern =
|
PPas
of
pre_ppattern
*
preid
val
make_ppattern
:
pre_ppattern
->
?
ghost
:
bool
->
vty_value
->
pvsymbol
Mstr
.
t
*
ppattern
pre_ppattern
->
?
ghost
:
bool
->
ity
->
pvsymbol
Mstr
.
t
*
ppattern
(** program symbols *)
...
...
@@ -194,7 +194,7 @@ val e_arrow : psymbol -> vty_arrow -> expr
exception
ValueExpected
of
expr
exception
ArrowExpected
of
expr
val
vtv_of_expr
:
expr
->
vty_value
val
ity_of_expr
:
expr
->
ity
val
vta_of_expr
:
expr
->
vty_arrow
exception
GhostWrite
of
expr
*
region
...
...
src/whyml/mlw_module.ml
View file @
2d0fb535
...
...
@@ -416,10 +416,9 @@ let clone_export uc m inst =
let
nr
=
create_region
(
id_clone
r
.
reg_name
)
(
conv_ity
r
.
reg_ity
)
in
Hreg
.
replace
regh
r
nr
;
nr
in
let
conv_vtv
v
=
vty_value
(
conv_ity
v
.
vtv_ity
)
in
let
conv_pv
pv
=
create_pvsymbol
(
id_clone
pv
.
pv_vs
.
vs_name
)
~
ghost
:
pv
.
pv_ghost
(
conv_
vtv
pv
.
pv_vtv
)
in
~
ghost
:
pv
.
pv_ghost
(
conv_
ity
pv
.
pv_ity
)
in
let
psh
=
Hid
.
create
3
in
let
conv_xs
xs
=
try
match
Hid
.
find
psh
xs
.
xs_name
with
|
XS
xs
->
xs
|
_
->
assert
false
with
Not_found
->
xs
in
...
...
@@ -455,7 +454,7 @@ let clone_export uc m inst =
let
spec
=
conv_spec
mv
a
.
vta_spec
in
let
vty
=
match
a
.
vta_result
with
|
VTarrow
a
->
VTarrow
(
conv_vta
mv
a
)
|
VTvalue
v
->
VTvalue
(
conv_
vtv
v
)
in
|
VTvalue
v
->
VTvalue
(
conv_
ity
v
)
in
vty_arrow
args
~
spec
vty
in
let
mvs
=
ref
(
Mvs
.
singleton
Mlw_wp
.
pv_old
.
pv_vs
Mlw_wp
.
pv_old
.
pv_vs
)
in
let
add_pdecl
uc
d
=
{
uc
with
...
...
src/whyml/mlw_ocaml.ml
View file @
2d0fb535
...
...
@@ -664,20 +664,18 @@ let rec print_ity_node inn info fmt ity = match ity.ity_node with
let
print_ity
info
=
print_ity_node
false
info
let
print_vtv
info
fmt
vtv
=
print_ity
info
fmt
vtv
.
vtv_ity
let
print_pvty
info
fmt
pv
=
if
pv
.
pv_ghost
then
fprintf
fmt
"((* ghost *))"
else
fprintf
fmt
"@[(%a:@ %a)@]"
(
print_lident
info
)
pv
.
pv_vs
.
vs_name
(
print_
vtv
info
)
pv
.
pv_vtv
(
print_lident
info
)
pv
.
pv_vs
.
vs_name
(
print_
ity
info
)
pv
.
pv_ity
let
rec
print_vta
info
fmt
vta
=
let
print_arg
fmt
pv
=
print_
vtv
info
fmt
pv
.
pv_vtv
in
let
print_arg
fmt
pv
=
print_
ity
info
fmt
pv
.
pv_ity
in
fprintf
fmt
"(%a -> %a)"
(
print_list
arrow
print_arg
)
vta
.
vta_args
(
print_vty
info
)
vta
.
vta_result
and
print_vty
info
fmt
=
function
|
VTvalue
vtv
->
print_vtv
info
fmt
vtv
|
VTvalue
ity
->
print_ity
info
fmt
ity
|
VTarrow
vta
->
print_vta
info
fmt
vta
let
is_letrec
=
function
...
...
@@ -705,11 +703,11 @@ and print_lexpr pri info fmt e =
|
Elet
({
let_expr
=
e1
}
,
e2
)
when
e1
.
e_ghost
->
print_expr
info
fmt
e2
|
Elet
({
let_sym
=
LetV
pv
}
,
e2
)
when
ity_equal
pv
.
pv_
vtv
.
vtv_
ity
ity_mark
->
when
ity_equal
pv
.
pv_ity
ity_mark
->
print_expr
info
fmt
e2
|
Elet
({
let_sym
=
LetV
pv
;
let_expr
=
e1
}
,
e2
)
when
pv
.
pv_vs
.
vs_name
.
id_string
=
"_"
&&
ity_equal
pv
.
pv_
vtv
.
vtv_
ity
ity_unit
->
ity_equal
pv
.
pv_ity
ity_unit
->
fprintf
fmt
(
protect_on
(
pri
>
0
)
"@[begin %a;@ %a end@]"
)
(
print_expr
info
)
e1
(
print_expr
info
)
e2
;
|
Elet
({
let_sym
=
lv
;
let_expr
=
e1
}
,
e2
)
->
...
...
@@ -835,19 +833,19 @@ let rec extract_vta_args args vta =
let
new_args
=
List
.
map
(
fun
pv
->
pv
.
pv_vs
)
vta
.
vta_args
in
let
args
=
List
.
rev_append
new_args
args
in
match
vta
.
vta_result
with
|
VTvalue
vtv
->
List
.
rev
args
,
vtv
|
VTvalue
ity
->
List
.
rev
args
,
ity
|
VTarrow
vta
->
extract_vta_args
args
vta
let
extract_lv_args
=
function
|
LetV
pv
->
[]
,
pv
.
pv_
vtv
|
LetV
pv
->
[]
,
pv
.
pv_
ity
|
LetA
ps
->
extract_vta_args
[]
ps
.
ps_vta
let
print_val_decl
info
fmt
lv
=
let
vars
,
vtv
=
extract_lv_args
lv
in
let
vars
,
ity
=
extract_lv_args
lv
in
fprintf
fmt
"@[<hov 2>let %a %a : %a =@ %a@]"
(
print_lv
info
)
lv
(
print_list
space
(
print_vs_arg
info
))
vars
(
print_
vtv
info
)
vtv
(
print_
ity
info
)
ity
to_be_implemented
"val"
;
forget_vars
vars
;
forget_tvs
()
...
...
src/whyml/mlw_pretty.ml
View file @
2d0fb535
...
...
@@ -124,20 +124,17 @@ let print_effect fmt eff =
Sexn
.
iter
(
print_xs
"ghost raise"
)
eff
.
eff_ghostx
;
Mreg
.
iter
print_reset
eff
.
eff_resets
let
print_vtv
fmt
vtv
=
fprintf
fmt
"%a"
print_ity
vtv
.
vtv_ity
let
rec
print_vta
fmt
vta
=
let
print_arg
fmt
pv
=
fprintf
fmt
"%a ->@ "
print_
vtv
pv
.
pv_vtv
in
let
print_arg
fmt
pv
=
fprintf
fmt
"%a ->@ "
print_
ity
pv
.
pv_ity
in
fprintf
fmt
"%a%a%a"
(
print_list
nothing
print_arg
)
vta
.
vta_args
print_effect
vta
.
vta_spec
.
c_effect
print_vty
vta
.
vta_result
and
print_vty
fmt
=
function
|
VTarrow
vta
->
print_vta
fmt
vta
|
VTvalue
vtv
->
print_vtv
fmt
vtv
|
VTvalue
ity
->
print_ity
fmt
ity
let
print_pvty
fmt
pv
=
fprintf
fmt
"@[%a:@,%a@]"
print_pv
pv
print_
vtv
pv
.
pv_vtv
print_pv
pv
print_
ity
pv
.
pv_ity
let
print_psty
fmt
ps
=
let
print_tvs
fmt
tvs
=
if
not
(
Stv
.
is_empty
tvs
)
then
...
...
@@ -167,7 +164,7 @@ let forget_lv = function
|
LetA
ps
->
forget_ps
ps
let
rec
print_type_v
fmt
=
function
|
VTvalue
vtv
->
print_vtv
fmt
vtv
|
VTvalue
ity
->
print_ity
fmt
ity
|
VTarrow
vta
->
let
print_arg
fmt
pv
=
fprintf
fmt
"@[(%a)@] ->@ "
print_pvty
pv
in
fprintf
fmt
"%a%a"
...
...
@@ -271,7 +268,7 @@ and print_enode pri fmt e = match e.e_node with
fprintf
fmt
"(%a@ %a)"
(
print_lexpr
pri
)
e
print_pv
v
|
Elet
({
let_sym
=
LetV
pv
;
let_expr
=
e1
}
,
e2
)
when
pv
.
pv_vs
.
vs_name
.
id_string
=
"_"
&&
ity_equal
pv
.
pv_
vtv
.
vtv_
ity
ity_unit
->
ity_equal
pv
.
pv_ity
ity_unit
->
fprintf
fmt
(
protect_on
(
pri
>
0
)
"%a;@
\n
%a"
)
print_expr
e1
print_expr
e2
;
|
Elet
({
let_sym
=
lv
;
let_expr
=
e1
}
,
e2
)
->
...
...
@@ -398,7 +395,7 @@ let print_data_decl fst fmt (ts,csl,inv) =
let
print_val_decl
fmt
lv
=
let
vty
=
match
lv
with
|
LetV
pv
->
VTvalue
pv
.
pv_
vtv
|
LetA
ps
->
VTarrow
ps
.
ps_vta
in
|
LetV
pv
->
VTvalue
pv
.
pv_
ity
|
LetA
ps
->
VTarrow
ps
.
ps_vta
in
fprintf
fmt
"@[<hov 2>val (%a) :@ %a@]"
print_lv
lv
print_type_v
vty
;
(* FIXME: forget only generalized regions *)
match
lv
with
LetA
_
->
forget_tvs_regs
()
|
_
->
()
...
...
src/whyml/mlw_pretty.mli
View file @
2d0fb535
...
...
@@ -29,7 +29,6 @@ val print_reg : formatter -> region -> unit (* region *)
val
print_its
:
formatter
->
itysymbol
->
unit
(* type symbol *)
val
print_ity
:
formatter
->
ity
->
unit
(* individual type *)
val
print_vtv
:
formatter
->
vty_value
->
unit
(* value type *)
val
print_vta
:
formatter
->
vty_arrow
->
unit
(* arrow type *)
val
print_vty
:
formatter
->
vty
->
unit
(* expression type *)
...
...
src/whyml/mlw_ty.ml
View file @
2d0fb535
...
...
@@ -786,19 +786,10 @@ let spec_check c ty =
(** program variables *)
type
vty_value
=
{
vtv_ity
:
ity
;
}
let
vty_value
ity
=
{
vtv_ity
=
ity
;
}
let
vtv_vars
vtv
=
vtv
.
vtv_ity
.
ity_vars
type
pvsymbol
=
{
pv_vs
:
vsymbol
;
pv_
vtv
:
vty_value
;
pv_
ity
:
ity
;
pv_ghost
:
bool
;
pv_vars
:
varset
;
}
module
PVsym
=
MakeMSHW
(
struct
...
...
@@ -813,17 +804,16 @@ module Wpv = PVsym.W
let
pv_equal
:
pvsymbol
->
pvsymbol
->
bool
=
(
==
)
let
create_pvsymbol
id
ghost
vtv
=
{
pv_vs
=
create_vsymbol
id
(
ty_of_ity
vtv
.
vtv_
ity
);
pv_
vtv
=
vtv
;
let
create_pvsymbol
id
ghost
ity
=
{
pv_vs
=
create_vsymbol
id
(
ty_of_ity
ity
);
pv_
ity
=
ity
;
pv_ghost
=
ghost
;
pv_vars
=
vtv_vars
vtv
;
}
let
create_pvsymbol
,
restore_pv
,
restore_pv_by_id
=
let
id_to_pv
=
Wid
.
create
17
in
(
fun
id
?
(
ghost
=
false
)
vtv
->
let
pv
=
create_pvsymbol
id
ghost
vtv
in
(
fun
id
?
(
ghost
=
false
)
ity
->
let
pv
=
create_pvsymbol
id
ghost
ity
in
Wid
.
set
id_to_pv
pv
.
pv_vs
.
vs_name
pv
;
pv
)
,
(
fun
vs
->
Wid
.
find
id_to_pv
vs
.
vs_name
)
,
...
...
@@ -832,7 +822,7 @@ let create_pvsymbol, restore_pv, restore_pv_by_id =
(** program types *)
type
vty
=
|
VTvalue
of
vty_value
|
VTvalue
of
ity
|
VTarrow
of
vty_arrow
and
vty_arrow
=
{
...
...
@@ -842,19 +832,19 @@ and vty_arrow = {
}
let
rec
vta_vars
vta
=
let
add_arg
vars
pv
=
vars_union
vars
pv
.
pv_vars
in
let
add_arg
vars
pv
=
vars_union
vars
pv
.
pv_
ity
.
ity_
vars
in
List
.
fold_left
add_arg
(
vty_vars
vta
.
vta_result
)
vta
.
vta_args
and
vty_vars
=
function
|
VTvalue
vtv
->
vtv_vars
vtv
|
VTvalue
ity
->
ity
.
ity_vars
|
VTarrow
vta
->
vta_vars
vta
let
ity_of_vty
=
function
|
VTvalue
vtv
->
vtv
.
vtv_
ity
|
VTvalue
ity
->
ity
|
VTarrow
_
->
ity_unit
let
ty_of_vty
=
function
|
VTvalue
vtv
->
ty_of_ity
vtv
.
vtv_
ity
|
VTvalue
ity
->
ty_of_ity
ity
|
VTarrow
_
->
ty_unit
let
spec_check
spec
vty
=
spec_check
spec
(
ty_of_vty
vty
)
...
...
@@ -884,27 +874,25 @@ let vty_arrow argl ?spec vty =
in .vta_vars are matched. The caller should supply a "freezing"
substitution that covers all external type variables and regions. *)
let
rec
vta_vars_match
s
a1
a2
=
let
vtv_match
s
v1
v2
=
ity_match
s
v1
.
vtv_ity
v2
.
vtv_ity
in
let
rec
match_args
s
l1
l2
=
match
l1
,
l2
with
|
[]
,
[]
->
s
,
a1
.
vta_result
,
a2
.
vta_result
|
[]
,
_
->
s
,
a1
.
vta_result
,
VTarrow
{
a2
with
vta_args
=
l2
}
|
_
,
[]
->
s
,
VTarrow
{
a1
with
vta_args
=
l1
}
,
a2
.
vta_result
|
{
pv_
vtv
=
v1
}
::
l1
,
{
pv_vtv
=
v2
}
::
l2
->
match_args
(
vtv
_match
s
v1
v2
)
l1
l2
|
{
pv_
ity
=
v1
}
::
l1
,
{
pv_ity
=
v2
}
::
l2
->
match_args
(
ity
_match
s
v1
v2
)
l1
l2
in
let
s
,
vty1
,
vty2
=
match_args
s
a1
.
vta_args
a2
.
vta_args
in
match
vty1
,
vty2
with
|
VTarrow
a1
,
VTarrow
a2
->
vta_vars_match
s
a1
a2
|
VTvalue
v1
,
VTvalue
v2
->
vtv
_match
s
v1
v2
|
VTvalue
v1
,
VTvalue
v2
->
ity
_match
s
v1
v2
|
_
->
invalid_arg
"Mlw_ty.vta_vars_match"
(* the substitution must cover not only vta.vta_tvs and vta.vta_regs
but also every type variable and every region in vta_spec *)
let
vta_full_inst
sbs
vta
=
let
tvm
=
Mtv
.
map
ty_of_ity
sbs
.
ity_subst_tv
in
let
vtv_inst
{
vtv_ity
=
ity
}
=
vty_value
(
ity_full_inst
sbs
ity
)
in
let
pv_inst
{
pv_vs
=
vs
;
pv_vtv
=
vtv
;
pv_ghost
=
ghost
}
=
create_pvsymbol
(
id_clone
vs
.
vs_name
)
~
ghost
(
vtv_inst
vtv
)
in
let
pv_inst
{
pv_vs
=
vs
;
pv_ity
=
ity
;
pv_ghost
=
ghost
}
=
create_pvsymbol
(
id_clone
vs
.
vs_name
)
~
ghost
(
ity_full_inst
sbs
ity
)
in
let
add_arg
vsm
pv
=
let
nv
=
pv_inst
pv
in
Mvs
.
add
pv
.
pv_vs
(
t_var
nv
.
pv_vs
)
vsm
,
nv
in
...
...
@@ -913,7 +901,7 @@ let vta_full_inst sbs vta =
let
spec
=
spec_full_inst
sbs
tvm
vsm
vta
.
vta_spec
in
let
vty
=
match
vta
.
vta_result
with
|
VTarrow
vta
->
VTarrow
(
vta_inst
vsm
vta
)
|
VTvalue
vtv
->
VTvalue
(
vtv_inst
vtv
)
in
|
VTvalue
ity
->
VTvalue
(
ity_full_inst
sbs
ity
)
in
vty_arrow_unsafe
args
spec
vty
in
vta_inst
Mvs
.
empty
vta
...
...
@@ -921,8 +909,8 @@ let vta_full_inst sbs vta =
(* remove from the given arrow every effect that is covered
neither by the arrow's vta_vars nor by the given varmap *)
let
rec
vta_filter
varm
vars
vta
=
let
add_m
pv
m
=
Mid
.
add
pv
.
pv_vs
.
vs_name
pv
.
pv_vars
m
in
let
add_s
pv
s
=
vars_union
pv
.
pv_vars
s
in
let
add_m
pv
m
=
Mid
.
add
pv
.
pv_vs
.
vs_name
pv
.
pv_
ity
.
ity_
vars
m
in
let
add_s
pv
s
=
vars_union
pv
.
pv_
ity
.
ity_
vars
s
in
let
varm
=
List
.
fold_right
add_m
vta
.
vta_args
varm
in
let
vars
=
List
.
fold_right
add_s
vta
.
vta_args
vars
in
let
vty
=
match
vta
.
vta_result
with
...
...
@@ -942,7 +930,7 @@ let rec vta_filter varm vars vta =
let
spec
=
match
vta
.
vta_result
with
|
VTvalue
v
->
let
on_reg
r
e
=
if
reg_occurs
r
vars
then
e
else
eff_reset
e
r
in
let
eff
=
reg_fold
on_reg
v
.
vtv_ity
.
ity_vars
spec
.
c_effect
in
let
eff
=
reg_fold
on_reg
v
.
ity_vars
spec
.
c_effect
in
{
spec
with
c_effect
=
eff
}
|
VTarrow
_
->
spec
in
vty_arrow_unsafe
vta
.
vta_args
spec
vty
...
...
@@ -951,10 +939,9 @@ let vta_filter varm vta =
vta_filter
varm
(
vars_merge
varm
vars_empty
)
vta
let
vta_app
vta
pv
=
let
vtv
=
pv
.
pv_vtv
in
let
arg
,
rest
=
match
vta
.
vta_args
with
|
arg
::
rest
->
arg
,
rest
|
_
->
assert
false
in
ity_equal_check
arg
.
pv_
vtv
.
vtv_ity
vtv
.
vt
v_ity
;
ity_equal_check
arg
.
pv_
ity
pv
.
p
v_ity
;
let
sbs
=
Mvs
.
singleton
arg
.
pv_vs
(
t_var
pv
.
pv_vs
)
in
let
rec
vty_subst
=
function
|
VTarrow
a
when
not
(
List
.
exists
(
pv_equal
arg
)
a
.
vta_args
)
->
...
...
@@ -967,5 +954,7 @@ let vta_app vta pv =
if
not
pv
.
pv_ghost
&&
arg
.
pv_ghost
then
Loc
.
errorm
"non-ghost value passed as a ghost argument"
;
let
ghost
=
pv
.
pv_ghost
&&
not
arg
.
pv_ghost
in
if
rest
=
[]
then
spec
,
ghost
,
result
else
spec_empty
ty_unit
,
ghost
,
VTarrow
(
vty_arrow_unsafe
rest
spec
result
)
if
rest
=
[]
then
spec
,
ghost
,
result
else
spec_empty
ty_unit
,
ghost
,
VTarrow
(
vty_arrow_unsafe
rest
spec
result
)
src/whyml/mlw_ty.mli
View file @
2d0fb535
...
...
@@ -254,17 +254,10 @@ type spec = {
(** program variables *)
type
vty_value
=
private
{
vtv_ity
:
ity
;
}
val
vty_value
:
ity
->
vty_value
type
pvsymbol
=
private
{
pv_vs
:
vsymbol
;
pv_
vtv
:
vty_value
;
pv_
ity
:
ity
;
pv_ghost
:
bool
;
pv_vars
:
varset
;
}
module
Mpv
:
Extmap
.
S
with
type
key
=
pvsymbol
...
...
@@ -274,7 +267,7 @@ module Wpv : Weakhtbl.S with type key = pvsymbol
val
pv_equal
:
pvsymbol
->
pvsymbol
->
bool
val
create_pvsymbol
:
preid
->
?
ghost
:
bool
->
vty_value
->
pvsymbol
val
create_pvsymbol
:
preid
->
?
ghost
:
bool
->
ity
->
pvsymbol
val
restore_pv
:
vsymbol
->
pvsymbol
(* raises Not_found if the argument is not a pv_vs *)
...
...
@@ -285,7 +278,7 @@ val restore_pv_by_id : ident -> pvsymbol
(** program types *)
type
vty
=
|
VTvalue
of
vty_value
|
VTvalue
of
ity
|
VTarrow
of
vty_arrow
and
vty_arrow
=
private
{
...
...
src/whyml/mlw_typing.ml
View file @
2d0fb535
...
...
@@ -886,7 +886,7 @@ let env_invariant lenv eff pvs =
let
lkn
=
Theory
.
get_known
(
get_theory
lenv
.
mod_uc
)
in
let
regs
=
Sreg
.
union
eff
.
eff_writes
eff
.
eff_ghostw
in
let
add_pv
pv
(
pinv
,
qinv
)
=
let
ity
=
pv
.
pv_
vtv
.
vtv_
ity
in
let
ity
=
pv
.
pv_ity
in
let
written
r
=
reg_occurs
r
ity
.
ity_vars
in
let
inv
=
Mlw_wp
.
full_invariant
lkn
kn
pv
.
pv_vs
ity
in
let
qinv
=
(* we reprove invariants for modified non-reset variables *)
...
...
@@ -918,12 +918,12 @@ let post_invariant lenv rvs inv ity q =
Mlw_ty
.
create_post
vs
q
let
ity_or_unit
=
function