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
121
Issues
121
List
Boards
Labels
Service Desk
Milestones
Merge Requests
14
Merge Requests
14
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
017deebd
Commit
017deebd
authored
Jul 15, 2010
by
Andrei Paskevich
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
keep real symbols in Clone and Meta
parent
7209c060
Changes
17
Hide whitespace changes
Inline
Side-by-side
Showing
17 changed files
with
197 additions
and
202 deletions
+197
-202
src/core/decl.ml
src/core/decl.ml
+1
-1
src/core/pretty.ml
src/core/pretty.ml
+24
-41
src/core/pretty.mli
src/core/pretty.mli
+1
-1
src/core/printer.ml
src/core/printer.ml
+17
-8
src/core/task.ml
src/core/task.ml
+22
-4
src/core/task.mli
src/core/task.mli
+3
-1
src/core/theory.ml
src/core/theory.ml
+70
-72
src/core/theory.mli
src/core/theory.mli
+2
-7
src/driver/driver.ml
src/driver/driver.ml
+3
-2
src/printer/alt_ergo.ml
src/printer/alt_ergo.ml
+4
-3
src/printer/why3.ml
src/printer/why3.ml
+27
-10
src/transform/eliminate_definition.ml
src/transform/eliminate_definition.ml
+5
-9
src/transform/encoding_decorate.ml
src/transform/encoding_decorate.ml
+3
-24
src/transform/encoding_decorate_mono.ml
src/transform/encoding_decorate_mono.ml
+6
-9
src/transform/encoding_enumeration.ml
src/transform/encoding_enumeration.ml
+4
-5
src/transform/filter_trigger.ml
src/transform/filter_trigger.ml
+4
-4
src/transform/hypothesis_selection.ml
src/transform/hypothesis_selection.ml
+1
-1
No files found.
src/core/decl.ml
View file @
017deebd
...
...
@@ -86,7 +86,7 @@ module Spr = Prop.S
module
Mpr
=
Prop
.
M
module
Hpr
=
Prop
.
H
let
pr_equal
pr1
pr2
=
id_equal
pr1
.
pr_name
pr2
.
pr_name
let
pr_equal
=
(
==
)
let
create_prsymbol
n
=
{
pr_name
=
id_register
n
}
...
...
src/core/pretty.ml
View file @
017deebd
...
...
@@ -43,18 +43,11 @@ let iprinter,tprinter,lprinter,pprinter =
create_ident_printer
bl
~
sanitizer
:
isanitize
,
create_ident_printer
bl
~
sanitizer
:
usanitize
let
thash
=
Hid
.
create
63
let
lhash
=
Hid
.
create
63
let
phash
=
Hid
.
create
63
let
forget_all
()
=
forget_all
iprinter
;
forget_all
tprinter
;
forget_all
lprinter
;
forget_all
pprinter
;
Hid
.
clear
thash
;
Hid
.
clear
lhash
;
Hid
.
clear
phash
forget_all
pprinter
let
tv_set
=
ref
Sid
.
empty
...
...
@@ -81,20 +74,16 @@ let print_th fmt th =
fprintf
fmt
"%s"
(
id_unique
iprinter
~
sanitizer
th
.
th_name
)
let
print_ts
fmt
ts
=
Hid
.
replace
thash
ts
.
ts_name
ts
;
fprintf
fmt
"%s"
(
id_unique
tprinter
ts
.
ts_name
)
let
print_ls
fmt
ls
=
Hid
.
replace
lhash
ls
.
ls_name
ls
;
fprintf
fmt
"%s"
(
id_unique
lprinter
ls
.
ls_name
)
let
print_cs
fmt
ls
=
Hid
.
replace
lhash
ls
.
ls_name
ls
;
let
sanitizer
=
String
.
capitalize
in
fprintf
fmt
"%s"
(
id_unique
lprinter
~
sanitizer
ls
.
ls_name
)
let
print_pr
fmt
pr
=
Hid
.
replace
phash
pr
.
pr_name
pr
;
fprintf
fmt
"%s"
(
id_unique
pprinter
pr
.
pr_name
)
(** Types *)
...
...
@@ -328,41 +317,35 @@ let print_decl fmt d = match d.d_node with
|
Dind
il
->
print_list
newline
print_ind_decl
fmt
il
|
Dprop
p
->
print_prop_decl
fmt
p
let
print_inst
fmt
(
id1
,
id2
)
=
if
Hid
.
mem
thash
id2
then
let
n
=
id_unique
tprinter
id1
in
fprintf
fmt
"type %s = %a"
n
print_ts
(
Hid
.
find
thash
id2
)
else
if
Hid
.
mem
lhash
id2
then
let
n
=
id_unique
lprinter
id1
in
fprintf
fmt
"logic %s = %a"
n
print_ls
(
Hid
.
find
lhash
id2
)
else
if
Hid
.
mem
phash
id2
then
let
n
=
id_unique
pprinter
id1
in
fprintf
fmt
"prop %s = %a"
n
print_pr
(
Hid
.
find
phash
id2
)
else
fprintf
fmt
"ident %s = %s"
id1
.
id_string
id2
.
id_string
let
print_inst_ts
fmt
(
ts1
,
ts2
)
=
fprintf
fmt
"type %a = %a"
print_ts
ts1
print_ts
ts2
let
print_inst_ls
fmt
(
ls1
,
ls2
)
=
fprintf
fmt
"logic %a = %a"
print_ls
ls1
print_ls
ls2
let
print_inst_pr
fmt
(
pr1
,
pr2
)
=
fprintf
fmt
"prop %a = %a"
print_pr
pr1
print_pr
pr2
let
print_meta_arg
fmt
=
function
|
MARid
id
->
if
Hid
.
mem
thash
id
then
fprintf
fmt
"type %a"
print_ts
(
Hid
.
find
thash
id
)
else
if
Hid
.
mem
lhash
id
then
fprintf
fmt
"logic %a"
print_ls
(
Hid
.
find
lhash
id
)
else
if
Hid
.
mem
phash
id
then
fprintf
fmt
"prop %a"
print_pr
(
Hid
.
find
phash
id
)
else
fprintf
fmt
"ident %s"
id
.
id_string
|
MARstr
s
->
fprintf
fmt
"
\"
%s
\"
"
s
|
MARint
i
->
fprintf
fmt
"%d"
i
|
MAts
ts
->
fprintf
fmt
"type %a"
print_ts
ts
|
MAls
ls
->
fprintf
fmt
"logic %a"
print_ls
ls
|
MApr
pr
->
fprintf
fmt
"prop %a"
print_pr
pr
|
MAstr
s
->
fprintf
fmt
"
\"
%s
\"
"
s
|
MAint
i
->
fprintf
fmt
"%d"
i
let
print_tdecl
fmt
td
=
match
td
.
td_node
with
|
Decl
d
->
print_decl
fmt
d
|
Use
th
->
fprintf
fmt
"@[<hov 2>(* use %a *)@]"
print_th
th
|
Clone
(
th
,
inst
)
->
let
inst
=
Mid
.
fold
(
fun
x
y
a
->
(
x
,
y
)
::
a
)
inst
[]
in
fprintf
fmt
"@[<hov 2>(* clone %a with %a *)@]"
print_th
th
(
print_list
comma
print_inst
)
inst
|
Clone
(
th
,
tm
,
lm
,
pm
)
->
let
tm
=
Mts
.
fold
(
fun
x
y
a
->
(
x
,
y
)
::
a
)
tm
[]
in
let
lm
=
Mls
.
fold
(
fun
x
y
a
->
(
x
,
y
)
::
a
)
lm
[]
in
let
pm
=
Mpr
.
fold
(
fun
x
y
a
->
(
x
,
y
)
::
a
)
pm
[]
in
fprintf
fmt
"@[<hov 2>(* clone %a with %a,%a,%a *)@]"
print_th
th
(
print_list
comma
print_inst_ts
)
tm
(
print_list
comma
print_inst_ls
)
lm
(
print_list
comma
print_inst_pr
)
pm
|
Meta
(
t
,
al
)
->
fprintf
fmt
"@[<hov 2>(* meta %s %a *)@]"
t
(
print_list
space
print_meta_arg
)
al
...
...
@@ -386,7 +369,7 @@ module NsTree = struct
let
contents
ns
kn
=
let
add_ns
s
ns
acc
=
Namespace
(
s
,
ns
,
kn
)
::
acc
in
let
add_pr
s
p
acc
=
let
add_pr
s
p
acc
=
let
k
,
_
=
find_prop_decl
kn
p
in
Leaf
(
sprint_pkind
k
^
" "
^
s
)
::
acc
in
let
add_ls
s
ls
acc
=
...
...
@@ -411,7 +394,7 @@ end
let
print_namespace
fmt
name
th
=
let
module
P
=
Print_tree
.
Make
(
NsTree
)
in
fprintf
fmt
"@[<hov>%a@]@."
P
.
print
fprintf
fmt
"@[<hov>%a@]@."
P
.
print
(
NsTree
.
Namespace
(
name
,
th
.
th_export
,
th
.
th_known
))
(* Exception reporting *)
...
...
src/core/pretty.mli
View file @
017deebd
...
...
@@ -47,7 +47,7 @@ val print_fmla : formatter -> fmla -> unit (* formula *)
val
print_expr
:
formatter
->
expr
->
unit
(* term or formula *)
val
print_pkind
:
formatter
->
prop_kind
->
unit
val
print_meta_arg
:
formatter
->
meta_arg
_real
->
unit
val
print_meta_arg
:
formatter
->
meta_arg
->
unit
val
print_type_decl
:
formatter
->
ty_decl
->
unit
val
print_logic_decl
:
formatter
->
logic_decl
->
unit
...
...
src/core/printer.ml
View file @
017deebd
...
...
@@ -113,7 +113,8 @@ let print_prelude fmt pl =
let
print_th_prelude
task
fmt
pm
=
let
th_used
=
task_fold
(
fun
acc
->
function
|
{
td_node
=
Clone
(
th
,
cl
)
}
when
Mid
.
is_empty
cl
->
th
::
acc
|
{
td_node
=
Clone
(
th
,
tm
,
lm
,
pm
)
}
when
Mts
.
is_empty
tm
&&
Mls
.
is_empty
lm
&&
Mpr
.
is_empty
pm
->
th
::
acc
|
_
->
acc
)
[]
task
in
List
.
iter
(
fun
th
->
...
...
@@ -140,19 +141,27 @@ let meta_remove_type = register_meta "remove_type" [MTtysymbol]
let
meta_remove_logic
=
register_meta
"remove_logic"
[
MTlsymbol
]
let
meta_remove_prop
=
register_meta
"remove_prop"
[
MTprsymbol
]
let
remove_type
ts
=
create_meta
meta_remove_type
[
MAts
ts
]
let
remove_type
ts
=
create_meta
meta_remove_type
[
MAts
ts
]
let
remove_logic
ls
=
create_meta
meta_remove_logic
[
MAls
ls
]
let
remove_prop
pr
=
create_meta
meta_remove_prop
[
MApr
pr
]
let
remove_prop
pr
=
create_meta
meta_remove_prop
[
MApr
pr
]
let
get_remove_set
task
=
let
add
td
s
=
match
td
.
td_node
with
|
Meta
(
_
,
[
MARid
id
])
->
Sid
.
add
id
s
let
add_ts
td
s
=
match
td
.
td_node
with
|
Meta
(
_
,
[
MAts
ts
])
->
Sid
.
add
ts
.
ts_name
s
|
_
->
assert
false
in
let
add_ls
td
s
=
match
td
.
td_node
with
|
Meta
(
_
,
[
MAls
ls
])
->
Sid
.
add
ls
.
ls_name
s
|
_
->
assert
false
in
let
add_pr
td
s
=
match
td
.
td_node
with
|
Meta
(
_
,
[
MApr
pr
])
->
Sid
.
add
pr
.
pr_name
s
|
_
->
assert
false
in
let
s
=
Sid
.
empty
in
let
s
=
Stdecl
.
fold
add
(
find_meta
task
meta_remove_type
)
.
tds_set
s
in
let
s
=
Stdecl
.
fold
add
(
find_meta
task
meta_remove_logic
)
.
tds_set
s
in
let
s
=
Stdecl
.
fold
add
(
find_meta
task
meta_remove_prop
)
.
tds_set
s
in
let
s
=
Stdecl
.
fold
add
_ts
(
find_meta
task
meta_remove_type
)
.
tds_set
s
in
let
s
=
Stdecl
.
fold
add
_ls
(
find_meta
task
meta_remove_logic
)
.
tds_set
s
in
let
s
=
Stdecl
.
fold
add
_pr
(
find_meta
task
meta_remove_prop
)
.
tds_set
s
in
s
(** {2 exceptions to use in transformations and printers} *)
...
...
src/core/task.ml
View file @
017deebd
...
...
@@ -165,7 +165,7 @@ let add_ind_decls tk dl = List.fold_left add_decl tk (create_ind_decls dl)
let
rec
add_tdecl
task
td
=
match
td
.
td_node
with
|
Decl
d
->
new_decl
task
d
td
|
Use
th
->
use_export
task
th
|
Clone
(
th
,_
)
->
add_clone
task
th
td
|
Clone
(
th
,_
,_,_
)
->
add_clone
task
th
td
|
Meta
(
t
,_
)
->
add_meta
task
t
td
and
flat_tdecl
task
td
=
match
td
.
td_node
with
...
...
@@ -215,13 +215,31 @@ let task_decls = task_fold (fun acc td ->
exception
NotTaggingMeta
of
string
let
find_tagged
t
tds
acc
=
let
find_tagged
_ts
t
tds
acc
=
begin
match
lookup_meta
t
with
|
[
MTtysymbol
|
MTlsymbol
|
MTprsymbol
]
->
()
|
[
MTtysymbol
]
->
()
|
_
->
raise
(
NotTaggingMeta
t
)
end
;
Stdecl
.
fold
(
fun
td
acc
->
match
td
.
td_node
with
|
Meta
(
s
,
[
MARid
id
])
when
s
=
t
->
Sid
.
add
id
acc
|
Meta
(
s
,
[
MAts
ts
])
when
s
=
t
->
Sts
.
add
ts
acc
|
_
->
assert
false
)
tds
.
tds_set
acc
let
find_tagged_ls
t
tds
acc
=
begin
match
lookup_meta
t
with
|
[
MTlsymbol
]
->
()
|
_
->
raise
(
NotTaggingMeta
t
)
end
;
Stdecl
.
fold
(
fun
td
acc
->
match
td
.
td_node
with
|
Meta
(
s
,
[
MAls
ls
])
when
s
=
t
->
Sls
.
add
ls
acc
|
_
->
assert
false
)
tds
.
tds_set
acc
let
find_tagged_pr
t
tds
acc
=
begin
match
lookup_meta
t
with
|
[
MTprsymbol
]
->
()
|
_
->
raise
(
NotTaggingMeta
t
)
end
;
Stdecl
.
fold
(
fun
td
acc
->
match
td
.
td_node
with
|
Meta
(
s
,
[
MApr
pr
])
when
s
=
t
->
Spr
.
add
pr
acc
|
_
->
assert
false
)
tds
.
tds_set
acc
exception
NotExclusiveMeta
of
string
...
...
src/core/task.mli
View file @
017deebd
...
...
@@ -99,7 +99,9 @@ val task_goal : task -> prsymbol
exception
NotTaggingMeta
of
string
val
find_tagged
:
string
->
tdecl_set
->
Sid
.
t
->
Sid
.
t
val
find_tagged_ts
:
string
->
tdecl_set
->
Sts
.
t
->
Sts
.
t
val
find_tagged_ls
:
string
->
tdecl_set
->
Sls
.
t
->
Sls
.
t
val
find_tagged_pr
:
string
->
tdecl_set
->
Spr
.
t
->
Spr
.
t
(* special selector for exclusive metaproperties *)
...
...
src/core/theory.ml
View file @
017deebd
...
...
@@ -96,11 +96,6 @@ type meta_arg =
|
MAstr
of
string
|
MAint
of
int
type
meta_arg_real
=
|
MARid
of
ident
|
MARstr
of
string
|
MARint
of
int
exception
KnownMeta
of
string
exception
UnknownMeta
of
string
exception
BadMetaArity
of
string
*
int
*
int
...
...
@@ -148,8 +143,8 @@ and tdecl = {
and
tdecl_node
=
|
Decl
of
decl
|
Use
of
theory
|
Clone
of
theory
*
ident
Mid
.
t
|
Meta
of
string
*
meta_arg
_real
list
|
Clone
of
theory
*
tysymbol
Mts
.
t
*
lsymbol
Mls
.
t
*
prsymbol
Mpr
.
t
|
Meta
of
string
*
meta_arg
list
(** Theory declarations *)
...
...
@@ -158,32 +153,42 @@ module Hstdecl = Hashcons.Make (struct
type
t
=
tdecl
let
eq_marg
a1
a2
=
match
a1
,
a2
with
|
MARid
id1
,
MARid
id2
->
id_equal
id1
id2
|
MARstr
s1
,
MARstr
s2
->
s1
=
s2
|
MARint
i1
,
MARint
i2
->
i1
=
i2
|
MAts
ts1
,
MAts
ts2
->
ts_equal
ts1
ts2
|
MAls
ls1
,
MAls
ls2
->
ls_equal
ls1
ls2
|
MApr
pr1
,
MApr
pr2
->
pr_equal
pr1
pr2
|
MAstr
s1
,
MAstr
s2
->
s1
=
s2
|
MAint
i1
,
MAint
i2
->
i1
=
i2
|
_
,_
->
false
let
equal
td1
td2
=
match
td1
.
td_node
,
td2
.
td_node
with
|
Decl
d1
,
Decl
d2
->
d_equal
d1
d2
|
Use
th1
,
Use
th2
->
id_equal
th1
.
th_name
th2
.
th_name
|
Clone
(
th1
,
cl1
)
,
Clone
(
th2
,
cl
2
)
->
|
Clone
(
th1
,
tm1
,
lm1
,
pm1
)
,
Clone
(
th2
,
tm2
,
lm2
,
pm
2
)
->
id_equal
th1
.
th_name
th2
.
th_name
&&
Mid
.
equal
id_equal
cl1
cl2
Mts
.
equal
ts_equal
tm1
tm2
&&
Mls
.
equal
ls_equal
lm1
lm2
&&
Mpr
.
equal
pr_equal
pm1
pm2
|
Meta
(
t1
,
al1
)
,
Meta
(
t2
,
al2
)
->
t1
=
t2
&&
list_all2
eq_marg
al1
al2
|
_
,_
->
false
let
hs_cl
_
id
acc
=
Hashcons
.
combine
acc
id
.
id_tag
let
hs_cl_ts
_
ts
acc
=
Hashcons
.
combine
acc
ts
.
ts_name
.
id_tag
let
hs_cl_ls
_
ls
acc
=
Hashcons
.
combine
acc
ls
.
ls_name
.
id_tag
let
hs_cl_pr
_
pr
acc
=
Hashcons
.
combine
acc
pr
.
pr_name
.
id_tag
let
hs_ta
=
function
|
MARid
id
->
id
.
id_tag
|
MARstr
s
->
Hashtbl
.
hash
s
|
MARint
i
->
Hashtbl
.
hash
i
|
MAts
ts
->
ts
.
ts_name
.
id_tag
|
MAls
ls
->
ls
.
ls_name
.
id_tag
|
MApr
pr
->
pr
.
pr_name
.
id_tag
|
MAstr
s
->
Hashtbl
.
hash
s
|
MAint
i
->
Hashtbl
.
hash
i
let
hash
td
=
match
td
.
td_node
with
|
Decl
d
->
d
.
d_tag
|
Use
th
->
th
.
th_name
.
id_tag
|
Clone
(
th
,
cl
)
->
Mid
.
fold
hs_cl
cl
th
.
th_name
.
id_tag
|
Clone
(
th
,
tm
,
lm
,
pm
)
->
Mts
.
fold
hs_cl_ts
tm
(
Mls
.
fold
hs_cl_ls
lm
(
Mpr
.
fold
hs_cl_pr
pm
th
.
th_name
.
id_tag
))
|
Meta
(
t
,
al
)
->
Hashcons
.
combine_list
hs_ta
(
Hashtbl
.
hash
t
)
al
let
tag
n
td
=
{
td
with
td_tag
=
n
}
...
...
@@ -261,12 +266,16 @@ let close_namespace uc import s =
(* Base constructors *)
let
known_clone
kn
cl
=
Mid
.
iter
(
fun
_
id
->
known_id
kn
id
)
cl
let
known_clone
kn
tm
lm
pm
=
Mts
.
iter
(
fun
_
ts
->
known_id
kn
ts
.
ts_name
)
tm
;
Mls
.
iter
(
fun
_
ls
->
known_id
kn
ls
.
ls_name
)
lm
;
Mpr
.
iter
(
fun
_
pr
->
known_id
kn
pr
.
pr_name
)
pm
let
known_meta
kn
al
=
let
check
=
function
|
MARid
id
->
known_id
kn
id
|
MAts
ts
->
known_id
kn
ts
.
ts_name
|
MAls
ls
->
known_id
kn
ls
.
ls_name
|
MApr
pr
->
known_id
kn
pr
.
pr_name
|
_
->
()
in
List
.
iter
check
al
...
...
@@ -281,7 +290,7 @@ let add_tdecl uc td = match td.td_node with
uc_decls
=
td
::
uc
.
uc_decls
;
uc_known
=
merge_known
uc
.
uc_known
th
.
th_known
;
uc_used
=
Sid
.
union
uc
.
uc_used
(
Sid
.
add
th
.
th_name
th
.
th_used
)
}
|
Clone
(
_
,
cl
)
->
known_clone
uc
.
uc_known
cl
;
|
Clone
(
_
,
tm
,
lm
,
pm
)
->
known_clone
uc
.
uc_known
tm
lm
pm
;
{
uc
with
uc_decls
=
td
::
uc
.
uc_decls
}
|
Meta
(
_
,
al
)
->
known_meta
uc
.
uc_known
al
;
{
uc
with
uc_decls
=
td
::
uc
.
uc_decls
}
...
...
@@ -373,72 +382,54 @@ exception CannotInstantiate of ident
type
clones
=
{
cl_local
:
Sid
.
t
;
ts_table
:
tysymbol
Hts
.
t
;
ls_table
:
lsymbol
Hls
.
t
;
pr_table
:
prsymbol
Hpr
.
t
;
mutable
id_table
:
ident
Mid
.
t
;
mutable
id_local
:
Sid
.
t
;
mutable
ts_table
:
tysymbol
Mts
.
t
;
mutable
ls_table
:
lsymbol
Mls
.
t
;
mutable
pr_table
:
prsymbol
Mpr
.
t
;
}
let
empty_clones
s
=
{
cl_local
=
s
;
ts_table
=
Hts
.
create
17
;
ls_table
=
Hls
.
create
17
;
pr_table
=
Hpr
.
create
17
;
id_table
=
Mid
.
empty
;
id_local
=
Sid
.
empty
;
ts_table
=
Mts
.
empty
;
ls_table
=
Mls
.
empty
;
pr_table
=
Mpr
.
empty
;
}
let
cl_add_ts
cl
ts
ts'
=
cl
.
id_table
<-
Mid
.
add
ts
.
ts_name
ts'
.
ts_name
cl
.
id_table
;
Hts
.
replace
cl
.
ts_table
ts
ts'
let
cl_add_ls
cl
ls
ls'
=
cl
.
id_table
<-
Mid
.
add
ls
.
ls_name
ls'
.
ls_name
cl
.
id_table
;
Hls
.
replace
cl
.
ls_table
ls
ls'
let
cl_add_pr
cl
pr
pr'
=
cl
.
id_table
<-
Mid
.
add
pr
.
pr_name
pr'
.
pr_name
cl
.
id_table
;
Hpr
.
replace
cl
.
pr_table
pr
pr'
(* populate the clone structure *)
let
cl_find_id
cl
id
=
if
not
(
Sid
.
mem
id
cl
.
cl_local
)
then
id
else
Mid
.
find
id
cl
.
id_table
let
rec
cl_find_ts
cl
ts
=
if
not
(
Sid
.
mem
ts
.
ts_name
cl
.
cl_local
)
then
ts
else
try
Hts
.
find
cl
.
ts_table
ts
else
try
Mts
.
find
ts
cl
.
ts_table
with
Not_found
->
let
td'
=
option_map
(
cl_trans_ty
cl
)
ts
.
ts_def
in
let
ts'
=
create_tysymbol
(
id_dup
ts
.
ts_name
)
ts
.
ts_args
td'
in
cl
.
id_local
<-
Sid
.
add
ts'
.
ts_name
cl
.
id_local
;
cl
_add_ts
cl
ts
ts'
;
cl
.
ts_table
<-
Mts
.
add
ts
ts'
cl
.
ts_table
;
ts'
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
Hls
.
find
cl
.
ls_table
ls
else
try
Mls
.
find
ls
cl
.
ls_table
with
Not_found
->
let
ta'
=
List
.
map
(
cl_trans_ty
cl
)
ls
.
ls_args
in
let
vt'
=
option_map
(
cl_trans_ty
cl
)
ls
.
ls_value
in
let
ls'
=
create_lsymbol
(
id_dup
ls
.
ls_name
)
ta'
vt'
in
cl
.
id_local
<-
Sid
.
add
ls'
.
ls_name
cl
.
id_local
;
cl
_add_ls
cl
ls
ls'
;
cl
.
ls_table
<-
Mls
.
add
ls
ls'
cl
.
ls_table
;
ls'
let
cl_trans_fmla
cl
f
=
f_s_map
(
cl_find_ts
cl
)
(
cl_find_ls
cl
)
f
let
cl_find_pr
cl
pr
=
if
not
(
Sid
.
mem
pr
.
pr_name
cl
.
cl_local
)
then
assert
false
else
try
ignore
(
Hpr
.
find
cl
.
pr_table
pr
);
assert
fals
e
if
not
(
Sid
.
mem
pr
.
pr_name
cl
.
cl_local
)
then
pr
else
try
Mpr
.
find
pr
cl
.
pr_tabl
e
with
Not_found
->
let
pr'
=
create_prsymbol
(
id_dup
pr
.
pr_name
)
in
cl
.
id_local
<-
Sid
.
add
pr'
.
pr_name
cl
.
id_local
;
cl
_add_pr
cl
pr
pr'
;
cl
.
pr_table
<-
Mpr
.
add
pr
pr'
cl
.
pr_table
;
pr'
(* initialize the clone structure *)
...
...
@@ -451,7 +442,7 @@ let cl_init_ts cl ts ts' =
if
not
(
Sid
.
mem
id
cl
.
cl_local
)
then
raise
(
NonLocal
id
);
if
List
.
length
ts
.
ts_args
<>
List
.
length
ts'
.
ts_args
then
raise
(
BadInstance
(
id
,
ts'
.
ts_name
));
cl
_add_ts
cl
ts
ts'
cl
.
ts_table
<-
Mts
.
add
ts
ts'
cl
.
ts_table
let
cl_init_ls
cl
ls
ls'
=
let
id
=
ls
.
ls_name
in
...
...
@@ -467,7 +458,7 @@ let cl_init_ls cl ls ls' =
in
ignore
(
try
List
.
fold_left2
mtch
sb
ls
.
ls_args
ls'
.
ls_args
with
Invalid_argument
_
->
raise
(
BadInstance
(
id
,
ls'
.
ls_name
)));
cl
_add_ls
cl
ls
ls'
cl
.
ls_table
<-
Mls
.
add
ls
ls'
cl
.
ls_table
let
cl_init_pr
cl
pr
=
let
id
=
pr
.
pr_name
in
...
...
@@ -564,13 +555,16 @@ let cl_decl cl inst d = match d.d_node with
|
Dprop
p
->
cl_prop
cl
inst
p
let
cl_marg
cl
=
function
|
MARid
id
->
MARid
(
cl_find_id
cl
id
)
|
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_tdecl
cl
inst
td
=
match
td
.
td_node
with
|
Decl
d
->
Decl
(
cl_decl
cl
inst
d
)
|
Use
th
->
Use
th
|
Clone
(
th
,
i
)
->
Clone
(
th
,
Mid
.
map
(
cl_find_id
cl
)
i
)
|
Clone
(
th
,
tm
,
lm
,
pm
)
->
Clone
(
th
,
Mts
.
map
(
cl_find_ts
cl
)
tm
,
Mls
.
map
(
cl_find_ls
cl
)
lm
,
Mpr
.
map
(
cl_find_pr
cl
)
pm
)
|
Meta
(
id
,
al
)
->
Meta
(
id
,
List
.
map
(
cl_marg
cl
)
al
)
let
clone_theory
cl
add_td
acc
th
inst
=
...
...
@@ -582,7 +576,7 @@ let clone_theory cl add_td acc th inst =
option_apply
acc
(
add_td
acc
)
td
in
let
acc
=
List
.
fold_left
add
acc
th
.
th_decls
in
add_td
acc
(
mk_tdecl
(
Clone
(
th
,
cl
.
id
_table
)))
add_td
acc
(
mk_tdecl
(
Clone
(
th
,
cl
.
ts_table
,
cl
.
ls_table
,
cl
.
pr
_table
)))
let
clone_export
uc
th
inst
=
let
cl
=
cl_init
th
inst
in
...
...
@@ -593,21 +587,21 @@ let clone_export uc th inst =
let
f_ts
n
ts
ns
=
if
Sid
.
mem
ts
.
ts_name
th
.
th_local
then
let
ts'
=
Hts
.
find
cl
.
ts_table
ts
in
let
ts'
=
Mts
.
find
ts
cl
.
ts_table
in
if
Sid
.
mem
ts'
.
ts_name
cl
.
id_local
then
add_ts
true
n
ts'
ns
else
ns
else
add_ts
true
n
ts
ns
in
let
f_ls
n
ls
ns
=
if
Sid
.
mem
ls
.
ls_name
th
.
th_local
then
let
ls'
=
Hls
.
find
cl
.
ls_table
ls
in
let
ls'
=
Mls
.
find
ls
cl
.
ls_table
in
if
Sid
.
mem
ls'
.
ls_name
cl
.
id_local
then
add_ls
true
n
ls'
ns
else
ns
else
add_ls
true
n
ls
ns
in
let
f_pr
n
pr
ns
=
if
Sid
.
mem
pr
.
pr_name
th
.
th_local
then
let
pr'
=
Hpr
.
find
cl
.
pr_table
pr
in
let
pr'
=
Mpr
.
find
pr
cl
.
pr_table
in
if
Sid
.
mem
pr'
.
pr_name
cl
.
id_local
then
add_pr
true
n
pr'
ns
else
ns
else
add_pr
true
n
pr
ns
in
...
...
@@ -633,7 +627,8 @@ let clone_theory add_td acc th inst =
let
create_clone
=
clone_theory
(
fun
tdl
td
->
td
::
tdl
)
let
create_null_clone
th
=
mk_tdecl
(
Clone
(
th
,
Mid
.
empty
))
let
create_null_clone
th
=
mk_tdecl
(
Clone
(
th
,
Mts
.
empty
,
Mls
.
empty
,
Mpr
.
empty
))
(** Meta properties *)
...
...
@@ -649,15 +644,11 @@ let create_meta s al =
let
atl
=
try
Hashtbl
.
find
meta_table
s
with
Not_found
->
raise
(
UnknownMeta
s
)
in
let
get_meta_arg_real
at
a
=
match
at
,
a
with
|
MTtysymbol
,
MAts
ts
->
MARid
ts
.
ts_name
|
MTlsymbol
,
MAls
ls
->
MARid
ls
.
ls_name
|
MTprsymbol
,
MApr
pr
->
MARid
pr
.
pr_name
|
MTstring
,
MAstr
s
->
MARstr
s
|
MTint
,
MAint
i
->
MARint
i
|
_
,_
->
raise
(
MetaTypeMismatch
(
s
,
at
,
get_meta_arg_type
a
))
let
get_meta_arg
at
a
=
let
mt
=
get_meta_arg_type
a
in
if
at
=
mt
then
a
else
raise
(
MetaTypeMismatch
(
s
,
at
,
mt
))
in
let
al
=
try
List
.
map2
get_meta_arg
_real
atl
al
let
al
=
try
List
.
map2
get_meta_arg
atl
al
with
Invalid_argument
_
->
raise
(
BadMetaArity
(
s
,
List
.
length
atl
,
List
.
length
al
))
in
...
...
@@ -666,9 +657,16 @@ let create_meta s al =
let
add_meta
uc
s
al
=
add_tdecl
uc
(
create_meta
s
al
)
let
clone_meta
tdt
th
tdc
=
match
tdt
.
td_node
,
tdc
.
td_node
with
|
Meta
(
t
,
al
)
,
Clone
(
th'
,
cl
)
when
id_equal
th
.
th_name
th'
.
th_name
->
let
find_id
id
=
try
Mid
.
find
id
cl
with
Not_found
->
id
in
let
cl_marg
=
function
MARid
id
->
MARid
(
find_id
id
)
|
a
->
a
in
|
Meta
(
t
,
al
)
,
Clone
(
th'
,
tm
,
lm
,
pm
)
when
id_equal
th
.
th_name
th'
.
th_name
->
let
find_ts
ts
=
try
Mts
.
find
ts
tm
with
Not_found
->
ts
in
let
find_ls
ls
=
try
Mls
.
find
ls
lm
with
Not_found
->
ls
in
let
find_pr
pr
=
try
Mpr
.
find
pr
pm
with
Not_found
->
pr
in
let
cl_marg
=
function
|
MAts
ts
->
MAts
(
find_ts
ts
)
|
MAls
ls
->
MAls
(
find_ls
ls
)
|
MApr
pr
->
MApr
(
find_pr
pr
)
|
a
->
a
in
mk_tdecl
(
Meta
(
t
,
List
.
map
cl_marg
al
))
|
_
,_
->
invalid_arg
"clone_meta"
...
...
src/core/theory.mli
View file @
017deebd
...
...
@@ -54,11 +54,6 @@ type meta_arg =
|
MAstr
of
string
|
MAint
of
int
type
meta_arg_real
=
|
MARid
of
ident
|
MARstr
of
string
|
MARint
of
int
val
register_meta
:
string
->
meta_arg_type
list
->
string
val
register_meta_exc
:
string
->
meta_arg_type
list
->
string
...
...
@@ -86,8 +81,8 @@ and tdecl = private {
and
tdecl_node
=
private
|
Decl
of
decl
|
Use
of
theory
|
Clone
of
theory
*
ident
Mid
.
t
|
Meta
of
string
*
meta_arg
_real
list
|
Clone
of
theory
*
tysymbol
Mts
.
t
*
lsymbol
Mls
.
t
*
prsymbol
Mpr
.
t
|
Meta
of
string
*
meta_arg
list
module
Stdecl
:
Set
.
S
with
type
elt
=
tdecl
module
Mtdecl
:
Map
.
S
with
type
key
=
tdecl
...
...
src/driver/driver.ml
View file @
017deebd
...
...
@@ -224,9 +224,10 @@ let print_task ?(debug=false) drv fmt task =
Mid
.
fold
(
fun
_
(
th
,
s
)
task
->
let
cs
=
(
find_clone
task
th
)
.
tds_set
in
Stdecl
.
fold
(
fun
td
task
->
match
td
.
td_node
with
|
Clone
(
_
,
cl
)
when
Mid
.
is_empty
cl
->
|
Clone
(
_
,
tm
,
lm
,
pm
)
when
Mts
.
is_empty
tm
&&
Mls
.
is_empty
lm
&&
Mpr
.
is_empty
pm
->
Stdecl
.
fold
(
fun
td
task
->
add_tdecl
task
td
)
s
task
|
_
->
assert
false
(* impossible *)
|
_
->
task
)
cs
task
)
drv
.
drv_meta
task
in
...
...
src/printer/alt_ergo.ml
View file @
017deebd
...
...
@@ -53,7 +53,7 @@ let forget_var v = forget_id ident_printer v.vs_name
type
info
=
{
info_syn
:
syntax_map
;
info_rem
:
Sid
.
t
;
info_ac
:
S
id
.
t
;
info_ac
:
S
ls
.
t
;
}
let
rec
print_type
info
fmt
ty
=
match
ty
.
ty_node
with
...
...
@@ -167,7 +167,7 @@ let ac_th = ["algebra";"AC"]
let
print_logic_decl
info
fmt
(
ls
,
ld
)
=
match
ld
with
|
None
->
let
sac
=
if
S
id
.
mem
ls
.
ls_name
info
.
info_ac
then
"ac "
else
""
in
let
sac
=
if
S
ls
.
mem
ls
info
.
info_ac
then
"ac "
else
""
in
fprintf
fmt
"@[<hov 2>logic %s%a : %a%s%a@]@
\n
"
sac
print_ident
ls
.
ls_name
(
print_list
comma
(
print_type
info
))
ls
.
ls_args
...
...
@@ -220,7 +220,8 @@ let print_task pr thpr syn fmt task =
let
info
=
{
info_syn
=
syn
;
info_rem
=
get_remove_set
task
;
info_ac
=
Task
.
find_tagged
meta_ac
(
find_meta
task
meta_ac
)
Sid
.
empty
}
info_ac
=
Task
.
find_tagged_ls
meta_ac
(
find_meta
task
meta_ac
)
Sls
.
empty
}
in
let
decls
=
Task
.
task_decls
task
in
ignore
(
print_list_opt
(
add_flush
newline2
)
(
print_decl
info
)
fmt
decls
)
...
...