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
811ab575
Commit
811ab575
authored
Jun 23, 2012
by
Andrei Paskevich
Browse files
whyml: ghost variables, functions, and expressions
parent
57635caf
Changes
7
Hide whitespace changes
Inline
Side-by-side
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
*/
{
[]
}
|
WRITE
S
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
READ
S
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
=
eff_no_ghost
e
.
Ptree
.
pe_reads
;
du_writes
=
eff_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