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
1501f43a
Commit
1501f43a
authored
May 16, 2011
by
Andrei Paskevich
Browse files
make term traversal functions take one fnT function
move old fnT+fnF versions of t_map, t_fold, etc. to a submodule
parent
903df0ef
Changes
46
Expand all
Hide whitespace changes
Inline
Side-by-side
examples/use_api.ml
View file @
1501f43a
...
...
@@ -34,17 +34,17 @@ let fmla1 : Term.fmla = Term.f_or fmla_true fmla_false
(* printing it *)
open
Format
let
()
=
printf
"@[formula 1 is:@ %a@]@."
Pretty
.
print_
fmla
fmla1
let
()
=
printf
"@[formula 1 is:@ %a@]@."
Pretty
.
print_
term
fmla1
(* a propositional goal: A and B implies A *)
let
prop_var_A
:
Term
.
lsymbol
=
Term
.
create_psymbol
(
Ident
.
id_fresh
"A"
)
[]
let
prop_var_B
:
Term
.
lsymbol
=
Term
.
create_psymbol
(
Ident
.
id_fresh
"B"
)
[]
let
atom_A
:
Term
.
fmla
=
Term
.
f
_app
prop_var_A
[]
let
atom_B
:
Term
.
fmla
=
Term
.
f
_app
prop_var_B
[]
let
atom_A
:
Term
.
fmla
=
Term
.
ps
_app
prop_var_A
[]
let
atom_B
:
Term
.
fmla
=
Term
.
ps
_app
prop_var_B
[]
let
fmla2
:
Term
.
fmla
=
Term
.
f_implies
(
Term
.
f_and
atom_A
atom_B
)
atom_A
let
()
=
printf
"@[formula 2 is:@ %a@]@."
Pretty
.
print_
fmla
fmla2
let
()
=
printf
"@[formula 2 is:@ %a@]@."
Pretty
.
print_
term
fmla2
(* building the task for formula 1 alone *)
...
...
@@ -122,7 +122,7 @@ let int_theory : Theory.theory =
Env
.
find_theory
env
[
"int"
]
"Int"
let
plus_symbol
:
Term
.
lsymbol
=
Theory
.
ns_find_ls
int_theory
.
Theory
.
th_export
[
"infix +"
]
let
two_plus_two
:
Term
.
term
=
Term
.
t
_app
plus_symbol
[
two
;
two
]
Ty
.
ty_int
let
two_plus_two
:
Term
.
term
=
Term
.
fs
_app
plus_symbol
[
two
;
two
]
Ty
.
ty_int
let
two_plus_two
:
Term
.
term
=
Term
.
t_app_infer
plus_symbol
[
two
;
two
]
let
fmla3
:
Term
.
fmla
=
Term
.
f_equ
two_plus_two
four
...
...
@@ -157,7 +157,7 @@ let x : Term.term = Term.t_var var_x
let
x_times_x
:
Term
.
term
=
Term
.
t_app_infer
mult_symbol
[
x
;
x
]
let
fmla4_aux
:
Term
.
fmla
=
Term
.
f
_app
ge_symbol
[
x_times_x
;
zero
]
Term
.
ps
_app
ge_symbol
[
x_times_x
;
zero
]
let
fmla4_quant
:
Term
.
fmla_quant
=
Term
.
f_close_quant
[
var_x
]
[]
fmla4_aux
let
fmla4
:
Term
.
fmla
=
...
...
src/core/decl.ml
View file @
1501f43a
...
...
@@ -44,39 +44,26 @@ let check_fvs f =
Svs
.
iter
(
fun
vs
->
raise
(
UnboundVar
vs
))
fvs
;
f
let
check_ty
=
Ty
.
check_ty_equal
let
check_vl
ty
v
=
ty_equal_check
ty
v
.
vs_ty
let
check_tl
ty
t
=
ty_equal_check
ty
(
t_type
t
)
let
check_vl
ty
v
=
check_ty
ty
v
.
vs_ty
let
check_tl
ty
t
=
check_ty
ty
(
t_type
t
)
let
make_fs_defn
fs
vl
t
=
let
hd
=
e_app
fs
(
List
.
map
t_var
vl
)
t
.
t_ty
in
let
fd
=
f_forall_close
vl
[]
(
f_equ
hd
t
)
in
check_t_ty
fs
.
ls_value
t
;
List
.
iter2
check_vl
fs
.
ls_args
vl
;
fs
,
Some
(
fs
,
check_fvs
fd
)
let
make_ps_defn
ps
vl
f
=
let
hd
=
f_app
ps
(
List
.
map
t_var
vl
)
in
let
pd
=
f_forall_close
vl
[]
(
f_iff
hd
f
)
in
List
.
iter2
check_vl
ps
.
ls_args
vl
;
ps
,
Some
(
ps
,
check_fvs
pd
)
let
make_ls_defn
ls
vl
=
e_map
(
make_fs_defn
ls
vl
)
(
make_ps_defn
ls
vl
)
let
make_ls_defn
ls
vl
t
=
let
hd
=
t_app
ls
(
List
.
map
t_var
vl
)
t
.
t_ty
in
let
hd
=
e_fold
f_equ
f_iff
hd
t
in
let
fd
=
f_forall_close
vl
[]
hd
in
List
.
iter2
check_vl
ls
.
ls_args
vl
;
t_ty_check
t
ls
.
ls_value
;
ls
,
Some
(
ls
,
check_fvs
fd
)
let
open_ls_defn
(
_
,
f
)
=
let
vl
,
ef
=
f_open_forall
f
in
match
ef
.
t_node
with
|
Tapp
(
_
,
[
_
;
t2
])
->
vl
,
t2
|
Fbinop
(
_
,
_
,
f2
)
->
vl
,
f2
let
vl
,_,
f
=
match
f
.
t_node
with
|
Fquant
(
Fforall
,
b
)
->
f_open_quant
b
|
_
->
[]
,
[]
,
f
in
match
f
.
t_node
with
|
Tapp
(
_
,
[
_
;
f
])
|
Fbinop
(
_
,
_
,
f
)
->
vl
,
f
|
_
->
assert
false
let
open_fs_defn
ld
=
let
vl
,
e
=
open_ls_defn
ld
in
if
e
.
t_ty
=
None
then
assert
false
else
vl
,
e
let
open_ps_defn
ld
=
let
vl
,
e
=
open_ls_defn
ld
in
if
e
.
t_ty
=
None
then
vl
,
e
else
assert
false
let
ls_defn_axiom
(
_
,
f
)
=
f
(** Termination checking for mutually recursive logic declarations *)
...
...
@@ -128,7 +115,7 @@ let build_call_graph cgr syms ls =
in
let
rec
term
vm
()
t
=
match
t
.
t_node
with
|
Tapp
(
s
,
tl
)
when
Mls
.
mem
s
syms
->
t_fold
(
term
vm
)
(
fmla
vm
)
()
t
;
call
vm
s
tl
t_fold
(
term
vm
)
()
t
;
call
vm
s
tl
|
Tlet
({
t_node
=
Tvar
v
}
,
b
)
when
Mvs
.
mem
v
vm
->
let
u
,
e
=
t_open_bound
b
in
term
(
Mvs
.
add
u
(
Mvs
.
find
v
vm
)
vm
)
()
e
...
...
@@ -137,27 +124,15 @@ let build_call_graph cgr syms ls =
let
p
,
t
=
t_open_branch
b
in
let
vml
=
match_term
vm
e
[
vm
]
p
in
List
.
iter
(
fun
vm
->
term
vm
()
t
)
vml
)
bl
|
_
->
t_fold
(
term
vm
)
(
fmla
vm
)
()
t
and
fmla
vm
()
f
=
match
f
.
t_node
with
|
Tapp
(
s
,
tl
)
when
Mls
.
mem
s
syms
->
t_fold
(
term
vm
)
(
fmla
vm
)
()
f
;
call
vm
s
tl
|
Tlet
({
t_node
=
Tvar
v
}
,
b
)
when
Mvs
.
mem
v
vm
->
let
u
,
e
=
t_open_bound
b
in
fmla
(
Mvs
.
add
u
(
Mvs
.
find
v
vm
)
vm
)
()
e
|
Tcase
(
e
,
bl
)
->
term
vm
()
e
;
List
.
iter
(
fun
b
->
let
p
,
f
=
t_open_branch
b
in
let
vml
=
match_term
vm
e
[
vm
]
p
in
List
.
iter
(
fun
vm
->
fmla
vm
()
f
)
vml
)
bl
|
Fquant
(
_
,
b
)
->
let
_
,_,
f
=
f_open_quant
b
in
fmla
vm
()
f
|
_
->
t_fold
(
term
vm
)
(
fmla
vm
)
()
f
let
_
,_,
f
=
f_open_quant
b
in
term
vm
()
f
|
_
->
t_fold
(
term
vm
)
(
)
t
in
fun
(
vl
,
e
)
->
let
i
=
ref
(
-
1
)
in
let
add
vm
v
=
incr
i
;
Mvs
.
add
v
(
Equal
!
i
)
vm
in
let
vm
=
List
.
fold_left
add
Mvs
.
empty
vl
in
e_map
(
term
vm
()
)
(
fmla
vm
()
)
e
term
vm
()
e
let
build_call_list
cgr
ls
=
let
htb
=
Hls
.
create
5
in
...
...
@@ -389,15 +364,14 @@ let syms_ts s ts = Sid.add ts.ts_name s
let
syms_ls
s
ls
=
Sid
.
add
ls
.
ls_name
s
let
syms_ty
s
ty
=
ty_s_fold
syms_ts
s
ty
let
syms_term
s
t
=
t_s_fold
syms_ts
syms_ls
s
t
let
syms_fmla
s
f
=
t_s_fold
syms_ts
syms_ls
s
f
let
syms_term
s
t
=
t_s_fold
syms_ty
syms_ls
s
t
let
create_ty_decl
tdl
=
if
tdl
=
[]
then
raise
EmptyDecl
;
let
add
s
(
ts
,_
)
=
Sts
.
add
ts
s
in
let
tss
=
List
.
fold_left
add
Sts
.
empty
tdl
in
let
check_constr
tys
ty
(
syms
,
news
)
fs
=
check
_ty
ty
(
of_option
fs
.
ls_value
);
ty_equal_
check
ty
(
of_option
fs
.
ls_value
);
let
add
s
ty
=
match
ty
.
ty_node
with
|
Tyvar
v
->
Stv
.
add
v
s
|
_
->
assert
false
...
...
@@ -437,7 +411,7 @@ let create_logic_decl ldl =
|
Some
(
s
,_
)
when
not
(
ls_equal
s
ls
)
->
raise
(
BadLogicDecl
(
ls
,
s
))
|
Some
(
_
,
f
)
->
syms_
fmla
syms
f
,
news_id
news
ls
.
ls_name
syms_
term
syms
f
,
news_id
news
ls
.
ls_name
|
None
->
let
syms
=
option_apply
syms
(
syms_ty
syms
)
ls
.
ls_value
in
let
syms
=
List
.
fold_left
syms_ty
syms
ls
.
ls_args
in
...
...
@@ -465,7 +439,7 @@ let rec f_pos_ps sps pol f = match f.t_node, pol with
f_pos_ps
sps
(
option_map
not
pol
)
f
|
Tif
(
f
,
g
,
h
)
,
_
->
f_pos_ps
sps
None
f
&&
f_pos_ps
sps
pol
g
&&
f_pos_ps
sps
pol
h
|
_
->
t_all
(
t_pos_ps
sps
)
(
f_pos_ps
sps
pol
)
f
|
_
->
TermTF
.
t_all
(
t_pos_ps
sps
)
(
f_pos_ps
sps
pol
)
f
let
create_ind_decl
idl
=
if
idl
=
[]
then
raise
EmptyDecl
;
...
...
@@ -484,7 +458,7 @@ let create_ind_decl idl =
List
.
iter2
check_tl
ps
.
ls_args
tl
;
(
try
ignore
(
List
.
for_all
(
f_pos_ps
sps
(
Some
true
))
cls
)
with
Found
ls
->
raise
(
NonPositiveIndDecl
(
ps
,
pr
,
ls
)));
syms_
fmla
syms
f
,
news_id
news
pr
.
pr_name
syms_
term
syms
f
,
news_id
news
pr
.
pr_name
|
_
->
raise
(
InvalidIndDecl
(
ps
,
pr
))
in
let
check_decl
(
syms
,
news
)
(
ps
,
al
)
=
...
...
@@ -496,70 +470,72 @@ let create_ind_decl idl =
mk_decl
(
Dind
idl
)
syms
news
let
create_prop_decl
k
p
f
=
let
syms
=
syms_
fmla
Sid
.
empty
f
in
let
syms
=
syms_
term
Sid
.
empty
f
in
let
news
=
news_id
Sid
.
empty
p
.
pr_name
in
mk_decl
(
Dprop
(
k
,
p
,
check_fvs
f
))
syms
news
(** Utilities *)
let
decl_map
fnT
fnF
d
=
match
d
.
d_node
with
|
Dtype
_
->
d
let
decl_map
fn
d
=
match
d
.
d_node
with
|
Dtype
_
->
d
|
Dlogic
l
->
let
fn
=
function
|
ls
,
Some
ld
->
let
vl
,
e
=
open_ls_defn
ld
in
make_ls_defn
ls
vl
(
e_map
fnT
fnF
e
)
make_ls_defn
ls
vl
(
fn
e
)
|
ld
->
ld
in
create_logic_decl
(
List
.
map
fn
l
)
|
Dind
l
->
let
fn
(
pr
,
f
)
=
pr
,
fn
F
f
in
let
fn
(
pr
,
f
)
=
pr
,
fn
f
in
let
fn
(
ps
,
l
)
=
ps
,
List
.
map
fn
l
in
create_ind_decl
(
List
.
map
fn
l
)
|
Dprop
(
k
,
pr
,
f
)
->
create_prop_decl
k
pr
(
fn
F
f
)
create_prop_decl
k
pr
(
fn
f
)
let
decl_fold
fn
T
fnF
acc
d
=
match
d
.
d_node
with
let
decl_fold
fn
acc
d
=
match
d
.
d_node
with
|
Dtype
_
->
acc
|
Dlogic
l
->
let
fn
acc
=
function
|
_
,
Some
ld
->
let
_
,
e
=
open_ls_defn
ld
in
e_fold
fnT
fnF
acc
e
fn
acc
e
|
_
->
acc
in
List
.
fold_left
fn
acc
l
|
Dind
l
->
let
fn
acc
(
_
,
f
)
=
fn
F
acc
f
in
let
fn
acc
(
_
,
f
)
=
fn
acc
f
in
let
fn
acc
(
_
,
l
)
=
List
.
fold_left
fn
acc
l
in
List
.
fold_left
fn
acc
l
|
Dprop
(
_
,_,
f
)
->
fn
F
acc
f
fn
acc
f
let
rpair_map_fold
f
acc
(
x1
,
x2
)
=
let
acc
,
x2
=
f
acc
x2
in
acc
,
(
x1
,
x2
)
let
acc
,
x2
=
f
acc
x2
in
acc
,
(
x1
,
x2
)
let
list_rpair_map_fold
f
=
Util
.
map_fold_left
(
rpair_map_fold
f
)
let
list_rpair_map_fold
f
=
Util
.
map_fold_left
(
rpair_map_fold
f
)
let
decl_map_fold
fnT
fnF
acc
d
=
match
d
.
d_node
with
let
decl_map_fold
fn
acc
d
=
match
d
.
d_node
with
|
Dtype
_
->
acc
,
d
|
Dprop
(
k
,
pr
,
f
)
->
let
acc
,
f
=
t_map_fold
fnT
fnF
acc
f
in
acc
,
create_prop_decl
k
pr
f
|
Dind
l
->
let
acc
,
l
=
list_rpair_map_fold
(
list_rpair_map_fold
(
t_map_fold
fnT
fnF
))
acc
l
in
acc
,
create_ind_decl
l
|
Dlogic
l
->
let
acc
,
l
=
list_rpair_map_fold
(
option_map_fold
(
rpair_map_fold
(
t_map_fold
fn
T
fnF
)))
acc
l
in
list_rpair_map_fold
(
option_map_fold
(
rpair_map_fold
(
t_map_fold
fn
)))
acc
l
in
acc
,
create_logic_decl
l
|
Dind
l
->
let
acc
,
l
=
list_rpair_map_fold
(
list_rpair_map_fold
(
t_map_fold
fn
))
acc
l
in
acc
,
create_ind_decl
l
|
Dprop
(
k
,
pr
,
f
)
->
let
acc
,
f
=
t_map_fold
fn
acc
f
in
acc
,
create_prop_decl
k
pr
f
module
DeclTF
=
struct
let
decl_map
fnT
fnF
=
decl_map
(
e_map
fnT
fnF
)
let
decl_fold
fnT
fnF
=
decl_fold
(
e_fold
fnT
fnF
)
let
decl_map_fold
fnT
fnF
=
decl_map_fold
(
e_fold
fnT
fnF
)
end
(** Known identifiers *)
...
...
@@ -630,25 +606,17 @@ let find_prop_decl kn pr =
|
Dprop
(
k
,_,
f
)
->
k
,
f
|
_
->
assert
false
exception
NonExhaustive
Expr
of
pattern
list
*
expr
exception
NonExhaustive
Case
of
pattern
list
*
term
let
rec
check_matchT
kn
()
t
=
match
t
.
t_node
with
|
Tcase
(
t1
,
bl
)
->
let
bl
=
List
.
map
(
fun
b
->
let
p
,
t
=
t_open_branch
b
in
[
p
]
,
t
)
bl
in
ignore
(
try
Pattern
.
CompileTerm
.
compile
(
find_constructors
kn
)
[
t1
]
bl
with
Pattern
.
NonExhaustive
p
->
raise
(
NonExhaustiveExpr
(
p
,
t
)));
t_fold
(
check_matchT
kn
)
(
check_matchF
kn
)
()
t
|
_
->
t_fold
(
check_matchT
kn
)
(
check_matchF
kn
)
()
t
and
check_matchF
kn
()
f
=
match
f
.
t_node
with
|
Tcase
(
t1
,
bl
)
->
let
bl
=
List
.
map
(
fun
b
->
let
p
,
f
=
t_open_branch
b
in
[
p
]
,
f
)
bl
in
ignore
(
try
Pattern
.
CompileTerm
.
compile
(
find_constructors
kn
)
[
t1
]
bl
with
Pattern
.
NonExhaustive
p
->
raise
(
NonExhaustiveExpr
(
p
,
f
)));
t_fold
(
check_matchT
kn
)
(
check_matchF
kn
)
()
f
|
_
->
t_fold
(
check_matchT
kn
)
(
check_matchF
kn
)
()
f
with
Pattern
.
NonExhaustive
p
->
raise
(
NonExhaustiveCase
(
p
,
t
)));
t_fold
(
check_matchT
kn
)
()
t
|
_
->
t_fold
(
check_matchT
kn
)
()
t
let
check_match
kn
d
=
decl_fold
(
check_matchT
kn
)
(
check_matchF
kn
)
()
d
let
check_match
kn
d
=
decl_fold
(
check_matchT
kn
)
()
d
exception
NonFoundedTypeDecl
of
tysymbol
...
...
src/core/decl.mli
View file @
1501f43a
...
...
@@ -39,13 +39,9 @@ type ls_defn
type
logic_decl
=
lsymbol
*
ls_defn
option
val
make_ls_defn
:
lsymbol
->
vsymbol
list
->
expr
->
logic_decl
val
make_fs_defn
:
lsymbol
->
vsymbol
list
->
term
->
logic_decl
val
make_ps_defn
:
lsymbol
->
vsymbol
list
->
fmla
->
logic_decl
val
make_ls_defn
:
lsymbol
->
vsymbol
list
->
term
->
logic_decl
val
open_ls_defn
:
ls_defn
->
vsymbol
list
*
expr
val
open_fs_defn
:
ls_defn
->
vsymbol
list
*
term
val
open_ps_defn
:
ls_defn
->
vsymbol
list
*
fmla
val
open_ls_defn
:
ls_defn
->
vsymbol
list
*
term
val
ls_defn_axiom
:
ls_defn
->
fmla
...
...
@@ -133,12 +129,21 @@ exception EmptyIndDecl of lsymbol
(** {2 Utilities} *)
val
decl_map
:
(
term
->
term
)
->
decl
->
decl
val
decl_fold
:
(
'
a
->
term
->
'
a
)
->
'
a
->
decl
->
'
a
val
decl_map_fold
:
(
'
a
->
term
->
'
a
*
term
)
->
'
a
->
decl
->
'
a
*
decl
module
DeclTF
:
sig
val
decl_map
:
(
term
->
term
)
->
(
fmla
->
fmla
)
->
decl
->
decl
val
decl_fold
:
(
'
a
->
term
->
'
a
)
->
(
'
a
->
fmla
->
'
a
)
->
'
a
->
decl
->
'
a
val
decl_map_fold
:
(
'
a
->
term
->
'
a
*
term
)
->
(
'
a
->
fmla
->
'
a
*
fmla
)
->
'
a
->
decl
->
'
a
*
decl
val
decl_map_fold
:
(
'
a
->
term
->
'
a
*
term
)
->
(
'
a
->
fmla
->
'
a
*
fmla
)
->
'
a
->
decl
->
'
a
*
decl
end
(** {2 Known identifiers} *)
...
...
@@ -151,7 +156,7 @@ val merge_known : known_map -> known_map -> known_map
exception
KnownIdent
of
ident
exception
UnknownIdent
of
ident
exception
RedeclaredIdent
of
ident
exception
NonExhaustive
Expr
of
pattern
list
*
expr
exception
NonExhaustive
Case
of
pattern
list
*
term
exception
NonFoundedTypeDecl
of
tysymbol
val
find_constructors
:
known_map
->
tysymbol
->
lsymbol
list
...
...
src/core/pretty.ml
View file @
1501f43a
...
...
@@ -136,7 +136,7 @@ let unambig_fs fs =
|
Tyvar
u
when
not
(
lookup
u
)
->
false
|
_
->
ty_all
inspect
ty
in
inspect
(
of_option
fs
.
ls_value
)
option_apply
true
inspect
fs
.
ls_value
(** Patterns, terms, and formulas *)
...
...
@@ -190,7 +190,6 @@ let print_ident_labels fmt id =
else
()
let
rec
print_term
fmt
t
=
print_lterm
0
fmt
t
and
print_fmla
fmt
f
=
print_lfmla
0
fmt
f
and
print_lterm
pri
fmt
t
=
match
t
.
t_label
with
|
_
when
Debug
.
nottest_flag
debug_print_labels
...
...
@@ -199,13 +198,6 @@ and print_lterm pri fmt t = match t.t_label with
|
ll
->
fprintf
fmt
(
protect_on
(
pri
>
0
)
"%a %a"
)
(
print_list
space
print_label
)
ll
(
print_tnode
0
)
t
and
print_lfmla
pri
fmt
f
=
match
f
.
t_label
with
|
_
when
Debug
.
nottest_flag
debug_print_labels
->
print_fnode
pri
fmt
f
|
[]
->
print_fnode
pri
fmt
f
|
ll
->
fprintf
fmt
(
protect_on
(
pri
>
0
)
"%a %a"
)
(
print_list
space
print_label
)
ll
(
print_fnode
0
)
f
and
print_app
pri
ls
fmt
tl
=
match
extract_op
ls
,
tl
with
|
_
,
[]
->
print_ls
fmt
ls
...
...
@@ -236,7 +228,7 @@ and print_tnode pri fmt t = match t.t_node with
(
print_app
5
fs
)
tl
print_ty
(
t_type
t
)
|
Tif
(
f
,
t1
,
t2
)
->
fprintf
fmt
(
protect_on
(
pri
>
0
)
"if @[%a@] then %a@ else %a"
)
print_
fmla
f
print_term
t1
print_term
t2
print_
term
f
print_term
t1
print_term
t2
|
Tlet
(
t1
,
tb
)
->
let
v
,
t2
=
t_open_bound
tb
in
fprintf
fmt
(
protect_on
(
pri
>
0
)
"let %a = @[%a@] in@ %a"
)
...
...
@@ -248,17 +240,12 @@ and print_tnode pri fmt t = match t.t_node with
|
Teps
fb
->
let
v
,
f
=
t_open_bound
fb
in
fprintf
fmt
(
protect_on
(
pri
>
0
)
"epsilon %a.@ %a"
)
print_vsty
v
print_
fmla
f
;
print_vsty
v
print_
term
f
;
forget_var
v
|
Fquant
_
|
Fbinop
_
|
Fnot
_
|
Ftrue
|
Ffalse
->
raise
(
TermExpected
t
)
and
print_fnode
pri
fmt
f
=
match
f
.
t_node
with
|
Tapp
(
ps
,
tl
)
->
print_app
pri
ps
fmt
tl
|
Fquant
(
q
,
fq
)
->
let
vl
,
tl
,
f
=
f_open_quant
fq
in
fprintf
fmt
(
protect_on
(
pri
>
0
)
"%a %a%a.@ %a"
)
print_quant
q
(
print_list
comma
print_vsty
)
vl
print_tl
tl
print_
fmla
f
;
(
print_list
comma
print_vsty
)
vl
print_tl
tl
print_
term
f
;
List
.
iter
forget_var
vl
|
Ftrue
->
fprintf
fmt
"true"
...
...
@@ -267,37 +254,18 @@ and print_fnode pri fmt f = match f.t_node with
|
Fbinop
(
b
,
f1
,
f2
)
->
let
p
=
prio_binop
b
in
fprintf
fmt
(
protect_on
(
pri
>
p
)
"%a %a@ %a"
)
(
print_l
fmla
(
p
+
1
))
f1
print_binop
b
(
print_l
fmla
p
)
f2
(
print_l
term
(
p
+
1
))
f1
print_binop
b
(
print_l
term
p
)
f2
|
Fnot
f
->
fprintf
fmt
(
protect_on
(
pri
>
4
)
"not %a"
)
(
print_lfmla
4
)
f
|
Tif
(
f1
,
f2
,
f3
)
->
fprintf
fmt
(
protect_on
(
pri
>
0
)
"if @[%a@] then %a@ else %a"
)
print_fmla
f1
print_fmla
f2
print_fmla
f3
|
Tlet
(
t
,
f
)
->
let
v
,
f
=
t_open_bound
f
in
fprintf
fmt
(
protect_on
(
pri
>
0
)
"let %a = @[%a@] in@ %a"
)
print_vs
v
(
print_lterm
4
)
t
print_fmla
f
;
forget_var
v
|
Tcase
(
t
,
bl
)
->
fprintf
fmt
"match @[%a@] with@
\n
@[<hov>%a@]@
\n
end"
print_term
t
(
print_list
newline
print_fbranch
)
bl
|
Tvar
_
|
Tconst
_
|
Teps
_
->
raise
(
FmlaExpected
f
)
fprintf
fmt
(
protect_on
(
pri
>
4
)
"not %a"
)
(
print_lterm
4
)
f
and
print_tbranch
fmt
br
=
let
p
,
t
=
t_open_branch
br
in
fprintf
fmt
"@[<hov 4>| %a ->@ %a@]"
print_pat
p
print_term
t
;
Svs
.
iter
forget_var
p
.
pat_vars
and
print_fbranch
fmt
br
=
let
p
,
f
=
t_open_branch
br
in
fprintf
fmt
"@[<hov 4>| %a ->@ %a@]"
print_pat
p
print_fmla
f
;
Svs
.
iter
forget_var
p
.
pat_vars
and
print_tl
fmt
tl
=
if
tl
=
[]
then
()
else
fprintf
fmt
"@ [%a]"
(
print_list
alt
(
print_list
comma
print_expr
))
tl
and
print_expr
fmt
=
e_map
(
print_term
fmt
)
(
print_fmla
fmt
)
(
print_list
alt
(
print_list
comma
print_term
))
tl
(** Declarations *)
...
...
@@ -340,7 +308,7 @@ let print_logic_decl fst fmt (ls,ld) = match ld with
fprintf
fmt
"@[<hov 2>%s %a%a%a =@ %a@]"
(
if
fst
then
"logic"
else
"with"
)
print_ls
ls
(
print_list
nothing
print_vs_arg
)
vl
(
print_option
print_ls_type
)
ls
.
ls_value
print_
expr
e
;
(
print_option
print_ls_type
)
ls
.
ls_value
print_
term
e
;
List
.
iter
forget_var
vl
|
None
->
fprintf
fmt
"@[<hov 2>%s %a%a%a@]"
...
...
@@ -352,7 +320,7 @@ let print_logic_decl fst fmt d = print_logic_decl fst fmt d; forget_tvs ()
let
print_ind
fmt
(
pr
,
f
)
=
fprintf
fmt
"@[<hov 4>| %a%a : %a@]"
print_pr
pr
print_ident_labels
pr
.
pr_name
print_
fmla
f
print_pr
pr
print_ident_labels
pr
.
pr_name
print_
term
f
let
print_ind_decl
fst
fmt
(
ps
,
bl
)
=
fprintf
fmt
"@[<hov 2>%s %a%a =@ @[<hov>%a@]@]"
...
...
@@ -371,7 +339,7 @@ let print_pkind fmt k = pp_print_string fmt (sprint_pkind k)
let
print_prop_decl
fmt
(
k
,
pr
,
f
)
=
fprintf
fmt
"@[<hov 2>%a %a%a : %a@]"
print_pkind
k
print_pr
pr
print_ident_labels
pr
.
pr_name
print_
fmla
f
;
print_pr
pr
print_ident_labels
pr
.
pr_name
print_
term
f
;
forget_tvs
()
let
print_list_next
sep
print
fmt
=
function
...
...
@@ -513,7 +481,7 @@ let () = Exn_printer.register
|
Term
.
PredicateSymbolExpected
ls
->
fprintf
fmt
"Not a predicate symbol: %a"
print_ls
ls
|
Term
.
TermExpected
t
->
fprintf
fmt
"Not a term: %a"
print_
fmla
t
fprintf
fmt
"Not a term: %a"
print_
term
t
|
Term
.
FmlaExpected
t
->
fprintf
fmt
"Not a formula: %a"
print_term
t
|
Term
.
NoMatch
->
...
...
@@ -563,9 +531,9 @@ let () = Exn_printer.register
id
.
id_string
|
Decl
.
NoTerminationProof
ls
->
fprintf
fmt
"Cannot prove the termination of %a"
print_ls
ls
|
Decl
.
NonExhaustive
Expr
(
pl
,
e
)
->
|
Decl
.
NonExhaustive
Case
(
pl
,
e
)
->
fprintf
fmt
"Pattern @[%a@] is not covered in expression:@
\n
@[%a@]"
(
print_list
comma
print_pat
)
pl
print_
expr
e
(
print_list
comma
print_pat
)
pl
print_
term
e
|
_
->
raise
exn
end
src/core/pretty.mli
View file @
1501f43a
...
...
@@ -45,8 +45,6 @@ val print_binop : formatter -> binop -> unit (* binary operator *)
val
print_const
:
formatter
->
constant
->
unit
(* int/real constant *)
val
print_pat
:
formatter
->
pattern
->
unit
(* pattern *)
val
print_term
:
formatter
->
term
->
unit
(* term *)
val
print_fmla
:
formatter
->
fmla
->
unit
(* formula *)
val
print_expr
:
formatter
->
expr
->
unit
(* term or formula *)
val
print_label
:
formatter
->
label
->
unit
val
print_pkind
:
formatter
->
prop_kind
->
unit
...
...
src/core/printer.ml
View file @
1501f43a
...
...
@@ -282,7 +282,7 @@ let () = Exn_printer.register (fun fmt exn -> match exn with
Pretty
.
print_ts
e
s
|
UnsupportedTerm
(
e
,
s
)
->
fprintf
fmt
"@[<hov 3> This expression isn't supported:@
\n
%a@
\n
%s@]"
Pretty
.
print_
expr
e
s
Pretty
.
print_
term
e
s
|
UnsupportedDecl
(
d
,
s
)
->
fprintf
fmt
"@[<hov 3> This declaration isn't supported:@
\n
%a@
\n
%s@]"
Pretty
.
print_decl
d
s
...
...
src/core/term.ml
View file @
1501f43a
This diff is collapsed.
Click to expand it.
src/core/term.mli
View file @
1501f43a
...
...
@@ -18,12 +18,11 @@
(**************************************************************************)
open
Stdlib
(** Terms and Formulas *)
open
Ident
open
Ty
(** Terms and Formulas *)
(** {2 Variable symbols} *)
type
vsymbol
=
private
{
...
...
@@ -45,7 +44,7 @@ val create_vsymbol : preid -> ty -> vsymbol
type
lsymbol
=
private
{
ls_name
:
ident
;
ls_args
:
ty
list
;
ls_value
:
o
ty
;
ls_value
:
ty
option
;
}
module
Mls
:
Map
.
S
with
type
key
=
lsymbol
...
...
@@ -57,7 +56,7 @@ val ls_equal : lsymbol -> lsymbol -> bool
(** equality of function and predicate symbols *)
val
ls_hash
:
lsymbol
->
int
val
create_lsymbol
:
preid
->
ty
list
->
o
ty
->
lsymbol
val
create_lsymbol
:
preid
->
ty
list
->
ty
option
->
lsymbol
val
create_fsymbol
:
preid
->
ty
list
->
ty
->
lsymbol
val
create_psymbol
:
preid
->
ty
list
->
lsymbol
...
...
@@ -128,10 +127,10 @@ type constant =
type
term
=
private
{
t_node
:
term_node
;
t_ty
:
ty
option
;
t_label
:
label
list
;
t_loc
:
Loc
.
position
option
;
t_vars
:
Svs
.
t
;
t_ty
:
oty
;
t_tag
:
int
;
}
...
...
@@ -150,17 +149,12 @@ and term_node = private
|
Ffalse
and
fmla
=
term
and
expr
=
term
and
term_bound
and
fmla_bound
=
term_bound
and
term_branch
and
fmla_branch
=
term_branch
and
fmla_quant
and
trigger
=
expr
list
and
trigger
=
term
list
list
module
Mterm
:
Map
.
S
with
type
key
=
term
module
Sterm
:
Mterm
.
Set
...
...
@@ -169,22 +163,19 @@ module Hterm : Hashtbl.S with type key = term
val
t_equal
:
term
->
term
->
bool
val
t_hash
:
term
->
int
val
tr_equal
:
trigger
list
->
trigger
list
->
bool
(** Bindings *)
(** close bindings *)
val
t_close_bound
:
vsymbol
->
term
->
term_bound
val
t_close_branch
:
pattern
->
term
->
term_branch
val
f_close_quant
:
vsymbol
list
->
trigger
list
->
fmla
->
fmla_quant
val
f_close_quant
:
vsymbol
list
->
trigger
->
fmla
->
fmla_quant
(** open bindings *)
val
t_open_bound
:
term_bound
->
vsymbol
*
term
val
t_open_branch
:
term_branch
->
pattern
*
term
val
f_open_quant
:
fmla_quant
->
vsymbol
list
*
trigger
list
*
fmla