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
d1a5ec78
Commit
d1a5ec78
authored
Apr 19, 2010
by
Andrei Paskevich
Browse files
silence Z warnings and fix a couple of nasty bugs in the meantime
parent
1a166dae
Changes
13
Hide whitespace changes
Inline
Side-by-side
Makefile.in
View file @
d1a5ec78
...
...
@@ -59,8 +59,8 @@ OCAMLVERSION = @OCAMLVERSION@
#PSVIEWER = @PSVIEWER@
#PDFVIEWER = @PDFVIEWER@
BFLAGS
=
-w
Ae
-warn-error
Z
-dtypes
-g
-I
src
$(INCLUDES)
OFLAGS
=
-w
Ae
-warn-error
Z
-dtypes
-I
src
$(INCLUDES)
BFLAGS
=
-w
Ae
-dtypes
-g
-I
src
$(INCLUDES)
OFLAGS
=
-w
Ae
-dtypes
-I
src
$(INCLUDES)
# external libraries common to all binaries
...
...
src/coq-plugin/whytac.ml
View file @
d1a5ec78
...
...
@@ -271,7 +271,7 @@ and tr_global_ts env r =
with
Not_found
->
add_global
global_ts
r
None
;
match
r
with
|
VarRef
id
->
|
VarRef
_
id
->
assert
false
(*TODO*)
|
ConstructRef
_
->
assert
false
...
...
src/core/decl.ml
View file @
d1a5ec78
...
...
@@ -58,16 +58,8 @@ let make_ls_defn ls vl = e_apply (make_fs_defn ls vl) (make_ps_defn ls vl)
let
open_ls_defn
(
_
,
f
)
=
let
vl
,
ef
=
f_open_forall
f
in
match
ef
.
f_node
with
|
Fapp
(
s
,
[
t1
;
t2
])
when
s
==
ps_equ
->
begin
match
t1
.
t_node
with
|
Tapp
(
fs
,
_
)
->
vl
,
Term
t2
|
_
->
assert
false
end
|
Fbinop
(
Fiff
,
f1
,
f2
)
->
begin
match
f1
.
f_node
with
|
Fapp
(
ps
,
_
)
->
vl
,
Fmla
f2
|
_
->
assert
false
end
|
Fapp
(
_
,
[
_
;
t2
])
->
vl
,
Term
t2
|
Fbinop
(
_
,
_
,
f2
)
->
vl
,
Fmla
f2
|
_
->
assert
false
let
open_fs_defn
ld
=
let
vl
,
e
=
open_ls_defn
ld
in
...
...
@@ -137,7 +129,7 @@ module Hsdecl = Hashcons.Make (struct
|
None
,
None
->
true
|
_
->
false
let
eq_iax
(
pr1
,
fr1
)
(
pr2
,
fr2
)
=
pr1
==
pr
1
&&
fr1
==
fr2
let
eq_iax
(
pr1
,
fr1
)
(
pr2
,
fr2
)
=
pr1
==
pr
2
&&
fr1
==
fr2
let
eq_ind
(
ps1
,
al1
)
(
ps2
,
al2
)
=
ps1
==
ps2
&&
list_all2
eq_iax
al1
al2
...
...
@@ -507,7 +499,7 @@ let find_prop kn pr =
|
Dind
dl
->
let
test
(
_
,
l
)
=
List
.
mem_assq
pr
l
in
List
.
assq
pr
(
snd
(
List
.
find
test
dl
))
|
Dprop
(
_
,
pr
,
f
)
->
f
|
Dprop
(
_
,
_
,
f
)
->
f
|
_
->
assert
false
exception
NonExhaustiveExpr
of
(
pattern
list
*
expr
)
...
...
src/core/term.ml
View file @
d1a5ec78
...
...
@@ -294,10 +294,7 @@ module Hsterm = Hashcons.Make (struct
|
Tvar
v1
,
Tvar
v2
->
v1
==
v2
|
Tconst
c1
,
Tconst
c2
->
c1
=
c2
|
Tapp
(
s1
,
l1
)
,
Tapp
(
s2
,
l2
)
->
s1
==
s2
&&
List
.
for_all2
(
==
)
l1
l2
(* Claude: en voila un beau bug
j'espere que cela convaincra les developpeurs
de Why3 de compiler avec l'option -w Z !!! *)
|
Tif
(
f1
,
t1
,
e1
)
,
Tif
(
f2
,
t2
,
e2
)
->
f1
==
f2
&&
t1
==
t2
&&
e2
==
e2
|
Tif
(
f1
,
t1
,
e1
)
,
Tif
(
f2
,
t2
,
e2
)
->
f1
==
f2
&&
t1
==
t2
&&
e1
==
e2
|
Tlet
(
t1
,
b1
)
,
Tlet
(
t2
,
b2
)
->
t1
==
t2
&&
t_eq_bound
b1
b2
|
Tcase
(
tl1
,
bl1
)
,
Tcase
(
tl2
,
bl2
)
->
list_all2
(
==
)
tl1
tl2
&&
list_all2
t_eq_branch
bl1
bl2
...
...
@@ -536,22 +533,22 @@ let brlvl fn lvl acc (_, nv, t) = fn (lvl + nv) acc t
let
t_fold_unsafe
fnT
fnF
lvl
acc
t
=
match
t
.
t_node
with
|
Tbvar
n
when
n
>=
lvl
->
raise
UnboundIndex
|
Tbvar
_
|
Tvar
_
|
Tconst
_
->
acc
|
Tapp
(
f
,
tl
)
->
List
.
fold_left
(
fnT
lvl
)
acc
tl
|
Tapp
(
_
,
tl
)
->
List
.
fold_left
(
fnT
lvl
)
acc
tl
|
Tif
(
f
,
t1
,
t2
)
->
fnT
lvl
(
fnT
lvl
(
fnF
lvl
acc
f
)
t1
)
t2
|
Tlet
(
t1
,
(
u
,
t2
))
->
fnT
(
lvl
+
1
)
(
fnT
lvl
acc
t1
)
t2
|
Tlet
(
t1
,
(
_
,
t2
))
->
fnT
(
lvl
+
1
)
(
fnT
lvl
acc
t1
)
t2
|
Tcase
(
tl
,
bl
)
->
List
.
fold_left
(
brlvl
fnT
lvl
)
(
List
.
fold_left
(
fnT
lvl
)
acc
tl
)
bl
|
Teps
(
u
,
f
)
->
fnF
(
lvl
+
1
)
acc
f
|
Teps
(
_
,
f
)
->
fnF
(
lvl
+
1
)
acc
f
let
f_fold_unsafe
fnT
fnF
lvl
acc
f
=
match
f
.
f_node
with
|
Fapp
(
p
,
tl
)
->
List
.
fold_left
(
fnT
lvl
)
acc
tl
|
Fquant
(
q
,
(
vl
,
nv
,
tl
,
f1
))
->
let
lvl
=
lvl
+
nv
in
|
Fapp
(
_
,
tl
)
->
List
.
fold_left
(
fnT
lvl
)
acc
tl
|
Fquant
(
_
,
(
_
,
nv
,
tl
,
f1
))
->
let
lvl
=
lvl
+
nv
in
tr_fold
(
fnT
lvl
)
(
fnF
lvl
)
(
fnF
lvl
acc
f1
)
tl
|
Fbinop
(
op
,
f1
,
f2
)
->
fnF
lvl
(
fnF
lvl
acc
f1
)
f2
|
Fbinop
(
_
,
f1
,
f2
)
->
fnF
lvl
(
fnF
lvl
acc
f1
)
f2
|
Fnot
f1
->
fnF
lvl
acc
f1
|
Ftrue
|
Ffalse
->
acc
|
Fif
(
f1
,
f2
,
f3
)
->
fnF
lvl
(
fnF
lvl
(
fnF
lvl
acc
f1
)
f2
)
f3
|
Flet
(
t
,
(
u
,
f1
))
->
fnF
(
lvl
+
1
)
(
fnT
lvl
acc
t
)
f1
|
Flet
(
t
,
(
_
,
f1
))
->
fnF
(
lvl
+
1
)
(
fnT
lvl
acc
t
)
f1
|
Fcase
(
tl
,
bl
)
->
List
.
fold_left
(
brlvl
fnF
lvl
)
(
List
.
fold_left
(
fnT
lvl
)
acc
tl
)
bl
...
...
@@ -732,10 +729,10 @@ and f_s_fold fnT fnL acc f =
let
fn_v
acc
u
=
ty_s_fold
fnT
acc
u
.
vs_ty
in
match
f
.
f_node
with
|
Fapp
(
p
,
tl
)
->
List
.
fold_left
fn_t
(
fnL
acc
p
)
tl
|
Fquant
(
q
,
(
vl
,_,
tl
,
f1
))
->
|
Fquant
(
_
,
(
vl
,_,
tl
,
f1
))
->
let
acc
=
List
.
fold_left
fn_v
acc
vl
in
fn_f
(
tr_fold
fn_t
fn_f
acc
tl
)
f1
|
Fbinop
(
op
,
f1
,
f2
)
->
fn_f
(
fn_f
acc
f1
)
f2
|
Fbinop
(
_
,
f1
,
f2
)
->
fn_f
(
fn_f
acc
f1
)
f2
|
Fnot
f1
->
fn_f
acc
f1
|
Ftrue
|
Ffalse
->
acc
|
Fif
(
f1
,
f2
,
f3
)
->
fn_f
(
fn_f
(
fn_f
acc
f1
)
f2
)
f3
...
...
@@ -964,7 +961,7 @@ let f_branch fn acc b = let _,f = f_open_branch b in fn acc f
let
t_fold
fnT
fnF
acc
t
=
match
t
.
t_node
with
|
Tbvar
_
->
raise
UnboundIndex
|
Tvar
_
|
Tconst
_
->
acc
|
Tapp
(
f
,
tl
)
->
List
.
fold_left
fnT
acc
tl
|
Tapp
(
_
,
tl
)
->
List
.
fold_left
fnT
acc
tl
|
Tif
(
f
,
t1
,
t2
)
->
fnT
(
fnT
(
fnF
acc
f
)
t1
)
t2
|
Tlet
(
t1
,
b
)
->
let
_
,
t2
=
t_open_bound
b
in
fnT
(
fnT
acc
t1
)
t2
|
Tcase
(
tl
,
bl
)
->
...
...
@@ -972,10 +969,10 @@ let t_fold fnT fnF acc t = match t.t_node with
|
Teps
b
->
let
_
,
f
=
f_open_bound
b
in
fnF
acc
f
let
f_fold
fnT
fnF
acc
f
=
match
f
.
f_node
with
|
Fapp
(
p
,
tl
)
->
List
.
fold_left
fnT
acc
tl
|
Fquant
(
q
,
b
)
->
let
vl
,
tl
,
f1
=
f_open_quant
b
in
|
Fapp
(
_
,
tl
)
->
List
.
fold_left
fnT
acc
tl
|
Fquant
(
_
,
b
)
->
let
_
,
tl
,
f1
=
f_open_quant
b
in
tr_fold
fnT
fnF
(
fnF
acc
f1
)
tl
|
Fbinop
(
op
,
f1
,
f2
)
->
fnF
(
fnF
acc
f1
)
f2
|
Fbinop
(
_
,
f1
,
f2
)
->
fnF
(
fnF
acc
f1
)
f2
|
Fnot
f1
->
fnF
acc
f1
|
Ftrue
|
Ffalse
->
acc
|
Fif
(
f1
,
f2
,
f3
)
->
fnF
(
fnF
(
fnF
acc
f1
)
f2
)
f3
...
...
@@ -1043,8 +1040,8 @@ let f_subst_single v t1 f = f_v_map (eq_vs v t1) f
(* set of free variables *)
let
t_freevars
s
t
=
t_v_fold
(
fun
s
u
->
Svs
.
add
u
s
)
Svs
.
empty
t
let
f_freevars
s
f
=
f_v_fold
(
fun
s
u
->
Svs
.
add
u
s
)
Svs
.
empty
f
let
t_freevars
s
t
=
t_v_fold
(
fun
s
u
->
Svs
.
add
u
s
)
s
t
let
f_freevars
s
f
=
f_v_fold
(
fun
s
u
->
Svs
.
add
u
s
)
s
f
(* equality modulo alpha *)
...
...
@@ -1063,15 +1060,15 @@ let rec t_equal_alpha t1 t2 =
|
Tif
(
f1
,
t1
,
e1
)
,
Tif
(
f2
,
t2
,
e2
)
->
f_equal_alpha
f1
f2
&&
t_equal_alpha
t1
t2
&&
t_equal_alpha
e1
e2
|
Tlet
(
t1
,
tb1
)
,
Tlet
(
t2
,
tb2
)
->
let
v1
,
b1
=
tb1
in
let
v2
,
b2
=
tb2
in
let
_
,
b1
=
tb1
in
let
_
,
b2
=
tb2
in
t_equal_alpha
t1
t2
&&
t_equal_alpha
b1
b2
|
Tcase
(
tl1
,
bl1
)
,
Tcase
(
tl2
,
bl2
)
->
list_all2
t_equal_alpha
tl1
tl2
&&
list_all2
t_equal_branch_alpha
bl1
bl2
|
Teps
fb1
,
Teps
fb2
->
let
v1
,
f1
=
fb1
in
let
v2
,
f2
=
fb2
in
let
_
,
f1
=
fb1
in
let
_
,
f2
=
fb2
in
f_equal_alpha
f1
f2
|
_
->
false
...
...
@@ -1092,8 +1089,8 @@ and f_equal_alpha f1 f2 =
|
Fif
(
f1
,
g1
,
h1
)
,
Fif
(
f2
,
g2
,
h2
)
->
f_equal_alpha
f1
f2
&&
f_equal_alpha
g1
g2
&&
f_equal_alpha
h1
h2
|
Flet
(
t1
,
fb1
)
,
Flet
(
t2
,
fb2
)
->
let
v1
,
f1
=
fb1
in
let
v2
,
f2
=
fb2
in
let
_
,
f1
=
fb1
in
let
_
,
f2
=
fb2
in
t_equal_alpha
t1
t2
&&
f_equal_alpha
f1
f2
|
Fcase
(
tl1
,
bl1
)
,
Fcase
(
tl2
,
bl2
)
->
list_all2
t_equal_alpha
tl1
tl2
&&
...
...
@@ -1145,16 +1142,16 @@ let rec t_match s t1 t2 =
|
Tif
(
f1
,
t1
,
e1
)
,
Tif
(
f2
,
t2
,
e2
)
->
t_match
(
t_match
(
f_match
s
f1
f2
)
t1
t2
)
e1
e2
|
Tlet
(
t1
,
tb1
)
,
Tlet
(
t2
,
tb2
)
->
let
v1
,
b1
=
tb1
in
let
v2
,
b2
=
tb2
in
let
_
,
b1
=
tb1
in
let
_
,
b2
=
tb2
in
t_match
(
t_match
s
t1
t2
)
b1
b2
|
Tcase
(
tl1
,
bl1
)
,
Tcase
(
tl2
,
bl2
)
->
(
try
List
.
fold_left2
t_match_branch
(
List
.
fold_left2
t_match
s
tl1
tl2
)
bl1
bl2
with
Invalid_argument
_
->
raise
NoMatch
)
|
Teps
fb1
,
Teps
fb2
->
let
v1
,
f1
=
fb1
in
let
v2
,
f2
=
fb2
in
let
_
,
f1
=
fb1
in
let
_
,
f2
=
fb2
in
f_match
s
f1
f2
|
_
->
raise
NoMatch
...
...
@@ -1175,8 +1172,8 @@ and f_match s f1 f2 =
|
Fif
(
f1
,
g1
,
h1
)
,
Fif
(
f2
,
g2
,
h2
)
->
f_match
(
f_match
(
f_match
s
f1
f2
)
g1
g2
)
h1
h2
|
Flet
(
t1
,
fb1
)
,
Flet
(
t2
,
fb2
)
->
let
v1
,
f1
=
fb1
in
let
v2
,
f2
=
fb2
in
let
_
,
f1
=
fb1
in
let
_
,
f2
=
fb2
in
f_match
(
t_match
s
t1
t2
)
f1
f2
|
Fcase
(
tl1
,
bl1
)
,
Fcase
(
tl2
,
bl2
)
->
(
try
List
.
fold_left2
f_match_branch
...
...
src/driver/call_provers.ml
View file @
d1a5ec78
...
...
@@ -171,7 +171,7 @@ let treat_result pr (t,c,outerr) =
here or in the use of why_cpulimit *)
Timeout
|
Unix
.
WSTOPPED
_
|
Unix
.
WSIGNALED
_
->
HighFailure
|
Unix
.
WEXITED
c
->
|
Unix
.
WEXITED
_
->
let
rec
greps
res
=
function
|
[]
->
HighFailure
|
(
r
,
pa
)
::
l
->
...
...
src/driver/driver.ml
View file @
d1a5ec78
...
...
@@ -289,7 +289,7 @@ let load_rules env (premap,tmap) {thr_name = loc,qualid; thr_rules = trl} =
with
Not_found
->
errorm
~
loc
"Unknown proposition %s"
(
string_of_qualid
qualid
q
)
end
|
Rprelude
(
loc
,
s
)
->
|
Rprelude
(
_
loc
,
s
)
->
let
l
=
try
Mid
.
find
th
.
th_name
premap
with
Not_found
->
[]
...
...
@@ -435,7 +435,7 @@ let file_printer =
[]
let
call_prover_on_file
?
debug
?
timeout
drv
filename
=
Call_provers
.
on_file
drv
.
drv_prover
filename
Call_provers
.
on_file
?
debug
?
timeout
drv
.
drv_prover
filename
let
call_prover_on_formatter
?
debug
?
timeout
?
filename
drv
ib
=
Call_provers
.
on_formatter
?
debug
?
timeout
?
filename
drv
.
drv_prover
ib
let
call_prover_on_buffer
?
debug
?
timeout
?
filename
drv
ib
=
...
...
src/main.ml
View file @
d1a5ec78
...
...
@@ -197,7 +197,7 @@ let print_th_namespace fmt th =
let
fname_printer
=
ref
(
Ident
.
create_ident_printer
[]
)
let
do_task
env
drv
fname
tname
(
th
:
Why
.
Theory
.
theory
)
(
task
:
Task
.
task
)
=
let
do_task
_
env
drv
fname
tname
(
th
:
Why
.
Theory
.
theory
)
(
task
:
Task
.
task
)
=
if
!
opt_prove
then
begin
let
res
=
Driver
.
call_prover
~
debug
:!
opt_debug
?
timeout
drv
task
in
printf
"%s %s %s : %a@."
fname
tname
...
...
src/parser/typing.ml
View file @
d1a5ec78
...
...
@@ -217,7 +217,7 @@ let find_lsymbol q uc = find_lsymbol_ns q (get_namespace uc)
let
specialize_lsymbol
p
uc
=
let
s
=
find_lsymbol
p
uc
in
s
,
specialize_lsymbol
(
qloc
p
)
s
s
,
specialize_lsymbol
~
loc
:
(
qloc
p
)
s
let
specialize_fsymbol
p
uc
=
let
s
,
(
tl
,
ty
)
=
specialize_lsymbol
p
uc
in
...
...
src/printer/alt_ergo.ml
View file @
d1a5ec78
...
...
@@ -171,7 +171,7 @@ let print_type_decl drv fmt = function
let
ac_th
=
[
"algebra"
;
"AC"
]
let
print_logic_decl
drv
task
fmt
(
ls
,
ld
)
=
let
print_logic_decl
drv
_
task
fmt
(
ls
,
ld
)
=
match
drv
ls
.
ls_name
with
|
Driver
.
Remove
|
Driver
.
Syntax
_
->
false
|
Driver
.
Tag
s
->
...
...
src/printer/smt.ml
View file @
d1a5ec78
...
...
@@ -39,7 +39,7 @@ let ident_printer =
let
print_ident
fmt
id
=
fprintf
fmt
"%s"
(
id_unique
ident_printer
id
)
let
print_tvsymbols
fmt
id
=
assert
false
let
print_tvsymbols
_
fmt
_
id
=
assert
false
let
forget_var
v
=
forget_id
ident_printer
v
.
vs_name
...
...
@@ -117,7 +117,7 @@ let rec print_fmla drv fmt f = match f.f_node with
end
|
Fquant
(
q
,
fq
)
->
let
q
=
match
q
with
Fforall
->
"forall"
|
Fexists
->
"exists"
in
let
vl
,
tl
,
f
=
f_open_quant
fq
in
let
vl
,
_
tl
,
f
=
f_open_quant
fq
in
(* TODO trigger *)
let
rec
forall
fmt
=
function
|
[]
->
print_fmla
drv
fmt
f
...
...
@@ -172,10 +172,10 @@ let print_type_decl drv fmt = function
|
_
,
Talgebraic
_
->
assert
false
let
print_logic_decl
drv
task
fmt
(
ls
,
ld
)
=
let
print_logic_decl
drv
_
task
fmt
(
ls
,
ld
)
=
match
drv
ls
.
ls_name
with
|
Driver
.
Remove
|
Driver
.
Syntax
_
->
false
|
Driver
.
Tag
s
->
|
Driver
.
Tag
_
s
->
begin
match
ld
with
|
None
->
begin
match
ls
.
ls_value
with
...
...
@@ -189,7 +189,7 @@ let print_logic_decl drv task fmt (ls,ld) =
(
print_list
space
(
print_type
drv
))
ls
.
ls_args
(
print_type
drv
)
value
end
|
Some
ld
->
assert
false
(* Dealt in Encoding *)
|
Some
_
->
assert
false
(* Dealt in Encoding *)
end
;
true
...
...
@@ -201,7 +201,7 @@ let print_decl drv task fmt d = match d.d_node with
|
Dind
_
->
assert
false
(* TODO *)
|
Dprop
(
Paxiom
,
pr
,
_
)
when
drv
pr
.
pr_name
=
Driver
.
Remove
->
false
|
Dprop
(
Paxiom
,
pr
,
f
)
->
|
Dprop
(
Paxiom
,
_
pr
,
f
)
->
fprintf
fmt
"@[<hov 2>:assumption@ %a@]@
\n
"
(
print_fmla
drv
)
f
;
true
|
Dprop
(
Pgoal
,
pr
,
f
)
->
...
...
src/programs/pgm_typing.ml
View file @
d1a5ec78
...
...
@@ -151,7 +151,7 @@ and expr_desc env loc = function
let
e2
=
dexpr
env
e2
in
expected_type
e2
env
.
ty_bool
;
DElazy
(
op
,
e1
,
e2
)
,
env
.
ty_bool
|
Pgm_ptree
.
Ematch
(
el
,
bl
)
->
|
Pgm_ptree
.
Ematch
(
_
el
,
_
bl
)
->
assert
false
(*TODO*)
|
Pgm_ptree
.
Eskip
->
DEskip
,
env
.
ty_unit
...
...
@@ -222,7 +222,7 @@ and expr_desc env denv = function
|
DElabel
(
s
,
e1
)
->
Elabel
(
s
,
expr
env
e1
)
let
code
uc
id
e
=
let
code
uc
_
id
e
=
let
env
=
create_denv
uc
in
let
e
=
dexpr
env
e
in
ignore
(
expr
Mstr
.
empty
e
)
...
...
src/transform/encoding_decorate.ml
View file @
d1a5ec78
...
...
@@ -230,7 +230,7 @@ and rewrite_fmla tenv tvar vsvar f =
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
=
f_open_quant
b
in
|
Fquant
(
q
,
b
)
->
let
vl
,
_
tl
,
f1
=
f_open_quant
b
in
let
conv_vs
(
vsvar
,
acc
)
vs
=
let
tres
,
vsres
=
let
ty_res
=
conv_ty_pos
tenv
vs
.
vs_ty
in
...
...
@@ -268,7 +268,7 @@ let decl (tenv:tenv) d =
type which are not in recursive bloc"
)
|
Dlogic
l
->
let
fn
=
function
|
ls
,
Some
_
->
assert
false
(* TODO or not
|
_
ls
,
Some
_
->
assert
false
(* TODO or not
(remove_logic_definition*)
|
ls
,
None
->
try
...
...
@@ -279,7 +279,7 @@ let decl (tenv:tenv) d =
Hls
.
add
tenv
.
trans_lsymbol
ls
ls_conv
;
ls_conv
,
None
in
[
create_logic_decl
(
List
.
map
fn
l
)]
|
Dind
l
->
failwith
(
"Encoding_decorate : I can't work on inductive"
)
|
Dind
_
->
failwith
(
"Encoding_decorate : I can't work on inductive"
)
(* let fn (pr,f) = pr, fnF f in *)
(* let fn (ps,l) = ps, List.map fn l in *)
(* [create_ind_decl (List.map fn l)] *)
...
...
src/transform/inlining.ml
View file @
d1a5ec78
...
...
@@ -56,7 +56,7 @@ and replacep env f =
match
f
.
f_node
with
|
Fapp
(
ps
,
tl
)
->
begin
try
let
(
vs
,
t
)
=
Mls
.
find
ps
env
.
ps
in
let
(
vs
,
f
)
=
Mls
.
find
ps
env
.
ps
in
let
m
=
List
.
fold_left2
(
fun
acc
x
y
->
Mvs
.
add
x
y
acc
)
Mvs
.
empty
vs
tl
in
f_subst
m
f
...
...
@@ -101,7 +101,7 @@ let fold isnotinlinedt isnotinlinedf d (env, task) =
let
vs
,
e
=
open_ls_defn
ld
in
let
e
=
e_map
(
replacet
env
)
(
replacep
env
)
e
in
make_ls_defn
ls
vs
e
)
dl
))
|
Dtype
dl
->
env
,
add_decl
task
d
|
Dtype
_
->
env
,
add_decl
task
d
|
Dprop
(
k
,
pr
,
f
)
->
env
,
add_decl
task
(
create_prop_decl
k
pr
(
replacep
env
f
))
...
...
@@ -121,14 +121,14 @@ let all = t ~isnotinlinedt:(fun _ -> false) ~isnotinlinedf:(fun _ -> false)
let
trivial
=
t
~
isnotinlinedt
:
(
fun
m
->
match
m
.
t_node
with
|
Tconst
_
|
Tvar
_
->
false
|
Tapp
(
ls
,
tl
)
when
List
.
for_all
|
Tapp
(
_
,
tl
)
when
List
.
for_all
(
fun
m
->
match
m
.
t_node
with
|
Tvar
_
->
true
|
_
->
false
)
tl
->
false
|
_
->
true
)
~
isnotinlinedf
:
(
fun
m
->
match
m
.
f_node
with
|
Ftrue
|
Ffalse
->
false
|
Fapp
(
ls
,
tl
)
when
List
.
for_all
|
Fapp
(
_
,
tl
)
when
List
.
for_all
(
fun
m
->
match
m
.
t_node
with
|
Tvar
_
->
true
|
_
->
false
)
tl
->
false
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment