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
119
Issues
119
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
72a36bd8
Commit
72a36bd8
authored
Dec 23, 2010
by
Jean-Christophe Filliâtre
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
modules: huge refactoring of programs types, in preparation for mutable types
parent
2d519b26
Changes
10
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
1107 additions
and
600 deletions
+1107
-600
Makefile.in
Makefile.in
+1
-1
src/programs/pgm_fastwp.ml
src/programs/pgm_fastwp.ml
+1
-1
src/programs/pgm_module.ml
src/programs/pgm_module.ml
+4
-5
src/programs/pgm_module.mli
src/programs/pgm_module.mli
+1
-0
src/programs/pgm_ttree.ml
src/programs/pgm_ttree.ml
+93
-41
src/programs/pgm_types.ml
src/programs/pgm_types.ml
+477
-216
src/programs/pgm_types.mli
src/programs/pgm_types.mli
+104
-42
src/programs/pgm_typing.ml
src/programs/pgm_typing.ml
+365
-241
src/programs/pgm_wp.ml
src/programs/pgm_wp.ml
+45
-44
tests/test-pgm-jcf.mlw
tests/test-pgm-jcf.mlw
+16
-9
No files found.
Makefile.in
View file @
72a36bd8
...
...
@@ -281,7 +281,7 @@ install_no_local::
PGMGENERATED
=
src/programs/pgm_parser.mli src/programs/pgm_parser.ml
\
src/programs/pgm_lexer.ml
PGM_FILES
=
pgm_ttree pgm_ptree pgm_parser pgm_lexer
pgm_effect
\
PGM_FILES
=
pgm_ttree pgm_ptree pgm_parser pgm_lexer
\
pgm_types pgm_module pgm_wp pgm_env pgm_typing pgm_main
PGMMODULES
=
$(
addprefix
src/programs/,
$(PGM_FILES)
)
...
...
src/programs/pgm_fastwp.ml
View file @
72a36bd8
...
...
@@ -29,7 +29,7 @@ open Theory
open
Pgm_ttree
open
Pgm_typing
module
E
=
Pgm_
effect
module
E
=
Pgm_
types
.
E
module
State
:
sig
type
t
...
...
src/programs/pgm_module.ml
View file @
72a36bd8
...
...
@@ -6,6 +6,7 @@ open Theory
open
Term
open
Pgm_types
open
Pgm_types
.
T
open
Pgm_ttree
module
Mnm
=
Mstr
...
...
@@ -34,11 +35,9 @@ let ns_replace eq chk x vo vn =
let
ns_union
eq
chk
=
Mnm
.
union
(
fun
x
vn
vo
->
Some
(
ns_replace
eq
chk
x
vo
vn
))
let
pr_equal
p1
p2
=
ls_equal
p1
.
p_ls
p2
.
p_ls
let
rec
merge_ns
chk
ns1
ns2
=
let
fusion
_
ns1
ns2
=
Some
(
merge_ns
chk
ns1
ns2
)
in
{
ns_pr
=
ns_union
p
r_equal
chk
ns1
.
ns_pr
ns2
.
ns_pr
;
{
ns_pr
=
ns_union
p
_equal
chk
ns1
.
ns_pr
ns2
.
ns_pr
;
ns_ex
=
ns_union
ls_equal
chk
ns1
.
ns_ex
ns2
.
ns_ex
;
ns_mt
=
ns_union
mt_equal
chk
ns1
.
ns_mt
ns2
.
ns_mt
;
ns_ns
=
Mnm
.
union
fusion
ns1
.
ns_ns
ns2
.
ns_ns
;
}
...
...
@@ -51,7 +50,7 @@ let ns_add eq chk x v m = Mnm.change x (function
|
None
->
Some
v
|
Some
vo
->
Some
(
ns_replace
eq
chk
x
vo
v
))
m
let
pr_add
=
ns_add
p
r
_equal
let
pr_add
=
ns_add
p_equal
let
ex_add
=
ns_add
ls_equal
let
mt_add
=
ns_add
mt_equal
...
...
@@ -131,7 +130,7 @@ let add_symbol add id v uc =
|
_
->
assert
false
let
add_psymbol
ps
uc
=
add_symbol
add_pr
ps
.
p_
ls
.
ls_
name
ps
uc
add_symbol
add_pr
ps
.
p_name
ps
uc
let
add_esymbol
ls
uc
=
add_symbol
add_ex
ls
.
ls_name
ls
uc
...
...
src/programs/pgm_module.mli
View file @
72a36bd8
...
...
@@ -3,6 +3,7 @@ open Why
open
Ident
open
Term
open
Pgm_types
open
Pgm_types
.
T
module
Mnm
:
Map
.
S
with
type
key
=
string
...
...
src/programs/pgm_ttree.ml
View file @
72a36bd8
...
...
@@ -18,6 +18,8 @@
(**************************************************************************)
open
Why
open
Pgm_types
open
Pgm_types
.
T
type
loc
=
Loc
.
position
...
...
@@ -36,20 +38,22 @@ type for_direction = Pgm_ptree.for_direction
type
dreference
=
|
DRlocal
of
string
|
DRglobal
of
Term
.
l
symbol
|
DRglobal
of
p
symbol
type
deffect
=
{
de_reads
:
dreference
list
;
de_writes
:
dreference
list
;
de_raises
:
Term
.
l
symbol
list
;
de_raises
:
e
symbol
list
;
}
type
dpre
=
Denv
.
dfmla
type
dpost
=
Denv
.
dfmla
*
(
Term
.
lsymbol
*
Denv
.
dfmla
)
list
type
dpost_fmla
=
Denv
.
dty
*
Denv
.
dfmla
type
dexn_post_fmla
=
Denv
.
dty
option
*
Denv
.
dfmla
type
dpost
=
dpost_fmla
*
(
Term
.
lsymbol
*
dexn_post_fmla
)
list
type
dtype_v
=
|
DTpure
of
Denv
.
dty
|
DTpure
of
Denv
.
dty
|
DTarrow
of
dbinder
list
*
dtype_c
and
dtype_c
=
...
...
@@ -58,7 +62,7 @@ and dtype_c =
dc_pre
:
dpre
;
dc_post
:
dpost
;
}
and
dbinder
=
ident
*
dtype_v
and
dbinder
=
ident
*
Denv
.
dty
*
dtype_v
type
dvariant
=
Denv
.
dterm
*
Term
.
lsymbol
...
...
@@ -76,8 +80,8 @@ type dexpr = {
and
dexpr_desc
=
|
DEconstant
of
constant
|
DElocal
of
string
*
dtype_v
|
DEglobal
of
Term
.
l
symbol
*
dtype_v
|
DElocal
of
string
*
Denv
.
dty
|
DEglobal
of
p
symbol
*
dtype_v
|
DElogic
of
Term
.
lsymbol
|
DEapply
of
dexpr
*
dexpr
|
DEfun
of
dbinder
list
*
dtriple
...
...
@@ -90,8 +94,8 @@ and dexpr_desc =
|
DElazy
of
lazy_op
*
dexpr
*
dexpr
|
DEmatch
of
dexpr
*
(
Denv
.
dpattern
*
dexpr
)
list
|
DEabsurd
|
DEraise
of
Term
.
l
symbol
*
dexpr
option
|
DEtry
of
dexpr
*
(
Term
.
l
symbol
*
string
option
*
dexpr
)
list
|
DEraise
of
e
symbol
*
dexpr
option
|
DEtry
of
dexpr
*
(
e
symbol
*
string
option
*
dexpr
)
list
|
DEfor
of
ident
*
dexpr
*
for_direction
*
dexpr
*
Denv
.
dfmla
option
*
dexpr
|
DEassert
of
assertion_kind
*
Denv
.
dfmla
...
...
@@ -107,19 +111,39 @@ and dtriple = dpre * dexpr * dpost
type
variant
=
Term
.
term
*
Term
.
lsymbol
type
re
c_variant
=
Term
.
vsymbol
*
Term
.
term
*
Term
.
lsymbol
type
re
ference
=
R
.
t
type
reference
=
Pgm_effect
.
referenc
e
type
pre
=
T
.
pr
e
type
p
re
=
Pgm_types
.
pre
type
p
ost
=
T
.
post
type
post
=
Pgm_types
.
post
type
ivsymbol
=
{
i_name
:
Ident
.
preid
;
i_ty
:
Ty
.
ty
;
i_vs
:
Term
.
vsymbol
;
}
type
ireference
=
|
IRlocal
of
ivsymbol
|
IRglobal
of
psymbol
type
ieffect
=
{
ie_reads
:
ireference
list
;
ie_writes
:
ireference
list
;
ie_raises
:
esymbol
list
;
}
type
type_v
=
Pgm_types
.
type_v
type
itype_v
=
|
ITpure
of
Ty
.
ty
|
ITarrow
of
ibinder
list
*
itype_c
type
type_c
=
Pgm_types
.
type_c
and
itype_c
=
{
ic_result_type
:
itype_v
;
ic_effect
:
ieffect
;
ic_pre
:
pre
;
ic_post
:
post
;
}
type
binder
=
Pgm_types
.
binder
and
ibinder
=
ivsymbol
*
itype_v
type
loop_annotation
=
{
loop_invariant
:
Term
.
fmla
option
;
...
...
@@ -128,6 +152,20 @@ type loop_annotation = {
type
label
=
Term
.
vsymbol
type
irec_variant
=
ivsymbol
*
Term
.
term
*
Term
.
lsymbol
type
ipattern
=
{
ipat_pat
:
Term
.
pattern
;
ipat_node
:
ipat_node
;
}
and
ipat_node
=
|
IPwild
|
IPvar
of
ivsymbol
|
IPapp
of
Term
.
lsymbol
*
ipattern
list
|
IPor
of
ipattern
*
ipattern
|
IPas
of
ipattern
*
ivsymbol
type
iexpr
=
{
iexpr_desc
:
iexpr_desc
;
iexpr_type
:
Ty
.
ty
;
...
...
@@ -136,29 +174,29 @@ type iexpr = {
and
iexpr_desc
=
|
IElogic
of
Term
.
term
|
IElocal
of
Term
.
vsymbol
*
type_v
|
IEglobal
of
Term
.
lsymbol
*
type_v
|
IEapply
of
iexpr
*
Term
.
vsymbol
|
IEapply_ref
of
iexpr
*
reference
|
IEfun
of
binder
list
*
itriple
|
IElet
of
Term
.
vsymbol
*
iexpr
*
iexpr
|
IElocal
of
ivsymbol
|
IEglobal
of
psymbol
|
IEapply
of
iexpr
*
i
vsymbol
(* | IEapply_ref of iexpr * reference *)
|
IEfun
of
i
binder
list
*
itriple
|
IElet
of
i
vsymbol
*
iexpr
*
iexpr
|
IEletrec
of
irecfun
list
*
iexpr
|
IEif
of
iexpr
*
iexpr
*
iexpr
|
IEloop
of
loop_annotation
*
iexpr
|
IElazy
of
lazy_op
*
iexpr
*
iexpr
|
IEmatch
of
Term
.
vsymbol
*
(
Term
.
pattern
*
iexpr
)
list
|
IEmatch
of
ivsymbol
*
(
i
pattern
*
iexpr
)
list
|
IEabsurd
|
IEraise
of
Term
.
l
symbol
*
iexpr
option
|
IEtry
of
iexpr
*
(
Term
.
lsymbol
*
Term
.
vsymbol
option
*
iexpr
)
list
|
IEfor
of
Term
.
vsymbol
*
Term
.
vsymbol
*
for_direction
*
Term
.
vsymbol
*
|
IEraise
of
e
symbol
*
iexpr
option
|
IEtry
of
iexpr
*
(
esymbol
*
i
vsymbol
option
*
iexpr
)
list
|
IEfor
of
ivsymbol
*
ivsymbol
*
for_direction
*
i
vsymbol
*
Term
.
fmla
option
*
iexpr
|
IEassert
of
assertion_kind
*
Term
.
fmla
|
IElabel
of
label
*
iexpr
|
IEany
of
type_c
|
IEany
of
i
type_c
and
irecfun
=
Term
.
vsymbol
*
binder
list
*
rec_variant
option
*
itriple
and
irecfun
=
ivsymbol
*
ibinder
list
*
i
rec_variant
option
*
itriple
and
itriple
=
pre
*
iexpr
*
post
...
...
@@ -166,43 +204,57 @@ and itriple = pre * iexpr * post
(*****************************************************************************)
(* phase 3: effect inference *)
type
rec_variant
=
pvsymbol
*
Term
.
term
*
Term
.
lsymbol
type
pattern
=
{
ppat_pat
:
Term
.
pattern
;
ppat_node
:
ppat_node
;
}
and
ppat_node
=
|
Pwild
|
Pvar
of
pvsymbol
|
Papp
of
Term
.
lsymbol
*
pattern
list
|
Por
of
pattern
*
pattern
|
Pas
of
pattern
*
pvsymbol
type
expr
=
{
expr_desc
:
expr_desc
;
expr_type
:
Ty
.
ty
;
expr_type_v
:
type_v
;
expr_effect
:
Pgm_effect
.
t
;
expr_effect
:
E
.
t
;
expr_loc
:
loc
;
}
and
expr_desc
=
|
Elogic
of
Term
.
term
|
Elocal
of
Term
.
vsymbol
|
Eglobal
of
Term
.
l
symbol
|
Efun
of
binder
list
*
triple
|
Elet
of
Term
.
vsymbol
*
expr
*
expr
|
Elocal
of
p
vsymbol
|
Eglobal
of
p
symbol
|
Efun
of
pvsymbol
list
*
triple
|
Elet
of
p
vsymbol
*
expr
*
expr
|
Eletrec
of
recfun
list
*
expr
|
Eif
of
expr
*
expr
*
expr
|
Eloop
of
loop_annotation
*
expr
|
Ematch
of
Term
.
vsymbol
*
(
Term
.
pattern
*
expr
)
list
|
Ematch
of
pvsymbol
*
(
pattern
*
expr
)
list
|
Eabsurd
|
Eraise
of
Term
.
l
symbol
*
expr
option
|
Etry
of
expr
*
(
Term
.
lsymbol
*
Term
.
vsymbol
option
*
expr
)
list
|
Efor
of
Term
.
vsymbol
*
Term
.
vsymbol
*
for_direction
*
Term
.
vsymbol
*
|
Eraise
of
e
symbol
*
expr
option
|
Etry
of
expr
*
(
esymbol
*
p
vsymbol
option
*
expr
)
list
|
Efor
of
pvsymbol
*
pvsymbol
*
for_direction
*
p
vsymbol
*
Term
.
fmla
option
*
expr
|
Eassert
of
assertion_kind
*
Term
.
fmla
|
Elabel
of
label
*
expr
|
Eany
of
type_c
and
recfun
=
Term
.
vsymbol
*
binder
list
*
rec_variant
option
*
triple
and
recfun
=
pvsymbol
*
pvsymbol
list
*
rec_variant
option
*
triple
and
triple
=
pre
*
expr
*
post
type
decl
=
|
Dlet
of
Pgm_types
.
psymbol
*
expr
|
Dletrec
of
(
Pgm_types
.
psymbol
*
recfun
)
list
|
Dparam
of
Pgm_types
.
psymbol
*
type_v
|
Dlet
of
T
.
psymbol
*
expr
|
Dletrec
of
(
T
.
psymbol
*
recfun
)
list
|
Dparam
of
T
.
psymbol
*
type_v
type
file
=
decl
list
...
...
src/programs/pgm_types.ml
View file @
72a36bd8
...
...
@@ -6,7 +6,6 @@ open Ty
open
Theory
open
Term
open
Decl
module
E
=
Pgm_effect
(* mutable types *)
...
...
@@ -54,228 +53,490 @@ let model_type ty = match ty.ty_node with
(* types *)
type
effect
=
Pgm_effect
.
t
type
reference
=
Pgm_effect
.
reference
type
pre
=
Term
.
fmla
type
post_fmla
=
Term
.
vsymbol
(* result *)
*
Term
.
fmla
type
exn_post_fmla
=
Term
.
vsymbol
(* result *)
option
*
Term
.
fmla
type
post
=
post_fmla
*
(
Term
.
lsymbol
*
exn_post_fmla
)
list
type
type_v
=
|
Tpure
of
Ty
.
ty
|
Tarrow
of
binder
list
*
type_c
and
type_c
=
{
c_result_type
:
type_v
;
c_effect
:
effect
;
c_pre
:
pre
;
c_post
:
post
;
}
and
binder
=
Term
.
vsymbol
*
type_v
(* purify: turns program types into logic types *)
let
ts_arrow
=
let
v
=
List
.
map
(
fun
s
->
create_tvsymbol
(
Ident
.
id_fresh
s
))
[
"a"
;
"b"
]
in
Ty
.
create_tysymbol
(
Ident
.
id_fresh
"arrow"
)
v
None
let
make_arrow_type
tyl
ty
=
let
arrow
ty1
ty2
=
Ty
.
ty_app
ts_arrow
[
ty1
;
ty2
]
in
List
.
fold_right
arrow
tyl
ty
let
rec
uncurry_type
?
(
logic
=
false
)
=
function
|
Tpure
ty
when
not
logic
->
[]
,
ty
|
Tpure
ty
->
[]
,
begin
try
model_type
ty
with
NotMutable
->
ty
end
|
Tarrow
(
bl
,
c
)
->
let
tyl1
=
List
.
map
(
fun
(
v
,_
)
->
v
.
vs_ty
)
bl
in
let
tyl2
,
ty
=
uncurry_type
~
logic
c
.
c_result_type
in
tyl1
@
tyl2
,
ty
(* TODO: improve efficiency? *)
let
purify
?
(
logic
=
false
)
v
=
let
tyl
,
ty
=
uncurry_type
~
logic
v
in
make_arrow_type
tyl
ty
(* symbols *)
type
psymbol
=
{
p_ls
:
lsymbol
;
p_tv
:
type_v
;
}
module
Sexn
=
Term
.
Sls
let
create_psymbol
id
v
=
let
tyl
,
ty
=
uncurry_type
v
in
let
ls
=
create_lsymbol
id
tyl
(
Some
ty
)
in
{
p_ls
=
ls
;
p_tv
=
v
}
type
esymbol
=
lsymbol
(* misc. functions *)
let
v_result
ty
=
create_vsymbol
(
id_fresh
"result"
)
ty
let
exn_v_result
ls
=
match
ls
.
ls_args
with
|
[]
->
None
|
[
ty
]
->
Some
(
v_result
ty
)
|
_
->
assert
false
let
post_map
f
((
v
,
q
)
,
ql
)
=
(
v
,
f
q
)
,
List
.
map
(
fun
(
e
,
(
v
,
q
))
->
e
,
(
v
,
f
q
))
ql
let
type_c_of_type_v
=
function
|
Tarrow
([]
,
c
)
->
c
|
v
->
let
ty
=
purify
v
in
{
c_result_type
=
v
;
c_effect
=
Pgm_effect
.
empty
;
c_pre
=
f_true
;
c_post
=
(
v_result
ty
,
f_true
)
,
[]
;
}
let
rec
subst_var
ts
s
vs
=
let
ty'
=
ty_inst
ts
vs
.
vs_ty
in
if
ty_equal
ty'
vs
.
vs_ty
then
s
,
vs
else
let
vs'
=
create_vsymbol
(
id_clone
vs
.
vs_name
)
ty'
in
Mvs
.
add
vs
(
t_var
vs'
)
s
,
vs'
and
subst_post
ts
s
((
v
,
q
)
,
ql
)
=
let
vq
=
let
s
,
v
=
subst_var
ts
s
v
in
v
,
f_ty_subst
ts
s
q
in
let
handler
(
e
,
(
v
,
q
))
=
match
v
with
|
None
->
e
,
(
v
,
f_ty_subst
ts
s
q
)
|
Some
v
->
let
s
,
v
=
subst_var
ts
s
v
in
e
,
(
Some
v
,
f_ty_subst
ts
s
q
)
in
vq
,
List
.
map
handler
ql
let
rec
subst_type_c
ef
ts
s
c
=
{
c_result_type
=
subst_type_v
ef
ts
s
c
.
c_result_type
;
c_effect
=
E
.
subst
ef
c
.
c_effect
;
c_pre
=
f_ty_subst
ts
s
c
.
c_pre
;
c_post
=
subst_post
ts
s
c
.
c_post
;
}
and
subst_type_v
ef
ts
s
=
function
|
Tpure
ty
->
Tpure
(
ty_inst
ts
ty
)
|
Tarrow
(
bl
,
c
)
->
let
s
,
bl
=
Util
.
map_fold_left
(
binder
ef
ts
)
s
bl
in
Tarrow
(
bl
,
subst_type_c
ef
ts
s
c
)
and
binder
ef
ts
s
(
vs
,
v
)
=
let
v
=
subst_type_v
ef
ts
s
v
in
let
s
,
vs
=
subst_var
ts
s
vs
in
s
,
(
vs
,
v
)
let
tpure
ty
=
Tpure
ty
let
tarrow
bl
c
=
match
bl
with
|
[]
->
invalid_arg
"tarrow"
|
_
->
let
rename
(
e
,
s
)
(
vs
,
v
)
=
let
vs'
=
create_vsymbol
(
id_clone
vs
.
vs_name
)
vs
.
vs_ty
in
let
v'
=
subst_type_v
e
Mtv
.
empty
s
v
in
let
e'
=
Mvs
.
add
vs
(
E
.
Rlocal
vs'
)
e
in
let
s'
=
Mvs
.
add
vs
(
t_var
vs'
)
s
in
(
e'
,
s'
)
,
(
vs'
,
v'
)
in
let
(
e
,
s
)
,
bl'
=
Util
.
map_fold_left
rename
(
Mvs
.
empty
,
Mvs
.
empty
)
bl
in
Tarrow
(
bl'
,
subst_type_c
e
Mtv
.
empty
s
c
)
let
subst1
vs1
t2
=
Mvs
.
add
vs1
t2
Mvs
.
empty
let
apply_type_v
v
vs
=
match
v
with
|
Tarrow
((
x
,
tyx
)
::
bl
,
c
)
->
let
ts
=
ty_match
Mtv
.
empty
(
purify
tyx
)
vs
.
vs_ty
in
let
c
=
type_c_of_type_v
(
Tarrow
(
bl
,
c
))
in
subst_type_c
Mvs
.
empty
ts
(
subst1
x
(
t_var
vs
))
c
|
Tarrow
([]
,
_
)
|
Tpure
_
->
assert
false
let
apply_type_v_ref
v
r
=
match
r
,
v
with
|
E
.
Rlocal
vs
as
r
,
Tarrow
((
x
,
tyx
)
::
bl
,
c
)
->
let
ts
=
ty_match
Mtv
.
empty
(
purify
tyx
)
vs
.
vs_ty
in
let
c
=
type_c_of_type_v
(
Tarrow
(
bl
,
c
))
in
let
ef
=
Mvs
.
add
x
r
Mvs
.
empty
in
subst_type_c
ef
ts
(
subst1
x
(
t_var
vs
))
c
|
E
.
Rglobal
ls
as
r
,
Tarrow
((
x
,
tyx
)
::
bl
,
c
)
->
let
ty
=
match
ls
.
ls_value
with
None
->
assert
false
|
Some
ty
->
ty
in
let
ts
=
ty_match
Mtv
.
empty
(
purify
tyx
)
ty
in
let
c
=
type_c_of_type_v
(
Tarrow
(
bl
,
c
))
in
let
ef
=
Mvs
.
add
x
r
Mvs
.
empty
in
subst_type_c
ef
ts
(
subst1
x
(
t_app
ls
[]
ty
))
c
|
_
->
assert
false
let
occur_formula
r
f
=
match
r
with
|
E
.
Rlocal
vs
->
f_occurs_single
vs
f
|
E
.
Rglobal
ls
->
f_s_any
(
fun
_
->
false
)
(
ls_equal
ls
)
f
let
rec
occur_type_v
r
=
function
|
Tpure
_
->
false
|
Tarrow
(
bl
,
c
)
->
occur_arrow
r
bl
c
and
occur_arrow
r
bl
c
=
match
bl
with
|
[]
->
occur_type_c
r
c
|
(
vs
,
v
)
::
bl
->
occur_type_v
r
v
||
not
(
E
.
ref_equal
r
(
E
.
Rlocal
vs
))
&&
occur_arrow
r
bl
c
and
occur_type_c
r
c
=
occur_type_v
r
c
.
c_result_type
||
occur_formula
r
c
.
c_pre
||
E
.
occur
r
c
.
c_effect
||
occur_post
r
c
.
c_post
and
occur_post
r
((
_
,
q
)
,
ql
)
=
occur_formula
r
q
||
List
.
exists
(
fun
(
_
,
(
_
,
qe
))
->
occur_formula
r
qe
)
ql
let
rec
eq_type_v
v1
v2
=
match
v1
,
v2
with
|
Tpure
ty1
,
Tpure
ty2
->
ty_equal
ty1
ty2
|
Tarrow
_
,
Tarrow
_
->
false
(* TODO? *)
|
_
->
assert
false
(* pretty-printers *)
open
Pp
open
Format
open
Pretty
let
print_post
fmt
((
_
,
q
)
,
el
)
=
let
print_exn_post
fmt
(
l
,
(
_
,
q
))
=
fprintf
fmt
"| %a -> {%a}"
print_ls
l
print_fmla
q
in
fprintf
fmt
"{%a} %a"
print_fmla
q
(
print_list
space
print_exn_post
)
el
module
rec
T
:
sig
let
rec
print_type_v
fmt
=
function
|
Tpure
ty
->
print_ty
fmt
ty
|
Tarrow
(
bl
,
c
)
->
fprintf
fmt
"@[<hov 2>%a ->@ %a@]"
(
print_list
arrow
print_binder
)
bl
print_type_c
c
type
pre
=
Term
.
fmla
and
print_type_c
fmt
c
=
fprintf
fmt
"@[{%a}@ %a%a@ %a@]"
print_fmla
c
.
c_pre
print_type_v
c
.
c_result_type
Pgm_effect
.
print
c
.
c_effect
print_post
c
.
c_post
type
post_fmla
=
Term
.
vsymbol
(* result *)
*
Term
.
fmla
type
exn_post_fmla
=
Term
.
vsymbol
(* result *)
option
*
Term
.
fmla
type
esymbol
=
lsymbol
and
print_binder
fmt
(
x
,
v
)
=
fprintf
fmt
"(%a:%a)"
print_vs
x
print_type_v
v
type
post
=
post_fmla
*
(
esymbol
*
exn_post_fmla
)
list
(* let apply_type_v env v vs = *)
(* eprintf "apply_type_v: v=%a vs=%a@." print_type_v v print_vs vs; *)
(* apply_type_v env v vs *)
type
type_v
=
private
|
Tpure
of
ty
|
Tarrow
of
pvsymbol
list
*
type_c
and
type_c
=
{
c_result_type
:
type_v
;
c_effect
:
E
.
t
;
c_pre
:
pre
;
c_post
:
post
;
}
and
pvsymbol
=
private
{
pv_name
:
ident
;
pv_tv
:
type_v
;
pv_ty
:
ty
;
(* as a logic type, for typing purposes only *)
pv_vs
:
vsymbol
;
(* for use in the logic *)
}
val
tpure
:
ty
->
type_v
val
tarrow
:
pvsymbol
list
->
type_c
->
type_v
val
create_pvsymbol
:
preid
->
?
vs
:
vsymbol
->
type_v
->
pvsymbol
val
compare_pvsymbol
:
pvsymbol
->
pvsymbol
->
int
(* program symbols *)
type
psymbol
=
private
{
p_name
:
ident
;
p_tv
:
type_v
;
p_ty
:
ty
;
(* as a logic type, for typing purposes only *)
p_ls
:
lsymbol
;
(* for use in the logic *)
}
val
create_psymbol
:
preid
->
type_v
->
psymbol
val
p_equal
:
psymbol
->
psymbol
->
bool
(* program types -> logic types *)
val
purify
:
ty
->
ty
val
purify_type_v
:
?
logic
:
bool
->
type_v
->
ty
(** when [logic] is [true], mutable types are turned into their models *)
(* operations on program types *)
val
apply_type_v_var
:
type_v
->
pvsymbol
->
type_c
val
apply_type_v_sym
:
type_v
->
psymbol
->
type_c