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
4cd5a72c
Commit
4cd5a72c
authored
Mar 03, 2010
by
Andrei Paskevich
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
join fsymbol and psymbol into the common lsymbol type
parent
e68cdad5
Changes
13
Hide whitespace changes
Inline
Side-by-side
Showing
13 changed files
with
300 additions
and
344 deletions
+300
-344
src/core/term.ml
src/core/term.ml
+100
-117
src/core/term.mli
src/core/term.mli
+37
-55
src/core/theory.ml
src/core/theory.ml
+52
-64
src/core/theory.mli
src/core/theory.mli
+14
-16
src/parser/parser.mly
src/parser/parser.mly
+6
-7
src/parser/ptree.mli
src/parser/ptree.mli
+1
-2
src/parser/typing.ml
src/parser/typing.ml
+43
-34
src/pretty.ml
src/pretty.ml
+16
-18
src/pretty.mli
src/pretty.mli
+1
-3
src/transform/inlining.ml
src/transform/inlining.ml
+12
-12
src/transform/simplify_recursive_definition.ml
src/transform/simplify_recursive_definition.ml
+14
-14
src/util/util.ml
src/util/util.ml
+1
-0
src/util/util.mli
src/util/util.mli
+3
-2
No files found.
src/core/term.ml
View file @
4cd5a72c
...
...
@@ -47,53 +47,36 @@ let create_vsymbol name ty = {
let
fresh_vsymbol
v
=
create_vsymbol
(
id_dup
v
.
vs_name
)
v
.
vs_ty
(** Function symbols *)
(** Function
and predicate
symbols *)
type
fsymbol
=
{
fs_name
:
ident
;
fs_scheme
:
ty
list
*
ty
;
fs_constr
:
bool
;
type
lsymbol
=
{
ls_name
:
ident
;
ls_args
:
ty
list
;
ls_value
:
ty
option
;
ls_constr
:
bool
;
}
module
F
sym
=
struct
type
t
=
f
symbol
module
L
sym
=
struct
type
t
=
l
symbol
let
equal
=
(
==
)
let
hash
fs
=
fs
.
f
s_name
.
id_tag
let
hash
fs
=
fs
.
l
s_name
.
id_tag
let
compare
fs1
fs2
=
Pervasives
.
compare
fs1
.
fs_name
.
id_tag
fs2
.
f
s_name
.
id_tag
Pervasives
.
compare
fs1
.
ls_name
.
id_tag
fs2
.
l
s_name
.
id_tag
end
module
Sfs
=
Set
.
Make
(
Fsym
)
module
Mfs
=
Map
.
Make
(
Fsym
)
module
Hfs
=
Hashtbl
.
Make
(
Fsym
)
let
create_fsymbol
name
scheme
constr
=
{
fs_name
=
id_register
name
;
fs_scheme
=
scheme
;
fs_constr
=
constr
;
module
Sls
=
Set
.
Make
(
Lsym
)
module
Mls
=
Map
.
Make
(
Lsym
)
module
Hls
=
Hashtbl
.
Make
(
Lsym
)
let
mk_lsymbol
name
args
value
constr
=
{
ls_name
=
id_register
name
;
ls_args
=
args
;
ls_value
=
value
;
ls_constr
=
constr
;
}
(** Predicate symbols *)
type
psymbol
=
{
ps_name
:
ident
;
ps_scheme
:
ty
list
;
}
module
Psym
=
struct
type
t
=
psymbol
let
equal
=
(
==
)
let
hash
ps
=
ps
.
ps_name
.
id_tag
let
compare
ps1
ps2
=
Pervasives
.
compare
ps1
.
ps_name
.
id_tag
ps2
.
ps_name
.
id_tag
end
module
Sps
=
Set
.
Make
(
Psym
)
module
Mps
=
Map
.
Make
(
Psym
)
module
Hps
=
Hashtbl
.
Make
(
Psym
)
let
create_psymbol
name
scheme
=
{
ps_name
=
id_register
name
;
ps_scheme
=
scheme
;
}
let
create_fsymbol
nm
al
vl
=
mk_lsymbol
nm
al
(
Some
vl
)
false
let
create_fconstr
nm
al
vl
=
mk_lsymbol
nm
al
(
Some
vl
)
true
let
create_psymbol
nm
al
=
mk_lsymbol
nm
al
None
false
(** Patterns *)
...
...
@@ -106,7 +89,7 @@ type pattern = {
and
pattern_node
=
|
Pwild
|
Pvar
of
vsymbol
|
Papp
of
f
symbol
*
pattern
list
|
Papp
of
l
symbol
*
pattern
list
|
Pas
of
pattern
*
vsymbol
module
Hpat
=
struct
...
...
@@ -128,7 +111,7 @@ module Hpat = struct
let
hash_node
=
function
|
Pwild
->
0
|
Pvar
v
->
v
.
vs_name
.
id_tag
|
Papp
(
s
,
pl
)
->
Hashcons
.
combine_list
hash_pattern
s
.
f
s_name
.
id_tag
pl
|
Papp
(
s
,
pl
)
->
Hashcons
.
combine_list
hash_pattern
s
.
l
s_name
.
id_tag
pl
|
Pas
(
p
,
v
)
->
Hashcons
.
combine
(
hash_pattern
p
)
v
.
vs_name
.
id_tag
let
hash
p
=
Hashcons
.
combine
(
hash_node
p
.
pat_node
)
p
.
pat_ty
.
ty_tag
...
...
@@ -167,17 +150,19 @@ let pat_any pr pat =
(* smart constructors for patterns *)
exception
BadArity
exception
ConstructorExpected
of
fsymbol
exception
ConstructorExpected
of
lsymbol
exception
FunctionSymbolExpected
of
lsymbol
exception
PredicateSymbolExpected
of
lsymbol
let
pat_app
fs
pl
ty
=
if
not
fs
.
fs_constr
then
raise
(
ConstructorExpected
fs
);
let
args
,
res
=
fs
.
fs_scheme
in
ignore
(
try
List
.
fold_left2
Ty
.
matching
(
Ty
.
matching
Mid
.
empty
res
ty
)
args
(
List
.
map
(
fun
p
->
p
.
pat_ty
)
pl
)
with
Invalid_argument
_
->
raise
BadArity
);
if
not
fs
.
ls_constr
then
raise
(
ConstructorExpected
fs
);
let
s
=
match
fs
.
ls_value
with
|
Some
vty
->
Ty
.
matching
Mid
.
empty
vty
ty
|
None
->
raise
(
FunctionSymbolExpected
fs
)
in
let
mtch
s
ty
p
=
Ty
.
matching
s
ty
p
.
pat_ty
in
ignore
(
try
List
.
fold_left2
mtch
s
fs
.
ls_args
pl
with
Invalid_argument
_
->
raise
BadArity
);
pat_app
fs
pl
ty
let
pat_as
p
v
=
...
...
@@ -192,21 +177,21 @@ let pat_map fn pat = match pat.pat_node with
(* symbol-wise map/fold *)
let
rec
pat_s_map
fnT
fnV
fn
F
pat
=
let
fn
p
=
pat_s_map
fnT
fnV
fn
F
p
in
let
rec
pat_s_map
fnT
fnV
fn
L
pat
=
let
fn
p
=
pat_s_map
fnT
fnV
fn
L
p
in
let
ty
=
fnT
pat
.
pat_ty
in
match
pat
.
pat_node
with
|
Pwild
->
pat_wild
ty
|
Pvar
v
->
pat_var
(
fnV
v
ty
)
|
Papp
(
s
,
pl
)
->
pat_app
(
fn
F
s
)
(
List
.
map
fn
pl
)
ty
|
Papp
(
s
,
pl
)
->
pat_app
(
fn
L
s
)
(
List
.
map
fn
pl
)
ty
|
Pas
(
p
,
v
)
->
pat_as
(
fn
p
)
(
fnV
v
ty
)
let
rec
pat_s_fold
fnT
fn
F
acc
pat
=
let
fn
acc
p
=
pat_s_fold
fnT
fn
F
acc
p
in
let
rec
pat_s_fold
fnT
fn
L
acc
pat
=
let
fn
acc
p
=
pat_s_fold
fnT
fn
L
acc
p
in
let
acc
=
ty_s_fold
fnT
acc
pat
.
pat_ty
in
match
pat
.
pat_node
with
|
Pwild
|
Pvar
_
->
acc
|
Papp
(
s
,
pl
)
->
List
.
fold_left
fn
(
fn
F
acc
s
)
pl
|
Papp
(
s
,
pl
)
->
List
.
fold_left
fn
(
fn
L
acc
s
)
pl
|
Pas
(
p
,
_
)
->
fn
acc
p
(* alpha-equality on patterns *)
...
...
@@ -260,13 +245,13 @@ and term_node =
|
Tbvar
of
int
|
Tvar
of
vsymbol
|
Tconst
of
constant
|
Tapp
of
f
symbol
*
term
list
|
Tapp
of
l
symbol
*
term
list
|
Tlet
of
term
*
term_bound
|
Tcase
of
term
*
term_branch
list
|
Teps
of
fmla_bound
and
fmla_node
=
|
Fapp
of
p
symbol
*
term
list
|
Fapp
of
l
symbol
*
term
list
|
Fquant
of
quant
*
fmla_quant
|
Fbinop
of
binop
*
fmla
*
fmla
|
Fnot
of
fmla
...
...
@@ -343,7 +328,7 @@ module T = struct
|
Tbvar
n
->
n
|
Tvar
v
->
v
.
vs_name
.
id_tag
|
Tconst
c
->
Hashtbl
.
hash
c
|
Tapp
(
f
,
tl
)
->
Hashcons
.
combine_list
t_hash
(
f
.
f
s_name
.
id_tag
)
tl
|
Tapp
(
f
,
tl
)
->
Hashcons
.
combine_list
t_hash
(
f
.
l
s_name
.
id_tag
)
tl
|
Tlet
(
t
,
bt
)
->
Hashcons
.
combine
t
.
t_tag
(
t_hash_bound
bt
)
|
Tcase
(
t
,
bl
)
->
Hashcons
.
combine_list
t_hash_branch
t
.
t_tag
bl
|
Teps
f
->
f_hash_bound
f
...
...
@@ -424,7 +409,7 @@ module F = struct
List
.
fold_left
(
Hashcons
.
combine_list
tr_hash
)
h
tl
let
f_hash_node
=
function
|
Fapp
(
p
,
tl
)
->
Hashcons
.
combine_list
t_hash
p
.
p
s_name
.
id_tag
tl
|
Fapp
(
p
,
tl
)
->
Hashcons
.
combine_list
t_hash
p
.
l
s_name
.
id_tag
tl
|
Fquant
(
q
,
bf
)
->
Hashcons
.
combine
(
Hashtbl
.
hash
q
)
(
f_hash_quant
bf
)
|
Fbinop
(
op
,
f1
,
f2
)
->
Hashcons
.
combine2
(
Hashtbl
.
hash
op
)
f1
.
f_tag
f2
.
f_tag
...
...
@@ -873,23 +858,25 @@ let t_let v t1 t2 =
let
f_let
v
t1
f2
=
if
v
.
vs_ty
==
t1
.
t_ty
then
f_let
v
t1
f2
else
raise
TypeMismatch
let
t_app
f
tl
ty
=
let
args
,
res
=
f
.
fs_scheme
in
let
_
=
try
List
.
fold_left2
Ty
.
matching
(
Ty
.
matching
Mid
.
empty
res
ty
)
args
(
List
.
map
(
fun
t
->
t
.
t_ty
)
tl
)
with
Invalid_argument
_
->
raise
BadArity
let
t_app
fs
tl
ty
=
let
s
=
match
fs
.
ls_value
with
|
Some
vty
->
Ty
.
matching
Mid
.
empty
vty
ty
|
_
->
raise
(
FunctionSymbolExpected
fs
)
in
t_app
f
tl
ty
let
f_app
p
tl
=
let
_
=
try
List
.
fold_left2
Ty
.
matching
Mid
.
empty
p
.
ps_scheme
(
List
.
map
(
fun
t
->
t
.
t_ty
)
tl
)
with
Invalid_argument
_
->
raise
BadArity
let
mtch
s
ty
t
=
Ty
.
matching
s
ty
t
.
t_ty
in
ignore
(
try
List
.
fold_left2
mtch
s
fs
.
ls_args
tl
with
Invalid_argument
_
->
raise
BadArity
);
t_app
fs
tl
ty
let
f_app
ps
tl
=
let
s
=
match
ps
.
ls_value
with
|
None
->
Mid
.
empty
|
_
->
raise
(
PredicateSymbolExpected
ps
)
in
f_app
p
tl
let
mtch
s
ty
t
=
Ty
.
matching
s
ty
t
.
t_ty
in
ignore
(
try
List
.
fold_left2
mtch
s
ps
.
ls_args
tl
with
Invalid_argument
_
->
raise
BadArity
);
f_app
ps
tl
let
t_case
t
bl
ty
=
let
t_check_branch
(
p
,
_
,
tbr
)
=
...
...
@@ -908,30 +895,30 @@ let f_case t bl =
(* symbol-wise map *)
let
rec
t_s_map
fnT
fnV
fn
F
fnP
t
=
let
fn_t
=
t_s_map
fnT
fnV
fn
F
fnP
in
let
fn_f
=
f_s_map
fnT
fnV
fn
F
fnP
in
let
rec
t_s_map
fnT
fnV
fn
L
t
=
let
fn_t
=
t_s_map
fnT
fnV
fn
L
in
let
fn_f
=
f_s_map
fnT
fnV
fn
L
in
let
ty
=
fnT
t
.
t_ty
in
t_label_try
t
.
t_label
(
match
t
.
t_node
with
|
Tbvar
n
->
t_bvar
n
ty
|
Tvar
v
->
t_var
(
fnV
v
ty
)
|
Tconst
_
->
t
|
Tapp
(
f
,
tl
)
->
t_app
(
fn
F
f
)
(
List
.
map
fn_t
tl
)
ty
|
Tapp
(
f
,
tl
)
->
t_app
(
fn
L
f
)
(
List
.
map
fn_t
tl
)
ty
|
Tlet
(
t1
,
(
u
,
t2
))
->
let
t1
=
fn_t
t1
in
t_let
(
fnV
u
t1
.
t_ty
)
t1
(
fn_t
t2
)
|
Tcase
(
t1
,
bl
)
->
let
fn_b
=
t_branch
fnT
fnV
fn
F
fnP
in
let
fn_b
=
t_branch
fnT
fnV
fn
L
in
t_case
(
fn_t
t1
)
(
List
.
map
fn_b
bl
)
ty
|
Teps
(
u
,
f
)
->
t_eps
(
fnV
u
ty
)
(
fn_f
f
))
and
t_branch
fnT
fnV
fn
F
fnP
(
pat
,
nv
,
t
)
=
(
pat_s_map
fnT
fnV
fn
F
pat
,
nv
,
t_s_map
fnT
fnV
fnF
fnP
t
)
and
t_branch
fnT
fnV
fn
L
(
pat
,
nv
,
t
)
=
(
pat_s_map
fnT
fnV
fn
L
pat
,
nv
,
t_s_map
fnT
fnV
fnL
t
)
and
f_s_map
fnT
fnV
fn
F
fnP
f
=
let
fn_t
=
t_s_map
fnT
fnV
fn
F
fnP
in
let
fn_f
=
f_s_map
fnT
fnV
fn
F
fnP
in
and
f_s_map
fnT
fnV
fn
L
f
=
let
fn_t
=
t_s_map
fnT
fnV
fn
L
in
let
fn_f
=
f_s_map
fnT
fnV
fn
L
in
f_label_try
f
.
f_label
(
match
f
.
f_node
with
|
Fapp
(
p
,
tl
)
->
f_app
(
fn
P
p
)
(
List
.
map
fn_t
tl
)
|
Fapp
(
p
,
tl
)
->
f_app
(
fn
L
p
)
(
List
.
map
fn_t
tl
)
|
Fquant
(
q
,
(
vl
,
nv
,
tl
,
f1
))
->
let
tl
=
tr_map
fn_t
fn_f
tl
in
let
fn_v
u
=
fnV
u
(
fnT
u
.
vs_ty
)
in
...
...
@@ -943,11 +930,11 @@ and f_s_map fnT fnV fnF fnP f =
|
Flet
(
t
,
(
u
,
f1
))
->
let
t1
=
fn_t
t
in
f_let
(
fnV
u
t1
.
t_ty
)
t1
(
fn_f
f1
)
|
Fcase
(
t
,
bl
)
->
let
fn_b
=
f_branch
fnT
fnV
fn
F
fnP
in
let
fn_b
=
f_branch
fnT
fnV
fn
L
in
f_case
(
fn_t
t
)
(
List
.
map
fn_b
bl
))
and
f_branch
fnT
fnV
fn
F
fnP
(
pat
,
nv
,
f
)
=
(
pat_s_map
fnT
fnV
fn
F
pat
,
nv
,
f_s_map
fnT
fnV
fnF
fnP
f
)
and
f_branch
fnT
fnV
fn
L
(
pat
,
nv
,
f
)
=
(
pat_s_map
fnT
fnV
fn
L
pat
,
nv
,
f_s_map
fnT
fnV
fnL
f
)
let
get_fnV
()
=
let
ht
=
Hid
.
create
17
in
...
...
@@ -970,33 +957,33 @@ let get_fnT fn =
in
fnT
let
t_s_map
fnT
fn
F
fnP
t
=
t_s_map
(
get_fnT
fnT
)
(
get_fnV
()
)
fnF
fnP
t
let
f_s_map
fnT
fn
F
fnP
f
=
f_s_map
(
get_fnT
fnT
)
(
get_fnV
()
)
fnF
fnP
f
let
t_s_map
fnT
fn
L
t
=
t_s_map
(
get_fnT
fnT
)
(
get_fnV
()
)
fnL
t
let
f_s_map
fnT
fn
L
f
=
f_s_map
(
get_fnT
fnT
)
(
get_fnV
()
)
fnL
f
(* symbol-wise fold *)
let
rec
t_s_fold
fnT
fn
F
fnP
acc
t
=
let
fn_t
=
t_s_fold
fnT
fn
F
fnP
in
let
fn_f
=
f_s_fold
fnT
fn
F
fnP
in
let
rec
t_s_fold
fnT
fn
L
acc
t
=
let
fn_t
=
t_s_fold
fnT
fn
L
in
let
fn_f
=
f_s_fold
fnT
fn
L
in
let
acc
=
ty_s_fold
fnT
acc
t
.
t_ty
in
match
t
.
t_node
with
|
Tbvar
_
|
Tvar
_
|
Tconst
_
->
acc
|
Tapp
(
f
,
tl
)
->
List
.
fold_left
fn_t
(
fn
F
acc
f
)
tl
|
Tapp
(
f
,
tl
)
->
List
.
fold_left
fn_t
(
fn
L
acc
f
)
tl
|
Tlet
(
t1
,
(
_
,
t2
))
->
fn_t
(
fn_t
acc
t1
)
t2
|
Tcase
(
t1
,
bl
)
->
let
fn_b
=
t_branch
fnT
fn
F
fnP
in
let
fn_b
=
t_branch
fnT
fn
L
in
List
.
fold_left
fn_b
(
fn_t
acc
t1
)
bl
|
Teps
(
_
,
f
)
->
fn_f
acc
f
and
t_branch
fnT
fn
F
fnP
acc
(
pat
,_,
t
)
=
t_s_fold
fnT
fn
F
fnP
(
pat_s_fold
fnT
fnF
acc
pat
)
t
and
t_branch
fnT
fn
L
acc
(
pat
,_,
t
)
=
t_s_fold
fnT
fn
L
(
pat_s_fold
fnT
fnL
acc
pat
)
t
and
f_s_fold
fnT
fn
F
fnP
acc
f
=
let
fn_t
=
t_s_fold
fnT
fn
F
fnP
in
let
fn_f
=
f_s_fold
fnT
fn
F
fnP
in
and
f_s_fold
fnT
fn
L
acc
f
=
let
fn_t
=
t_s_fold
fnT
fn
L
in
let
fn_f
=
f_s_fold
fnT
fn
L
in
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
(
fn
P
acc
p
)
tl
|
Fapp
(
p
,
tl
)
->
List
.
fold_left
fn_t
(
fn
L
acc
p
)
tl
|
Fquant
(
q
,
(
vl
,_,
tl
,
f1
))
->
let
acc
=
List
.
fold_left
fn_v
acc
vl
in
fn_f
(
tr_fold
fn_t
fn_f
acc
tl
)
f1
...
...
@@ -1006,27 +993,23 @@ and f_s_fold fnT fnF fnP acc f =
|
Fif
(
f1
,
f2
,
f3
)
->
fn_f
(
fn_f
(
fn_f
acc
f1
)
f2
)
f3
|
Flet
(
t
,
(
_
,
f1
))
->
fn_f
(
fn_t
acc
t
)
f1
|
Fcase
(
t
,
bl
)
->
let
fn_b
=
f_branch
fnT
fn
F
fnP
in
let
fn_b
=
f_branch
fnT
fn
L
in
List
.
fold_left
fn_b
(
fn_t
acc
t
)
bl
and
f_branch
fnT
fn
F
fnP
acc
(
pat
,_,
f
)
=
f_s_fold
fnT
fn
F
fnP
(
pat_s_fold
fnT
fnF
acc
pat
)
f
and
f_branch
fnT
fn
L
acc
(
pat
,_,
f
)
=
f_s_fold
fnT
fn
L
(
pat_s_fold
fnT
fnL
acc
pat
)
f
let
t_s_all
prT
prF
prP
t
=
try
t_s_fold
(
all_fn
prT
)
(
all_fn
prF
)
(
all_fn
prP
)
true
t
with
FoldSkip
->
false
let
t_s_all
prT
prL
t
=
try
t_s_fold
(
all_fn
prT
)
(
all_fn
prL
)
true
t
with
FoldSkip
->
false
let
f_s_all
prT
prF
prP
f
=
try
f_s_fold
(
all_fn
prT
)
(
all_fn
prF
)
(
all_fn
prP
)
true
f
with
FoldSkip
->
false
let
f_s_all
prT
prL
f
=
try
f_s_fold
(
all_fn
prT
)
(
all_fn
prL
)
true
f
with
FoldSkip
->
false
let
t_s_any
prT
prF
prP
t
=
try
t_s_fold
(
any_fn
prT
)
(
any_fn
prF
)
(
any_fn
prP
)
false
t
with
FoldSkip
->
true
let
t_s_any
prT
prL
t
=
try
t_s_fold
(
any_fn
prT
)
(
any_fn
prL
)
false
t
with
FoldSkip
->
true
let
f_s_any
prT
prF
prP
f
=
try
f_s_fold
(
any_fn
prT
)
(
any_fn
prF
)
(
any_fn
prP
)
false
f
with
FoldSkip
->
true
let
f_s_any
prT
prL
f
=
try
f_s_fold
(
any_fn
prT
)
(
any_fn
prL
)
false
f
with
FoldSkip
->
true
(* safe smart constructors *)
...
...
src/core/term.mli
View file @
4cd5a72c
...
...
@@ -33,38 +33,30 @@ module Hvs : Hashtbl.S with type key = vsymbol
val
create_vsymbol
:
preid
->
ty
->
vsymbol
(** Function symbols *)
(** Function
and predicate
symbols *)
type
fsymbol
=
private
{
fs_name
:
ident
;
fs_scheme
:
ty
list
*
ty
;
fs_constr
:
bool
;
type
lsymbol
=
private
{
ls_name
:
ident
;
ls_args
:
ty
list
;
ls_value
:
ty
option
;
ls_constr
:
bool
;
}
val
create_fsymbol
:
preid
->
ty
list
*
ty
->
bool
->
fsymbol
val
create_fsymbol
:
preid
->
ty
list
->
ty
->
lsymbol
val
create_fconstr
:
preid
->
ty
list
->
ty
->
lsymbol
val
create_psymbol
:
preid
->
ty
list
->
lsymbol
module
Sfs
:
Set
.
S
with
type
elt
=
fsymbol
module
Mfs
:
Map
.
S
with
type
key
=
fsymbol
module
Hfs
:
Hashtbl
.
S
with
type
key
=
fsymbol
(** Predicate symbols *)
type
psymbol
=
private
{
ps_name
:
ident
;
ps_scheme
:
ty
list
;
}
val
create_psymbol
:
preid
->
ty
list
->
psymbol
module
Sps
:
Set
.
S
with
type
elt
=
psymbol
module
Mps
:
Map
.
S
with
type
key
=
psymbol
module
Hps
:
Hashtbl
.
S
with
type
key
=
psymbol
module
Sls
:
Set
.
S
with
type
elt
=
lsymbol
module
Mls
:
Map
.
S
with
type
key
=
lsymbol
module
Hls
:
Hashtbl
.
S
with
type
key
=
lsymbol
(** Exceptions *)
exception
BadArity
exception
NonLinear
of
vsymbol
exception
ConstructorExpected
of
fsymbol
exception
ConstructorExpected
of
lsymbol
exception
FunctionSymbolExpected
of
lsymbol
exception
PredicateSymbolExpected
of
lsymbol
(** Patterns *)
...
...
@@ -77,14 +69,14 @@ type pattern = private {
and
pattern_node
=
private
|
Pwild
|
Pvar
of
vsymbol
|
Papp
of
f
symbol
*
pattern
list
|
Papp
of
l
symbol
*
pattern
list
|
Pas
of
pattern
*
vsymbol
(* smart constructors for patterns *)
val
pat_wild
:
ty
->
pattern
val
pat_var
:
vsymbol
->
pattern
val
pat_app
:
f
symbol
->
pattern
list
->
ty
->
pattern
val
pat_app
:
l
symbol
->
pattern
list
->
ty
->
pattern
val
pat_as
:
pattern
->
vsymbol
->
pattern
(* generic traversal functions *)
...
...
@@ -137,13 +129,13 @@ and term_node = private
|
Tbvar
of
int
|
Tvar
of
vsymbol
|
Tconst
of
constant
|
Tapp
of
f
symbol
*
term
list
|
Tapp
of
l
symbol
*
term
list
|
Tlet
of
term
*
term_bound
|
Tcase
of
term
*
term_branch
list
|
Teps
of
fmla_bound
and
fmla_node
=
private
|
Fapp
of
p
symbol
*
term
list
|
Fapp
of
l
symbol
*
term
list
|
Fquant
of
quant
*
fmla_quant
|
Fbinop
of
binop
*
fmla
*
fmla
|
Fnot
of
fmla
...
...
@@ -178,7 +170,7 @@ module Sfmla : Set.S with type elt = fmla
val
t_var
:
vsymbol
->
term
val
t_const
:
constant
->
ty
->
term
val
t_app
:
f
symbol
->
term
list
->
ty
->
term
val
t_app
:
l
symbol
->
term
list
->
ty
->
term
val
t_let
:
vsymbol
->
term
->
term
->
term
val
t_case
:
term
->
(
pattern
*
term
)
list
->
ty
->
term
val
t_eps
:
vsymbol
->
fmla
->
term
...
...
@@ -188,7 +180,7 @@ val t_label_add : label -> term -> term
(* smart constructors for fmla *)
val
f_app
:
p
symbol
->
term
list
->
fmla
val
f_app
:
l
symbol
->
term
list
->
fmla
val
f_forall
:
vsymbol
list
->
trigger
list
->
fmla
->
fmla
val
f_exists
:
vsymbol
list
->
trigger
list
->
fmla
->
fmla
val
f_quant
:
quant
->
vsymbol
list
->
trigger
list
->
fmla
->
fmla
...
...
@@ -222,11 +214,11 @@ val f_open_quant : fmla_quant -> vsymbol list * trigger list * fmla
val
t_map
:
(
term
->
term
)
->
(
fmla
->
fmla
)
->
term
->
term
val
f_map
:
(
term
->
term
)
->
(
fmla
->
fmla
)
->
fmla
->
fmla
val
t_fold
:
(
'
a
->
term
->
'
a
)
->
(
'
a
->
fmla
->
'
a
)
->
'
a
->
term
->
'
a
val
t_fold
:
(
'
a
->
term
->
'
a
)
->
(
'
a
->
fmla
->
'
a
)
->
'
a
->
term
->
'
a
val
f_fold
:
(
'
a
->
term
->
'
a
)
->
(
'
a
->
fmla
->
'
a
)
->
'
a
->
fmla
->
'
a
val
f_fold
:
(
'
a
->
term
->
'
a
)
->
(
'
a
->
fmla
->
'
a
)
->
'
a
->
fmla
->
'
a
val
t_all
:
(
term
->
bool
)
->
(
fmla
->
bool
)
->
term
->
bool
val
f_all
:
(
term
->
bool
)
->
(
fmla
->
bool
)
->
fmla
->
bool
...
...
@@ -235,29 +227,19 @@ val f_any : (term -> bool) -> (fmla -> bool) -> fmla -> bool
(* symbol-wise map/fold *)
val
t_s_map
:
(
tysymbol
->
tysymbol
)
->
(
fsymbol
->
fsymbol
)
->
(
psymbol
->
psymbol
)
->
term
->
term
val
f_s_map
:
(
tysymbol
->
tysymbol
)
->
(
fsymbol
->
fsymbol
)
->
(
psymbol
->
psymbol
)
->
fmla
->
fmla
val
t_s_fold
:
(
'
a
->
tysymbol
->
'
a
)
->
(
'
a
->
fsymbol
->
'
a
)
->
(
'
a
->
psymbol
->
'
a
)
->
'
a
->
term
->
'
a
val
f_s_fold
:
(
'
a
->
tysymbol
->
'
a
)
->
(
'
a
->
fsymbol
->
'
a
)
->
(
'
a
->
psymbol
->
'
a
)
->
'
a
->
fmla
->
'
a
val
t_s_all
:
(
tysymbol
->
bool
)
->
(
fsymbol
->
bool
)
->
(
psymbol
->
bool
)
->
term
->
bool
val
t_s_map
:
(
tysymbol
->
tysymbol
)
->
(
lsymbol
->
lsymbol
)
->
term
->
term
val
f_s_map
:
(
tysymbol
->
tysymbol
)
->
(
lsymbol
->
lsymbol
)
->
fmla
->
fmla
val
f_s_all
:
(
tysymbol
->
bool
)
->
(
fsymbol
->
bool
)
->
(
psymbol
->
bool
)
->
fmla
->
bool
val
t_s_fold
:
(
'
a
->
tysymbol
->
'
a
)
->
(
'
a
->
lsymbol
->
'
a
)
->
'
a
->
term
->
'
a
val
t_s_any
:
(
tysymbol
->
bool
)
->
(
fsymbol
->
bool
)
->
(
psymbol
->
bool
)
->
term
->
bool
val
f_s_fold
:
(
'
a
->
tysymbol
->
'
a
)
->
(
'
a
->
lsymbol
->
'
a
)
->
'
a
->
fmla
->
'
a
val
f_s_any
:
(
tysymbol
->
bool
)
->
(
fsymbol
->
bool
)
->
(
psymbol
->
bool
)
->
fmla
->
bool
val
t_s_all
:
(
tysymbol
->
bool
)
->
(
lsymbol
->
bool
)
->
term
->
bool
val
f_s_all
:
(
tysymbol
->
bool
)
->
(
lsymbol
->
bool
)
->
fmla
->
bool
val
t_s_any
:
(
tysymbol
->
bool
)
->
(
lsymbol
->
bool
)
->
term
->
bool
val
f_s_any
:
(
tysymbol
->
bool
)
->
(
lsymbol
->
bool
)
->
fmla
->
bool
(* map/fold over free variables *)
...
...
@@ -329,8 +311,8 @@ val f_match : fmla -> fmla -> term Mvs.t -> term Mvs.t option
(* built-in symbols *)
val
ps_equ
:
p
symbol
val
ps_neq
:
p
symbol
val
ps_equ
:
l
symbol
val
ps_neq
:
l
symbol
val
f_equ
:
term
->
term
->
fmla
val
f_neq
:
term
->
term
->
fmla
...
...
src/core/theory.ml
View file @
4cd5a72c
...
...
@@ -19,6 +19,7 @@
open
Format
open
Pp
open
Util
open
Ident
open
Ty
open
Term
...
...
@@ -29,19 +30,19 @@ open Term
type
ty_def
=
|
Tabstract
|
Talgebraic
of
f
symbol
list
|
Talgebraic
of
l
symbol
list
type
ty_decl
=
tysymbol
*
ty_def
(* logic declaration *)
type
fs_defn
=
f
symbol
*
vsymbol
list
*
term
*
fmla
type
ps_defn
=
p
symbol
*
vsymbol
list
*
fmla
*
fmla
type
fs_defn
=
l
symbol
*
vsymbol
list
*
term
*
fmla
type
ps_defn
=
l
symbol
*
vsymbol
list
*
fmla
*
fmla
type
logic_decl
=
|
Lfunction
of
f
symbol
*
fs_defn
option
|
Lpredicate
of
p
symbol
*
ps_defn
option
|
Linductive
of
p
symbol
*
(
ident
*
fmla
)
list
|
Lfunction
of
l
symbol
*
fs_defn
option
|
Lpredicate
of
l
symbol
*
ps_defn
option
|
Linductive
of
l
symbol
*
(
ident
*
fmla
)
list
(* proposition declaration *)
...
...
@@ -97,17 +98,17 @@ module D = struct
let
hs_td
(
ts
,
td
)
=
match
td
with
|
Tabstract
->
ts
.
ts_name
.
id_tag
|
Talgebraic
l
->
let
tag
fs
=
fs
.
f
s_name
.
id_tag
in
let
tag
fs
=
fs
.
l
s_name
.
id_tag
in
1
+
Hashcons
.
combine_list
tag
ts
.
ts_name
.
id_tag
l
let
hs_fd
fd
=
Hashcons
.
combine_option
(
fun
(
_
,_,_,
f
)
->
f
.
f_tag
)
fd
let
hs_ld
ld
=
match
ld
with
|
Lfunction
(
fs
,
fd
)
->
Hashcons
.
combine
fs
.
f
s_name
.
id_tag
(
hs_fd
fd
)
|
Lpredicate
(
ps
,
pd
)
->
Hashcons
.
combine
ps
.
p
s_name
.
id_tag
(
hs_fd
pd
)
|
Lfunction
(
fs
,
fd
)
->
Hashcons
.
combine
fs
.
l
s_name
.
id_tag
(
hs_fd
fd
)
|
Lpredicate
(
ps
,
pd
)
->
Hashcons
.
combine
ps
.
l
s_name
.
id_tag
(
hs_fd
pd
)
|
Linductive
(
ps
,
l
)
->
let
hs_pair
(
i
,
f
)
=
Hashcons
.
combine
i
.
id_tag
f
.
f_tag
in
Hashcons
.
combine_list
hs_pair
ps
.
p
s_name
.
id_tag
l
Hashcons
.
combine_list
hs_pair
ps
.
l
s_name
.
id_tag
l
let
hash
d
=
match
d
.
d_node
with
|
Dtype
l
->
Hashcons
.
combine_list
hs_td
0
l
...
...
@@ -135,11 +136,11 @@ let create_prop k i f = Hdecl.hashcons (mk_decl (Dprop (k, id_register i, f)))
(* error reporting *)