Skip to content
GitLab
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
7d681280
Commit
7d681280
authored
Feb 21, 2012
by
Jean-Christophe Filliâtre
Browse files
simplified typing of use/clone declarations
parent
2f34052b
Changes
15
Hide whitespace changes
Inline
Side-by-side
Makefile.in
View file @
7d681280
...
@@ -390,12 +390,12 @@ $(PGMCMO) $(PGMCMX): INCLUDES += -I src/programs
...
@@ -390,12 +390,12 @@ $(PGMCMO) $(PGMCMX): INCLUDES += -I src/programs
byte
:
bin/why3ml.byte
byte
:
bin/why3ml.byte
opt
:
bin/why3ml.opt
opt
:
bin/why3ml.opt
bin/why3ml.opt
:
src/why3.cmxa $(PGMCMX) src/main.cmx
bin/why3ml.opt
:
src/why3.cmxa $(PGMCMX)
$(MLWCMX)
src/main.cmx
$(
if
$(QUIET)
, @echo
'Linking $@'
&&
)
\
$(
if
$(QUIET)
, @echo
'Linking $@'
&&
)
\
$(OCAMLOPT)
$(OFLAGS)
-o
$@
$(EXTCMXA)
$^
$(OCAMLOPT)
$(OFLAGS)
-o
$@
$(EXTCMXA)
$^
$(STRIP)
$@
$(STRIP)
$@
bin/why3ml.byte
:
src/why3.cma $(PGMCMO) src/main.cmo
bin/why3ml.byte
:
src/why3.cma $(PGMCMO)
$(MLWCMO)
src/main.cmo
$(
if
$(QUIET)
,@echo
'Linking $@'
&&
)
\
$(
if
$(QUIET)
,@echo
'Linking $@'
&&
)
\
$(OCAMLC)
$(BFLAGS)
-o
$@
$(EXTCMA)
$^
$(OCAMLC)
$(BFLAGS)
-o
$@
$(EXTCMA)
$^
...
@@ -573,12 +573,12 @@ bin/why3ide.opt bin/why3ide.byte: INCLUDES += -I @LABLGTK2LIB@
...
@@ -573,12 +573,12 @@ bin/why3ide.opt bin/why3ide.byte: INCLUDES += -I @LABLGTK2LIB@
bin/why3ide.opt bin/why3ide.byte
:
EXTOBJS +=
bin/why3ide.opt bin/why3ide.byte
:
EXTOBJS +=
bin/why3ide.opt bin/why3ide.byte
:
EXTLIBS += lablgtk lablgtksourceview2
bin/why3ide.opt bin/why3ide.byte
:
EXTLIBS += lablgtk lablgtksourceview2
bin/why3ide.opt
:
src/why3.cmxa $(PGMCMX) $(IDECMX)
bin/why3ide.opt
:
src/why3.cmxa $(PGMCMX)
$(MLWCMX)
$(IDECMX)
$(
if
$(QUIET)
, @echo
'Linking $@'
&&
)
\
$(
if
$(QUIET)
, @echo
'Linking $@'
&&
)
\
$(OCAMLOPT)
$(OFLAGS)
-o
$@
$(EXTCMXA)
$^
$(OCAMLOPT)
$(OFLAGS)
-o
$@
$(EXTCMXA)
$^
$(STRIP)
$@
$(STRIP)
$@
bin/why3ide.byte
:
src/why3.cma $(PGMCMO) $(IDECMO)
bin/why3ide.byte
:
src/why3.cma $(PGMCMO)
$(MLWCMO)
$(IDECMO)
$(
if
$(QUIET)
,@echo
'Linking $@'
&&
)
\
$(
if
$(QUIET)
,@echo
'Linking $@'
&&
)
\
$(OCAMLC)
$(BFLAGS)
-o
$@
$(EXTCMA)
$^
$(OCAMLC)
$(BFLAGS)
-o
$@
$(EXTCMA)
$^
...
...
src/core/env.ml
View file @
7d681280
...
@@ -179,8 +179,6 @@ let read_lib_theory lib path th =
...
@@ -179,8 +179,6 @@ let read_lib_theory lib path th =
try
Mstr
.
find
th
mth
with
Not_found
->
try
Mstr
.
find
th
mth
with
Not_found
->
raise
(
TheoryNotFound
(
path
,
th
))
raise
(
TheoryNotFound
(
path
,
th
))
let
read_lib_file
lib
path
=
fst
(
read_lib_file
lib
path
)
let
register_format
name
exts
read
=
let
register_format
name
exts
read
=
if
Hashtbl
.
mem
read_format_table
name
then
raise
(
KnownFormat
name
);
if
Hashtbl
.
mem
read_format_table
name
then
raise
(
KnownFormat
name
);
let
getlib
=
Wenv
.
memoize
5
(
mk_library
read
exts
)
in
let
getlib
=
Wenv
.
memoize
5
(
mk_library
read
exts
)
in
...
...
src/core/env.mli
View file @
7d681280
...
@@ -114,7 +114,7 @@ val env_of_library : 'a library -> env
...
@@ -114,7 +114,7 @@ val env_of_library : 'a library -> env
val
list_formats
:
unit
->
(
fformat
*
extension
list
)
list
val
list_formats
:
unit
->
(
fformat
*
extension
list
)
list
(** [list_formats ()] returns the list of registered formats *)
(** [list_formats ()] returns the list of registered formats *)
val
read_lib_file
:
'
a
library
->
pathname
->
'
a
val
read_lib_file
:
'
a
library
->
pathname
->
'
a
*
theory
Mstr
.
t
(** [read_lib_file lib path] retrieves the contents of a library file
(** [read_lib_file lib path] retrieves the contents of a library file
@raise LibFileNotFound [path] if the library file was not found *)
@raise LibFileNotFound [path] if the library file was not found *)
...
...
src/core/theory.ml
View file @
7d681280
...
@@ -663,7 +663,6 @@ let is_empty_sm sm =
...
@@ -663,7 +663,6 @@ let is_empty_sm sm =
Mls
.
is_empty
sm
.
sm_ls
&&
Mls
.
is_empty
sm
.
sm_ls
&&
Mpr
.
is_empty
sm
.
sm_pr
Mpr
.
is_empty
sm
.
sm_pr
(** Meta properties *)
(** Meta properties *)
let
get_meta_arg_type
=
function
let
get_meta_arg_type
=
function
...
...
src/core/theory.mli
View file @
7d681280
...
@@ -124,6 +124,7 @@ val close_theory : theory_uc -> theory
...
@@ -124,6 +124,7 @@ val close_theory : theory_uc -> theory
val
open_namespace
:
theory_uc
->
theory_uc
val
open_namespace
:
theory_uc
->
theory_uc
val
close_namespace
:
theory_uc
->
bool
->
string
option
->
theory_uc
val
close_namespace
:
theory_uc
->
bool
->
string
option
->
theory_uc
(* the Boolean indicates [import]; the string option indicates [as T] *)
val
get_namespace
:
theory_uc
->
namespace
val
get_namespace
:
theory_uc
->
namespace
val
get_known
:
theory_uc
->
known_map
val
get_known
:
theory_uc
->
known_map
...
...
src/parser/parser.mly
View file @
7d681280
...
@@ -62,6 +62,7 @@ module Incremental = struct
...
@@ -62,6 +62,7 @@ module Incremental = struct
let
new_use_clone
d
=
let
new_use_clone
d
=
let
env
=
ref_get
env_ref
in
let
lenv
=
ref_get
lenv_ref
in
let
env
=
ref_get
env_ref
in
let
lenv
=
ref_get
lenv_ref
in
ref_set
uc_ref
(
Typing
.
add_use_clone
env
lenv
(
ref_get
uc_ref
)
d
)
ref_set
uc_ref
(
Typing
.
add_use_clone
env
lenv
(
ref_get
uc_ref
)
d
)
end
end
open
Ptree
open
Ptree
...
@@ -184,6 +185,9 @@ end
...
@@ -184,6 +185,9 @@ end
|
Term
.
IConstBinary
s
->
int_of_string
(
"0b"
^
s
)
|
Term
.
IConstBinary
s
->
int_of_string
(
"0b"
^
s
)
with
Failure
_
->
raise
Parsing
.
Parse_error
with
Failure
_
->
raise
Parsing
.
Parse_error
let
qualid_last
=
function
|
Qident
x
|
Qdot
(
_
,
x
)
->
x
.
id
%
}
%
}
/*
Tokens
*/
/*
Tokens
*/
...
@@ -316,7 +320,7 @@ namespace_import:
...
@@ -316,7 +320,7 @@ namespace_import:
;
;
namespace_name
:
namespace_name
:
|
uident
{
Some
$
1
}
|
uident
{
Some
$
1
.
id
}
|
UNDERSCORE
{
None
}
|
UNDERSCORE
{
None
}
;
;
...
@@ -354,17 +358,17 @@ use_clone:
...
@@ -354,17 +358,17 @@ use_clone:
use
:
use
:
|
imp_exp
tqualid
|
imp_exp
tqualid
{
{
use_theory
=
$
2
;
use_as
=
None
;
use_imp_exp
=
$
1
}
}
{
{
use_theory
=
$
2
;
use_as
=
Some
(
qualid_last
$
2
)
;
use_imp_exp
=
$
1
}
}
|
imp_exp
tqualid
AS
uident
|
imp_exp
tqualid
AS
uident
{
{
use_theory
=
$
2
;
use_as
=
Some
(
Some
$
4
)
;
use_imp_exp
=
$
1
}
}
{
{
use_theory
=
$
2
;
use_as
=
Some
$
4
.
id
;
use_imp_exp
=
$
1
}
}
|
imp_exp
tqualid
AS
UNDERSCORE
|
imp_exp
tqualid
AS
UNDERSCORE
{
{
use_theory
=
$
2
;
use_as
=
Some
None
;
use_imp_exp
=
$
1
}
}
{
{
use_theory
=
$
2
;
use_as
=
None
;
use_imp_exp
=
$
1
}
}
;
;
imp_exp
:
imp_exp
:
|
IMPORT
{
Import
}
|
IMPORT
{
Some
true
}
|
EXPORT
{
Export
}
|
EXPORT
{
None
}
|
/*
epsilon
*/
{
Nothing
}
|
/*
epsilon
*/
{
Some
false
}
;
;
clone_subst
:
clone_subst
:
...
@@ -378,13 +382,13 @@ list1_comma_subst:
...
@@ -378,13 +382,13 @@ list1_comma_subst:
;
;
subst
:
subst
:
|
NAMESPACE
ns
EQUAL
ns
{
CSns
(
$
2
,
$
4
)
}
|
NAMESPACE
ns
EQUAL
ns
{
CSns
(
floc
()
,
$
2
,
$
4
)
}
|
TYPE
qualid
EQUAL
qualid
{
CStsym
(
$
2
,
$
4
)
}
|
TYPE
qualid
EQUAL
qualid
{
CStsym
(
floc
()
,
$
2
,
$
4
)
}
|
CONSTANT
qualid
EQUAL
qualid
{
CSfsym
(
$
2
,
$
4
)
}
|
CONSTANT
qualid
EQUAL
qualid
{
CSfsym
(
floc
()
,
$
2
,
$
4
)
}
|
FUNCTION
qualid
EQUAL
qualid
{
CSfsym
(
$
2
,
$
4
)
}
|
FUNCTION
qualid
EQUAL
qualid
{
CSfsym
(
floc
()
,
$
2
,
$
4
)
}
|
PREDICATE
qualid
EQUAL
qualid
{
CSpsym
(
$
2
,
$
4
)
}
|
PREDICATE
qualid
EQUAL
qualid
{
CSpsym
(
floc
()
,
$
2
,
$
4
)
}
|
LEMMA
qualid
{
CSlemma
$
2
}
|
LEMMA
qualid
{
CSlemma
(
floc
()
,
$
2
)
}
|
GOAL
qualid
{
CSgoal
$
2
}
|
GOAL
qualid
{
CSgoal
(
floc
()
,
$
2
)
}
;
;
ns
:
ns
:
...
@@ -1062,9 +1066,9 @@ opt_semicolon:
...
@@ -1062,9 +1066,9 @@ opt_semicolon:
use_module
:
use_module
:
|
imp_exp
MODULE
tqualid
|
imp_exp
MODULE
tqualid
{
Duse
(
$
3
,
$
1
,
None
)
}
{
Duse
(
$
3
,
$
1
,
Some
(
qualid_last
$
3
)
)
}
|
imp_exp
MODULE
tqualid
AS
uident
|
imp_exp
MODULE
tqualid
AS
uident
{
Duse
(
$
3
,
$
1
,
Some
$
5
)
}
{
Duse
(
$
3
,
$
1
,
Some
$
5
.
id
)
}
;
;
list1_recfun_sep_and
:
list1_recfun_sep_and
:
...
...
src/parser/ptree.ml
View file @
7d681280
...
@@ -94,22 +94,21 @@ type plogic_type =
...
@@ -94,22 +94,21 @@ type plogic_type =
|
PPredicate
of
pty
list
|
PPredicate
of
pty
list
|
PFunction
of
pty
list
*
pty
|
PFunction
of
pty
list
*
pty
type
imp_exp
=
|
Import
|
Export
|
Nothing
type
use
=
{
type
use
=
{
use_theory
:
qualid
;
use_theory
:
qualid
;
use_as
:
ident
option
option
;
use_as
:
string
option
;
use_imp_exp
:
imp_exp
;
(* None = as _, Some id = as id *)
use_imp_exp
:
bool
option
;
(* None = export, Some false = default, Some true = import *)
}
}
type
clone_subst
=
type
clone_subst
=
|
CSns
of
qualid
option
*
qualid
option
|
CSns
of
loc
*
qualid
option
*
qualid
option
|
CStsym
of
qualid
*
qualid
|
CStsym
of
loc
*
qualid
*
qualid
|
CSfsym
of
qualid
*
qualid
|
CSfsym
of
loc
*
qualid
*
qualid
|
CSpsym
of
qualid
*
qualid
|
CSpsym
of
loc
*
qualid
*
qualid
|
CSlemma
of
qualid
|
CSlemma
of
loc
*
qualid
|
CSgoal
of
qualid
|
CSgoal
of
loc
*
qualid
type
is_mutable
=
bool
type
is_mutable
=
bool
...
@@ -246,8 +245,8 @@ type program_decl =
...
@@ -246,8 +245,8 @@ type program_decl =
|
Dparam
of
ident
*
type_v
|
Dparam
of
ident
*
type_v
|
Dexn
of
ident
*
pty
option
|
Dexn
of
ident
*
pty
option
(* modules *)
(* modules *)
|
Duse
of
qualid
*
imp_exp
*
(*as:*)
ident
option
|
Duse
of
qualid
*
bool
option
*
(*as:*)
string
option
|
Dnamespace
of
loc
*
ident
option
*
(* import: *)
bool
*
program_decl
list
|
Dnamespace
of
loc
*
string
option
*
(* import: *)
bool
*
program_decl
list
type
theory
=
{
type
theory
=
{
pth_name
:
ident
;
pth_name
:
ident
;
...
...
src/parser/typing.ml
View file @
7d681280
...
@@ -31,7 +31,6 @@ open Denv
...
@@ -31,7 +31,6 @@ open Denv
(** errors *)
(** errors *)
exception
Message
of
string
exception
DuplicateTypeVar
of
string
exception
DuplicateTypeVar
of
string
exception
TypeArity
of
qualid
*
int
*
int
exception
TypeArity
of
qualid
*
int
*
int
exception
Clash
of
string
exception
Clash
of
string
...
@@ -47,28 +46,15 @@ exception UnboundTypeVar of string
...
@@ -47,28 +46,15 @@ exception UnboundTypeVar of string
exception
UnboundType
of
string
list
exception
UnboundType
of
string
list
exception
UnboundSymbol
of
string
list
exception
UnboundSymbol
of
string
list
let
error
?
loc
e
=
match
loc
with
let
error
=
Loc
.
error
|
None
->
raise
e
|
Some
loc
->
raise
(
Loc
.
Located
(
loc
,
e
))
let
errorm
=
Loc
.
errorm
let
errorm
?
loc
f
=
let
buf
=
Buffer
.
create
512
in
let
fmt
=
Format
.
formatter_of_buffer
buf
in
Format
.
kfprintf
(
fun
_
->
Format
.
pp_print_flush
fmt
()
;
let
s
=
Buffer
.
contents
buf
in
Buffer
.
clear
buf
;
error
?
loc
(
Message
s
))
fmt
f
let
rec
print_qualid
fmt
=
function
let
rec
print_qualid
fmt
=
function
|
Qident
s
->
fprintf
fmt
"%s"
s
.
id
|
Qident
s
->
fprintf
fmt
"%s"
s
.
id
|
Qdot
(
m
,
s
)
->
fprintf
fmt
"%a.%s"
print_qualid
m
s
.
id
|
Qdot
(
m
,
s
)
->
fprintf
fmt
"%a.%s"
print_qualid
m
s
.
id
let
()
=
Exn_printer
.
register
(
fun
fmt
e
->
match
e
with
let
()
=
Exn_printer
.
register
(
fun
fmt
e
->
match
e
with
|
Message
s
->
fprintf
fmt
"%s"
s
|
DuplicateTypeVar
s
->
|
DuplicateTypeVar
s
->
fprintf
fmt
"duplicate type parameter %s"
s
fprintf
fmt
"duplicate type parameter %s"
s
|
TypeArity
(
id
,
a
,
n
)
->
|
TypeArity
(
id
,
a
,
n
)
->
...
@@ -1135,6 +1121,44 @@ let add_decl th = function
...
@@ -1135,6 +1121,44 @@ let add_decl th = function
let
add_decl
th
d
=
let
add_decl
th
d
=
if
Debug
.
test_flag
debug_parse_only
then
th
else
add_decl
th
d
if
Debug
.
test_flag
debug_parse_only
then
th
else
add_decl
th
d
let
type_inst
th
t
s
=
let
add_inst
s
=
function
|
CSns
(
loc
,
p
,
q
)
->
let
find
ns
x
=
find_namespace_ns
x
ns
in
let
ns1
=
option_fold
find
t
.
th_export
p
in
let
ns2
=
option_fold
find
(
get_namespace
th
)
q
in
clone_ns
loc
t
.
th_local
ns2
ns1
s
|
CStsym
(
loc
,
p
,
q
)
->
let
ts1
=
find_tysymbol_ns
p
t
.
th_export
in
let
ts2
=
find_tysymbol
q
th
in
if
Mts
.
mem
ts1
s
.
inst_ts
then
error
~
loc
(
Clash
ts1
.
ts_name
.
id_string
);
{
s
with
inst_ts
=
Mts
.
add
ts1
ts2
s
.
inst_ts
}
|
CSfsym
(
loc
,
p
,
q
)
->
let
ls1
=
find_fsymbol_ns
p
t
.
th_export
in
let
ls2
=
find_fsymbol
q
th
in
if
Mls
.
mem
ls1
s
.
inst_ls
then
error
~
loc
(
Clash
ls1
.
ls_name
.
id_string
);
{
s
with
inst_ls
=
Mls
.
add
ls1
ls2
s
.
inst_ls
}
|
CSpsym
(
loc
,
p
,
q
)
->
let
ls1
=
find_psymbol_ns
p
t
.
th_export
in
let
ls2
=
find_psymbol
q
th
in
if
Mls
.
mem
ls1
s
.
inst_ls
then
error
~
loc
(
Clash
ls1
.
ls_name
.
id_string
);
{
s
with
inst_ls
=
Mls
.
add
ls1
ls2
s
.
inst_ls
}
|
CSlemma
(
loc
,
p
)
->
let
pr
=
find_prop_ns
p
t
.
th_export
in
if
Spr
.
mem
pr
s
.
inst_lemma
||
Spr
.
mem
pr
s
.
inst_goal
then
error
~
loc
(
Clash
pr
.
pr_name
.
id_string
);
{
s
with
inst_lemma
=
Spr
.
add
pr
s
.
inst_lemma
}
|
CSgoal
(
loc
,
p
)
->
let
pr
=
find_prop_ns
p
t
.
th_export
in
if
Spr
.
mem
pr
s
.
inst_lemma
||
Spr
.
mem
pr
s
.
inst_goal
then
error
~
loc
(
Clash
pr
.
pr_name
.
id_string
);
{
s
with
inst_goal
=
Spr
.
add
pr
s
.
inst_goal
}
in
List
.
fold_left
add_inst
empty_inst
s
let
add_use_clone
env
lenv
th
(
loc
,
use
,
subst
)
=
let
add_use_clone
env
lenv
th
(
loc
,
use
,
subst
)
=
if
Debug
.
test_flag
debug_parse_only
then
th
else
if
Debug
.
test_flag
debug_parse_only
then
th
else
let
q
,
id
=
split_qualid
use
.
use_theory
in
let
q
,
id
=
split_qualid
use
.
use_theory
in
...
@@ -1145,65 +1169,17 @@ let add_use_clone env lenv th (loc, use, subst) =
...
@@ -1145,65 +1169,17 @@ let add_use_clone env lenv th (loc, use, subst) =
|
TheoryNotFound
_
->
error
~
loc
(
UnboundTheory
use
.
use_theory
)
|
TheoryNotFound
_
->
error
~
loc
(
UnboundTheory
use
.
use_theory
)
in
in
let
use_or_clone
th
=
match
subst
with
let
use_or_clone
th
=
match
subst
with
|
None
->
|
None
->
use_export
th
t
use_export
th
t
|
Some
s
->
clone_export
th
t
(
type_inst
th
t
s
)
|
Some
s
->
let
add_inst
s
=
function
|
CSns
(
p
,
q
)
->
let
find
ns
x
=
find_namespace_ns
x
ns
in
let
ns1
=
option_fold
find
t
.
th_export
p
in
let
ns2
=
option_fold
find
(
get_namespace
th
)
q
in
clone_ns
loc
t
.
th_local
ns2
ns1
s
|
CStsym
(
p
,
q
)
->
let
ts1
=
find_tysymbol_ns
p
t
.
th_export
in
let
ts2
=
find_tysymbol
q
th
in
if
Mts
.
mem
ts1
s
.
inst_ts
then
error
~
loc
(
Clash
ts1
.
ts_name
.
id_string
);
{
s
with
inst_ts
=
Mts
.
add
ts1
ts2
s
.
inst_ts
}
|
CSfsym
(
p
,
q
)
->
let
ls1
=
find_fsymbol_ns
p
t
.
th_export
in
let
ls2
=
find_fsymbol
q
th
in
if
Mls
.
mem
ls1
s
.
inst_ls
then
error
~
loc
(
Clash
ls1
.
ls_name
.
id_string
);
{
s
with
inst_ls
=
Mls
.
add
ls1
ls2
s
.
inst_ls
}
|
CSpsym
(
p
,
q
)
->
let
ls1
=
find_psymbol_ns
p
t
.
th_export
in
let
ls2
=
find_psymbol
q
th
in
if
Mls
.
mem
ls1
s
.
inst_ls
then
error
~
loc
(
Clash
ls1
.
ls_name
.
id_string
);
{
s
with
inst_ls
=
Mls
.
add
ls1
ls2
s
.
inst_ls
}
|
CSlemma
p
->
let
pr
=
find_prop_ns
p
t
.
th_export
in
if
Spr
.
mem
pr
s
.
inst_lemma
||
Spr
.
mem
pr
s
.
inst_goal
then
error
~
loc
(
Clash
pr
.
pr_name
.
id_string
);
{
s
with
inst_lemma
=
Spr
.
add
pr
s
.
inst_lemma
}
|
CSgoal
p
->
let
pr
=
find_prop_ns
p
t
.
th_export
in
if
Spr
.
mem
pr
s
.
inst_lemma
||
Spr
.
mem
pr
s
.
inst_goal
then
error
~
loc
(
Clash
pr
.
pr_name
.
id_string
);
{
s
with
inst_goal
=
Spr
.
add
pr
s
.
inst_goal
}
in
let
s
=
List
.
fold_left
add_inst
empty_inst
s
in
clone_export
th
t
s
in
let
n
=
match
use
.
use_as
with
|
None
->
Some
t
.
th_name
.
id_string
|
Some
(
Some
x
)
->
Some
x
.
id
|
Some
None
->
None
in
in
begin
try
match
use
.
use_imp_exp
with
begin
try
match
use
.
use_imp_exp
with
|
Nothing
->
|
Some
imp
->
(* use T = namespace T use_export T end *)
(* use T = namespace T use_export T end *)
let
th
=
open_namespace
th
in
let
th
=
open_namespace
th
in
let
th
=
use_or_clone
th
in
let
th
=
use_or_clone
th
in
close_namespace
th
false
n
close_namespace
th
imp
use
.
use_as
|
Import
->
|
None
->
(* use import T = namespace T use_export T end import T *)
use_or_clone
th
let
th
=
open_namespace
th
in
let
th
=
use_or_clone
th
in
close_namespace
th
true
n
|
Export
->
use_or_clone
th
with
ClashSymbol
s
->
error
~
loc
(
Clash
s
)
with
ClashSymbol
s
->
error
~
loc
(
Clash
s
)
end
end
...
@@ -1214,13 +1190,12 @@ let close_theory loc lenv th =
...
@@ -1214,13 +1190,12 @@ let close_theory loc lenv th =
if
Mstr
.
mem
id
lenv
then
error
~
loc
(
ClashTheory
id
);
if
Mstr
.
mem
id
lenv
then
error
~
loc
(
ClashTheory
id
);
Mstr
.
add
id
th
lenv
Mstr
.
add
id
th
lenv
let
close_namespace
loc
import
name
th
=
let
close_namespace
loc
import
id
th
=
let
id
=
option_map
(
fun
id
->
id
.
id
)
name
in
try
close_namespace
th
import
id
try
close_namespace
th
import
id
with
ClashSymbol
s
->
error
~
loc
(
Clash
s
)
with
ClashSymbol
s
->
error
~
loc
(
Clash
s
)
(*
(*
Local Variables:
Local Variables:
compile-command: "unset LANG; make -C ../..
test
"
compile-command: "unset LANG; make -C ../.."
End:
End:
*)
*)
src/parser/typing.mli
View file @
7d681280
...
@@ -35,7 +35,7 @@ val add_use_clone :
...
@@ -35,7 +35,7 @@ val add_use_clone :
unit
Env
.
library
->
theory
Mstr
.
t
->
theory_uc
->
Ptree
.
use_clone
->
theory_uc
unit
Env
.
library
->
theory
Mstr
.
t
->
theory_uc
->
Ptree
.
use_clone
->
theory_uc
val
close_namespace
:
val
close_namespace
:
Loc
.
position
->
bool
->
P
tr
ee
.
ident
option
->
theory_uc
->
theory_uc
Loc
.
position
->
bool
->
s
tr
ing
option
->
theory_uc
->
theory_uc
val
close_theory
:
Loc
.
position
->
theory
Mstr
.
t
->
theory_uc
->
theory
Mstr
.
t
val
close_theory
:
Loc
.
position
->
theory
Mstr
.
t
->
theory_uc
->
theory
Mstr
.
t
...
@@ -95,3 +95,4 @@ val list_fields: theory_uc ->
...
@@ -95,3 +95,4 @@ val list_fields: theory_uc ->
(** check that the given fields all belong to the same record type
(** check that the given fields all belong to the same record type
and do not appear several times *)
and do not appear several times *)
val
type_inst
:
theory_uc
->
theory
->
Ptree
.
clone_subst
list
->
th_inst
src/programs/pgm_typing.ml
View file @
7d681280
...
@@ -2262,7 +2262,7 @@ let find_module penv lmod q id = match q with
...
@@ -2262,7 +2262,7 @@ let find_module penv lmod q id = match q with
Mstr
.
find
id
lmod
Mstr
.
find
id
lmod
|
_
::
_
->
|
_
::
_
->
(* module in file f *)
(* module in file f *)
Mstr
.
find
id
(
Env
.
read_lib_file
penv
q
)
Mstr
.
find
id
(
fst
(
Env
.
read_lib_file
penv
q
)
)
(* env = to retrieve theories and modules from the loadpath
(* env = to retrieve theories and modules from the loadpath
lmod = local modules *)
lmod = local modules *)
...
@@ -2346,22 +2346,13 @@ let rec decl ~wp env ltm lmod uc = function
...
@@ -2346,22 +2346,13 @@ let rec decl ~wp env ltm lmod uc = function
with
Not_found
->
with
Not_found
->
errorm
~
loc
"@[unbound module %a@]"
print_qualid
qid
errorm
~
loc
"@[unbound module %a@]"
print_qualid
qid
in
in
let
n
=
match
use_as
with
|
None
->
Some
(
m
.
m_name
.
id_string
)
|
Some
x
->
Some
x
.
id
in
begin
try
match
imp_exp
with
begin
try
match
imp_exp
with
|
Nothing
->
|
Some
imp
->
(* use T = namespace T use_export T end *)
(* use T = namespace T use_export T end *)
let
uc
=
open_namespace
uc
in
let
uc
=
open_namespace
uc
in
let
uc
=
use_export
uc
m
in
let
uc
=
use_export
uc
m
in
close_namespace
uc
false
n
close_namespace
uc
imp
use_as
|
Import
->
|
None
->
(* use import T = namespace T use_export T end import T *)
let
uc
=
open_namespace
uc
in
let
uc
=
use_export
uc
m
in
close_namespace
uc
true
n
|
Export
->
use_export
uc
m
use_export
uc
m
with
ClashSymbol
s
->
with
ClashSymbol
s
->
errorm
~
loc
"clash with previous symbol %s"
s
errorm
~
loc
"clash with previous symbol %s"
s
...
@@ -2369,7 +2360,6 @@ let rec decl ~wp env ltm lmod uc = function
...
@@ -2369,7 +2360,6 @@ let rec decl ~wp env ltm lmod uc = function
|
Ptree
.
Dnamespace
(
loc
,
id
,
import
,
dl
)
->
|
Ptree
.
Dnamespace
(
loc
,
id
,
import
,
dl
)
->
let
uc
=
open_namespace
uc
in
let
uc
=
open_namespace
uc
in
let
uc
=
List
.
fold_left
(
decl
~
wp
env
ltm
lmod
)
uc
dl
in
let
uc
=
List
.
fold_left
(
decl
~
wp
env
ltm
lmod
)
uc
dl
in
let
id
=
option_map
(
fun
id
->
id
.
id
)
id
in
begin
try
close_namespace
uc
import
id
begin
try
close_namespace
uc
import
id
with
ClashSymbol
s
->
errorm
~
loc
"clash with previous symbol %s"
s
end
with
ClashSymbol
s
->
errorm
~
loc
"clash with previous symbol %s"
s
end
|
Ptree
.
Dlogic
(
TypeDecl
d
)
->
|
Ptree
.
Dlogic
(
TypeDecl
d
)
->
...
...
src/util/exn_printer.mli
View file @
7d681280
...
@@ -26,5 +26,5 @@ val register : exn_printer -> unit
...
@@ -26,5 +26,5 @@ val register : exn_printer -> unit
(* Register a formatter of exception *)
(* Register a formatter of exception *)
val
exn_printer
:
exn_printer
val
exn_printer
:
exn_printer
(* exn_printer fmt exn
:
print
the
exception using all
the
previously
(*
[
exn_printer fmt exn
]
print
s
exception
[exn]
using all previously
registered printer and return *)
registered printer
s
and return
s
*)
src/util/loc.ml
View file @
7d681280
...
@@ -54,8 +54,6 @@ let user_position fname lnum cnum1 cnum2 = (fname,lnum,cnum1,cnum2)
...
@@ -54,8 +54,6 @@ let user_position fname lnum cnum1 cnum2 = (fname,lnum,cnum1,cnum2)
let
get
loc
=
loc
let
get
loc
=
loc
exception
Located
of
position
*
exn
let
dummy_position
=
(
""
,
0
,
0
,
0
)
let
dummy_position
=
(
""
,
0
,
0
,
0
)
let
join
(
f1
,
l1
,
b1
,
e1
)
(
f2
,_,
b2
,
e2
)
=
let
join
(
f1
,
l1
,
b1
,
e1
)
(
f2
,_,
b2
,
e2
)
=
...
@@ -77,9 +75,44 @@ let gen_report_position fmt (f,l,b,e) =
...
@@ -77,9 +75,44 @@ let gen_report_position fmt (f,l,b,e) =
let
report_position
fmt
=
fprintf
fmt
"%a:@
\n
"
gen_report_position
let
report_position
fmt
=
fprintf
fmt
"%a:@
\n
"
gen_report_position
(* located exceptions *)
exception
Located
of
position
*
exn
let
try1
loc
f
x
=
try
f
x
with
Located
_
as
e
->
raise
e
|
e
->
raise
(
Located
(
loc
,
e
))
let
try2
loc
f
x
y
=
try
f
x
y
with
Located
_
as
e
->
raise
e
|
e
->
raise
(
Located
(
loc
,
e
))
let
try3
loc
f
x
y
z
=
try
f
x
y
z
with
Located
_
as
e
->
raise
e
|
e
->
raise
(
Located
(
loc
,
e
))
let
try4
loc
f
x
y
z
t
=
try
f
x
y
z
t
with
Located
_
as
e
->
raise
e
|
e
->
raise
(
Located
(
loc
,
e
))
let
error
?