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
1b291599
Commit
1b291599
authored
Aug 16, 2010
by
Francois Bobot
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
encoding_smt should work with the default option
parent
637c820f
Changes
15
Hide whitespace changes
Inline
Side-by-side
Showing
15 changed files
with
142 additions
and
301 deletions
+142
-301
Makefile.in
Makefile.in
+3
-24
drivers/cvc3.drv
drivers/cvc3.drv
+6
-1
drivers/gen_drv.sh
drivers/gen_drv.sh
+0
-22
drivers/why3_encoding_decorate.drv
drivers/why3_encoding_decorate.drv
+1
-1
drivers/z3.drv
drivers/z3.drv
+6
-2
src/core/term.ml
src/core/term.ml
+1
-0
src/core/term.mli
src/core/term.mli
+1
-0
src/transform/encoding_bridge.ml
src/transform/encoding_bridge.ml
+9
-35
src/transform/encoding_decorate.ml
src/transform/encoding_decorate.ml
+26
-106
src/transform/encoding_decorate.mli
src/transform/encoding_decorate.mli
+0
-1
src/transform/encoding_enumeration.ml
src/transform/encoding_enumeration.ml
+2
-2
src/transform/encoding_enumeration.mli
src/transform/encoding_enumeration.mli
+1
-0
src/transform/encoding_instantiate.ml
src/transform/encoding_instantiate.ml
+84
-87
src/transform/explicit_polymorphism.ml
src/transform/explicit_polymorphism.ml
+2
-0
why.conf
why.conf
+0
-20
No files found.
Makefile.in
View file @
1b291599
...
...
@@ -108,11 +108,11 @@ LIB_DRIVER = call_provers driver_ast driver_parser driver_lexer driver \
whyconf
LIB_TRANSFORM
=
simplify_recursive_definition simplify_formula inlining
\
split_conjunction encoding_decorate encoding_decorate_mono
\
encoding_bridge
\
split_conjunction encoding_const
\
eliminate_definition eliminate_algebraic
\
encoding_enumeration
\
eliminate_inductive eliminate_let eliminate_if
\
encoding_enumeration encoding encoding_decorate_mono
\
encoding_decorate encoding_bridge
\
explicit_polymorphism encoding_simple encoding_instantiate
\
simplify_array filter_trigger split_goal
...
...
@@ -464,27 +464,6 @@ install::
mkdir
-p
$(BINDIR)
cp
-f
bin/why3-cpulimit
$(BINDIR)
#########
# drivers
#########
#Only generated drivers
DIR_DRIVERS
:=
drivers/
DRIVERS
:=
z3_inst cvc3_inst z3_simple cvc3_simple
DRIVERS
:=
$(
addsuffix
.drv,
$(DRIVERS)
)
DRIVERS
:=
$(
addprefix
$(DIR_DRIVERS)
,
$(DRIVERS)
)
#Not great for -j
$(DRIVERS)
:
$(DIR_DRIVERS)z3.drv $(DIR_DRIVERS)cvc3.drv drivers/gen_drv.sh
drivers/gen_drv.sh
byte opt
:
$(DRIVERS)
clean
::
rm
-f
$(DRIVERS)
########
# bench
########
...
...
drivers/cvc3.drv
View file @
1b291599
...
...
@@ -20,7 +20,7 @@ transformation "eliminate_algebraic"
transformation "simplify_formula"
transformation "simplify_trivial_quantification"
transformation "encoding_
decorate
"
transformation "encoding_
smt
"
theory BuiltIn
syntax type int "Int"
...
...
@@ -56,6 +56,9 @@ theory int.Int
remove prop Trans
remove prop Antisymm
remove prop Total
meta "encoding : kept" type int
end
theory real.Real
...
...
@@ -90,6 +93,8 @@ theory real.Real
remove prop Antisymm
remove prop Total
meta "encoding : kept" type real
end
(*
...
...
drivers/gen_drv.sh
deleted
100755 → 0
View file @
637c820f
#!/bin/sh
DIR
=
drivers/
replace
(){
prover
=
$1
;
suffix
=
$2
;
src
=
$3
dst
=
$4
cat
${
DIR
}${
prover
}
.drv |sed
-e
"s/
${
src
}
/
${
dst
}
/"
>
${
DIR
}${
prover
}
_
${
suffix
}
.drv
}
for
prover
in
z3 cvc3
;
do
replace
$prover
"inst"
transformation
\ \"
encoding_decorate
\"
transformation
\ \"
encoding_instantiate
\"
done
for
prover
in
z3 cvc3
;
do
replace
$prover
"simple"
transformation
\ \"
encoding_decorate
\"
\
"transformation
\"
encoding_enumeration
\"\n
transformation
\"
explicit_polymorphism
\"\n
transformation
\"
encoding_simple_kept
\"
"
done
drivers/why3_encoding_decorate.drv
View file @
1b291599
...
...
@@ -8,7 +8,7 @@ transformation "eliminate_algebraic"
transformation "eliminate_if"
transformation "eliminate_let"
transformation "encoding_
decorate
"
transformation "encoding_
smt
"
theory BuiltIn
syntax type int "int"
...
...
drivers/z3.drv
View file @
1b291599
...
...
@@ -20,7 +20,7 @@ transformation "eliminate_algebraic"
transformation "simplify_formula"
transformation "simplify_trivial_quantification"
transformation "encoding_
decorate
"
transformation "encoding_
smt
"
(* transformation "encoding_decorate_every_simple" *)
theory BuiltIn
...
...
@@ -33,7 +33,7 @@ end
theory int.Int
prelude ";;; this is a prelude for Z3, Arithmetic"
syntax logic zero "0"
syntax logic (+) "(+ %1 %2)"
...
...
@@ -59,6 +59,8 @@ theory int.Int
remove prop Antisymm
remove prop Total
meta "encoding : kept" type int
end
...
...
@@ -94,6 +96,8 @@ theory real.Real
remove prop Antisymm
remove prop Total
meta "encoding : kept" type real
end
(*
...
...
src/core/term.ml
View file @
1b291599
...
...
@@ -443,6 +443,7 @@ end)
module
Sterm
=
Term
.
S
module
Mterm
=
Term
.
M
module
Hterm
=
Term
.
H
module
Wterm
=
Term
.
W
module
Hsfmla
=
Hashcons
.
Make
(
struct
...
...
src/core/term.mli
View file @
1b291599
...
...
@@ -173,6 +173,7 @@ and trigger = expr list
module
Mterm
:
Map
.
S
with
type
key
=
term
module
Sterm
:
Set
.
S
with
type
elt
=
term
module
Wterm
:
Hashweak
.
S
with
type
key
=
term
module
Mfmla
:
Map
.
S
with
type
key
=
fmla
module
Sfmla
:
Set
.
S
with
type
elt
=
fmla
...
...
src/transform/encoding_bridge.ml
View file @
1b291599
...
...
@@ -25,18 +25,17 @@ open Task
open
Theory
open
Task
open
Decl
open
Encoding
let
why_filename
=
[
"transform"
;
"encoding_decorate"
]
let
meta_kept
=
Encoding_decorate
.
meta_kept
(* From Encoding Polymorphism CADE07*)
type
lconv
=
{
tb2t
:
lsymbol
;
t2tb
:
lsymbol
;
tb
:
ty
}
type
tenv
=
{
kept
:
Sts
.
t
option
;
type
tenv
=
{
kept
:
Sts
.
t
;
clone_builtin
:
tysymbol
->
Theory
.
tdecl
list
;
specials
:
lconv
Hty
.
t
;
trans_lsymbol
:
lsymbol
Hls
.
t
;
...
...
@@ -52,7 +51,6 @@ let load_prelude kept env =
let
type_t
=
Theory
.
ns_find_ts
builtin
.
th_export
[
"t"
]
in
let
trans_tsymbol
=
Hts
.
create
17
in
let
clone_builtin
ts
=
let
task
=
None
in
let
name
=
ts
.
ts_name
.
id_string
in
let
th_uc
=
create_theory
(
id_fresh
(
"bridge_for_"
^
name
))
in
let
th_uc
=
...
...
@@ -66,7 +64,7 @@ let load_prelude kept env =
let
t2tb
=
ns_find_ls
th
.
th_export
[
"t2tb"
]
in
let
tb
=
ns_find_ts
th
.
th_export
[
"tb"
]
in
let
lconv
=
{
tb2t
=
tb2t
;
t2tb
=
t2tb
;
tb
=
ty_app
tb
[]
}
in
let
task
=
Task
.
use_export
task
th
in
let
task
=
Task
.
use_export
None
th
in
Hts
.
add
trans_tsymbol
ts
tb
;
Hty
.
add
specials
(
ty_app
ts
[]
)
lconv
;
task_tdecls
task
in
...
...
@@ -91,13 +89,7 @@ let rec ty_of_ty tenv ty =
let
ty_of_ty_specials
tenv
ty
=
if
Hty
.
mem
tenv
.
specials
ty
then
ty
else
ty_of_ty
tenv
ty
let
is_kept
tenv
ts
=
ts
.
ts_args
=
[]
&&
begin
match
tenv
.
kept
with
|
None
->
true
(* every_simple *)
|
Some
s
->
Sts
.
mem
ts
s
end
let
is_kept
tenv
ts
=
ts
.
ts_args
=
[]
&&
Sts
.
mem
ts
tenv
.
kept
(* Convert a logic symbols to the encoded one *)
let
conv_ls
tenv
ls
=
...
...
@@ -155,26 +147,15 @@ let rec rewrite_term tenv t =
let
p
=
Hls
.
find
tenv
.
trans_lsymbol
p
in
let
tl
=
List
.
map2
(
conv_arg
tenv
)
tl
p
.
ls_args
in
conv_res_app
tenv
p
tl
t
.
t_ty
|
Tconst
_
|
Tvar
_
|
Tif
_
|
Tlet
_
->
t_map
fnT
fnF
t
|
Tcase
_
|
Teps
_
|
Tbvar
_
->
Printer
.
unsupportedTerm
t
"Encoding decorate : I can't encode this term"
|
_
->
t_map
fnT
fnF
t
and
rewrite_fmla
tenv
f
=
(* Format.eprintf "@[<hov 2>Fmla : %a =>@\n@?" Pretty.print_fmla f; *)
let
fnT
=
rewrite_term
tenv
in
let
fnF
=
rewrite_fmla
tenv
in
match
f
.
f_node
with
|
Fapp
(
p
,
tl
)
when
ls_equal
p
ps_equ
->
let
tl
=
List
.
map
fnT
tl
in
begin
match
tl
with
|
[
a1
;
_
]
->
let
ty
=
a1
.
t_ty
in
let
tl
=
List
.
map2
(
conv_arg
tenv
)
tl
[
ty
;
ty
]
in
f_app
p
tl
|
_
->
assert
false
end
|
Fapp
(
p
,
[
t1
;
t2
])
when
ls_equal
p
ps_equ
->
f_equ
(
fnT
t1
)
(
fnT
t2
)
|
Fapp
(
p
,
tl
)
->
let
tl
=
List
.
map
fnT
tl
in
let
p
=
Hls
.
find
tenv
.
trans_lsymbol
p
in
...
...
@@ -227,15 +208,8 @@ let decl tenv d =
let
t
env
=
Trans
.
on_meta
meta_kept
(
fun
tds
->
let
s
=
Task
.
find_tagged_ts
meta_kept
tds
Sts
.
empty
in
let
init_task
,
tenv
=
load_prelude
(
Some
s
)
env
in
let
init_task
,
tenv
=
load_prelude
s
env
in
Trans
.
tdecl
(
decl
tenv
)
init_task
)
let
()
=
Trans
.
register_env_transform
"encoding_bridge"
t
let
t_all
env
=
let
init_task
,
tenv
=
load_prelude
None
env
in
Trans
.
tdecl
(
decl
tenv
)
init_task
let
()
=
Trans
.
register_env_transform
"encoding_bridge_every_simple"
t_all
let
()
=
register_enco_kept
"bridge"
t
src/transform/encoding_decorate.ml
View file @
1b291599
...
...
@@ -25,20 +25,14 @@ open Task
open
Theory
open
Task
open
Decl
open
Encoding
let
why_filename
=
[
"transform"
;
"encoding_decorate"
]
let
meta_kept
=
register_meta
"encoding_decorate : kept"
[
MTtysymbol
]
(* From Encoding Polymorphism CADE07*)
type
lconv
=
{
d2t
:
lsymbol
;
t2u
:
lsymbol
;
tty
:
term
}
type
tenv
=
{
kept
:
Sts
.
t
option
;
clone_builtin
:
tysymbol
->
Theory
.
tdecl
list
;
specials
:
lconv
Hty
.
t
;
type
tenv
=
{
kept
:
Sts
.
t
;
keptty
:
Sty
.
t
;
deco
:
ty
;
undeco
:
ty
;
sort
:
lsymbol
;
...
...
@@ -58,42 +52,10 @@ let load_prelude kept env =
let
task
=
None
in
let
task
=
Task
.
use_export
task
prelude
in
let
trans_tsymbol
=
Hts
.
create
17
in
let
specials
=
Hty
.
create
17
in
let
builtin
=
Env
.
find_theory
env
why_filename
"Builtin"
in
let
type_t
=
Theory
.
ns_find_ts
builtin
.
th_export
[
"t"
]
in
let
logic_d2t
=
Theory
.
ns_find_ls
builtin
.
th_export
[
"d2t"
]
in
let
logic_t2u
=
Theory
.
ns_find_ls
builtin
.
th_export
[
"t2u"
]
in
let
logic_tty
=
Theory
.
ns_find_ls
builtin
.
th_export
[
"tty"
]
in
let
clone_builtin
ts
=
let
task
=
None
in
let
name
=
ts
.
ts_name
.
id_string
in
let
th_uc
=
create_theory
(
id_fresh
(
"encoding_decorate_for_"
^
name
))
in
let
th_uc
=
Theory
.
use_export
th_uc
prelude
in
let
th_uc
=
if
ts_equal
ts
ts_int
||
ts_equal
ts
ts_real
then
th_uc
else
Theory
.
add_ty_decl
th_uc
[
ts
,
Tabstract
]
in
let
ty
=
ty_app
ts
[]
in
let
add_fsymbol
fs
th_uc
=
Theory
.
add_logic_decl
th_uc
[
fs
,
None
]
in
let
tty
=
create_fsymbol
(
id_clone
ts
.
ts_name
)
[]
tyty
in
let
d2ty
=
create_fsymbol
(
id_fresh
(
"d2"
^
name
))
[
deco
]
ty
in
let
ty2u
=
create_fsymbol
(
id_fresh
(
name
^
"2u"
))
[
ty
]
undeco
in
let
th_uc
=
add_fsymbol
d2ty
(
add_fsymbol
ty2u
(
add_fsymbol
tty
th_uc
))
in
let
th_inst
=
create_inst
~
ts
:
[
type_t
,
ts
]
~
ls
:
[
logic_d2t
,
d2ty
;
logic_t2u
,
ty2u
;
logic_tty
,
tty
]
~
lemma
:
[]
~
goal
:
[]
in
let
lconv
=
{
d2t
=
d2ty
;
t2u
=
ty2u
;
tty
=
t_app
tty
[]
tyty
}
in
let
th_uc
=
Theory
.
clone_export
th_uc
builtin
th_inst
in
let
th
=
close_theory
th_uc
in
let
task
=
Task
.
use_export
task
th
in
Hts
.
add
trans_tsymbol
ts
tty
;
Hty
.
add
specials
(
ty_app
ts
[]
)
lconv
;
task_tdecls
task
in
let
kepty
=
Sts
.
fold
(
fun
ts
->
Sty
.
add
(
ty_app
ts
[]
))
kept
Sty
.
empty
in
task
,
{
kept
=
kept
;
clone_builtin
=
Wts
.
memoize
7
clone_builtin
;
specials
=
specials
;
keptty
=
kepty
;
deco
=
deco
;
undeco
=
undeco
;
ty
=
tyty
;
...
...
@@ -102,13 +64,7 @@ let load_prelude kept env =
trans_tsymbol
=
trans_tsymbol
}
let
is_kept
tenv
ts
=
ts
.
ts_args
=
[]
&&
begin
ts_equal
ts
ts_int
||
ts_equal
ts
ts_real
(* for the constant *)
||
match
tenv
.
kept
with
|
None
->
true
(* every_simple *)
|
Some
s
->
Sts
.
mem
ts
s
end
ts
.
ts_args
=
[]
&&
Sts
.
mem
ts
tenv
.
kept
(* Translate a type to a term *)
let
rec
term_of_ty
tenv
tvar
ty
=
...
...
@@ -131,14 +87,14 @@ let sort_app tenv tvar t ty =
(* Convert a type at the right of an arrow *)
let
conv_ty_neg
tenv
ty
=
if
Hty
.
mem
tenv
.
specials
ty
then
if
Sty
.
mem
ty
tenv
.
kept
ty
then
ty
else
tenv
.
deco
(* Convert a type at the left of an arrow *)
let
conv_ty_pos
tenv
ty
=
if
Hty
.
mem
tenv
.
specials
ty
then
if
Sty
.
mem
ty
tenv
.
kept
ty
then
ty
else
tenv
.
undeco
...
...
@@ -163,31 +119,11 @@ let conv_ts tenv ts =
let
tyl
=
List
.
map
(
fun
_
->
tenv
.
ty
)
ts
.
ts_args
in
create_fsymbol
preid
tyl
tenv
.
ty
(* Convert the argument of a function from specials to deco or deco to
specials if needed*)
let
conv_arg
tenv
tvar
t
ty
=
let
tty
=
t
.
t_ty
in
if
ty_equal
tty
ty
then
t
else
if
ty_equal
ty
tenv
.
deco
then
let
tylconv
=
Hty
.
find
tenv
.
specials
tty
in
let
t
=
(
t_app
tylconv
.
t2u
[
t
]
tenv
.
undeco
)
in
sort_app
tenv
tvar
t
tty
else
(* tty is tenv.deco *)
begin
assert
(
ty_equal
tty
tenv
.
deco
);
let
tylconv
=
Hty
.
find
tenv
.
specials
ty
in
t_app
tylconv
.
d2t
[
t
]
ty
end
(* Convert to undeco or to a specials an application *)
let
conv_res_app
tenv
tvar
p
tl
ty
=
let
tty
=
Util
.
of_option
p
.
ls_value
in
if
ty_equal
tty
ty
then
t_app
p
tl
tty
else
begin
assert
(
ty_equal
tty
tenv
.
undeco
);
let
t
=
t_app
p
tl
tenv
.
undeco
in
sort_app
tenv
tvar
t
ty
end
let
conv_res_app
tenv
tvar
t
ty
=
let
tty
=
t
.
t_ty
in
if
Sty
.
mem
tty
tenv
.
keptty
then
t
else
sort_app
tenv
tvar
t
ty
let
conv_vs
tenv
tvar
(
vsvar
,
acc
)
vs
=
let
tres
,
vsres
=
...
...
@@ -214,7 +150,8 @@ let conv_vs_let vsvar vs ty_res =
let
rec
rewrite_term
tenv
tvar
vsvar
t
=
(*Format.eprintf "@[<hov 2>Term : %a =>@\n@?" Pretty.print_term t;*)
(* Format.eprintf "@[<hov 3>Term : %a : %a =>@\n@?" *)
(* Pretty.print_term t Pretty.print_ty t.t_ty; *)
let
fnT
=
rewrite_term
tenv
tvar
in
let
fnF
=
rewrite_fmla
tenv
tvar
vsvar
in
match
t
.
t_node
with
...
...
@@ -223,8 +160,8 @@ let rec rewrite_term tenv tvar vsvar t =
|
Tapp
(
p
,
tl
)
->
let
tl
=
List
.
map
(
fnT
vsvar
)
tl
in
let
p
=
Hls
.
find
tenv
.
trans_lsymbol
p
in
let
t
l
=
List
.
map2
(
conv_arg
tenv
tvar
)
tl
p
.
ls_args
in
conv_res_app
tenv
tvar
p
tl
t
.
t_ty
let
t
'
=
t_app_infer
p
tl
in
conv_res_app
tenv
tvar
t'
t
.
t_ty
|
Tif
(
f
,
t1
,
t2
)
->
t_if
(
fnF
f
)
(
fnT
vsvar
t1
)
(
fnT
vsvar
t2
)
|
Tlet
(
t1
,
b
)
->
...
...
@@ -238,27 +175,19 @@ let rec rewrite_term tenv tvar vsvar t =
"Encoding decorate : I can't encode this term"
and
rewrite_fmla
tenv
tvar
vsvar
f
=
(* Format.eprintf "@[<hov
2>Fmla : %a =>@\n@?
" Pretty.print_fmla f; *)
(* Format.eprintf "@[<hov
>Fmla : %a =>@]@.
" Pretty.print_fmla f; *)
let
fnT
=
rewrite_term
tenv
tvar
vsvar
in
let
fnF
=
rewrite_fmla
tenv
tvar
in
match
f
.
f_node
with
|
Fapp
(
p
,
tl
)
when
ls_equal
p
ps_equ
->
let
tl
=
List
.
map
fnT
tl
in
begin
match
tl
with
|
[
a1
;
_
]
->
let
ty
=
if
Hty
.
mem
tenv
.
specials
a1
.
t_ty
then
a1
.
t_ty
else
tenv
.
deco
in
let
tl
=
List
.
map2
(
conv_arg
tenv
tvar
)
tl
[
ty
;
ty
]
in
f_app
p
tl
|
_
->
assert
false
end
|
Fapp
(
p
,
[
a1
;
a2
])
when
ls_equal
p
ps_equ
->
let
a1
=
fnT
a1
in
let
a2
=
fnT
a2
in
(* Format.eprintf "@[<hov>%a : %a = %a : %a@]@." *)
(* Pretty.print_term a1 Pretty.print_ty a1.t_ty *)
(* Pretty.print_term a2 Pretty.print_ty a2.t_ty; *)
f_equ
a1
a2
|
Fapp
(
p
,
tl
)
->
let
tl
=
List
.
map
fnT
tl
in
let
p
=
Hls
.
find
tenv
.
trans_lsymbol
p
in
let
tl
=
List
.
map2
(
conv_arg
tenv
tvar
)
tl
p
.
ls_args
in
f_app
p
tl
|
Fquant
(
q
,
b
)
->
let
vl
,
tl
,
f1
,
close
=
f_open_quant_cb
b
in
...
...
@@ -281,8 +210,7 @@ let decl (tenv:tenv) d =
(* let fnT = rewrite_term tenv in *)
let
fnF
=
rewrite_fmla
tenv
in
match
d
.
d_node
with
|
Dtype
[
ts
,
Tabstract
]
when
is_kept
tenv
ts
->
tenv
.
clone_builtin
ts
|
Dtype
[
ts
,
Tabstract
]
when
is_kept
tenv
ts
->
[
create_decl
d
]
|
Dtype
[
ts
,
Tabstract
]
->
let
tty
=
try
...
...
@@ -333,15 +261,7 @@ let decl tenv d =
let
t
env
=
Trans
.
on_meta
meta_kept
(
fun
tds
->
let
s
=
Task
.
find_tagged_ts
meta_kept
tds
Sts
.
empty
in
let
init_task
,
tenv
=
load_prelude
(
Some
s
)
env
in
let
init_task
,
tenv
=
load_prelude
s
env
in
Trans
.
tdecl
(
decl
tenv
)
init_task
)
let
()
=
Trans
.
register_env_transform
"encoding_decorate"
t
let
t_all
env
=
let
init_task
,
tenv
=
load_prelude
None
env
in
Trans
.
tdecl
(
decl
tenv
)
init_task
let
()
=
Trans
.
register_env_transform
"encoding_decorate_every_simple"
t_all
let
()
=
register_enco_poly
"decorate"
t
src/transform/encoding_decorate.mli
View file @
1b291599
...
...
@@ -23,4 +23,3 @@
Jean-Francois Couchot et Stephane Lescuyer *)
val
why_filename
:
string
list
val
meta_kept
:
Theory
.
meta
src/transform/encoding_enumeration.ml
View file @
1b291599
...
...
@@ -79,12 +79,12 @@ let decl tenv d = match d.d_node with
|
_
->
[
decl_map
(
rewrite_term
tenv
)
(
rewrite_fmla
tenv
)
d
]
let
t
=
let
encoding_enumeration
=
let
projs
=
Hts
.
create
17
in
Trans
.
on_meta
meta_enum
(
fun
tds
->
let
enum
=
Task
.
find_tagged_ts
meta_enum
tds
Sts
.
empty
in
let
tenv
=
{
enum
=
enum
;
projs
=
projs
}
in
Trans
.
decl
(
decl
tenv
)
None
)
let
()
=
Trans
.
register_transform
"encoding_enumeration"
t
let
()
=
Trans
.
register_transform
"encoding_enumeration"
encoding_enumeration
src/transform/encoding_enumeration.mli
View file @
1b291599
...
...
@@ -17,3 +17,4 @@
(* *)
(**************************************************************************)
val
encoding_enumeration
:
Task
.
task
Trans
.
trans
src/transform/encoding_instantiate.ml
View file @
1b291599
...
...
@@ -26,23 +26,19 @@ open Task
open
Theory
open
Task
open
Decl
open
Encoding
let
meta_kept
=
register_meta
"encoding_instantiate : kept"
[
MTtysymbol
]
let
meta_level
=
register_meta_excl
"encoding_instantiate : level"
[
MTstring
]
let
meta_complete
=
register_meta_excl
let
meta_complete
=
register_meta_excl
"encoding_instantiate : complete"
[
MTstring
]
(* Ce type est utiliser pour indiquer un alpha *)
let
tv_dumb
=
create_tvsymbol
(
id_fresh
"instantiate_alpha"
)
let
tv_dumb
=
create_tvsymbol
(
id_fresh
"instantiate_alpha"
)
let
ty_dumb
=
ty_var
tv_dumb
(* TODO : transmettre les tags des logiques polymorphe vers les logiques
instantié. Un tag sur un logique polymorphe doit être un tag sur toute
la famille de fonctions *)
(* TODO : transmettre les tags des logiques polymorphe vers les logiques
instantié. Un tag sur un logique polymorphe doit être un tag sur toute
la famille de fonctions *)
module
OHTyl
=
OrderedHashList
(
Tty
)
module
Mtyl
=
Map
.
Make
(
OHTyl
)
...
...
@@ -59,7 +55,7 @@ type tenv =
|
Incomplete
(* The environnement when the transformation isn't complete*)
(* A type is projected on term or type depending
(* A type is projected on term or type depending
of its color (green part,red part, black part) *)
type
tty
=
|
Tyterm
of
ty
...
...
@@ -100,7 +96,7 @@ type env = {
edefined_tsymbol
:
tysymbol
Mtyl
.
t
Mts
.
t
;
}
(* The environnement of the transformation during
(* The environnement of the transformation during
the transformation of a formula *)
type
menv
=
{
tenv
:
tenv
;
...
...
@@ -114,12 +110,12 @@ type menv = {
let
print_env
fmt
menv
=
Format
.
fprintf
fmt
"defined_lsymbol (%a)@."
(
Pp
.
print_iter2
Mls
.
iter
Pp
.
semi
Pp
.
comma
Pretty
.
print_ls
(
Pp
.
print_iter2
Mls
.
iter
Pp
.
semi
Pp
.
comma
Pretty
.
print_ls
(
Pp
.
print_iter2
Mtyl
.
iter
Pp
.
semi
Pp
.
arrow
(
Pp
.
print_list
Pp
.
space
Pretty
.
print_ty
)
Pretty
.
print_ls
))
menv
.
defined_lsymbol
;
Format
.
fprintf
fmt
"defined_tsymbol (%a)@."
(
Pp
.
print_iter2
Mts
.
iter
Pp
.
semi
Pp
.
comma
Pretty
.
print_ts
(
Pp
.
print_iter2
Mts
.
iter
Pp
.
semi
Pp
.
comma
Pretty
.
print_ts
(
Pp
.
print_iter2
Mtyl
.
iter
Pp
.
semi
Pp
.
arrow
(
Pp
.
print_list
Pp
.
space
Pretty
.
print_ty
)
Pretty
.
print_ts
))
menv
.
defined_tsymbol
...
...
@@ -137,9 +133,9 @@ let rec projty menv tvar ty =
Tyty
(
Mty
.
find
ty
menv
.
projty
)
with
Not_found
->
match
menv
.
tenv
with
|
Incomplete
->
|
Incomplete
->
(* In this configuration there is no term representing type,
all type are a type or are in the black part
all type are a type or are in the black part
(the or is not a xor)*)
let
preid
=
id_clone
ts
.
ts_name
in
let
ts
=
create_tysymbol
preid
[]
None
(*Some ty*)
in
...
...
@@ -152,7 +148,7 @@ let rec projty menv tvar ty =
|
Complete
->
let
tyl
=
List
.
map
aux
tyl
in
let
tyl_red
=
List
.
map
reduce_to_type
tyl
in
let
tys
=
let
tys
=
try
Mtyl
.
find
tyl_red
(
Mts
.
find
ts
menv
.
defined_tsymbol
)
with
Not_found
->
...
...
@@ -162,8 +158,8 @@ let rec projty menv tvar ty =
match
e
with
|
Tyterm
_
->
(
create_tvsymbol
(
id_fresh
"a"
))
::
acc
|
Tyty
_
->
acc
)
[]
tyl
in
let
tys
=
if
List
.
length
args
=
List
.
length
ts
.
ts_args
then
ts
let
tys
=
if
List
.
length
args
=
List
.
length
ts
.
ts_args
then
ts
else
create_tysymbol
(
id_clone
ts
.
ts_name
)
args
None
in
let
insts
=
Mtyl
.
add
tyl_red
tys
insts
in
menv
.
defined_tsymbol
<-
...
...
@@ -187,7 +183,7 @@ let projty_real menv tvar ty = reduce_to_real (projty menv tvar ty)
(* | Complete -> projty menv Mtv.empty d *)
let
reduce_to_default
menv
tvar
d
ty
=
let
reduce_to_default
menv
tvar
d
ty
=
match
projty
menv
tvar
ty
with
|
Tyty
ty
->
ty
|
Tyterm
_
->
ty_var
d
...
...
@@ -196,7 +192,7 @@ let find_logic menv tvar p tyl ret =
if
ls_equal
p
ps_equ
then
p
else
begin
let
inst
=
ls_app_inst
p
tyl
ret
in
(*Format.eprintf "inst : %a@."
(Pp.print_iter2 Mtv.iter Pp.comma Pp.space Pp.nothing
(Pp.print_iter2 Mtv.iter Pp.comma Pp.space Pp.nothing
Pretty.print_ty) inst;*)
let
inst
=
Mtv
.
mapi
(
reduce_to_default
menv
tvar
)
inst
in
let
inst_l
=
Mtv
.
fold
(
fun
_
v
acc
->
v
::
acc
)
inst
[]
in
...
...
@@ -208,9 +204,9 @@ let find_logic menv tvar p tyl ret =
(* (List.length inst_l); *)
try
let
insts
=
Mls
.
find
p
menv
.
defined_lsymbol
in
Mtyl
.
find
inst_l
insts
Mtyl
.
find
inst_l
insts
with
Not_found
->