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
125
Issues
125
List
Boards
Labels
Service Desk
Milestones
Merge Requests
16
Merge Requests
16
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
811ab575
Commit
811ab575
authored
Jun 23, 2012
by
Andrei Paskevich
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
whyml: ghost variables, functions, and expressions
parent
57635caf
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
184 additions
and
108 deletions
+184
-108
src/parser/parser.mly
src/parser/parser.mly
+61
-37
src/parser/ptree.ml
src/parser/ptree.ml
+13
-11
src/programs/pgm_typing.ml
src/programs/pgm_typing.ml
+22
-9
src/whyml/mlw_dtree.ml
src/whyml/mlw_dtree.ml
+2
-2
src/whyml/mlw_ty.ml
src/whyml/mlw_ty.ml
+5
-5
src/whyml/mlw_typing.ml
src/whyml/mlw_typing.ml
+75
-38
tests/test-pgm-jcf.mlx
tests/test-pgm-jcf.mlx
+6
-6
No files found.
src/parser/parser.mly
View file @
811ab575
...
...
@@ -167,6 +167,13 @@ end
let
empty_effect
=
{
pe_reads
=
[]
;
pe_writes
=
[]
;
pe_raises
=
[]
}
let
effect_union
e1
e2
=
let
{
pe_reads
=
r1
;
pe_writes
=
w1
;
pe_raises
=
x1
}
=
e1
in
let
{
pe_reads
=
r2
;
pe_writes
=
w2
;
pe_raises
=
x2
}
=
e2
in
{
pe_reads
=
r1
@
r2
;
pe_writes
=
w1
@
w2
;
pe_raises
=
x1
@
x2
}
let
effect_exprs
ghost
l
=
List
.
map
(
fun
x
->
(
ghost
,
x
))
l
let
type_c
p
ty
ef
q
=
{
pc_result_type
=
ty
;
pc_effect
=
ef
;
...
...
@@ -245,7 +252,7 @@ end
%
nonassoc
IN
%
right
SEMICOLON
%
nonassoc
prec_no_else
%
nonassoc
DOT
ELSE
%
nonassoc
DOT
ELSE
GHOST
%
nonassoc
prec_named
%
nonassoc
COLON
...
...
@@ -1053,17 +1060,16 @@ program_decl:
{
Dlogic
$
1
}
|
use_clone
{
Duseclone
$
1
}
|
LET
lident_rich_pgm
labels
list1_type_v_binder
opt_cast
EQUAL
triple
{
Dlet
(
add_lab
$
2
$
3
,
mk_expr_i
7
(
Efun
(
$
4
,
cast_body
$
5
$
7
)))
}
|
LET
lident_rich_pgm
labels
EQUAL
FUN
list1_type_v_binder
ARROW
triple
{
Dlet
(
add_lab
$
2
$
3
,
mk_expr_i
8
(
Efun
(
$
6
,
$
8
)))
}
|
LET
ghost
lident_rich_pgm
labels
list1_type_v_binder
opt_cast
EQUAL
triple
{
Dlet
(
add_lab
$
3
$
4
,
$
2
,
mk_expr_i
8
(
Efun
(
$
5
,
cast_body
$
6
$
8
)))
}
|
LET
ghost
lident_rich_pgm
labels
EQUAL
FUN
list1_type_v_binder
ARROW
triple
{
Dlet
(
add_lab
$
3
$
4
,
$
2
,
mk_expr_i
9
(
Efun
(
$
7
,
$
9
)))
}
|
LET
REC
list1_recfun_sep_and
{
Dletrec
$
3
}
|
VAL
lident_rich_pgm
labels
COLON
type_v
{
Dparam
(
add_lab
$
2
$
3
,
$
5
)
}
|
VAL
lident_rich_pgm
labels
list1_type_v_param
COLON
type_c
{
let
tv
=
Tarrow
(
$
4
,
$
6
)
in
Dparam
(
add_lab
$
2
$
3
,
tv
)
}
|
VAL
ghost
lident_rich_pgm
labels
COLON
type_v
{
Dparam
(
add_lab
$
3
$
4
,
$
2
,
$
6
)
}
|
VAL
ghost
lident_rich_pgm
labels
list1_type_v_param
COLON
type_c
{
Dparam
(
add_lab
$
3
$
4
,
$
2
,
Tarrow
(
$
5
,
$
7
))
}
|
EXCEPTION
uident
labels
{
Dexn
(
add_lab
$
2
$
3
,
None
)
}
|
EXCEPTION
uident
labels
primitive_type
...
...
@@ -1099,8 +1105,9 @@ list1_recfun_sep_and:
;
recfun
:
|
lident_rich_pgm
labels
list1_type_v_binder
opt_cast
opt_variant
EQUAL
triple
{
add_lab
$
1
$
2
,
$
3
,
$
5
,
cast_body
$
4
$
7
}
|
ghost
lident_rich_pgm
labels
list1_type_v_binder
opt_cast
opt_variant
EQUAL
triple
{
add_lab
$
2
$
3
,
$
1
,
$
4
,
$
6
,
cast_body
$
5
$
8
}
;
expr
:
...
...
@@ -1152,10 +1159,16 @@ expr:
{
mk_expr
(
Elazy
(
LazyOr
,
$
1
,
$
3
))
}
|
LET
pattern
EQUAL
expr
IN
expr
{
match
$
2
.
pat_desc
with
|
PPpvar
id
->
mk_expr
(
Elet
(
id
,
$
4
,
$
6
))
|
_
->
mk_expr
(
Ematch
(
$
4
,
[
$
2
,
$
6
]))
}
|
PPpvar
id
->
mk_expr
(
Elet
(
id
,
false
,
$
4
,
$
6
))
|
_
->
mk_expr
(
Ematch
(
$
4
,
[
$
2
,
$
6
]))
}
|
LET
GHOST
pattern
EQUAL
expr
IN
expr
{
match
$
3
.
pat_desc
with
|
PPpvar
id
->
mk_expr
(
Elet
(
id
,
true
,
$
5
,
$
7
))
|
_
->
Loc
.
errorm
~
loc
:
(
floc_i
3
)
"`ghost' cannot come before a pattern"
}
|
LET
lident
labels
list1_type_v_binder
EQUAL
triple
IN
expr
{
mk_expr
(
Elet
(
add_lab
$
2
$
3
,
mk_expr_i
6
(
Efun
(
$
4
,
$
6
))
,
$
8
))
}
{
mk_expr
(
Elet
(
add_lab
$
2
$
3
,
false
,
mk_expr_i
6
(
Efun
(
$
4
,
$
6
))
,
$
8
))
}
|
LET
GHOST
lident
labels
list1_type_v_binder
EQUAL
triple
IN
expr
{
mk_expr
(
Elet
(
add_lab
$
3
$
4
,
true
,
mk_expr_i
7
(
Efun
(
$
5
,
$
7
))
,
$
9
))
}
|
LET
REC
list1_recfun_sep_and
IN
expr
{
mk_expr
(
Eletrec
(
$
3
,
$
5
))
}
|
FUN
list1_type_v_binder
ARROW
triple
...
...
@@ -1190,6 +1203,8 @@ expr:
{
mk_expr
(
Etry
(
$
2
,
$
5
))
}
|
ANY
simple_type_c
{
mk_expr
(
Eany
$
2
)
}
|
GHOST
expr
{
mk_expr
(
Eghost
$
2
)
}
|
ABSTRACT
expr
post
{
mk_expr
(
Eabstract
(
$
2
,
$
3
))
}
|
label
expr
%
prec
prec_named
...
...
@@ -1309,17 +1324,17 @@ list1_type_v_param:
;
type_v_binder
:
|
lident
labels
{
[
add_lab
$
1
$
2
,
None
]
}
|
ghost
lident
labels
{
[
add_lab
$
2
$
3
,
$
1
,
None
]
}
|
type_v_param
{
$
1
}
;
type_v_param
:
|
LEFTPAR
RIGHTPAR
{
[
id_anonymous
()
,
Some
(
ty_unit
()
)]
}
|
LEFTPAR
lidents_lab
COLON
primitive_type
RIGHTPAR
{
List
.
map
(
fun
i
->
(
i
,
Some
$
4
))
$
2
}
{
[
id_anonymous
()
,
false
,
Some
(
ty_unit
()
)]
}
|
LEFTPAR
ghost
lidents_lab
COLON
primitive_type
RIGHTPAR
{
List
.
map
(
fun
i
->
(
i
,
$
2
,
Some
$
5
))
$
3
}
;
lidents_lab
:
...
...
@@ -1335,9 +1350,13 @@ type_v:
arrow_type_v
:
|
primitive_type
ARROW
type_c
{
Tarrow
([
id_anonymous
()
,
Some
$
1
]
,
$
3
)
}
{
Tarrow
([
id_anonymous
()
,
false
,
Some
$
1
]
,
$
3
)
}
|
GHOST
primitive_type
ARROW
type_c
{
Tarrow
([
id_anonymous
()
,
true
,
Some
$
2
]
,
$
4
)
}
|
lident
labels
COLON
primitive_type
ARROW
type_c
{
Tarrow
([
add_lab
$
1
$
2
,
Some
$
4
]
,
$
6
)
}
{
Tarrow
([
add_lab
$
1
$
2
,
false
,
Some
$
4
]
,
$
6
)
}
|
GHOST
lident
labels
COLON
primitive_type
ARROW
type_c
{
Tarrow
([
add_lab
$
2
$
3
,
true
,
Some
$
5
]
,
$
7
)
}
/*
TODO
:
we
could
alllow
lidents
instead
,
e
.
g
.
x
y
:
int
->
...
*/
/*
{
Tarrow
(
List
.
map
(
fun
x
->
x
,
Some
$
3
)
$
1
,
$
5
)
}
*/
;
...
...
@@ -1392,23 +1411,23 @@ post_exn:
;
effects
:
|
opt_reads
opt_writes
opt_raises
{
{
pe_reads
=
$
1
;
pe_writes
=
$
2
;
pe_raises
=
$
3
}
}
|
/*
epsilon
*/
{
empty_effect
}
|
effect
effects
{
effect_union
$
1
$
2
}
;
opt_reads
:
|
/*
epsilon
*/
{
[]
}
|
READS
list1_lexpr_arg
{
$
2
}
;
opt_writes
:
|
/*
epsilon
*/
{
[]
}
|
WRITES
list1_lexpr_arg
{
$
2
}
;
opt_raises
:
|
/*
epsilon
*/
{
[]
}
|
RAISES
list1_uqualid
{
$
2
}
effect
:
|
READS
list1_lexpr_arg
{
{
pe_reads
=
effect_exprs
false
$
2
;
pe_writes
=
[]
;
pe_raises
=
[]
}
}
|
WRITES
list1_lexpr_arg
{
{
pe_writes
=
effect_exprs
false
$
2
;
pe_reads
=
[]
;
pe_raises
=
[]
}
}
|
RAISES
list1_uqualid
{
{
pe_raises
=
effect_exprs
false
$
2
;
pe_writes
=
[]
;
pe_reads
=
[]
}
}
|
GHOST
READS
list1_lexpr_arg
{
{
pe_reads
=
effect_exprs
true
$
3
;
pe_writes
=
[]
;
pe_raises
=
[]
}
}
|
GHOST
WRITES
list1_lexpr_arg
{
{
pe_writes
=
effect_exprs
true
$
3
;
pe_reads
=
[]
;
pe_raises
=
[]
}
}
|
GHOST
RAISES
list1_uqualid
{
{
pe_raises
=
effect_exprs
true
$
3
;
pe_writes
=
[]
;
pe_reads
=
[]
}
}
;
opt_variant
:
...
...
@@ -1427,6 +1446,11 @@ list1_uqualid:
|
uqualid
list1_uqualid
{
$
1
::
$
2
}
;
ghost
:
|
/*
epsilon
*/
{
false
}
|
GHOST
{
true
}
;
/*
Local
Variables
:
compile
-
command
:
"unset LANG; make -C ../.."
...
...
src/parser/ptree.ml
View file @
811ab575
...
...
@@ -186,17 +186,19 @@ type loop_annotation = {
type
for_direction
=
To
|
Downto
type
ghost
=
bool
type
effect
=
{
pe_reads
:
lexpr
list
;
pe_writes
:
lexpr
list
;
pe_raises
:
qualid
list
;
pe_reads
:
(
ghost
*
lexpr
)
list
;
pe_writes
:
(
ghost
*
lexpr
)
list
;
pe_raises
:
(
ghost
*
qualid
)
list
;
}
type
pre
=
lexpr
type
post
=
lexpr
*
(
qualid
*
lexpr
)
list
type
binder
=
ident
*
pty
option
type
binder
=
ident
*
ghost
*
pty
option
type
type_v
=
|
Tpure
of
pty
...
...
@@ -219,8 +221,9 @@ and expr_desc =
|
Eident
of
qualid
|
Eapply
of
expr
*
expr
|
Efun
of
binder
list
*
triple
|
Elet
of
ident
*
expr
*
expr
|
Eletrec
of
(
ident
*
binder
list
*
variant
option
*
triple
)
list
*
expr
|
Elet
of
ident
*
ghost
*
expr
*
expr
|
Eletrec
of
(
ident
*
ghost
*
binder
list
*
variant
option
*
triple
)
list
*
expr
|
Etuple
of
expr
list
|
Erecord
of
(
qualid
*
expr
)
list
|
Eupdate
of
expr
*
(
qualid
*
expr
)
list
...
...
@@ -241,19 +244,18 @@ and expr_desc =
|
Emark
of
ident
*
expr
|
Ecast
of
expr
*
pty
|
Eany
of
type_c
|
Eghost
of
expr
|
Eabstract
of
expr
*
post
|
Enamed
of
label
*
expr
(* TODO: ghost *)
and
triple
=
pre
*
expr
*
post
type
program_decl
=
|
Dlet
of
ident
*
expr
|
Dletrec
of
(
ident
*
binder
list
*
variant
option
*
triple
)
list
|
Dlet
of
ident
*
ghost
*
expr
|
Dletrec
of
(
ident
*
ghost
*
binder
list
*
variant
option
*
triple
)
list
|
Dlogic
of
decl
|
Duseclone
of
use_clone
|
Dparam
of
ident
*
type_v
|
Dparam
of
ident
*
ghost
*
type_v
|
Dexn
of
ident
*
pty
option
(* modules *)
|
Duse
of
qualid
*
bool
option
*
(*as:*)
string
option
...
...
src/programs/pgm_typing.ml
View file @
811ab575
...
...
@@ -248,12 +248,17 @@ let dexception uc qid =
print_dty
ty
;
r
let
no_ghost
gh
=
if
gh
then
errorm
"ghost types are not supported in this version of WhyML"
let
eff_no_ghost
l
=
List
.
map
(
fun
(
gh
,
x
)
->
no_ghost
gh
;
x
)
l
let
dueffect
env
e
=
{
du_reads
=
e
.
Ptree
.
pe_reads
;
du_writes
=
e
.
Ptree
.
pe_writes
;
{
du_reads
=
e
ff_no_ghost
e
.
Ptree
.
pe_reads
;
du_writes
=
e
ff_no_ghost
e
.
Ptree
.
pe_writes
;
du_raises
=
List
.
map
(
fun
id
->
let
ls
,_,_
=
dexception
env
.
uc
id
in
ls
)
e
.
Ptree
.
pe_raises
;
}
(
eff_no_ghost
e
.
Ptree
.
pe_raises
)
;
}
let
dpost
uc
(
q
,
ql
)
=
let
dexn
(
id
,
l
)
=
let
s
,
_
,
_
=
dexception
uc
id
in
s
,
l
in
...
...
@@ -309,7 +314,8 @@ and dutype_c env c =
duc_post
=
dpost
env
.
uc
c
.
Ptree
.
pc_post
;
}
and
dubinder
env
({
id
=
x
;
id_loc
=
loc
}
as
id
,
v
)
=
and
dubinder
env
({
id
=
x
;
id_loc
=
loc
}
as
id
,
gh
,
v
)
=
no_ghost
gh
;
let
ty
=
match
v
with
|
Some
v
->
dtype
~
user
:
true
env
v
|
None
->
create_type_var
loc
...
...
@@ -480,7 +486,8 @@ and dexpr_desc ~ghost ~userloc env loc = function
let
tyl
=
List
.
map
(
fun
(
_
,
ty
)
->
ty
)
bl
in
let
ty
=
dcurrying
tyl
e
.
dexpr_type
in
DEfun
(
bl
,
t
)
,
ty
|
Ptree
.
Elet
(
x
,
e1
,
e2
)
->
|
Ptree
.
Elet
(
x
,
gh
,
e1
,
e2
)
->
no_ghost
gh
;
let
e1
=
dexpr
~
ghost
~
userloc
env
e1
in
let
ty1
=
e1
.
dexpr_type
in
let
env
=
add_local
env
x
.
id
ty1
in
...
...
@@ -716,12 +723,16 @@ and dexpr_desc ~ghost ~userloc env loc = function
let
e1
=
dexpr
~
ghost
~
userloc
env
e1
in
let
q
=
dpost
env
.
uc
q
in
DEabstract
(
e1
,
q
)
,
e1
.
dexpr_type
|
Ptree
.
Eghost
_
->
no_ghost
true
;
assert
false
|
Ptree
.
Enamed
_
->
assert
false
and
dletrec
~
ghost
~
userloc
env
dl
=
(* add all functions into environment *)
let
add_one
env
(
id
,
bl
,
var
,
t
)
=
let
add_one
env
(
id
,
gh
,
bl
,
var
,
t
)
=
no_ghost
gh
;
let
ty
=
create_type_var
id
.
id_loc
in
let
env
=
add_local_top
env
id
.
id
ty
in
env
,
((
id
,
ty
)
,
bl
,
var
,
t
)
...
...
@@ -1560,7 +1571,7 @@ let rec is_pure_expr e =
|
Elocal
_
|
Elogic
_
->
true
|
Eif
(
e1
,
e2
,
e3
)
->
is_pure_expr
e1
&&
is_pure_expr
e2
&&
is_pure_expr
e3
|
Elet
(
_
,
e1
,
e2
)
->
is_pure_expr
e1
&&
is_pure_expr
e2
|
Eabstract
(
e1
,
_
)
|
Eabstract
(
e1
,
_
)
|
Emark
(
_
,
e1
)
->
is_pure_expr
e1
|
Eany
c
->
E
.
no_side_effect
c
.
c_effect
|
Eassert
_
|
Etry
_
|
Efor
_
|
Eraise
_
|
Ematch
_
...
...
@@ -2295,7 +2306,8 @@ let find_module penv lmod q id = match q with
(* env = to retrieve theories and modules from the loadpath
lmod = local modules *)
let
rec
decl
~
wp
env
ltm
lmod
uc
=
function
|
Ptree
.
Dlet
(
id
,
e
)
->
|
Ptree
.
Dlet
(
id
,
gh
,
e
)
->
no_ghost
gh
;
let
denv
=
create_denv
uc
in
let
e
=
dexpr
~
ghost
:
false
~
userloc
:
None
denv
e
in
let
e
=
iexpr
(
create_ienv
denv
)
e
in
...
...
@@ -2334,7 +2346,8 @@ let rec decl ~wp env ltm lmod uc = function
let
d
=
Dletrec
dl
in
let
uc
=
add_decl
d
uc
in
if
wp
then
Pgm_wp
.
decl
uc
d
else
uc
|
Ptree
.
Dparam
(
id
,
tyv
)
->
|
Ptree
.
Dparam
(
id
,
gh
,
tyv
)
->
no_ghost
gh
;
let
loc
=
id
.
id_loc
in
let
denv
=
create_denv
uc
in
let
tyv
=
dutype_v
denv
tyv
in
...
...
src/whyml/mlw_dtree.ml
View file @
811ab575
...
...
@@ -75,7 +75,7 @@ and dexpr_desc =
|
DEglobal_ls
of
Term
.
lsymbol
|
DEapply
of
dexpr
*
dexpr
list
|
DEfun
of
dlambda
|
DElet
of
ident
*
dexpr
*
dexpr
|
DElet
of
ident
*
ghost
*
dexpr
*
dexpr
|
DEletrec
of
drecfun
list
*
dexpr
|
DEassign
of
dexpr
*
dexpr
|
DEif
of
dexpr
*
dexpr
*
dexpr
...
...
@@ -92,6 +92,6 @@ and dexpr_desc =
|
DEghost
of
dexpr
|
DEany
of
dtype_c
and
drecfun
=
ident
*
dity
*
dlambda
and
drecfun
=
ident
*
ghost
*
dity
*
dlambda
and
dlambda
=
dbinder
list
*
dvariant
list
*
dpre
*
dexpr
*
dpost
*
dxpost
src/whyml/mlw_ty.ml
View file @
811ab575
...
...
@@ -668,6 +668,10 @@ let vtv_unmut vtv =
if
vtv
.
vtv_mut
=
None
then
vtv
else
vty_value
~
ghost
:
vtv
.
vtv_ghost
vtv
.
vtv_ity
let
vty_ghost
=
function
|
VTvalue
vtv
->
vtv
.
vtv_ghost
|
VTarrow
vta
->
vta
.
vta_ghost
let
vty_arrow
vtv
?
(
effect
=
eff_empty
)
?
(
ghost
=
false
)
vty
=
(* mutable arguments are rejected outright *)
if
vtv
.
vtv_mut
<>
None
then
...
...
@@ -681,14 +685,10 @@ let vty_arrow vtv ?(effect=eff_empty) ?(ghost=false) vty =
vta_arg
=
vtv
;
vta_result
=
vty
;
vta_effect
=
effect
;
vta_ghost
=
ghost
;
vta_ghost
=
ghost
||
vty_ghost
vty
;
vta_vars
=
vty_vars
vtv
.
vtv_vars
vty
;
}
let
vty_ghost
=
function
|
VTvalue
vtv
->
vtv
.
vtv_ghost
|
VTarrow
vta
->
vta
.
vta_ghost
let
vtv_ghostify
vtv
=
{
vtv
with
vtv_ghost
=
true
}
let
vta_ghostify
vta
=
{
vta
with
vta_ghost
=
true
}
...
...
src/whyml/mlw_typing.ml
View file @
811ab575
...
...
@@ -219,7 +219,7 @@ let mk_let ~loc ~uloc e (desc,dity) =
if
test_var
e
then
desc
,
dity
else
let
loc
=
def_option
loc
uloc
in
let
e1
=
mk_dexpr
desc
dity
loc
Slab
.
empty
in
DElet
(
mk_id
"q"
loc
,
e
,
e1
)
,
dity
DElet
(
mk_id
"q"
loc
,
false
,
e
,
e1
)
,
dity
(* patterns *)
...
...
@@ -321,18 +321,18 @@ and dpat_app denv ({ de_loc = loc } as de) ppl =
(* specifications *)
let
dbinders
denv
bl
=
let
dbinder
(
id
,
pty
)
(
denv
,
bl
,
tyl
)
=
let
dbinder
(
id
,
gh
,
pty
)
(
denv
,
bl
,
tyl
)
=
let
dity
=
match
pty
with
|
Some
pty
->
dity_of_pty
~
user
:
true
denv
pty
|
None
->
create_type_variable
()
in
add_var
id
dity
denv
,
(
id
,
false
,
dity
)
::
bl
,
dity
::
tyl
add_var
id
dity
denv
,
(
id
,
gh
,
dity
)
::
bl
,
dity
::
tyl
in
List
.
fold_right
dbinder
bl
(
denv
,
[]
,
[]
)
let
deff_of_peff
uc
pe
=
{
deff_reads
=
List
.
map
(
fun
le
->
false
,
le
)
pe
.
pe_reads
;
deff_writes
=
List
.
map
(
fun
le
->
false
,
le
)
pe
.
pe_writes
;
deff_raises
=
List
.
map
(
fun
q
->
false
,
find_xsymbol
uc
q
)
pe
.
pe_raises
;
}
{
deff_reads
=
pe
.
pe_reads
;
deff_writes
=
pe
.
pe_writes
;
deff_raises
=
List
.
map
(
fun
(
gh
,
q
)
->
gh
,
find_xsymbol
uc
q
)
pe
.
pe_raises
;
}
let
dxpost
uc
ql
=
List
.
map
(
fun
(
q
,
f
)
->
find_xsymbol
uc
q
,
f
)
ql
...
...
@@ -392,7 +392,7 @@ and de_desc denv loc = function
let
e
,
el
=
decompose_app
[
e2
]
e1
in
let
el
=
List
.
map
(
dexpr
denv
)
el
in
de_app
(
dexpr
denv
e
)
el
|
Ptree
.
Elet
(
id
,
e1
,
e2
)
->
|
Ptree
.
Elet
(
id
,
gh
,
e1
,
e2
)
->
let
e1
=
dexpr
denv
e1
in
let
dity
=
e1
.
de_type
in
let
tvars
=
match
e1
.
de_desc
with
...
...
@@ -401,10 +401,10 @@ and de_desc denv loc = function
let
locals
=
Mstr
.
add
id
.
id
(
tvars
,
dity
)
denv
.
locals
in
let
denv
=
{
denv
with
locals
=
locals
;
tvars
=
tvars
}
in
let
e2
=
dexpr
denv
e2
in
DElet
(
id
,
e1
,
e2
)
,
e2
.
de_type
DElet
(
id
,
gh
,
e1
,
e2
)
,
e2
.
de_type
|
Ptree
.
Eletrec
(
rdl
,
e1
)
->
let
rdl
=
dletrec
denv
rdl
in
let
add_one
denv
({
id
=
id
}
,
dity
,
_
)
=
let
add_one
denv
({
id
=
id
}
,
_
,
dity
,
_
)
=
{
denv
with
locals
=
Mstr
.
add
id
(
denv
.
tvars
,
dity
)
denv
.
locals
}
in
let
denv
=
List
.
fold_left
add_one
denv
rdl
in
let
e1
=
dexpr
denv
e1
in
...
...
@@ -422,7 +422,7 @@ and de_desc denv loc = function
let
e1
=
dexpr
denv
e1
in
expected_type
e1
dity_unit
;
let
e2
=
dexpr
denv
e2
in
DElet
(
mk_id
"_"
loc
,
e1
,
e2
)
,
e2
.
de_type
DElet
(
mk_id
"_"
loc
,
false
,
e1
,
e2
)
,
e2
.
de_type
|
Ptree
.
Eif
(
e1
,
e2
,
e3
)
->
let
e1
=
dexpr
denv
e1
in
expected_type
e1
dity_bool
;
...
...
@@ -537,6 +537,9 @@ and de_desc denv loc = function
|
Ptree
.
Eany
tyc
->
let
tyc
,
dity
=
dtype_c
denv
tyc
in
DEany
tyc
,
dity
|
Ptree
.
Eghost
e1
->
let
e1
=
dexpr
denv
e1
in
DEghost
e1
,
e1
.
de_type
|
Ptree
.
Eloop
({
loop_invariant
=
inv
;
loop_variant
=
var
}
,
e1
)
->
let
e1
=
dexpr
denv
e1
in
let
var
=
dvariant
denv
.
uc
var
in
...
...
@@ -556,15 +559,15 @@ and de_desc denv loc = function
and
dletrec
denv
rdl
=
(* add all functions into environment *)
let
add_one
denv
(
id
,
bl
,
var
,
tr
)
=
let
add_one
denv
(
id
,
gh
,
bl
,
var
,
tr
)
=
let
res
=
create_type_variable
()
in
add_var
id
res
denv
,
(
id
,
res
,
bl
,
var
,
tr
)
in
add_var
id
res
denv
,
(
id
,
gh
,
res
,
bl
,
var
,
tr
)
in
let
denv
,
rdl
=
Util
.
map_fold_left
add_one
denv
rdl
in
(* then type-check all of them and unify *)
let
type_one
(
id
,
res
,
bl
,
var
,
tr
)
=
let
type_one
(
id
,
gh
,
res
,
bl
,
var
,
tr
)
=
let
lam
,
dity
=
dlambda
denv
bl
var
tr
in
Loc
.
try2
id
.
id_loc
unify
dity
res
;
id
,
dity
,
lam
in
id
,
gh
,
dity
,
lam
in
List
.
map
type_one
rdl
and
dlambda
denv
bl
var
(
p
,
e
,
(
q
,
xq
))
=
...
...
@@ -707,8 +710,8 @@ let eff_of_deff lenv deff =
let
eff
=
List
.
fold_left
add_raise
eff
deff
.
deff_raises
in
eff
let
rec
type_c
lenv
vars
dtyc
=
let
result
=
type_v
lenv
vars
dtyc
.
dc_result
in
let
rec
type_c
lenv
gh
vars
dtyc
=
let
result
=
type_v
lenv
gh
vars
dtyc
.
dc_result
in
let
ty
=
match
result
with
|
SpecV
v
->
ty_of_ity
v
.
vtv_ity
|
SpecA
_
->
ty_unit
in
...
...
@@ -727,17 +730,24 @@ let rec type_c lenv vars dtyc =
c_post
=
create_post
lenv
"result"
ty
dtyc
.
dc_post
;
c_xpost
=
xpost
lenv
dtyc
.
dc_xpost
;
}
and
type_v
lenv
vars
=
function
and
type_v
lenv
gh
vars
=
function
|
DSpecV
(
ghost
,
v
)
->
let
ghost
=
ghost
||
gh
in
SpecV
(
vty_value
~
ghost
(
ity_of_dity
v
))
|
DSpecA
(
bl
,
tyc
)
->
let
lenv
,
pvl
=
binders
lenv
bl
in
let
add_pv
s
pv
=
vars_union
s
pv
.
pv_vtv
.
vtv_vars
in
let
vars
=
List
.
fold_left
add_pv
vars
pvl
in
SpecA
(
pvl
,
type_c
lenv
vars
tyc
)
SpecA
(
pvl
,
type_c
lenv
gh
vars
tyc
)
(* expressions *)
let
vty_ghostify
gh
vty
=
if
gh
&&
not
(
vty_ghost
vty
)
then
vty_ghostify
vty
else
vty
let
e_ghostify
gh
e
=
if
gh
&&
not
(
vty_ghost
e
.
e_vty
)
then
e_ghost
e
else
e
let
rec
expr
lenv
de
=
let
loc
=
de
.
de_loc
in
let
e
=
Loc
.
try3
loc
expr_desc
lenv
loc
de
in
...
...
@@ -750,18 +760,29 @@ and expr_desc lenv loc de = match de.de_desc with
|
LetV
pv
->
e_value
pv
|
LetA
ps
->
e_cast
ps
(
vty_of_dity
de
.
de_type
)
end
|
DElet
(
x
,
{
de_desc
=
DEfun
lam
}
,
de2
)
->
let
def
=
expr_fun
lenv
x
lam
in
|
DElet
(
x
,
gh
,
{
de_desc
=
DEfun
lam
}
,
de2
)
->
let
def
=
expr_fun
lenv
x
gh
lam
in
let
lenv
=
add_local
x
.
id
(
LetA
def
.
rec_ps
)
lenv
in
let
e2
=
expr
lenv
de2
in
e_rec
[
def
]
e2
|
DEfun
lam
->
let
x
=
mk_id
"fn"
loc
in
let
def
=
expr_fun
lenv
x
lam
in
let
def
=
expr_fun
lenv
x
false
lam
in
let
e2
=
e_cast
def
.
rec_ps
(
VTarrow
def
.
rec_ps
.
ps_vta
)
in
e_rec
[
def
]
e2
|
DElet
(
x
,
de1
,
de2
)
->
let
e1
=
expr
lenv
de1
in
(* FIXME? (ghost "lab" fun x -> ...) loses the label "lab" *)
|
DEghost
{
de_desc
=
DEfun
lam
}
->
let
x
=
mk_id
"fn"
loc
in
let
def
=
expr_fun
lenv
x
true
lam
in
let
e2
=
e_cast
def
.
rec_ps
(
VTarrow
def
.
rec_ps
.
ps_vta
)
in
e_rec
[
def
]
e2
|
DElet
(
x
,
gh
,
de1
,
de2
)
->
let
e1
=
e_ghostify
gh
(
expr
lenv
de1
)
in
begin
match
e1
.
e_vty
with
|
VTarrow
{
vta_ghost
=
true
}
when
not
gh
->
errorm
~
loc
"%s must be a ghost function"
x
.
id
|
_
->
()
end
;
let
def1
=
create_let_defn
(
Denv
.
create_user_id
x
)
e1
in
let
lenv
=
add_local
x
.
id
def1
.
let_var
lenv
in
let
e2
=
expr
lenv
de2
in
...
...
@@ -826,14 +847,19 @@ and expr_desc lenv loc de = match de.de_desc with
let
lenv
=
add_local
id
.
id
(
LetV
pv
)
lenv
in
xs
,
pv
,
expr
lenv
de
in
e_try
e1
(
List
.
map
branch
bl
)
(* We push ghost down in order to safely capture even non-ghost
raises of the inner expression in "ghost try e1 with ..." *)
|
DEghost
({
de_desc
=
DEtry
(
de2
,
bl
)
}
as
de1
)
->
let
de2
=
{
de1
with
de_desc
=
DEghost
de2
}
in
expr
lenv
{
de1
with
de_desc
=
DEtry
(
de2
,
bl
)
}
|
DEmark
(
x
,
de1
)
->
let
ld
=
create_let_defn
(
Denv
.
create_user_id
x
)
e_setmark
in
let
lenv
=
add_local
x
.
id
ld
.
let_var
lenv
in
e_let
ld
(
expr
lenv
de1
)
|
DEany
dtyc
->
e_any
(
type_c
lenv
vars_empty
dtyc
)
e_any
(
type_c
lenv
false
vars_empty
dtyc
)
|
DEghost
de1
->
e_ghost
(
expr
lenv
de1
)
e_ghost
ify
true
(
expr
lenv
de1
)
|
DEloop
(
var
,
inv
,
de1
)
->
let
inv
=
match
inv
with
|
Some
inv
->
create_pre
lenv
inv
...
...
@@ -855,23 +881,25 @@ and expr_desc lenv loc de = match de.de_desc with
e_for
pv
efrom
dir
eto
inv
e1
and
expr_rec
lenv
rdl
=
let
step1
lenv
(
id
,
dity
,
lam
)
=
let
vta
=
match
vty_
of_dity
dity
with
let
step1
lenv
(
id
,
gh
,
dity
,
lam
)
=
let
vta
=
match
vty_
ghostify
gh
(
vty_of_dity
dity
)
with
|
VTarrow
vta
->
vta
|
VTvalue
_
->
assert
false
in
let
ps
=
create_psymbol
(
Denv
.
create_user_id
id
)
vta
vars_empty
in
add_local
id
.
id
(
LetA
ps
)
lenv
,
(
ps
,
lam
)
in
add_local
id
.
id
(
LetA
ps
)
lenv
,
(
ps
,
gh
,
lam
)
in
let
lenv
,
rdl
=
Util
.
map_fold_left
step1
lenv
rdl
in
let
step2
(
ps
,
lam
)
=
ps
,
expr_lam
lenv
lam
in
let
step2
(
ps
,
gh
,
lam
)
=
ps
,
expr_lam
lenv
gh
lam
in
create_rec_defn
(
List
.
map
step2
rdl
)
and
expr_fun
lenv
x
lam
=
let
lam
=
expr_lam
lenv
lam
in
and
expr_fun
lenv
x
gh
lam
=
let
lam
=
expr_lam
lenv
gh
lam
in
create_fun_defn
(
Denv
.
create_user_id
x
)
lam
and
expr_lam
lenv
(
bl
,
var
,
p
,
e
,
q
,
xq
)
=
and
expr_lam
lenv
gh
(
bl
,
var
,
p
,
d
e
,
q
,
xq
)
=
let
lenv
,
pvl
=
binders
lenv
bl
in
let
e
=
expr
lenv
e
in
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"
;
let
ty
=
match
e
.
e_vty
with
|
VTarrow
_
->
ty_unit
|
VTvalue
vtv
->
ty_of_ity
vtv
.
vtv_ity
...
...
@@ -1343,14 +1371,16 @@ let add_module lib path mm mt m =
let
uc
=
open_namespace
uc
in
let
uc
=
List
.
fold_left
add_decl
uc
dl
in
Loc
.
try3
loc
close_namespace
uc
import
name
|
Dlet
(
id
,
e
)
->
|
Dlet
(
id
,
gh
,
e
)
->
let
e
=
dexpr
(
create_denv
uc
)
e
in
let
pd
=
match
e
.
de_desc
with
|
DEfun
lam
->
let
def
=
expr_fun
(
create_lenv
uc
)
id
lam
in
let
def
=
expr_fun
(
create_lenv
uc
)
id
gh
lam
in
create_rec_decl
[
def
]
|
_
->
let
e
=
expr
(
create_lenv
uc
)
e
in
let
e
=
e_ghostify
gh
(
expr
(
create_lenv
uc
)
e
)
in
if
not
gh
&&
vty_ghost
e
.
e_vty
then
errorm
~
loc
"%s must be a ghost variable"
id
.
id
;
let
def
=
create_let_defn
(
Denv
.
create_user_id
id
)
e
in
create_let_decl
def
in
...
...
@@ -1368,10 +1398,17 @@ let add_module lib path mm mt m =
let
xs
=
create_xsymbol
(
Denv
.
create_user_id
id
)
ity
in
let
pd
=
create_exn_decl
xs
in
Loc
.
try2
loc
add_pdecl_with_tuples
uc
pd