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
d3f483bc
Commit
d3f483bc
authored
Jul 28, 2015
by
Andrei Paskevich
Browse files
Mlw: cloning (wip)
parent
ed0c99a6
Changes
9
Hide whitespace changes
Inline
Side-by-side
src/core/theory.ml
View file @
d3f483bc
...
...
@@ -287,8 +287,6 @@ let close_theory uc = match uc.uc_export with
|
_
->
raise
CloseTheory
let
get_namespace
uc
=
List
.
hd
uc
.
uc_import
let
get_known
uc
=
uc
.
uc_known
let
get_rev_decls
uc
=
uc
.
uc_decls
let
open_namespace
uc
s
=
match
uc
.
uc_import
with
|
ns
::
_
->
{
uc
with
...
...
src/core/theory.mli
View file @
d3f483bc
...
...
@@ -116,7 +116,17 @@ val td_hash : tdecl -> int
(** {2 Constructors and utilities} *)
type
theory_uc
(** a theory under construction *)
type
theory_uc
=
private
{
uc_name
:
ident
;
uc_path
:
string
list
;
uc_decls
:
tdecl
list
;
uc_prefix
:
string
list
;
uc_import
:
namespace
list
;
uc_export
:
namespace
list
;
uc_known
:
known_map
;
uc_local
:
Sid
.
t
;
uc_used
:
Sid
.
t
;
}
val
create_theory
:
?
path
:
string
list
->
preid
->
theory_uc
val
close_theory
:
theory_uc
->
theory
...
...
@@ -125,8 +135,6 @@ val open_namespace : theory_uc -> string -> theory_uc
val
close_namespace
:
theory_uc
->
bool
(* import *)
->
theory_uc
val
get_namespace
:
theory_uc
->
namespace
val
get_known
:
theory_uc
->
known_map
val
get_rev_decls
:
theory_uc
->
tdecl
list
val
restore_path
:
ident
->
string
list
*
string
*
string
list
(** [restore_path id] returns the triple (library path, theory,
...
...
src/mlw/pdecl.ml
View file @
d3f483bc
...
...
@@ -440,7 +440,9 @@ let create_exn_decl xs =
"The type of top-level exception %a has mutable components"
print_xs
xs
;
mk_decl
(
PDexn
xs
)
[]
let
create_pure_decl
d
=
mk_decl
PDpure
[
d
]
let
create_pure_decl
d
=
match
d
.
d_node
with
|
Dtype
_
|
Ddata
_
->
invalid_arg
"Pdecl.create_pure_decl"
|
Dparam
_
|
Dlogic
_
|
Dind
_
|
Dprop
_
->
mk_decl
PDpure
[
d
]
(** {2 Built-in decls} *)
...
...
src/mlw/pmodule.ml
View file @
d3f483bc
...
...
@@ -13,6 +13,7 @@ open Stdlib
open
Ident
open
Ty
open
Term
open
Decl
open
Theory
open
Ity
open
Expr
...
...
@@ -91,22 +92,36 @@ let ns_find_rs ns s = match ns_find_prog_symbol ns s with
(** {2 Module} *)
type
pmodule
=
{
mod_theory
:
theory
;
(* pure theory *)
mod_decls
:
pdecl
list
;
(* module declarations *)
mod_export
:
namespace
;
(* exported namespace *)
mod_known
:
known_map
;
(* known identifiers *)
mod_local
:
Sid
.
t
;
(* locally declared idents *)
mod_used
:
Sid
.
t
;
(* used modules *)
mod_theory
:
theory
;
(* pure theory *)
mod_units
:
mod_unit
list
;
(* module declarations *)
mod_export
:
namespace
;
(* exported namespace *)
mod_known
:
known_map
;
(* known identifiers *)
mod_local
:
Sid
.
t
;
(* locally declared idents *)
mod_used
:
Sid
.
t
;
(* used modules *)
}
and
mod_unit
=
|
Udecl
of
pdecl
|
Uuse
of
pmodule
|
Uinst
of
mod_inst
|
Umeta
of
meta
*
meta_arg
list
|
Uscope
of
string
*
bool
*
mod_unit
list
and
mod_inst
=
private
{
mi_mod
:
pmodule
;
mi_ts
:
itysymbol
Mts
.
t
;
mi_ls
:
lsymbol
Mls
.
t
;
mi_pr
:
prsymbol
Mpr
.
t
;
mi_pv
:
pvsymbol
Mpv
.
t
;
mi_rs
:
rsymbol
Mrs
.
t
;
mi_xs
:
xsymbol
Mexn
.
t
;
}
(** {2 Module under construction} *)
type
pmodule_uc
=
{
muc_theory
:
theory_uc
;
muc_name
:
string
;
muc_path
:
string
list
;
muc_decls
:
pdecl
list
;
muc_prefix
:
string
list
;
muc_units
:
mod_unit
list
;
muc_import
:
namespace
list
;
muc_export
:
namespace
list
;
muc_known
:
known_map
;
...
...
@@ -115,15 +130,9 @@ type pmodule_uc = {
muc_env
:
Env
.
env
option
;
}
(* FIXME? We wouldn't need to store muc_name, muc_path,
and muc_prefix if theory_uc was exported *)
let
empty_module
env
n
p
=
{
muc_theory
=
create_theory
~
path
:
p
n
;
muc_name
=
n
.
Ident
.
pre_name
;
muc_path
=
p
;
muc_decls
=
[]
;
muc_prefix
=
[]
;
muc_units
=
[]
;
muc_import
=
[
empty_ns
];
muc_export
=
[
empty_ns
];
muc_known
=
Mid
.
empty
;
...
...
@@ -137,7 +146,7 @@ let close_module, restore_module =
(
fun
uc
->
let
th
=
close_theory
uc
.
muc_theory
in
(* catches errors *)
let
m
=
{
mod_theory
=
th
;
mod_
decl
s
=
List
.
rev
uc
.
muc_
decl
s
;
mod_
unit
s
=
List
.
rev
uc
.
muc_
unit
s
;
mod_export
=
List
.
hd
uc
.
muc_export
;
mod_known
=
uc
.
muc_known
;
mod_local
=
uc
.
muc_local
;
...
...
@@ -149,61 +158,55 @@ let close_module, restore_module =
let
open_namespace
uc
s
=
match
uc
.
muc_import
with
|
ns
::
_
->
{
uc
with
muc_theory
=
Theory
.
open_namespace
uc
.
muc_theory
s
;
muc_
prefix
=
s
::
uc
.
muc_
prefix
;
muc_
units
=
[
Uscope
(
s
,
false
,
uc
.
muc_
units
)]
;
muc_import
=
ns
::
uc
.
muc_import
;
muc_export
=
empty_ns
::
uc
.
muc_export
;
}
|
[]
->
assert
false
let
close_namespace
uc
~
import
=
let
th
=
Theory
.
close_namespace
uc
.
muc_theory
import
in
(* catches errors *)
match
uc
.
muc_
prefix
,
uc
.
muc_import
,
uc
.
muc_export
with
|
s
::
prf
,
_
::
i1
::
sti
,
e0
::
e1
::
ste
->
let
th
=
Theory
.
close_namespace
uc
.
muc_theory
import
in
match
List
.
rev
uc
.
muc_
units
,
uc
.
muc_import
,
uc
.
muc_export
with
|
Uscope
(
s
,_,
ul1
)
::
ul0
,
_
::
i1
::
sti
,
e0
::
e1
::
ste
->
let
i1
=
if
import
then
merge_ns
false
e0
i1
else
i1
in
let
_
=
if
import
then
merge_ns
true
e0
e1
else
e1
in
let
i1
=
add_ns
false
s
e0
i1
in
let
e1
=
add_ns
true
s
e0
e1
in
{
uc
with
muc_theory
=
th
;
muc_
prefix
=
prf
;
muc_
units
=
Uscope
(
s
,
import
,
ul0
)
::
ul1
;
muc_import
=
i1
::
sti
;
muc_export
=
e1
::
ste
;
}
|
_
->
assert
false
|
_
->
assert
false
let
add_to_module
uc
th
ns
=
let
use_export
uc
({
mod_theory
=
mth
}
as
m
)
=
let
th
=
Theory
.
use_export
uc
.
muc_theory
mth
in
let
uc
=
if
Sid
.
mem
mth
.
th_name
uc
.
muc_used
then
uc
else
{
uc
with
muc_known
=
merge_known
uc
.
muc_known
m
.
mod_known
;
muc_used
=
Sid
.
add
mth
.
th_name
uc
.
muc_used
}
in
match
uc
.
muc_import
,
uc
.
muc_export
with
|
i0
::
sti
,
e0
::
ste
->
{
uc
with
muc_theory
=
th
;
muc_import
=
merge_ns
false
ns
i0
::
sti
;
muc_export
=
merge_ns
true
ns
e0
::
ste
;
}
muc_units
=
Uuse
m
::
uc
.
muc_units
;
muc_import
=
merge_ns
false
m
.
mod_export
i0
::
sti
;
muc_export
=
merge_ns
true
m
.
mod_export
e0
::
ste
;
}
|
_
->
assert
false
let
use_export
uc
m
=
let
mth
=
m
.
mod_theory
in
let
id
=
mth
.
th_name
in
let
uc
=
if
Sid
.
mem
id
uc
.
muc_used
then
uc
else
{
uc
with
muc_known
=
merge_known
uc
.
muc_known
m
.
mod_known
;
muc_used
=
Sid
.
add
id
uc
.
muc_used
}
in
let
th
=
Theory
.
use_export
uc
.
muc_theory
mth
in
add_to_module
uc
th
m
.
mod_export
let
add_meta
uc
m
al
=
{
uc
with
muc_theory
=
Theory
.
add_meta
uc
.
muc_theory
m
al
}
let
add_meta
uc
m
al
=
{
uc
with
muc_theory
=
Theory
.
add_meta
uc
.
muc_theory
m
al
;
muc_units
=
Umeta
(
m
,
al
)
::
uc
.
muc_units
;
}
let
store_path
,
store_module
,
restore_path
=
let
id_to_path
=
Wid
.
create
17
in
let
store_path
uc
path
id
=
let
store_path
{
muc_theory
=
uc
}
path
id
=
(* this symbol already belongs to some theory *)
if
Wid
.
mem
id_to_path
id
then
()
else
let
prefix
=
List
.
rev
(
id
.
id_string
::
path
@
uc
.
muc_prefix
)
in
Wid
.
set
id_to_path
id
(
uc
.
muc_path
,
uc
.
muc_name
,
prefix
)
in
let
store_module
m
=
let
id
=
m
.
mod_theory
.
th_name
in
let
prefix
=
List
.
rev
(
id
.
id_string
::
path
@
uc
.
uc_prefix
)
in
Wid
.
set
id_to_path
id
(
uc
.
uc_path
,
uc
.
uc_name
.
id_string
,
prefix
)
in
let
store_module
{
mod_theory
=
{
th_name
=
id
}
as
th
}
=
(* this symbol is already a module *)
if
Wid
.
mem
id_to_path
id
then
()
else
Wid
.
set
id_to_path
id
(
m
.
mod_theory
.
th_path
,
id
.
id_string
,
[]
)
in
Wid
.
set
id_to_path
id
(
th
.
th_path
,
id
.
id_string
,
[]
)
in
let
restore_path
id
=
Wid
.
find
id_to_path
id
in
store_path
,
store_module
,
restore_path
...
...
@@ -248,7 +251,7 @@ let add_symbol add id v uc =
let
add_pdecl
uc
d
=
let
uc
=
{
uc
with
muc_decl
s
=
d
::
uc
.
muc_
decl
s
;
muc_
units
=
U
decl
d
::
uc
.
muc_
unit
s
;
muc_known
=
known_add_decl
uc
.
muc_known
d
;
muc_local
=
Sid
.
union
uc
.
muc_local
d
.
pd_news
}
in
let
add_rs
uc
s
=
add_symbol
add_ps
s
.
rs_name
(
RS
s
)
uc
in
...
...
@@ -331,9 +334,310 @@ let add_pdecl ~vc uc d =
|
None
->
uc
)
ids
uc
in
ignore
vc
;
(* TODO *)
let
uc
=
add_pdecl
uc
d
in
let
th
=
List
.
fold_left
Theory
.
add_decl
uc
.
muc_theory
d
.
pd_pure
in
let
th
=
List
.
fold_left
add_decl
uc
.
muc_theory
d
.
pd_pure
in
{
uc
with
muc_theory
=
th
}
(** {2 Cloning} *)
type
clones
=
{
cl_local
:
Sid
.
t
;
mutable
ts_table
:
itysymbol
Mts
.
t
;
mutable
ls_table
:
lsymbol
Mls
.
t
;
mutable
pr_table
:
prsymbol
Mpr
.
t
;
mutable
rn_table
:
region
Mreg
.
t
;
mutable
pv_table
:
pvsymbol
Mpv
.
t
;
mutable
rs_table
:
rsymbol
Mrs
.
t
;
mutable
xs_table
:
xsymbol
Mexn
.
t
;
}
let
empty_clones
s
=
{
cl_local
=
s
;
ts_table
=
Mts
.
empty
;
ls_table
=
Mls
.
empty
;
pr_table
=
Mpr
.
empty
;
rn_table
=
Mreg
.
empty
;
pv_table
=
Mpv
.
empty
;
rs_table
=
Mrs
.
empty
;
xs_table
=
Mexn
.
empty
;
}
(* populate the clone structure *)
let
rec
cl_find_its
cl
its
=
if
not
(
Sid
.
mem
its
.
its_ts
.
ts_name
cl
.
cl_local
)
then
match
its
.
its_def
with
|
Some
_
->
cl_make_its_alias
cl
its
|
None
->
its
else
try
Mts
.
find
its
.
its_ts
cl
.
ts_table
with
Not_found
->
cl_make_its_pure
cl
its
and
cl_find_ts
cl
ts
=
if
not
(
Sid
.
mem
ts
.
ts_name
cl
.
cl_local
)
then
match
ts
.
ts_def
with
|
Some
_
->
(
cl_make_its_alias
cl
(
restore_its
ts
))
.
its_ts
|
None
->
ts
else
try
(
Mts
.
find
ts
cl
.
ts_table
)
.
its_ts
with
Not_found
->
(
cl_make_its_pure
cl
(
restore_its
ts
))
.
its_ts
and
cl_make_its_pure
cl
({
its_ts
=
ts
}
as
its
)
=
let
id
=
id_clone
ts
.
ts_name
in
let
nts
=
match
its
.
its_def
with
|
Some
def
->
create_itysymbol_alias
id
ts
.
ts_args
(
cl_trans_ity
cl
def
)
|
None
->
create_itysymbol_pure
id
ts
.
ts_args
in
cl
.
ts_table
<-
Mts
.
add
its
.
its_ts
nts
cl
.
ts_table
;
nts
and
cl_make_its_alias
cl
its
=
let
odf
=
Opt
.
get
its
.
its_def
in
let
ndf
=
cl_trans_ity
cl
odf
in
if
ity_equal
odf
ndf
then
its
else
create_itysymbol_alias
(
id_clone
its
.
its_ts
.
ts_name
)
its
.
its_ts
.
ts_args
ndf
and
cl_trans_ity
cl
ity
=
match
ity
.
ity_node
with
|
Ityreg
r
->
ity_reg
(
cl_trans_reg
cl
r
)
|
Ityapp
(
s
,
tl
,
rl
)
->
ity_app
(
cl_find_its
cl
s
)
(
List
.
map
(
cl_trans_ity
cl
)
tl
)
(
List
.
map
(
cl_trans_reg
cl
)
rl
)
|
Itypur
(
s
,
tl
)
->
ity_pur
(
cl_find_its
cl
s
)
(
List
.
map
(
cl_trans_ity
cl
)
tl
)
|
Ityvar
_
->
ity
and
cl_trans_reg
cl
reg
=
(* FIXME: what about global non-instantiated regions? *)
try
Mreg
.
find
reg
cl
.
rn_table
with
Not_found
->
let
r
=
create_region
(
id_clone
reg
.
reg_name
)
(
cl_find_its
cl
reg
.
reg_its
)
(
List
.
map
(
cl_trans_ity
cl
)
reg
.
reg_args
)
(
List
.
map
(
cl_trans_reg
cl
)
reg
.
reg_regs
)
in
cl
.
rn_table
<-
Mreg
.
add
reg
r
cl
.
rn_table
;
r
and
cl_trans_ty
cl
ty
=
ty_s_map
(
cl_find_ts
cl
)
ty
let
cl_find_ls
cl
ls
=
if
not
(
Sid
.
mem
ls
.
ls_name
cl
.
cl_local
)
then
ls
else
(*try*)
Mls
.
find
ls
cl
.
ls_table
(*
with Not_found ->
let constr = ls.ls_constr in
let id = id_clone ls.ls_name in
let ta' = List.map (cl_trans_ty cl) ls.ls_args in
let vt' = Opt.map (cl_trans_ty cl) ls.ls_value in
let ls' = create_lsymbol ~constr id ta' vt' in
cl.ls_table <- Mls.add ls ls' cl.ls_table;
ls'
*)
let
_cl_trans_fmla
cl
f
=
t_s_map
(
cl_trans_ty
cl
)
(
cl_find_ls
cl
)
f
let
_cl_find_pr
cl
pr
=
if
not
(
Sid
.
mem
pr
.
pr_name
cl
.
cl_local
)
then
pr
else
(*try*)
Mpr
.
find
pr
cl
.
pr_table
(*
with Not_found ->
let pr' = create_prsymbol (id_clone pr.pr_name) in
cl.pr_table <- Mpr.add pr pr' cl.pr_table;
pr'
*)
let
_cl_find_pv
cl
pv
=
if
not
(
Sid
.
mem
pv
.
pv_vs
.
vs_name
cl
.
cl_local
)
then
pv
else
Mpv
.
find
pv
cl
.
pv_table
let
_cl_find_rs
cl
rs
=
if
not
(
Sid
.
mem
rs
.
rs_name
cl
.
cl_local
)
then
rs
else
Mrs
.
find
rs
cl
.
rs_table
let
_cl_find_xs
cl
xs
=
if
not
(
Sid
.
mem
xs
.
xs_name
cl
.
cl_local
)
then
xs
else
Mexn
.
find
xs
cl
.
xs_table
(* initialize the clone structure *)
let
cl_init_ts
cl
({
ts_name
=
id
}
as
ts
)
ts'
=
if
not
(
Sid
.
mem
id
cl
.
cl_local
)
then
raise
(
NonLocal
id
);
(* TODO: check later
if List.length ts.ts_args <> List.length ts'.ts_args
then raise (BadInstance (id, ts'.ts_name));
*)
cl
.
ts_table
<-
Mts
.
add
ts
(
restore_its
ts'
)
cl
.
ts_table
let
cl_init_ls
cl
({
ls_name
=
id
}
as
ls
)
ls'
=
if
not
(
Sid
.
mem
id
cl
.
cl_local
)
then
raise
(
NonLocal
id
);
(* TODO: check later
let mtch sb ty ty' =
try ty_match sb ty' (cl_trans_ty cl ty)
with TypeMismatch _ -> raise (BadInstance (id, ls'.ls_name))
in
let sb = match ls.ls_value,ls'.ls_value with
| Some ty, Some ty' -> mtch Mtv.empty ty ty'
| None, None -> Mtv.empty
| _ -> raise (BadInstance (id, ls'.ls_name))
in
ignore (try List.fold_left2 mtch sb ls.ls_args ls'.ls_args
with Invalid_argument _ -> raise (BadInstance (id, ls'.ls_name)));
*)
cl
.
ls_table
<-
Mls
.
add
ls
ls'
cl
.
ls_table
let
cl_init_pr
cl
{
pr_name
=
id
}
=
if
not
(
Sid
.
mem
id
cl
.
cl_local
)
then
raise
(
NonLocal
id
)
let
_cl_init
th
inst
=
let
cl
=
empty_clones
th
.
th_local
in
Mts
.
iter
(
cl_init_ts
cl
)
inst
.
inst_ts
;
Mls
.
iter
(
cl_init_ls
cl
)
inst
.
inst_ls
;
Spr
.
iter
(
cl_init_pr
cl
)
inst
.
inst_lemma
;
Spr
.
iter
(
cl_init_pr
cl
)
inst
.
inst_goal
;
cl
(* clone declarations *)
(*
let cl_type cl inst ts =
if Mts.mem ts inst.inst_ts then
if ts.ts_def = None then raise EmptyDecl
else raise (CannotInstantiate ts.ts_name);
create_ty_decl (cl_find_ts cl ts)
let cl_data cl inst tdl =
let add_ls ls =
if Mls.mem ls inst.inst_ls then
raise (CannotInstantiate ls.ls_name);
cl_find_ls cl ls
in
let add_constr (ls,pl) =
add_ls ls, List.map (Opt.map add_ls) pl
in
let add_type (ts,csl) =
if Mts.mem ts inst.inst_ts then
raise (CannotInstantiate ts.ts_name);
let ts' = cl_find_ts cl ts in
let td' = List.map add_constr csl in
(ts',td')
in
create_data_decl (List.map add_type tdl)
let extract_ls_defn f =
let vl,_,f = match f.t_node with
| Tquant (Tforall,b) -> t_open_quant b
| _ -> [],[],f in
match f.t_node with
| Tapp (_, [{t_node = Tapp (ls,_)}; f])
| Tbinop (_, {t_node = Tapp (ls,_)}, f) -> make_ls_defn ls vl f
| _ -> assert false
let cl_param cl inst ls =
if Mls.mem ls inst.inst_ls then raise EmptyDecl;
create_param_decl (cl_find_ls cl ls)
let cl_logic cl inst ldl =
let add_logic (ls,ld) =
if Mls.mem ls inst.inst_ls then
raise (CannotInstantiate ls.ls_name);
let f = ls_defn_axiom ld in
extract_ls_defn (cl_trans_fmla cl f)
in
create_logic_decl (List.map add_logic ldl)
let cl_ind cl inst (s, idl) =
let add_case (pr,f) =
if Spr.mem pr inst.inst_lemma || Spr.mem pr inst.inst_goal
then raise (CannotInstantiate pr.pr_name)
else cl_find_pr cl pr, cl_trans_fmla cl f
in
let add_ind (ps,la) =
if Mls.mem ps inst.inst_ls
then raise (CannotInstantiate ps.ls_name)
else cl_find_ls cl ps, List.map add_case la
in
create_ind_decl s (List.map add_ind idl)
let cl_prop cl inst (k,pr,f) =
let k' = match k with
| Pskip | Pgoal -> Pskip
| Plemma when Spr.mem pr inst.inst_goal -> Pskip
| Paxiom when Spr.mem pr inst.inst_goal -> Pgoal
| Paxiom when Spr.mem pr inst.inst_lemma -> Plemma
| Paxiom | Plemma -> Paxiom
in
let pr' = cl_find_pr cl pr in
let f' = cl_trans_fmla cl f in
create_prop_decl k' pr' f'
let cl_decl cl inst d = match d.d_node with
| Dtype ts -> cl_type cl inst ts
| Ddata tdl -> cl_data cl inst tdl
| Dparam ls -> cl_param cl inst ls
| Dlogic ldl -> cl_logic cl inst ldl
| Dind idl -> cl_ind cl inst idl
| Dprop p -> cl_prop cl inst p
let cl_marg cl = function
| MAty ty -> MAty (cl_trans_ty cl ty)
| MAts ts -> MAts (cl_find_ts cl ts)
| MAls ls -> MAls (cl_find_ls cl ls)
| MApr pr -> MApr (cl_find_pr cl pr)
| a -> a
let cl_smap cl sm = {
sm_ts = Mts.map (cl_find_ts cl) sm.sm_ts;
sm_ls = Mls.map (cl_find_ls cl) sm.sm_ls;
sm_pr = Mpr.map (cl_find_pr cl) sm.sm_pr}
let cl_tdecl cl inst td = match td.td_node with
| Decl d -> Decl (cl_decl cl inst d)
| Use th -> Use th
| Clone (th,sm) -> Clone (th, cl_smap cl sm)
| Meta (id,al) -> Meta (id, List.map (cl_marg cl) al)
let clone_theory cl add_td acc th inst =
let add acc td =
let td =
try Some (mk_tdecl (cl_tdecl cl inst td))
with EmptyDecl -> None
in
Opt.fold add_td acc td
in
let acc = List.fold_left add acc th.th_decls in
let sm = {
sm_ts = cl.ts_table;
sm_ls = cl.ls_table;
sm_pr = cl.pr_table}
in
add_td acc (mk_tdecl (Clone (th, sm)))
let clone_export muc m inst =
let cl = cl_init th inst in
let uc = clone_theory cl add_tdecl uc th inst in
let g_ts _ ts = not (Mts.mem ts inst.inst_ts) in
let g_ls _ ls = not (Mls.mem ls inst.inst_ls) in
let f_ts p ts =
try let ts = Mts.find ts cl.ts_table in store_path uc p ts.ts_name; ts
with Not_found -> ts in
let f_ls p ls =
try let ls = Mls.find ls cl.ls_table in store_path uc p ls.ls_name; ls
with Not_found -> ls in
let f_pr p pr =
try let pr = Mpr.find pr cl.pr_table in store_path uc p pr.pr_name; pr
with Not_found -> pr in
let rec f_ns p ns = {
ns_ts = Mstr.map (f_ts p) (Mstr.filter g_ts ns.ns_ts);
ns_ls = Mstr.map (f_ls p) (Mstr.filter g_ls ns.ns_ls);
ns_pr = Mstr.map (f_pr p) ns.ns_pr;
ns_ns = Mstr.mapi (fun n -> f_ns (n::p)) ns.ns_ns; } in
let ns = f_ns [] th.th_export in
match uc.uc_import, uc.uc_export with
| i0 :: sti, e0 :: ste -> { uc with
uc_import = merge_ns false ns i0 :: sti;
uc_export = merge_ns true ns e0 :: ste; }
| _ -> assert false
*)
let
clone_export
_muc
_m
_inst
=
assert
false
(* TODO *)
(** {2 WhyML language} *)
type
mlw_file
=
pmodule
Mstr
.
t
...
...
@@ -349,8 +653,6 @@ let convert mm =
let
mlw_language
=
Env
.
register_language
Env
.
base_language
convert
open
Theory
module
Hpath
=
Exthtbl
.
Make
(
struct
type
t
=
Env
.
pathname
let
hash
=
Hashtbl
.
hash
...
...
@@ -379,9 +681,37 @@ let read_module env path s =
let
mm
=
Env
.
read_library
mlw_language
env
path
in
Mstr
.
find_exn
(
ModuleNotFound
(
path
,
s
))
s
mm
(* pretty-printing *)
let
print_path
fmt
sl
=
Pp
.
print_list
(
Pp
.
constant_string
"."
)
Format
.
pp_print_string
fmt
sl
let
print_mname
fmt
{
mod_theory
=
th
}
=
List
.
iter
(
fun
s
->
Format
.
pp_print_string
fmt
s
;
Format
.
pp_print_char
fmt
'.'
)
th
.
th_path
;
Format
.
pp_print_string
fmt
th
.
th_name
.
id_string
let
rec
print_unit
fmt
=
function
|
Udecl
d
->
Pdecl
.
print_pdecl
fmt
d
|
Uuse
m
->
Format
.
fprintf
fmt
"use export %a"
print_mname
m
|
Uinst
mi
->
Format
.
fprintf
fmt
"clone export %a with ..."
print_mname
mi
.
mi_mod
|
Umeta
(
m
,
al
)
->
Format
.
fprintf
fmt
"@[<hov 2>meta %s %a@]"
m
.
meta_name
(
Pp
.
print_list
Pp
.
comma
Pretty
.
print_meta_arg
)
al
|
Uscope
(
s
,
i
,
[
Uuse
m
])
->
Format
.
fprintf
fmt
"use%s %a%s"
(
if
i
then
" import"
else
""
)
print_mname
m
(
if
s
=
m
.
mod_theory
.
th_name
.
id_string
then
""
else
" as "
^
s
)
|
Uscope
(
s
,
i
,
[
Uinst
mi
])
->
Format
.
fprintf
fmt
"clone%s %a%s with ..."
(
if
i
then
" import"
else
""
)
print_mname
mi
.
mi_mod
(
if
s
=
mi
.
mi_mod
.
mod_theory
.
th_name
.
id_string
then
""
else
" as "
^
s
)
|
Uscope
(
s
,
i
,
ul
)
->
Format
.
fprintf
fmt
"@[<hov 2>scope%s %s@
\n
%a@]@
\n
end"
(
if
i
then
" import"
else
""
)
s
(
Pp
.
print_list
Pp
.
newline2
print_unit
)
ul
let
print_module
fmt
m
=
Format
.
fprintf
fmt
"@[<hov 2>module %s@
\n
%a@]@
\n
end"
m
.
mod_theory
.
th_name
.
id_string
(
Pp
.
print_list
Pp
.
newline2
print_unit
)
m
.
mod_units
let
()
=
Exn_printer
.
register
(
fun
fmt
e
->
match
e
with
|
ModuleNotFound
(
sl
,
s
)
->
Format
.
fprintf
fmt
"Module %s not found in library %a"
s
print_path
sl
...
...
src/mlw/pmodule.mli
View file @
d3f483bc
...
...
@@ -11,6 +11,9 @@
open
Stdlib
open
Ident
open
Ty
open
Term
open
Decl
open
Theory
open
Ity
open
Expr
...
...
@@ -42,22 +45,36 @@ val ns_find_ns : namespace -> string list -> namespace
(** {2 Module} *)
type
pmodule
=
private
{
mod_theory
:
theory
;
(* pure theory *)
mod_decls
:
pdecl
list
;
(* module declarations *)
mod_export
:
namespace
;
(* exported namespace *)
mod_known
:
known_map
;
(* known identifiers *)
mod_local
:
Sid
.
t
;
(* locally declared idents *)
mod_used
:
Sid
.
t
;
(* used modules *)
mod_theory
:
theory
;
(* pure theory *)
mod_units
:
mod_unit
list
;
(* module declarations *)
mod_export
:
namespace
;
(* exported namespace *)
mod_known
:
known_map
;
(* known identifiers *)
mod_local
:
Sid
.
t
;
(* locally declared idents *)
mod_used
:
Sid
.
t
;
(* used modules *)
}
and
mod_unit
=
|
Udecl
of
pdecl
|
Uuse
of
pmodule
|
Uinst
of
mod_inst
|
Umeta
of
meta
*
meta_arg
list
|
Uscope
of
string
*
bool
*
mod_unit
list
and
mod_inst
=
private
{