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
ae369448
Commit
ae369448
authored
Apr 25, 2012
by
Andrei Paskevich
Browse files
whyml: another attempt on program types
parent
ebfefedf
Changes
12
Hide whitespace changes
Inline
Side-by-side
src/whyml/mlw_decl.ml
View file @
ae369448
...
...
@@ -27,9 +27,7 @@ open Decl
open
Mlw_ty
open
Mlw_expr
type
ps_ls
=
{
ps
:
psymbol
;
ls
:
lsymbol
}
type
constructor
=
ps_ls
*
ps_ls
option
list
type
constructor
=
plsymbol
*
plsymbol
option
list
type
data_decl
=
itysymbol
*
constructor
list
...
...
@@ -58,7 +56,7 @@ let syms_ts s ts = Sid.add ts.ts_name s
let
syms_ls
s
ls
=
Sid
.
add
ls
.
ls_name
s
let
syms_its
s
its
=
Sid
.
add
its
.
its_pure
.
ts_name
s
let
syms_ps
s
ps
=
Sid
.
add
ps
.
p_name
s
let
syms_ps
s
ps
=
Sid
.
add
ps
.
p
s
_name
s
let
syms_ty
s
ty
=
ty_s_fold
syms_ts
s
ty
let
syms_term
s
t
=
t_s_fold
syms_ty
syms_ls
s
t
...
...
@@ -76,66 +74,47 @@ type pre_constructor = preid * (pvsymbol * bool) list
type
pre_data_decl
=
itysymbol
*
pre_constructor
list
exception
ConstantConstructor
of
ident
let
create_data_decl
tdl
=
let
syms
=
ref
Sid
.
empty
in
let
add
s
(
its
,_
)
=
news_id
s
its
.
its_pure
.
ts_name
in
let
news
=
ref
(
List
.
fold_left
add
Sid
.
empty
tdl
)
in
let
projections
=
Hvs
.
create
17
in
(* vs -> ps_ls *)
let
build_constructor
its
(
id
,
al
)
=
if
al
=
[]
then
raise
(
ConstantConstructor
(
id_register
id
));
let
projections
=
Hid
.
create
17
in
(* id -> plsymbol *)
let
build_constructor
its
(
id
,
al
)
=
(* check well-formedness *)
let
vtvs
=
List
.
map
(
fun
(
pv
,_
)
->
vtv_of_pv
pv
)
al
in
let
tvs
=
List
.
fold_right
Stv
.
add
its
.
its_args
Stv
.
empty
in
let
regs
=
List
.
fold_right
Sreg
.
add
its
.
its_regs
Sreg
.
empty
in
let
check_tv
tv
=
if
not
(
Stv
.
mem
tv
tvs
)
then
raise
(
UnboundTypeVar
tv
);
true
in
let
check_reg
r
=
if
not
(
Sreg
.
mem
r
regs
)
then
raise
(
UnboundRegion
r
);
true
in
let
check_
pv
(
pv
,_
)
=
match
pv
.
p
v_mut
able
with
|
None
->
ignore
(
ity_v_all
check_tv
check_reg
pv
.
p
v_ity
)
|
Some
r
->
if
not
(
Sreg
.
mem
r
regs
)
then
raise
(
UnboundRegion
r
)
let
check_
arg
vtv
=
match
vtv
.
vt
v_mut
with
|
None
->
ity_v_all
check_tv
check_reg
vtv
.
vt
v_ity
|
Some
r
->
check_reg
r
in
List
.
iter
check_pv
al
;
ignore
(
List
.
for_all
check_arg
vtvs
)
;
(* build the constructor ps *)
let
ity
=
ity_app
its
(
List
.
map
ity_var
its
.
its_args
)
its
.
its_regs
in
let
result
=
create_pvsymbol
(
id_fresh
"result"
)
ity
in
let
ty_args
=
List
.
map
(
fun
(
pv
,
_
)
->
pv
.
pv_vs
.
vs_ty
)
al
in
let
ls
=
create_fsymbol
id
ty_args
(
ty_of_ity
ity
)
in
let
tl
=
List
.
map
(
fun
(
pv
,_
)
->
t_var
pv
.
pv_vs
)
al
in
let
post
=
t_equ
(
t_var
result
.
pv_vs
)
(
t_app
ls
tl
ls
.
ls_value
)
in
let
add_erase
ef
(
pv
,_
)
=
option_fold
eff_reset
ef
pv
.
pv_mutable
in
let
effect
=
List
.
fold_left
add_erase
eff_empty
al
in
let
al
,
(
a
,
_
)
=
Util
.
chop_last
al
in
let
c
=
vty_arrow
a
~
post
~
effect
(
vty_value
result
)
in
let
arrow
(
pv
,_
)
c
=
vty_arrow
pv
c
in
let
v
=
List
.
fold_right
arrow
al
c
in
let
ps
=
create_psymbol
id
Stv
.
empty
Sreg
.
empty
v
in
let
ps_ls
=
{
ps
=
ps
;
ls
=
ls
}
in
news
:=
Sid
.
add
ps
.
p_name
!
news
;
let
tvl
=
List
.
map
ity_var
its
.
its_args
in
let
res
=
vty_value
(
ity_app
its
tvl
its
.
its_regs
)
in
let
pls
=
create_plsymbol
id
vtvs
res
in
news
:=
Sid
.
add
pls
.
pl_ls
.
ls_name
!
news
;
(* build the projections, if any *)
let
build_proj
pv
=
let
id
=
id_clone
pv
.
pv_vs
.
vs_name
in
let
ls
=
create_fsymbol
id
[
result
.
pv_vs
.
vs_ty
]
pv
.
pv_vs
.
vs_ty
in
let
t
=
fs_app
ls
[
t_var
result
.
pv_vs
]
pv
.
pv_vs
.
vs_ty
in
let
post
=
t_equ
(
t_var
pv
.
pv_vs
)
t
in
let
effect
=
option_fold
eff_read
eff_empty
pv
.
pv_mutable
in
let
vty
=
vty_arrow
result
~
post
~
effect
(
vty_value
pv
)
in
let
ps
=
create_psymbol
id
Stv
.
empty
Sreg
.
empty
vty
in
let
ps_ls
=
{
ps
=
ps
;
ls
=
ls
}
in
news
:=
Sid
.
add
ps
.
p_name
!
news
;
Hvs
.
add
projections
pv
.
pv_vs
ps_ls
;
ps_ls
let
build_proj
id
vtv
=
try
Hid
.
find
projections
id
with
Not_found
->
let
pls
=
create_plsymbol
(
id_clone
id
)
[
res
]
vtv
in
news
:=
Sid
.
add
pls
.
pl_ls
.
ls_name
!
news
;
Hid
.
add
projections
id
pls
;
pls
in
let
build_proj
(
pv
,
pj
)
=
let
vtv
=
vtv_of_pv
pv
in
syms
:=
ity_s_fold
syms_its
syms_ts
!
syms
vtv
.
vtv_ity
;
if
pj
then
Some
(
build_proj
pv
.
pv_vs
.
vs_name
vtv
)
else
None
in
let
build_proj
pv
=
try
Hvs
.
find
projections
pv
.
pv_vs
with
Not_found
->
build_proj
pv
in
let
build_proj
(
pv
,
pj
)
=
syms
:=
ity_s_fold
syms_its
syms_ts
!
syms
pv
.
pv_ity
;
if
pj
then
Some
(
build_proj
pv
)
else
None
in
ps_ls
,
List
.
map
build_proj
al
pls
,
List
.
map
build_proj
al
in
let
build_type
(
its
,
cl
)
=
H
vs
.
clear
projections
;
let
build_type
(
its
,
cl
)
=
H
id
.
clear
projections
;
its
,
List
.
map
(
build_constructor
its
)
cl
in
let
tdl
=
List
.
map
build_type
tdl
in
...
...
src/whyml/mlw_decl.mli
View file @
ae369448
...
...
@@ -27,9 +27,7 @@ open Mlw_expr
(** {2 Type declaration} *)
type
ps_ls
=
private
{
ps
:
psymbol
;
ls
:
lsymbol
}
type
constructor
=
ps_ls
*
ps_ls
option
list
type
constructor
=
plsymbol
*
plsymbol
option
list
type
data_decl
=
itysymbol
*
constructor
list
...
...
@@ -42,7 +40,7 @@ type pdecl = private {
pd_tag
:
int
;
(* unique tag *)
}
and
pdecl_node
=
and
pdecl_node
=
private
|
PDtype
of
itysymbol
|
PDdata
of
data_decl
list
...
...
src/whyml/mlw_expr.ml
View file @
ae369448
...
...
@@ -24,6 +24,134 @@ open Ty
open
Term
open
Mlw_ty
(** program variables *)
type
pvsymbol
=
{
pv_vs
:
vsymbol
;
(* has a dummy type if pv_vty is an arrow *)
pv_vty
:
vty
;
pv_tvs
:
Stv
.
t
;
pv_regs
:
Sreg
.
t
;
}
module
Pv
=
Util
.
StructMake
(
struct
type
t
=
pvsymbol
let
tag
pv
=
Hashweak
.
tag_hash
pv
.
pv_vs
.
vs_name
.
id_tag
end
)
module
Spv
=
Pv
.
S
module
Mpv
=
Pv
.
M
let
pv_equal
:
pvsymbol
->
pvsymbol
->
bool
=
(
==
)
let
ts_dummy
=
create_tysymbol
(
id_fresh
"arrow_dummy"
)
[]
None
let
ty_dummy
=
ty_app
ts_dummy
[]
let
create_pvsymbol
id
vtv
=
let
ty
=
ty_of_ity
vtv
.
vtv_ity
in
let
vs
=
create_vsymbol
id
ty
in
{
pv_vs
=
vs
;
pv_vty
=
VTvalue
vtv
;
pv_tvs
=
vtv
.
vtv_tvs
;
pv_regs
=
vtv
.
vtv_regs
;
}
exception
NotValue
of
pvsymbol
let
vtv_of_pv
pv
=
match
pv
.
pv_vty
with
|
VTvalue
vtv
->
vtv
|
VTarrow
_
->
raise
(
NotValue
pv
)
(** program symbols *)
type
psymbol
=
{
ps_name
:
ident
;
ps_vty
:
vty_arrow
;
ps_tvs
:
Stv
.
t
;
ps_regs
:
Sreg
.
t
;
(* these sets cover the type variables and regions of the defining
lambda that cannot be instantiated. Every other type variable
and region in ps_vty is generalized and can be instantiated. *)
}
let
ps_equal
:
psymbol
->
psymbol
->
bool
=
(
==
)
(** program/logic symbols *)
type
plsymbol
=
{
pl_ls
:
lsymbol
;
pl_args
:
vty_value
list
;
pl_value
:
vty_value
;
pl_effect
:
effect
;
}
let
pl_equal
:
plsymbol
->
plsymbol
->
bool
=
(
==
)
let
create_plsymbol
id
args
value
=
let
ty_of_vtv
vtv
=
ty_of_ity
vtv
.
vtv_ity
in
let
pure_args
=
List
.
map
ty_of_vtv
args
in
let
ls
=
create_fsymbol
id
pure_args
(
ty_of_vtv
value
)
in
let
effect
=
Util
.
option_fold
eff_read
eff_empty
value
.
vtv_mut
in
let
arg_reset
acc
a
=
Util
.
option_fold
eff_reset
acc
a
.
vtv_mut
in
let
effect
=
List
.
fold_left
arg_reset
effect
args
in
{
pl_ls
=
ls
;
pl_args
=
args
;
pl_value
=
value
;
pl_effect
=
effect
;
}
(* TODO: patterns *)
(* program expressions *)
type
pre
=
term
(* precondition *)
type
post
=
term
(* postcondition *)
type
xpost
=
(
vsymbol
*
post
)
Mexn
.
t
(* exceptional postconditions *)
type
variant
=
{
v_term
:
term
;
(* : tau *)
v_rel
:
lsymbol
option
;
(* tau tau : prop *)
}
type
expr
=
private
{
e_node
:
expr_node
;
e_vty
:
vty
;
e_effect
:
effect
;
e_tvs
:
Stv
.
t
Mid
.
t
;
e_regs
:
Sreg
.
t
Mid
.
t
;
e_label
:
Slab
.
t
;
e_loc
:
Loc
.
position
option
;
}
and
expr_node
=
|
Elogic
of
term
|
Esymb
of
pvsymbol
|
Ecast
of
psymbol
*
ity_subst
|
Eapp
of
pvsymbol
*
pvsymbol
|
Elet
of
let_defn
*
expr
|
Erec
of
rec_defn
list
*
expr
|
Eif
of
pvsymbol
*
expr
*
expr
|
Eassign
of
pvsymbol
*
pvsymbol
(* mutable pv <- expr *)
|
Eany
and
let_defn
=
{
ld_pv
:
pvsymbol
;
ld_expr
:
expr
;
}
and
rec_defn
=
{
rd_ps
:
psymbol
;
rd_lambda
:
lambda
;
}
and
lambda
=
{
l_args
:
pvsymbol
list
;
l_variant
:
variant
list
;
(* lexicographic order *)
l_pre
:
pre
;
l_expr
:
expr
;
l_post
:
post
;
l_xpost
:
xpost
;
}
(*
- A "proper type" of a vty [v] is [v] with empty specification
(effect/pre/post/xpost). Basically, it is formed from pv_ity's
...
...
@@ -82,66 +210,3 @@ open Mlw_ty
region in [e.e_vty] appear in the range of [e.e_tvs] and [e.e_regs].
*)
type
variant
=
{
v_term
:
term
;
(* : tau *)
v_rel
:
lsymbol
option
;
(* tau tau : prop *)
}
(* program symbols *)
type
psymbol
=
{
p_name
:
ident
;
p_tvs
:
Stv
.
t
;
p_reg
:
Sreg
.
t
;
p_vty
:
vty
;
}
let
create_psymbol
id
tvars
regs
=
function
|
VTvalue
pv
->
let
pv
=
create_pvsymbol
id
?
mut
:
pv
.
pv_mutable
~
ghost
:
pv
.
pv_ghost
pv
.
pv_ity
in
{
p_name
=
pv
.
pv_vs
.
vs_name
;
p_tvs
=
tvars
;
p_reg
=
regs
;
p_vty
=
vty_value
pv
;
}
|
VTarrow
_
as
vty
->
(* TODO? check that tvars/regs are in vty *)
{
p_name
=
id_register
id
;
p_tvs
=
tvars
;
p_reg
=
regs
;
p_vty
=
vty
;
}
let
ps_equal
:
psymbol
->
psymbol
->
bool
=
(
==
)
type
expr
=
private
{
e_node
:
expr_node
;
e_vty
:
vty
;
e_eff
:
effect
;
e_ghost
:
bool
;
e_label
:
Slab
.
t
;
e_loc
:
Loc
.
position
option
;
}
and
expr_node
=
|
Elogic
of
term
|
Esym
of
psymbol
(* function *)
|
Eapp
of
psymbol
*
expr
|
Elet
of
psymbol
*
expr
*
expr
|
Eletrec
of
recfun
list
*
expr
|
Efun
of
lambda
|
Eif
of
expr
*
expr
*
expr
|
Eassign
of
pvsymbol
*
psymbol
*
region
*
expr
(* e1.f<rho> <- e2 *)
and
recfun
=
psymbol
*
lambda
and
lambda
=
{
l_args
:
pvsymbol
list
;
l_variant
:
variant
list
;
(* lexicographic order *)
l_pre
:
term
;
l_body
:
expr
;
l_post
:
term
;
l_xpost
:
xpost
;
}
let
lapp
_
=
assert
false
(*TODO*)
let
papp
_
=
assert
false
(*TODO*)
let
app
_
=
assert
false
(*TODO*)
let
plet
_
=
assert
false
(*TODO*)
let
pletrec
_
=
assert
false
(*TODO*)
let
pfun
_
=
assert
false
(*TODO*)
let
assign
_
=
assert
false
(*TODO*)
src/whyml/mlw_expr.mli
View file @
ae369448
...
...
@@ -24,19 +24,79 @@ open Ty
open
Term
open
Mlw_ty
(* program symbols *)
type
psymbol
=
private
{
p_name
:
ident
;
p_tvs
:
Stv
.
t
;
(* type variables that cannot be instantiated *)
p_reg
:
Sreg
.
t
;
(* regions that cannot be instantiated *)
p_vty
:
vty
;
(** program variables *)
(* pvsymbols represent function arguments (then they must be VTvalue's),
pattern variables (again, VTvalue) or intermediate computation results
introduced by let-expressions. They cannot be type-instantiated. *)
type
pvsymbol
=
private
{
pv_vs
:
vsymbol
;
(* has a dummy type if pv_vty is an arrow *)
pv_vty
:
vty
;
pv_tvs
:
Stv
.
t
;
pv_regs
:
Sreg
.
t
;
(* If pv_vty is a value, these sets coinside with pv_vty.vty_tvs/regs.
If pv_vty is an arrow, we additionally count all type variables
and regions of the defining expression, in order to cover effects
and specification and not overgeneralize. *)
}
val
create_psymbol
:
preid
->
Stv
.
t
->
Sreg
.
t
->
vty
->
psymbol
val
pv_equal
:
pvsymbol
->
pvsymbol
->
bool
(* a value-typed pvsymbol to use in function arguments and patterns *)
val
create_pvsymbol
:
preid
->
vty_value
->
pvsymbol
exception
NotValue
of
pvsymbol
val
vtv_of_pv
:
pvsymbol
->
vty_value
(** program symbols *)
(* psymbols represent lambda-abstractions. They are polymorphic and
can be type-instantiated in some type variables and regions of
their type signature. *)
type
psymbol
=
private
{
ps_name
:
ident
;
ps_vty
:
vty_arrow
;
ps_tvs
:
Stv
.
t
;
ps_regs
:
Sreg
.
t
;
(* these sets cover the type variables and regions of the defining
lambda that cannot be instantiated. Every other type variable
and region in ps_vty is generalized and can be instantiated. *)
}
val
ps_equal
:
psymbol
->
psymbol
->
bool
(* program expressions *)
(** program/logic symbols *)
(* plymbols represent algebraic type constructors and projections.
They must be fully applied and the result is equal to the application of
the lsymbol. We need this kind of symbols to cover nullary constructors,
such as Nil, which cannot be given a post-condition. They cannot be
locally defined and therefore every type variable and region in their
type signature can be instantiated. *)
type
plsymbol
=
private
{
pl_ls
:
lsymbol
;
pl_args
:
vty_value
list
;
pl_value
:
vty_value
;
pl_effect
:
effect
;
}
val
pl_equal
:
plsymbol
->
plsymbol
->
bool
val
create_plsymbol
:
preid
->
vty_value
list
->
vty_value
->
plsymbol
(* FIXME? Effect calculation is hardwired to correspond to constructors
and projections : mutable arguments are reset, mutable result is read. *)
(* TODO: patterns *)
(** program expressions *)
type
pre
=
term
(* precondition *)
type
post
=
term
(* postcondition *)
type
xpost
=
(
vsymbol
*
post
)
Mexn
.
t
(* exceptional postconditions *)
type
variant
=
{
v_term
:
term
;
(* : tau *)
...
...
@@ -44,35 +104,49 @@ type variant = {
}
type
expr
=
private
{
e_node
:
expr_node
;
e_vty
:
vty
;
e_eff
:
effect
;
e_ghost
:
bool
;
e_label
:
Slab
.
t
;
e_loc
:
Loc
.
position
option
;
e_node
:
expr_node
;
e_vty
:
vty
;
e_effect
:
effect
;
e_tvs
:
Stv
.
t
Mid
.
t
;
e_regs
:
Sreg
.
t
Mid
.
t
;
e_label
:
Slab
.
t
;
e_loc
:
Loc
.
position
option
;
}
and
expr_node
=
private
|
Elogic
of
term
|
Esym
of
psymbol
(* function *)
|
Eapp
of
psymbol
*
expr
|
Elet
of
psymbol
*
expr
*
expr
|
Eletrec
of
recfun
list
*
expr
|
Efun
of
lambda
|
Eif
of
expr
*
expr
*
expr
|
Eassign
of
pvsymbol
*
psymbol
*
region
*
expr
(* e1.f<rho> <- e2 *)
|
Esymb
of
pvsymbol
|
Ecast
of
psymbol
*
ity_subst
|
Eapp
of
pvsymbol
*
pvsymbol
|
Elet
of
let_defn
*
expr
|
Erec
of
rec_defn
list
*
expr
|
Eif
of
pvsymbol
*
expr
*
expr
|
Eassign
of
pvsymbol
*
pvsymbol
(* mutable pv <- expr *)
|
Eany
and
recfun
=
psymbol
*
lambda
and
let_defn
=
private
{
ld_pv
:
pvsymbol
;
ld_expr
:
expr
;
}
and
lambda
=
private
{
and
rec_defn
=
private
{
rd_ps
:
psymbol
;
rd_lambda
:
lambda
;
}
and
lambda
=
{
l_args
:
pvsymbol
list
;
l_variant
:
variant
list
;
(* lexicographic order *)
l_pre
:
term
;
l_
body
:
expr
;
l_post
:
term
;
l_pre
:
pre
;
l_
expr
:
expr
;
l_post
:
post
;
l_xpost
:
xpost
;
}
(* TODO: when should we check for escaping identifiers (regions?)
in pre/post/xpost/effects? Here or in WP? *)
(*
val lapp : lsymbol -> expr list -> expr
val papp : psymbol -> expr list -> expr
val app : expr -> expr -> expr
...
...
@@ -80,3 +154,4 @@ val plet : psymbol -> expr -> expr -> expr
val pletrec : recfun list -> expr -> expr
val pfun : lambda -> expr
val assign : expr -> psymbol -> expr -> expr
*)
src/whyml/mlw_module.ml
View file @
ae369448
...
...
@@ -22,6 +22,7 @@ open Why3
open
Util
open
Ident
open
Ty
open
Term
open
Theory
open
Mlw_ty
open
Mlw_expr
...
...
@@ -39,9 +40,15 @@ open Mlw_decl
2. logic decls (no types)
3. program decls
*)
type
prgsymbol
=
|
PV
of
pvsymbol
|
PS
of
psymbol
|
PL
of
plsymbol
type
namespace
=
{
ns_it
:
itysymbol
Mstr
.
t
;
(* type symbols *)
ns_ps
:
psymbol
Mstr
.
t
;
(* program symbols *)
ns_ps
:
p
rg
symbol
Mstr
.
t
;
(* program symbols *)
ns_ns
:
namespace
Mstr
.
t
;
(* inner namespaces *)
}
...
...
@@ -59,11 +66,17 @@ let ns_replace eq chk x vo vn =
let
ns_union
eq
chk
=
Mstr
.
union
(
fun
x
vn
vo
->
Some
(
ns_replace
eq
chk
x
vo
vn
))
let
prg_equal
p1
p2
=
match
p1
,
p2
with
|
PV
p1
,
PV
p2
->
pv_equal
p1
p2
|
PS
p1
,
PS
p2
->
ps_equal
p1
p2
|
PL
p1
,
PL
p2
->
pl_equal
p1
p2
|
_
,
_
->
false
let
rec
merge_ns
chk
ns1
ns2
=
let
fusion
_
ns1
ns2
=
Some
(
merge_ns
chk
ns1
ns2
)
in
{
ns_it
=
ns_union
its_equal
chk
ns1
.
ns_it
ns2
.
ns_it
;
ns_ps
=
ns_union
p
s
_equal
chk
ns1
.
ns_ps
ns2
.
ns_ps
;
ns_ns
=
Mstr
.
union
fusion
ns1
.
ns_ns
ns2
.
ns_ns
;
}
ns_ps
=
ns_union
p
rg
_equal
chk
ns1
.
ns_ps
ns2
.
ns_ps
;
ns_ns
=
Mstr
.
union
fusion
ns1
.
ns_ns
ns2
.
ns_ns
;
}
let
nm_add
chk
x
ns
m
=
Mstr
.
change
(
function
|
None
->
Some
ns
...
...
@@ -74,7 +87,7 @@ let ns_add eq chk x v m = Mstr.change (function
|
Some
vo
->
Some
(
ns_replace
eq
chk
x
vo
v
))
x
m
let
it_add
=
ns_add
its_equal
let
ps_add
=
ns_add
p
s
_equal
let
ps_add
=
ns_add
p
rg
_equal
let
add_it
chk
x
ts
ns
=
{
ns
with
ns_it
=
it_add
chk
x
ts
ns
.
ns_it
}
let
add_ps
chk
x
pf
ns
=
{
ns
with
ns_ps
=
ps_add
chk
x
pf
ns
.
ns_ps
}
...
...
@@ -214,9 +227,9 @@ let add_type uc its =
add_symbol
add_it
its
.
its_pure
.
ts_name
its
uc
let
add_data
uc
(
its
,
csl
)
=
let
add_ps
uc
{
ps
=
ps
}
=
add_symbol
add_ps
ps
.
p
_name
ps
uc
in
let
add_proj
=
option_fold
add_ps
in
let
add_constr
uc
(
ps
,
pjl
)
=
List
.
fold_left
add_proj
(
add_ps
uc
ps
)
pjl
in
let
add_p
l
s
uc
pls
=
add_symbol
add_ps
p
l
s
.
p
l_ls
.
ls_name
(
PL
pls
)
uc
in
let
add_proj
=
option_fold
add_p
l
s
in
let
add_constr
uc
(
ps
,
pjl
)
=
List
.
fold_left
add_proj
(
add_p
l
s
uc
ps
)
pjl
in
let
uc
=
add_symbol
add_it
its
.
its_pure
.
ts_name
its
uc
in
List
.
fold_left
add_constr
uc
csl
...
...
@@ -232,8 +245,8 @@ let add_pdecl uc d =
add_to_theory
Theory
.
add_ty_decl
uc
its
.
its_pure
|
PDdata
dl
->
let
uc
=
List
.
fold_left
add_data
uc
dl
in
let
projection
=
option_map
(
fun
ps
->
ps
.
ls
)
in
let
constructor
(
ps
,
pjl
)
=
ps
.
ls
,
List
.
map
projection
pjl
in
let
projection
=
option_map
(
fun
p
l
s
->
p
l
s
.
pl_
ls
)
in
let
constructor
(
p
l
s
,
pjl
)
=
p
l
s
.
pl_
ls
,
List
.
map
projection
pjl
in
let
defn
cl
=
List
.
map
constructor
cl
in
let
dl
=
List
.
map
(
fun
(
its
,
cl
)
->
its
.
its_pure
,
defn
cl
)
dl
in
add_to_theory
Theory
.
add_data_decl
uc
dl
...
...
src/whyml/mlw_module.mli
View file @
ae369448
...
...
@@ -29,14 +29,19 @@ open Mlw_ty
open
Mlw_expr
open
Mlw_decl
type
prgsymbol
=
|
PV
of
pvsymbol
|
PS
of
psymbol
|
PL
of
plsymbol
type
namespace
=
private
{
ns_it
:
itysymbol
Mstr
.
t
;
(* type symbols *)
ns_ps
:
psymbol
Mstr
.
t
;
(* program symbols *)
ns_ps
:
p
rg
symbol
Mstr
.
t
;
(* program symbols *)
ns_ns
:
namespace
Mstr
.
t
;
(* inner namespaces *)
}
val
ns_find_it
:
namespace
->
string
list
->
itysymbol
val
ns_find_ps
:
namespace
->
string
list
->
psymbol
val
ns_find_ps
:
namespace
->
string
list
->
p
rg
symbol
val
ns_find_ns
:
namespace
->
string
list
->
namespace
(** Module *)
...
...
src/whyml/mlw_pretty.ml
View file @
ae369448
...
...
@@ -50,7 +50,7 @@ let print_reg fmt reg =
(
id_unique
rprinter
reg
.
reg_name
)
let
print_pv
fmt
pv
=
fprintf
fmt
"%s%a"
(
if
pv
.
pv
_ghost
then
"?"
else
""
)
fprintf
fmt
"%s%a"
(
if
vty
_ghost
pv
.
pv_vty
then
"?"
else
""
)
print_vs
pv
.
pv_vs
let
forget_pv
pv
=
forget_var
pv
.
pv_vs
...
...
@@ -87,8 +87,10 @@ let print_reg_opt fmt = function
|
Some
r
->
fprintf
fmt
"<%a>"
print_regty
r
|
None
->
()
(*
let print_pvty fmt pv = fprintf fmt "%a%a:@,%a"
print_pv pv print_reg_opt pv.pv_mutable print_ity pv.pv_ity
*)
(* Labels and locs - copied from Pretty *)
...
...
@@ -107,31 +109,25 @@ let print_tv_arg fmt tv = fprintf fmt "@ %a" print_tv tv
let