Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Why3
why3
Commits
89d56e7e
Commit
89d56e7e
authored
Aug 29, 2014
by
Andrei Paskevich
Browse files
Env: organize supported languages in a tree
parent
c37f6cd1
Changes
41
Hide whitespace changes
Inline
Side-by-side
examples/use_api/logic.ml
View file @
89d56e7e
...
...
@@ -122,7 +122,7 @@ An arithmetic goal: 2+2 = 4
let
two
:
Term
.
term
=
Term
.
t_const
(
Number
.
ConstInt
(
Number
.
int_const_dec
"2"
))
let
four
:
Term
.
term
=
Term
.
t_const
(
Number
.
ConstInt
(
Number
.
int_const_dec
"4"
))
let
int_theory
:
Theory
.
theory
=
Env
.
fin
d_theory
env
[
"int"
]
"Int"
Env
.
rea
d_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
.
fs_app
plus_symbol
[
two
;
two
]
Ty
.
ty_int
...
...
@@ -301,13 +301,10 @@ declaration of
*)
(* import the ref.Ref module *)
let
ref_modules
,
ref_theories
=
Env
.
read_lib_file
(
Mlw_main
.
library_of_env
env
)
[
"ref"
]
let
ref_module
:
Mlw_module
.
modul
=
Stdlib
.
Mstr
.
find
"Ref"
ref_modules
let
ref_module
:
Mlw_module
.
modul
=
Mlw_module
.
read_module
env
[
"ref"
]
"Ref"
let
ref_type
:
Mlw_ty
.
T
.
itysymbol
=
Mlw_module
.
ns_find_its
ref_module
.
Mlw_module
.
mod_export
[
"ref"
]
...
...
examples/use_api/mlw.ml
View file @
89d56e7e
...
...
@@ -31,7 +31,7 @@ let provers : Whyconf.config_prover Whyconf.Mprover.t =
let
env
:
Env
.
env
=
Env
.
create_env
(
Whyconf
.
loadpath
main
)
let
int_theory
:
Theory
.
theory
=
Env
.
fin
d_theory
env
[
"int"
]
"Int"
Env
.
rea
d_theory
env
[
"int"
]
"Int"
let
mul_int
:
Term
.
lsymbol
=
Theory
.
ns_find_ls
int_theory
.
Theory
.
th_export
[
"infix *"
]
...
...
@@ -96,10 +96,8 @@ declaration of
(* import the ref.Ref module *)
let
ref_modules
,
ref_theories
=
Env
.
read_lib_file
(
Mlw_main
.
library_of_env
env
)
[
"ref"
]
let
ref_module
:
Mlw_module
.
modul
=
Stdlib
.
Mstr
.
find
"Ref"
ref_modules
let
ref_module
:
Mlw_module
.
modul
=
Mlw_module
.
read_module
env
[
"ref"
]
"Ref"
let
ref_type
:
Mlw_ty
.
T
.
itysymbol
=
Mlw_module
.
ns_find_its
ref_module
.
Mlw_module
.
mod_export
[
"ref"
]
...
...
examples/use_api/mlw_tree.ml
View file @
89d56e7e
...
...
@@ -31,7 +31,7 @@ let provers : Whyconf.config_prover Whyconf.Mprover.t =
let
env
:
Env
.
env
=
Env
.
create_env
(
Whyconf
.
loadpath
main
)
let
int_theory
:
Theory
.
theory
=
Env
.
fin
d_theory
env
[
"int"
]
"Int"
Env
.
rea
d_theory
env
[
"int"
]
"Int"
let
mul_int
:
Term
.
lsymbol
=
Theory
.
ns_find_ls
int_theory
.
Theory
.
th_export
[
"infix *"
]
...
...
@@ -40,11 +40,9 @@ let unit_type = Ty.ty_tuple []
(* start a parsing *)
let
lib
=
Mlw_main
.
library_of_env
env
let
pathname
=
[]
(* dummy pathname *)
let
t
:
Ptree
.
incremental
=
Mlw_typing
.
open_file
lib
pathname
let
t
:
Ptree
.
incremental
=
Mlw_typing
.
open_file
env
pathname
open
Ptree
...
...
plugins/parser/dimacs.mll
View file @
89d56e7e
...
...
@@ -125,22 +125,17 @@ let parse th_uc filename cin =
let
th_uc
,
vars
=
init_vars
th_uc
nb_vars
in
file
th_uc
vars
0
lexbuf
)
lb
let
parse
_env
_path
filename
cin
=
let
th_uc
=
Theory
.
create_theory
(
Ident
.
id_fresh
"Cnf"
)
in
let
th_uc
=
parse
th_uc
filename
cin
in
let
pr
=
Decl
.
create_prsymbol
(
Ident
.
id_fresh
"false"
)
in
let
th_uc
=
Theory
.
add_prop_decl
th_uc
Decl
.
Pgoal
pr
Term
.
t_false
in
()
,
Mstr
.
singleton
"Cnf"
(
Theory
.
close_theory
th_uc
)
Mstr
.
singleton
"Cnf"
(
Theory
.
close_theory
th_uc
)
let
library_of_env
=
Env
.
register_format
"
D
imacs"
[
"cnf"
]
parse
let
()
=
Env
.
register_format
"
d
imacs"
[
"cnf"
]
Env
.
base_language
parse
~
desc
:
"@[<hov>Parser for dimacs format.@]"
}
(*
Local Variables:
compile-command: "unset LANG; make -C ../.."
...
...
plugins/parser/genequlin.ml
View file @
89d56e7e
...
...
@@ -61,7 +61,7 @@ let scanf s =
(** the main function *)
let
read_channel
env
path
filename
cin
=
(** Find the int theory and the needed operation *)
let
th_int
=
Env
.
fin
d_theory
(
Env
.
env_of_library
env
)
[
"int"
]
"Int"
in
let
th_int
=
Env
.
rea
d_theory
env
[
"int"
]
"Int"
in
let
leq
=
ns_find_ls
th_int
.
th_export
[
"infix <"
]
in
let
plus_symbol
=
Theory
.
ns_find_ls
th_int
.
Theory
.
th_export
[
"infix +"
]
in
let
neg_symbol
=
Theory
.
ns_find_ls
th_int
.
Theory
.
th_export
[
"prefix -"
]
in
...
...
@@ -123,9 +123,9 @@ let read_channel env path filename cin =
(** Read all the file *)
let
th_uc
=
Sysutil
.
fold_channel
fold
th_uc
cin
in
(** Return the map with the theory *)
()
,
Mstr
.
singleton
"EquLin"
(
close_theory
th_uc
)
Mstr
.
singleton
"EquLin"
(
close_theory
th_uc
)
let
library_of_env
=
Env
.
register_format
"
E
qu
L
in"
[
"equlin"
]
read_channel
let
()
=
Env
.
register_format
"
e
qu
l
in"
[
"equlin"
]
Env
.
base_language
read_channel
~
desc
:
"@[<hov>Generate@ random@ linear@ arithmetic@ problems.@ \
The@ first@ line@ gives@ the@ seed.@ Each@ other@ line@ \
describes@ a@ goal@ and@ contains@ three@ numbers:@]@
\n
\
...
...
plugins/tptp/tptp_lexer.mll
View file @
89d56e7e
...
...
@@ -246,9 +246,9 @@ and comment_line = parse
let lb = Lexing.from_channel c in
Loc.set_file file lb;
let ast = Loc.with_location (tptp_file token) lb in
(),
Tptp_typing.typecheck env path ast
Tptp_typing.typecheck env path ast
let
_library_of_env
= Env.register_format "
tptp
" ["
p
";"
ax
"] read_channel
let
()
= Env.register_format "
tptp
" ["
p
";"
ax
"]
Env.base_language
read_channel
~desc:"
TPTP
format
(
CNF
FOF
FOFX
TFF
)
"
}
...
...
plugins/tptp/tptp_typing.ml
View file @
89d56e7e
...
...
@@ -82,9 +82,8 @@ type denv = {
ts_rat
:
tysymbol
;
}
let
make_denv
lib
=
let
env
=
Env
.
env_of_library
lib
in
let
get_theory
=
Env
.
read_theory
~
format
:
"why"
env
[
"tptp"
]
in
let
make_denv
env
=
let
get_theory
s
=
Env
.
read_theory
env
[
"tptp"
]
s
in
let
th_univ
=
get_theory
"Univ"
in
let
th_ghost
=
get_theory
"Ghost"
in
let
th_rat
=
get_theory
"Rat"
in
...
...
@@ -125,7 +124,7 @@ let defined_arith ~loc denv env impl dw tl =
|
{
t_ty
=
Some
{
ty_node
=
Tyapp
(
ts
,
[]
)
}}
::_
->
ts
|
_
::_
->
error
~
loc
NonNumeric
|
[]
->
error
~
loc
BadArity
in
let
get_theory
=
Env
.
read_theory
~
format
:
"why"
denv
.
de_env
[
"tptp"
]
in
let
get_theory
s
=
Env
.
read_theory
denv
.
de_env
[
"tptp"
]
s
in
let
get_int_theory
=
function
|
DF
DFquot
->
errorm
~
loc
"$quotient/2 is not defined on $int"
|
DF
(
DFquot_e
|
DFrem_e
)
->
get_theory
"IntDivE"
...
...
@@ -667,4 +666,3 @@ let typecheck lib path ast =
|
[]
->
add_prop_decl
uc
Pgoal
pr_false
t_false
in
Mstr
.
singleton
"T"
(
close_theory
uc
)
plugins/tptp/tptp_typing.mli
View file @
89d56e7e
...
...
@@ -9,6 +9,6 @@
(* *)
(********************************************************************)
val
typecheck
:
unit
Why3
.
Env
.
library
->
Why3
.
Env
.
pathname
->
val
typecheck
:
Why3
.
Env
.
env
->
Why3
.
Env
.
pathname
->
Tptp_ast
.
tptp_file
->
Why3
.
Theory
.
theory
Why3
.
Stdlib
.
Mstr
.
t
src/coq-tactic/why3tac.ml
View file @
89d56e7e
...
...
@@ -303,9 +303,9 @@ let print_dep fmt =
(* the task under construction *)
let
task
=
ref
None
let
th_int
=
lazy
(
Env
.
fin
d_theory
env
[
"int"
]
"Int"
)
let
th_eucl
=
lazy
(
Env
.
fin
d_theory
env
[
"int"
]
"EuclideanDivision"
)
let
th_real
=
lazy
(
Env
.
fin
d_theory
env
[
"real"
]
"Real"
)
let
th_int
=
lazy
(
Env
.
rea
d_theory
env
[
"int"
]
"Int"
)
let
th_eucl
=
lazy
(
Env
.
rea
d_theory
env
[
"int"
]
"EuclideanDivision"
)
let
th_real
=
lazy
(
Env
.
rea
d_theory
env
[
"real"
]
"Real"
)
let
why_constant_int
dep
s
=
task
:=
Task
.
use_export
!
task
(
Lazy
.
force
th_int
);
...
...
src/core/env.ml
View file @
89d56e7e
...
...
@@ -10,8 +10,6 @@
(********************************************************************)
open
Stdlib
open
Ident
open
Theory
(** Library environment *)
...
...
@@ -22,10 +20,13 @@ type pathname = string list (* library path *)
exception
KnownFormat
of
fformat
exception
UnknownFormat
of
fformat
exception
UnknownExtension
of
extension
exception
InvalidFormat
of
fformat
exception
UnspecifiedFormat
exception
LibFileNotFound
of
pathname
exception
KnownExtension
of
extension
*
fformat
exception
UnknownExtension
of
extension
exception
LibraryNotFound
of
pathname
exception
TheoryNotFound
of
pathname
*
string
exception
AmbiguousPath
of
filename
*
filename
...
...
@@ -47,16 +48,80 @@ let create_env = let c = ref (-1) in fun lp -> {
let
get_loadpath
env
=
Sstr
.
elements
env
.
env_path
let
read_format_table
=
Hstr
.
create
17
(* format name -> read_format *)
let
extensions_table
=
Hstr
.
create
17
(* suffix -> format name *)
(** Input languages *)
type
'
a
format_parser
=
env
->
pathname
->
filename
->
in_channel
->
'
a
module
Hpath
=
Hashtbl
.
Make
(
struct
type
t
=
pathname
let
hash
=
Hashtbl
.
hash
let
equal
=
(
=
)
end
)
type
'
a
language
=
{
memo
:
'
a
Hpath
.
t
;
push
:
pathname
->
'
a
->
unit
;
mutable
fmts
:
(
fformat
*
extension
list
*
Pp
.
formatted
)
list
;
}
let
base_language
=
{
memo
=
Hpath
.
create
17
;
push
=
(
fun
_
_
->
()
);
fmts
=
[]
;
}
exception
LibraryConflict
of
pathname
let
store
lang
path
c
=
lang
.
push
path
c
;
Hpath
.
add
lang
.
memo
path
c
let
store
lang
path
c
=
if
path
=
[]
then
store
lang
path
c
else
try
let
d
=
Hpath
.
find
lang
.
memo
path
in
if
c
!=
d
then
raise
(
LibraryConflict
path
)
with
Not_found
->
store
lang
path
c
let
retrieve_file
lang
ff
path
=
try
Hpath
.
find
lang
.
memo
path
with
Not_found
->
raise
(
InvalidFormat
ff
)
let
retrieve_lib
lang
path
=
try
Hpath
.
find
lang
.
memo
path
with
Not_found
->
raise
(
LibraryNotFound
path
)
let
register_language
parent
convert
=
{
memo
=
Hpath
.
create
17
;
push
=
(
fun
path
c
->
store
parent
path
(
convert
c
));
fmts
=
[]
;
}
let
extension_table
=
ref
Mstr
.
empty
let
format_table
=
ref
Mstr
.
empty
let
builtin_list
=
ref
[]
let
lookup_format
name
=
try
Hstr
.
find
read_format_table
name
with
Not_found
->
raise
(
UnknownFormat
name
)
let
register_format
~
desc
ff
extl
lang
fp
=
let
fp
env
path
fn
ch
=
store
lang
path
(
fp
env
path
fn
ch
)
in
format_table
:=
Mstr
.
add_new
(
KnownFormat
ff
)
ff
fp
!
format_table
;
let
add_ext
m
e
=
Mstr
.
change
(
function
|
Some
ff
->
raise
(
KnownExtension
(
e
,
ff
))
|
None
->
Some
ff
)
e
m
in
extension_table
:=
List
.
fold_left
add_ext
!
extension_table
extl
;
lang
.
fmts
<-
(
ff
,
extl
,
desc
)
::
lang
.
fmts
let
list_formats
()
=
let
add
n
(
_
,_,
l
,
desc
)
acc
=
(
n
,
l
,
desc
)
::
acc
in
Hstr
.
fold
add
read_format_table
[]
let
list_formats
lang
=
List
.
rev
lang
.
fmts
(* older to newer *)
let
add_builtin
lang
bp
=
let
bp
path
=
store
lang
(
"why3"
::
path
)
(
bp
path
)
in
builtin_list
:=
bp
::
!
builtin_list
let
read_builtin
lang
path
=
let
read
bp
=
try
bp
path
with
Not_found
->
()
in
List
.
iter
read
!
builtin_list
;
retrieve_lib
lang
(
"why3"
::
path
)
(** Input file parsing *)
let
get_extension
file
=
let
s
=
try
Filename
.
chop_extension
file
...
...
@@ -66,131 +131,117 @@ let get_extension file =
let
get_format
file
=
let
ext
=
get_extension
file
in
try
Hstr
.
find
extensions_table
ext
with
Not_found
->
raise
(
UnknownExtension
ext
)
let
read_channel
?
format
env
file
ic
=
let
name
=
match
format
with
|
Some
name
->
name
|
None
->
get_format
file
in
let
rc
,_,_,_
=
lookup_format
name
in
rc
env
file
ic
let
read_file
?
format
env
file
=
let
ic
=
open_in
file
in
try
let
mth
=
read_channel
?
format
env
file
ic
in
close_in
ic
;
mth
with
e
->
close_in
ic
;
raise
e
Mstr
.
find_exn
(
UnknownExtension
ext
)
ext
!
extension_table
let
read_theory
~
format
env
p
ath
th
=
let
_
,
rl
,_,_
=
lookup_format
format
in
rl
env
path
th
let
get_format
?
format
file
=
m
at
c
h
format
wi
th
|
Some
ff
->
ff
|
None
->
get_format
file
let
find_theory
=
read_theory
~
format
:
"why"
let
get_parser
ff
=
Mstr
.
find_exn
(
UnknownFormat
ff
)
ff
!
format_table
(** Navigation in the library *)
let
read_channel
?
format
lang
env
file
ch
=
let
ff
=
get_format
?
format
file
in
let
fp
=
get_parser
ff
in
fp
env
[]
file
ch
;
retrieve_file
lang
ff
[]
let
read_file_raw
?
format
lang
env
path
file
=
let
ff
=
get_format
?
format
file
in
let
fp
=
get_parser
ff
in
let
ch
=
open_in
file
in
begin
try
fp
env
path
file
ch
;
close_in
ch
with
exn
->
close_in
ch
;
raise
exn
;
end
;
retrieve_file
lang
ff
path
exception
InvalidQualifier
of
string
let
read_file
?
format
lang
env
file
=
read_file_raw
?
format
lang
env
[]
file
let
check_qualifier
s
=
if
(
s
=
Filename
.
parent_dir_name
||
s
=
Filename
.
current_dir_name
||
Filename
.
basename
s
<>
s
)
then
raise
(
InvalidQualifier
s
)
(** Navigation in the library *)
let
locate_lib_file
env
path
exts
=
if
path
=
[]
||
path
=
[
"why3"
]
then
raise
(
LibFileNotFound
path
);
let
locate_library
env
path
=
if
path
=
[]
||
path
=
[
"why3"
]
then
invalid_arg
"Env.locate_library"
;
let
check_qualifier
s
=
if
(
s
=
Filename
.
parent_dir_name
||
s
=
Filename
.
current_dir_name
||
Filename
.
basename
s
<>
s
)
then
invalid_arg
"Env.locate_library"
in
List
.
iter
check_qualifier
path
;
let
file
=
List
.
fold_left
Filename
.
concat
""
path
in
let
add_ext
ext
=
file
^
"."
^
ext
in
let
fl
=
if
exts
=
[]
then
[
file
]
else
List
.
map
add_ext
exts
in
let
fl
=
List
.
map
add_ext
(
Mstr
.
keys
!
extension_table
)
in
if
fl
=
[]
then
failwith
"Env.locate_library (no formats)"
;
let
add_dir
dir
=
List
.
map
(
Filename
.
concat
dir
)
fl
in
let
fl
=
List
.
concat
(
List
.
map
add_dir
(
get_loadpath
env
))
in
if
fl
=
[]
then
failwith
"Env.locate_library (empty loadpath)"
;
match
List
.
filter
Sys
.
file_exists
fl
with
|
[]
->
raise
(
Lib
File
NotFound
path
)
|
[]
->
raise
(
Lib
rary
NotFound
path
)
|
[
file
]
->
file
|
file1
::
file2
::
_
->
raise
(
AmbiguousPath
(
file1
,
file2
))
(** Input formats *)
exception
CircularDependency
of
pathname
type
'
a
contents
=
'
a
*
theory
Mstr
.
t
module
Hpath
=
Hashtbl
.
Make
(
struct
type
t
=
pathname
let
hash
=
Hashtbl
.
hash
let
equal
=
(
=
)
end
)
type
'
a
library
=
{
lib_env
:
env
;
lib_read
:
'
a
read_format
;
lib_exts
:
extension
list
;
lib_memo
:
(
'
a
contents
option
)
Hpath
.
t
;
}
and
'
a
read_format
=
'
a
library
->
pathname
->
filename
->
in_channel
->
'
a
contents
let
mk_library
read
exts
env
=
{
lib_env
=
env
;
lib_read
=
read
;
lib_exts
=
exts
;
lib_memo
=
Hpath
.
create
17
;
}
let
read_library
lang
env
path
=
let
file
=
locate_library
env
path
in
read_file_raw
lang
env
path
file
let
env_of_library
lib
=
lib
.
lib_env
let
libstack
=
Hpath
.
create
17
let
read_lib_file
lib
path
=
let
file
=
locate_lib_file
lib
.
lib_env
path
lib
.
lib_exts
in
let
ic
=
open_in
file
in
let
read_library
lang
env
path
=
if
Hpath
.
mem
libstack
path
then
raise
(
CircularDependency
path
);
Hpath
.
add
libstack
path
()
;
try
Hpath
.
replace
lib
.
lib_memo
path
None
;
let
res
=
lib
.
lib_read
lib
path
file
ic
in
Hpath
.
replace
lib
.
lib_memo
path
(
Some
res
);
close_in
ic
;
res
let
c
=
read_library
lang
env
path
in
Hpath
.
remove
libstack
path
;
c
with
e
->
Hpath
.
remove
lib
.
lib_memo
path
;
close_in
ic
;
Hpath
.
remove
libstack
path
;
raise
e
let
read_lib_file
lib
path
=
try
match
Hpath
.
find
lib
.
lib_memo
path
with
|
Some
res
->
res
|
None
->
raise
(
CircularDependency
path
)
with
Not_found
->
read_lib_file
lib
path
let
get_builtin
s
=
if
s
=
builtin_theory
.
th_name
.
id_string
then
builtin_theory
else
if
s
=
bool_theory
.
th_name
.
id_string
then
bool_theory
else
if
s
=
unit_theory
.
th_name
.
id_string
then
unit_theory
else
if
s
=
highord_theory
.
th_name
.
id_string
then
highord_theory
else
match
tuple_theory_name
s
with
|
Some
n
->
tuple_theory
n
|
None
->
raise
(
TheoryNotFound
([]
,
s
))
let
read_lib_theory
lib
path
th
=
if
path
=
[]
||
path
=
[
"why3"
]
then
get_builtin
th
else
let
_
,
mth
=
read_lib_file
lib
path
in
try
Mstr
.
find
th
mth
with
Not_found
->
raise
(
TheoryNotFound
(
path
,
th
))
let
register_format
~
(
desc
:
Pp
.
formatted
)
name
exts
read
=
if
Hstr
.
mem
read_format_table
name
then
raise
(
KnownFormat
name
);
let
getlib
=
Wenv
.
memoize
5
(
mk_library
read
exts
)
in
let
rc
env
file
ic
=
snd
(
read
(
getlib
env
)
[]
file
ic
)
in
let
rl
env
path
th
=
read_lib_theory
(
getlib
env
)
path
th
in
Hstr
.
add
read_format_table
name
(
rc
,
rl
,
exts
,
desc
);
List
.
iter
(
fun
s
->
Hstr
.
replace
extensions_table
s
name
)
exts
;
getlib
let
locate_lib_file
env
format
path
=
let
_
,_,
exts
,_
=
lookup_format
format
in
locate_lib_file
env
path
exts
let
read_library
lang
env
=
function
|
"why3"
::
path
->
read_builtin
lang
path
|
path
->
read_library
lang
env
path
let
read_library
lang
env
path
=
let
path
=
if
path
=
[]
then
[
"why3"
]
else
path
in
try
Hpath
.
find
lang
.
memo
path
with
Not_found
->
if
Hpath
.
mem
base_language
.
memo
path
then
begin
match
path
with
(* loaded for another format *)
|
"why3"
::
_
->
raise
(
LibraryNotFound
path
)
|
_
->
let
file
=
locate_library
env
path
in
raise
(
InvalidFormat
(
get_format
file
))
end
else
read_library
lang
env
path
let
read_theory
env
path
s
=
let
path
=
if
path
=
[]
then
[
"why3"
;
s
]
else
path
in
let
mt
=
read_library
base_language
env
path
in
Mstr
.
find_exn
(
TheoryNotFound
(
path
,
s
))
s
mt
(* Builtin theories *)
open
Ident
open
Theory
let
base_builtin
path
=
let
builtin
s
=
if
s
=
builtin_theory
.
th_name
.
id_string
then
builtin_theory
else
if
s
=
highord_theory
.
th_name
.
id_string
then
highord_theory
else
if
s
=
bool_theory
.
th_name
.
id_string
then
bool_theory
else
if
s
=
unit_theory
.
th_name
.
id_string
then
unit_theory
else
match
tuple_theory_name
s
with
|
Some
n
->
tuple_theory
n
|
None
->
raise
Not_found
in
match
path
with
|
[
s
]
->
Mstr
.
singleton
s
(
builtin
s
)
|
_
->
raise
Not_found
let
()
=
add_builtin
base_language
base_builtin
(* Exception reporting *)
...
...
@@ -199,24 +250,27 @@ let print_path fmt sl =
let
()
=
Exn_printer
.
register
begin
fun
fmt
exn
->
match
exn
with
|
CircularDependency
sl
->
Format
.
fprintf
fmt
"Circular dependency in %a"
print_path
sl
|
LibFileNotFound
sl
->
Format
.
fprintf
fmt
"Library file not found: %a"
print_path
sl
|
TheoryNotFound
(
sl
,
s
)
->
Format
.
fprintf
fmt
"Theory not found: %a"
print_path
(
sl
@
[
s
])
|
KnownFormat
s
->
Format
.
fprintf
fmt
"Format %s is already registered"
s
|
UnknownFormat
s
->
Format
.
fprintf
fmt
"Unknown input format: %s"
s
|
UnknownExtension
s
->
Format
.
fprintf
fmt
"Unknown file extension: `%s'"
s
|
UnspecifiedFormat
->
Format
.
fprintf
fmt
"Format not specified"
|
AmbiguousPath
(
f1
,
f2
)
->
Format
.
fprintf
fmt
"Ambiguous path:@ both `%s'@ and `%s'@ match"
f1
f2
|
InvalidQualifier
s
->
Format
.
fprintf
fmt
"Invalid qualifier `%s'"
s
|
CircularDependency
sl
->
Format
.
fprintf
fmt
"Circular dependency in %a"
print_path
sl
|
LibraryNotFound
sl
->
Format
.
fprintf
fmt
"Library file not found: %a"
print_path
sl
|
TheoryNotFound
(
sl
,
s
)
->
Format
.
fprintf
fmt
"Theory %s not found in library %a"
s
print_path
sl
|
KnownFormat
s
->
Format
.
fprintf
fmt
"Format %s is already registered"
s
|
UnknownFormat
s
->
Format
.
fprintf
fmt
"Unknown input format: %s"
s
|
UnknownExtension
s
->
Format
.
fprintf
fmt
"Unknown file extension: `%s'"
s
|
KnownExtension
(
s
,
f
)
->
Format
.
fprintf
fmt
"File extension `%s' is already registered for input format %s"
s
f
|
UnspecifiedFormat
->
Format
.
fprintf
fmt
"Format not specified"
|
AmbiguousPath
(
f1
,
f2
)
->
Format
.
fprintf
fmt
"Ambiguous path:@ both %s@ and %s@ match"
f1
f2
|
InvalidFormat
f
->
Format
.
fprintf
fmt
"Input format %s is unsuitable for the desired content"
f
|
LibraryConflict
sl
->
Format
.
fprintf
fmt
"Conflicting definitions for library %a"
print_path
sl
|
_
->
raise
exn
end
src/core/env.mli
View file @
89d56e7e
...
...
@@ -10,22 +10,14 @@
(********************************************************************)
open
Stdlib
open
Theory
(** Local type aliases
and exceptions
*)
(** Local type aliases *)
type
fformat
=
string
(* format name *)
type
filename
=
string
(* file name *)
type
extension
=
string
(* file extension *)
type
pathname
=
string
list
(* library path *)
exception
KnownFormat
of
fformat
exception
UnknownFormat
of
fformat
exception
UnknownExtension
of
extension
exception
UnspecifiedFormat
exception
LibFileNotFound
of
pathname
exception
TheoryNotFound
of
pathname
*
string
(** Library environment *)
type
env
...
...
@@ -41,93 +33,138 @@ val create_env : filename list -> env
val
get_loadpath
:
env
->
filename
list
(** returns the loadpath of a given environment *)
val
read_channel
:
?
format
:
fformat
->
env
->
filename
->
in_channel
->
theory
Mstr
.
t
(** [read_channel ?format env path file ch] returns the theories in [ch].
When given, [format] enforces the format, otherwise we choose
the format according to [file]'s extension. Nothing ensures
that [ch] corresponds to the contents of [file].
(** Input languages *)
type
'
a
language
val
base_language
:
Theory
.
theory
Mstr
.
t
language
(** [base_language] is the root of the tree of supported languages.
Any input language must be translatable into pure theories for
the purposes of verification. *)
val
register_language
:
'
a
language
->
(
'
b
->
'
a
)
->
'
b
language
(** [register_language parent convert] adds a leaf to the language tree.
The [convert] function provides translation from the new language to
[parent]. *)
val
add_builtin
:
'
a
language
->
(
pathname
->
'
a
)
->
unit