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
9b255042
Commit
9b255042
authored
Jun 24, 2015
by
Andrei Paskevich
Browse files
Parser: merge "why" and "whyml" formats, move to Mlw
parent
a3109482
Changes
13
Hide whitespace changes
Inline
Side-by-side
Makefile.in
View file @
9b255042
...
...
@@ -154,7 +154,7 @@ LIB_DRIVER = call_provers driver_ast driver_parser driver_lexer driver \
LIB_MLW
=
ity
expr
dexpr pdecl pmodule
LIB_PARSER
=
ptree glob
parser typing
lexer
LIB_PARSER
=
ptree glob
typing parser
lexer
LIB_TRANSFORM
=
simplify_formula inlining split_goal induction
\
detect_polymorphism
\
...
...
@@ -173,10 +173,6 @@ LIB_TRANSFORM = simplify_formula inlining split_goal induction \
LIB_PRINTER
=
alt_ergo why3printer smtv1 smtv2 coq pvs isabelle
\
simplify gappa cvc3 yices mathematica
LIB_WHYML
=
mlw_ty mlw_expr mlw_decl mlw_pretty mlw_wp mlw_module
\
mlw_dexpr mlw_typing mlw_driver mlw_exec mlw_ocaml
\
mlw_main mlw_interp
LIB_SESSION
=
compress xml termcode session session_tools strategy
\
strategy_parser session_scheduler
...
...
@@ -187,10 +183,9 @@ LIBMODULES = $(addprefix src/util/, $(LIB_UTIL)) \
$(
addprefix
src/parser/,
$(LIB_PARSER)
)
\
$(
addprefix
src/transform/,
$(LIB_TRANSFORM)
)
\
$(
addprefix
src/printer/,
$(LIB_PRINTER)
)
\
$(
addprefix
src/whyml/,
$(LIB_WHYML)
)
\
$(
addprefix
src/session/,
$(LIB_SESSION)
)
LIBDIRS
=
util core driver mlw parser transform printer
whyml
session
LIBDIRS
=
util core driver mlw parser transform printer session
LIBINCLUDES
=
$(
addprefix
-I
src/,
$(LIBDIRS)
)
LIBDEP
=
$(
addsuffix
.dep,
$(LIBMODULES)
)
...
...
@@ -453,7 +448,10 @@ install_no_local::
TOOLSGENERATED
=
src/tools/why3wc.ml
TOOLS_BIN
=
why3config why3execute why3extract why3prove
\
# TODO
#TOOLS_BIN = why3config why3execute why3extract why3prove \
# why3realize why3replay why3wc
TOOLS_BIN
=
why3config why3prove
\
why3realize why3replay why3wc
TOOLS_FILES
=
main
$(TOOLS_BIN)
...
...
@@ -1384,8 +1382,9 @@ $(WHY3DOCDEP): $(WHY3DOCGENERATED)
# build targets
byte
:
bin/why3doc.byte
opt
:
bin/why3doc.opt
# TODO
#byte: bin/why3doc.byte
#opt: bin/why3doc.opt
bin/why3doc.opt
:
lib/why3/why3.cmxa $(WHY3DOCCMX)
$(
if
$(QUIET)
,@echo
'Linking $@'
&&
)
\
...
...
@@ -1412,7 +1411,8 @@ clean_old_install::
install_no_local
::
cp
-f
bin/why3doc.@OCAMLBEST@
$(TOOLDIR)
/why3doc
$(EXE)
install_local
::
bin/why3doc
# TODO
#install_local:: bin/why3doc
########
# bench
...
...
@@ -1602,8 +1602,6 @@ MODULESTODOC = \
core/env core/task
\
driver/whyconf driver/driver
\
session/session session/session_tools session/session_scheduler
\
whyml/mlw_ty whyml/mlw_expr whyml/mlw_decl whyml/mlw_module
\
whyml/mlw_main
# transform/introduction
\
# ide/db
...
...
src/mlw/dexpr.ml
View file @
9b255042
...
...
@@ -795,6 +795,8 @@ let check_spec dsp ecty e =
if
check_rwd
&&
bad_write
eeff
ueff
then
Loc
.
errorm
?
loc
:
(
e_locate_effect
(
fun
eff
->
bad_write
eff
ueff
)
e
)
"this@ expression@ produces@ an@ unlisted@ write@ effect"
;
(* TODO FIXME : revise the requirements for explicit "raises".
Should we only require them at the top level? *)
if
ecty
.
cty_args
<>
[]
&&
bad_raise
eeff
ueff
then
Sexn
.
iter
(
fun
xs
->
Loc
.
errorm
?
loc
:
(
e_locate_effect
(
fun
eff
->
Sexn
.
mem
xs
eff
.
eff_raises
)
e
)
"this@ expression@ raises@ unlisted@ exception@ %a"
...
...
src/mlw/pdecl.ml
View file @
9b255042
...
...
@@ -368,3 +368,7 @@ let known_add_decl kn0 d =
let
unk
=
Mid
.
set_diff
d
.
pd_syms
kn
in
if
Sid
.
is_empty
unk
then
kn
else
raise
(
Decl
.
UnknownIdent
(
Sid
.
choose
unk
))
(** {2 Pretty-printing} *)
let
print_pdecl
_fmt
_d
=
assert
false
(* TODO *)
src/mlw/pdecl.mli
View file @
9b255042
...
...
@@ -82,3 +82,7 @@ type known_map = pdecl Mid.t
val
known_id
:
known_map
->
ident
->
unit
val
known_add_decl
:
known_map
->
pdecl
->
known_map
val
merge_known
:
known_map
->
known_map
->
known_map
(** {2 Pretty-printing *)
val
print_pdecl
:
Format
.
formatter
->
pdecl
->
unit
src/mlw/pmodule.ml
View file @
9b255042
...
...
@@ -297,10 +297,11 @@ let add_pdecl_with_tuples _uc _md = assert false (*TODO*)
(** {2 WhyML language} *)
type
mlw_file
=
pmodule
Mstr
.
t
*
theory
Mstr
.
t
type
mlw_file
=
pmodule
Mstr
.
t
let
mlw_language
=
(
Env
.
register_language
Env
.
base_language
snd
:
mlw_file
Env
.
language
)
let
conv
mm
=
Mstr
.
map
(
fun
m
->
m
.
mod_theory
)
mm
in
(
Env
.
register_language
Env
.
base_language
conv
:
mlw_file
Env
.
language
)
(* TODO
let () = Env.add_builtin mlw_language (function
...
...
@@ -314,7 +315,7 @@ exception ModuleNotFound of Env.pathname * string
let
read_module
env
path
s
=
let
path
=
if
path
=
[]
then
[
"why3"
;
s
]
else
path
in
let
mm
,
_
=
Env
.
read_library
mlw_language
env
path
in
let
mm
=
Env
.
read_library
mlw_language
env
path
in
Mstr
.
find_exn
(
ModuleNotFound
(
path
,
s
))
s
mm
let
print_path
fmt
sl
=
...
...
src/mlw/pmodule.mli
View file @
9b255042
...
...
@@ -120,7 +120,7 @@ val add_pdecl_with_tuples : pmodule_uc -> pdecl -> pmodule_uc
open
Env
type
mlw_file
=
pmodule
Mstr
.
t
*
theory
Mstr
.
t
type
mlw_file
=
pmodule
Mstr
.
t
val
mlw_language
:
mlw_file
language
...
...
src/parser/lexer.mli
View file @
9b255042
...
...
@@ -8,5 +8,3 @@
(* on linking described in file LICENSE. *)
(* *)
(********************************************************************)
val
parse_program_file
:
Ptree
.
incremental
->
Lexing
.
lexbuf
->
unit
src/parser/lexer.mll
View file @
9b255042
...
...
@@ -75,7 +75,6 @@
"ghost"
,
GHOST
;
"invariant"
,
INVARIANT
;
"loop"
,
LOOP
;
"model"
,
MODEL
;
"module"
,
MODULE
;
"mutable"
,
MUTABLE
;
"private"
,
PRIVATE
;
...
...
@@ -157,8 +156,6 @@ rule token = parse
{
LEFTPAR_STAR_RIGHTPAR
}
|
"(*"
{
Lexlib
.
comment
lexbuf
;
token
lexbuf
}
|
"~'"
(
lident
as
id
)
{
OPAQUE_QUOTE_LIDENT
id
}
|
"'"
(
lident
as
id
)
{
QUOTE_LIDENT
id
}
|
"'"
(
uident
as
id
)
...
...
@@ -225,27 +222,38 @@ rule token = parse
{
raise
(
IllegalCharacter
c
)
}
{
let
parse_logic_file
env
path
lb
=
open_file
token
(
Lexing
.
from_string
""
)
(
Typing
.
open_file
env
path
);
Loc
.
with_location
(
logic_file
token
)
lb
;
Typing
.
close_file
()
let
debug
=
Debug
.
register_info_flag
"print_modules"
~
desc
:
"Print@ program@ modules@ after@ typechecking."
let
parse_program_file
inc
lb
=
open_file
token
(
Lexing
.
from_string
""
)
inc
;
Loc
.
with_location
(
program_file
token
)
lb
open
Stdlib
open
Ident
open
Theory
open
Pmodule
let
read_channel
env
path
file
c
=
let
lb
=
Lexing
.
from_channel
c
in
Loc
.
set_file
file
lb
;
parse_logic_file
env
path
lb
Typing
.
open_file
~
pure
:
false
env
path
;
let
mm
=
Loc
.
with_location
(
mlw_file
token
)
lb
in
if
path
=
[]
&&
Debug
.
test_flag
debug
then
begin
let
add_m
_
m
mm
=
Mid
.
add
m
.
mod_theory
.
th_name
m
mm
in
let
mm
=
Mstr
.
fold
add_m
mm
Mid
.
empty
in
let
print_m
_
m
=
Format
.
eprintf
"@[<hov 2>module %a@
\n
%a@]@
\n
end@
\n
@."
Pretty
.
print_th
m
.
mod_theory
(
Pp
.
print_list
Pp
.
newline2
Pdecl
.
print_pdecl
)
m
.
mod_decls
in
Mid
.
iter
print_m
mm
end
;
mm
let
()
=
Env
.
register_format
Env
.
base_language
"why"
[
"why"
]
read_channel
~
desc
:
"WhyML@ logical@ language"
}
let
()
=
Env
.
register_format
mlw_language
"whyml"
[
"mlw"
]
read_channel
~
desc
:
"WhyML@ programming@ and@ specification@ language"
(*
Local Variables:
compile-command: "unset LANG; make -C ../.. test"
End:
*)
let
read_channel
env
path
file
c
=
let
lb
=
Lexing
.
from_channel
c
in
Loc
.
set_file
file
lb
;
Typing
.
open_file
~
pure
:
true
env
path
;
Loc
.
with_location
(
mlw_file
token
)
lb
let
()
=
Env
.
register_format
mlw_language
"whyml_spec"
[
"why"
]
read_channel
~
desc
:
"WhyML@ specification@ sublanguage"
}
src/parser/parser.mly
View file @
9b255042
...
...
@@ -10,21 +10,6 @@
(********************************************************************)
%
{
module
Incremental
=
struct
let
stack
=
Stack
.
create
()
let
open_file
inc
=
Stack
.
push
inc
stack
let
close_file
()
=
ignore
(
Stack
.
pop
stack
)
let
open_theory
id
=
(
Stack
.
top
stack
)
.
Ptree
.
open_theory
id
let
close_theory
()
=
(
Stack
.
top
stack
)
.
Ptree
.
close_theory
()
let
open_module
id
=
(
Stack
.
top
stack
)
.
Ptree
.
open_module
id
let
close_module
()
=
(
Stack
.
top
stack
)
.
Ptree
.
close_module
()
let
open_namespace
n
=
(
Stack
.
top
stack
)
.
Ptree
.
open_namespace
n
let
close_namespace
l
b
=
(
Stack
.
top
stack
)
.
Ptree
.
close_namespace
l
b
let
new_decl
loc
d
=
(
Stack
.
top
stack
)
.
Ptree
.
new_decl
loc
d
let
new_pdecl
loc
d
=
(
Stack
.
top
stack
)
.
Ptree
.
new_pdecl
loc
d
let
use_clone
loc
use
=
(
Stack
.
top
stack
)
.
Ptree
.
use_clone
loc
use
end
open
Ptree
let
infix
s
=
"infix "
^
s
...
...
@@ -111,7 +96,7 @@ end
%
token
<
Ptree
.
real_constant
>
FLOAT
%
token
<
string
>
STRING
%
token
<
Loc
.
position
>
POSITION
%
token
<
string
>
QUOTE_UIDENT
QUOTE_LIDENT
OPAQUE_QUOTE_LIDENT
%
token
<
string
>
QUOTE_UIDENT
QUOTE_LIDENT
(* keywords *)
...
...
@@ -125,7 +110,7 @@ end
%
token
ABSTRACT
ABSURD
ANY
ASSERT
ASSUME
BEGIN
CHECK
%
token
DIVERGES
DO
DONE
DOWNTO
ENSURES
EXCEPTION
FOR
%
token
FUN
GHOST
INVARIANT
LOOP
MODEL
MODULE
MUTABLE
%
token
FUN
GHOST
INVARIANT
LOOP
MODULE
MUTABLE
%
token
PRIVATE
RAISE
RAISES
READS
REC
REQUIRES
RETURNS
%
token
TO
TRY
VAL
VARIANT
WHILE
WRITES
...
...
@@ -173,51 +158,33 @@ end
(* Entry points *)
%
start
<
Ptree
.
incremental
->
unit
>
open_file
%
start
<
unit
>
logic_file
program_file
%
start
<
Pmodule
.
pmodule
Stdlib
.
Mstr
.
t
>
mlw_file
%%
(* Theories, modules, namespaces *)
open_file
:
(* Dummy token. Menhir does not accept epsilon. *)
|
EOF
{
Incremental
.
open_file
}
logic_file
:
|
theory
*
EOF
{
Incremental
.
close_file
()
}
program_file
:
|
theory_or_module
*
EOF
{
Incremental
.
close_file
()
}
theory
:
|
theory_head
theory_decl
*
END
{
Incremental
.
close_theory
()
}
mlw_file
:
|
theory_or_module
*
EOF
{
Typing
.
close_file
()
}
(* TODO
| module_decl* EOF { Typing.close_file () }
*)
theory_or_module
:
|
theory
{
()
}
|
module_head
module_decl
*
END
{
Incremental
.
close_module
()
}
theory_head
:
|
THEORY
labels
(
uident
)
{
Incremental
.
open_theory
$
2
}
|
module_head
module_decl
*
END
{
Typing
.
close_module
(
floc
$
startpos
(
$
3
)
$
endpos
(
$
3
))
}
module_head
:
|
MODULE
labels
(
uident
)
{
Incremental
.
open_module
$
2
}
theory_decl
:
|
decl
{
Incremental
.
new_decl
(
floc
$
startpos
$
endpos
)
$
1
}
|
use_clone
{
Incremental
.
use_clone
(
floc
$
startpos
$
endpos
)
$
1
}
|
namespace_head
theory_decl
*
END
{
Incremental
.
close_namespace
(
floc
$
startpos
(
$
1
)
$
endpos
(
$
1
))
$
1
}
|
THEORY
labels
(
uident
)
{
Typing
.
open_module
$
2
~
theory
:
true
}
|
MODULE
labels
(
uident
)
{
Typing
.
open_module
$
2
~
theory
:
false
}
module_decl
:
|
decl
{
Incremental
.
new_decl
(
floc
$
startpos
$
endpos
)
$
1
}
|
pdecl
{
Incremental
.
new_pdecl
(
floc
$
startpos
$
endpos
)
$
1
}
|
use_clone
{
Incremental
.
use_clone
(
floc
$
startpos
$
endpos
)
$
1
}
|
decl
{
Typing
.
add_decl
(
floc
$
startpos
$
endpos
)
$
1
}
|
use_clone
{
Typing
.
use_clone
(
floc
$
startpos
$
endpos
)
$
1
}
|
namespace_head
module_decl
*
END
{
Incremental
.
close_namespace
(
floc
$
startpos
(
$
1
)
$
endpos
(
$
1
))
$
1
}
{
Typing
.
close_namespace
(
floc
$
startpos
(
$
1
)
$
endpos
(
$
1
))
~
import
:
$
1
}
namespace_head
:
|
NAMESPACE
boption
(
IMPORT
)
uident
{
Incremental
.
open_namespace
$
3
.
id_str
;
$
2
}
|
NAMESPACE
boption
(
IMPORT
)
uident
{
Typing
.
open_namespace
$
3
;
$
2
}
(* Use and clone *)
...
...
@@ -252,7 +219,6 @@ ns:
decl
:
|
TYPE
with_list1
(
type_decl
)
{
Dtype
$
2
}
|
TYPE
late_invariant
{
Dtype
[
$
2
]
}
|
CONSTANT
constant_decl
{
Dlogic
[
$
2
]
}
|
FUNCTION
function_decl
with_logic_decl
*
{
Dlogic
(
$
2
::$
3
)
}
|
PREDICATE
predicate_decl
with_logic_decl
*
{
Dlogic
(
$
2
::$
3
)
}
...
...
@@ -262,6 +228,7 @@ decl:
|
LEMMA
labels
(
ident
)
COLON
term
{
Dprop
(
Decl
.
Plemma
,
$
2
,
$
4
)
}
|
GOAL
labels
(
ident
)
COLON
term
{
Dprop
(
Decl
.
Pgoal
,
$
2
,
$
4
)
}
|
META
sident
comma_list1
(
meta_arg
)
{
Dmeta
(
$
2
,
$
3
)
}
|
pdecl
{
$
1
}
meta_arg
:
|
TYPE
ty
{
Mty
$
2
}
...
...
@@ -275,40 +242,44 @@ meta_arg:
(* Type declarations *)
type_decl
:
|
labels
(
lident
)
ty_var
*
typedefn
{
let
model
,
vis
,
def
,
inv
=
$
3
in
let
vis
=
if
model
then
Abstract
else
vis
in
|
labels
(
lident
)
ty_var
*
typedefn
invariant
*
{
let
(
vis
,
mut
)
,
def
=
$
3
in
{
td_ident
=
$
1
;
td_params
=
$
2
;
td_model
=
model
;
td_vis
=
vis
;
td_def
=
def
;
td_inv
=
inv
;
td_loc
=
floc
$
startpos
$
endpos
}
}
late_invariant
:
|
labels
(
lident
)
ty_var
*
invariant
+
{
{
td_ident
=
$
1
;
td_params
=
$
2
;
td_model
=
false
;
td_vis
=
Public
;
td_def
=
TDabstract
;
td_inv
=
$
3
;
td_loc
=
floc
$
startpos
$
endpos
}
}
td_vis
=
vis
;
td_mut
=
mut
;
td_inv
=
$
4
;
td_def
=
def
;
td_loc
=
floc
$
startpos
$
endpos
}
}
ty_var
:
|
labels
(
quote_lident
)
{
$
1
}
(* TODO: should global "mutable" imply "private"?
"type t 'a = mutable { x : int }"
- if "x" is immutable then the type can only be private
- if "x" is automatically mutable then I don't like it
- if there are known mutable fields, then a global "mutable"
is redundant, unless it also means "private" *)
(* TODO: what should be the syntax for mutable private records
without known fields? *)
typedefn
:
|
(* epsilon *)
{
false
,
Public
,
TDabstract
,
[]
}
|
model
abstract
bar_list1
(
type_case
)
invariant
*
{
$
1
,
$
2
,
TDalgebraic
$
3
,
$
4
}
|
model
abstract
LEFTBRC
semicolon_list1
(
type_field
)
RIGHTBRC
invariant
*
{
$
1
,
$
2
,
TDrecord
$
4
,
$
6
}
|
model
abstract
ty
invariant
*
{
$
1
,
$
2
,
TDalias
$
3
,
$
4
}
model
:
|
EQUAL
{
false
}
|
MODEL
{
true
}
{
(
Public
,
false
)
,
TDabstract
}
|
EQUAL
vis_mut
bar_list1
(
type_case
)
{
$
2
,
TDalgebraic
$
3
}
|
EQUAL
vis_mut
LEFTBRC
semicolon_list1
(
type_field
)
RIGHTBRC
{
$
2
,
TDrecord
$
4
}
|
EQUAL
vis_mut
ty
{
$
2
,
TDalias
$
3
}
vis_mut
:
|
(* epsilon *)
{
Public
,
false
}
|
MUTABLE
{
Public
,
true
}
|
abstract
{
$
1
,
false
}
|
abstract
MUTABLE
{
$
1
,
true
}
|
MUTABLE
abstract
{
$
2
,
true
}
abstract
:
|
(* epsilon *)
{
Public
}
|
PRIVATE
{
Private
}
|
ABSTRACT
{
Abstract
}
|
PRIVATE
{
Private
}
|
ABSTRACT
{
Abstract
}
type_field
:
|
field_modifiers
labels
(
lident
)
cast
...
...
@@ -370,8 +341,7 @@ ty:
ty_arg
:
|
lqualid
{
PTtyapp
(
$
1
,
[]
)
}
|
quote_lident
{
PTtyvar
(
$
1
,
false
)
}
|
opaque_quote_lident
{
PTtyvar
(
$
1
,
true
)
}
|
quote_lident
{
PTtyvar
$
1
}
|
LEFTPAR
comma_list2
(
ty
)
RIGHTPAR
{
PTtuple
$
2
}
|
LEFTPAR
RIGHTPAR
{
PTtuple
[]
}
|
LEFTPAR
ty
RIGHTPAR
{
PTparen
$
2
}
...
...
@@ -886,10 +856,6 @@ uident:
lident
:
|
LIDENT
{
mk_id
$
1
$
startpos
$
endpos
}
|
lident_keyword
{
mk_id
$
1
$
startpos
$
endpos
}
lident_keyword
:
|
MODEL
{
"model"
}
quote_uident
:
|
QUOTE_UIDENT
{
mk_id
(
"'"
^
$
1
)
$
startpos
$
endpos
}
...
...
@@ -897,9 +863,6 @@ quote_uident:
quote_lident
:
|
QUOTE_LIDENT
{
mk_id
$
1
$
startpos
$
endpos
}
opaque_quote_lident
:
|
OPAQUE_QUOTE_LIDENT
{
mk_id
$
1
$
startpos
$
endpos
}
(* Idents + symbolic operation names *)
ident_rich
:
...
...
src/parser/ptree.ml
View file @
9b255042
...
...
@@ -42,10 +42,8 @@ type qualid =
|
Qident
of
ident
|
Qdot
of
qualid
*
ident
type
opacity
=
bool
type
pty
=
|
PTtyvar
of
ident
*
opacity
|
PTtyvar
of
ident
|
PTtyapp
of
qualid
*
pty
list
|
PTtuple
of
pty
list
|
PTarrow
of
pty
*
pty
...
...
@@ -127,7 +125,7 @@ type type_def =
|
TDalgebraic
of
(
loc
*
ident
*
param
list
)
list
|
TDrecord
of
field
list
type
visibility
=
Public
|
Private
|
Abstract
type
visibility
=
Public
|
Private
|
Abstract
(* = Private + ghost fields *)
type
invariant
=
term
list
...
...
@@ -135,10 +133,10 @@ type type_decl = {
td_loc
:
loc
;
td_ident
:
ident
;
td_params
:
ident
list
;
td_model
:
bool
;
td_vis
:
visibility
;
td_vis
:
visibility
;
(* records only *)
td_mut
:
bool
;
(* records or abstract types *)
td_inv
:
invariant
;
(* records only *)
td_def
:
type_def
;
td_inv
:
invariant
;
}
type
logic_decl
=
{
...
...
@@ -166,13 +164,6 @@ type metarg =
type
use_clone
=
use
*
clone_subst
list
option
type
decl
=
|
Dtype
of
type_decl
list
|
Dlogic
of
logic_decl
list
|
Dind
of
Decl
.
ind_sign
*
ind_decl
list
|
Dprop
of
Decl
.
prop_kind
*
ident
*
term
|
Dmeta
of
ident
*
metarg
list
(* program files *)
type
assertion_kind
=
Aassert
|
Aassume
|
Acheck
...
...
@@ -259,23 +250,14 @@ and fundef = ident * top_ghost * lambda
and
lambda
=
binder
list
*
pty
option
*
expr
*
spec
type
pdecl
=
type
decl
=
|
Dtype
of
type_decl
list
|
Dlogic
of
logic_decl
list
|
Dind
of
Decl
.
ind_sign
*
ind_decl
list
|
Dprop
of
Decl
.
prop_kind
*
ident
*
term
|
Dmeta
of
ident
*
metarg
list
|
Dval
of
ident
*
top_ghost
*
type_v
|
Dlet
of
ident
*
top_ghost
*
expr
|
Dfun
of
ident
*
top_ghost
*
lambda
|
Drec
of
fundef
list
|
Dexn
of
ident
*
pty
(* incremental parsing *)
type
incremental
=
{
open_theory
:
ident
->
unit
;
close_theory
:
unit
->
unit
;
open_module
:
ident
->
unit
;
close_module
:
unit
->
unit
;
open_namespace
:
string
->
unit
;
close_namespace
:
loc
->
bool
(*import:*)
->
unit
;
new_decl
:
loc
->
decl
->
unit
;
new_pdecl
:
loc
->
pdecl
->
unit
;
use_clone
:
loc
->
use_clone
->
unit
;
}
src/parser/typing.ml
View file @
9b255042
...
...
@@ -18,6 +18,11 @@ open Decl
open
Theory
open
Dterm
open
Env
(*
open Pdecl
open Pmodule
open Dexpr
*)
(** debug flags *)
...
...
@@ -31,7 +36,6 @@ let debug_type_only = Debug.register_flag "type_only"
exception
UnboundTypeVar
of
string
exception
DuplicateTypeVar
of
string
exception
ClashTheory
of
string
(** lazy declaration of tuples *)
...
...
@@ -99,12 +103,9 @@ let find_namespace_ns ns q =
(** Parsing types *)
let
ty_of_pty
?
(
noop
=
true
)
uc
pty
=
let
ty_of_pty
uc
pty
=
let
rec
get_ty
=
function
|
PTtyvar
({
id_loc
=
loc
}
,
true
)
when
noop
->
Loc
.
errorm
~
loc
"Opaqueness@ annotations@ are@ only@ \
allowed@ in@ function@ and@ predicate@ prototypes"
|
PTtyvar
({
id_str
=
x
}
,
_
)
->
|
PTtyvar
{
id_str
=
x
}
->
ty_var
(
tv_of_string
x
)
|
PTtyapp
(
q
,
tyl
)
->
let
ts
=
find_tysymbol
uc
q
in
...
...
@@ -120,16 +121,6 @@ let ty_of_pty ?(noop=true) uc pty =
in
get_ty
pty
let
opaque_tvs
args
=
let
rec
opaque_tvs
acc
=
function
|
PTtyvar
(
id
,
true
)
->
Stv
.
add
(
tv_of_string
id
.
id_str
)
acc
|
PTtyvar
(
_
,
false
)
->
acc
|
PTtyapp
(
_
,
pl
)
|
PTtuple
pl
->
List
.
fold_left
opaque_tvs
acc
pl
|
PTarrow
(
ty1
,
ty2
)
->
opaque_tvs
(
opaque_tvs
acc
ty1
)
ty2
|
PTparen
ty
->
opaque_tvs
acc
ty
in
List
.
fold_left
(
fun
acc
(
_
,_,_,
ty
)
->
opaque_tvs
acc
ty
)
Stv
.
empty
args
(** typing using destructive type variables
parsed trees intermediate trees typed trees
...
...
@@ -204,8 +195,6 @@ let chainable_op uc op =
&&
not
(
ty_equal
ty2
ty_bool
)
|
_
->
false
type
global_vs
=
Ptree
.
qualid
->
vsymbol
option
let
mk_closure
loc
ls
=
let
mk
dt
=
Dterm
.
dterm
~
loc
dt
in
let
mk_v
i
_
=
...
...
@@ -353,11 +342,13 @@ let rec dterm uc gvars denv {term_desc = desc; term_loc = loc} =
|
Ptree
.
Tcast
(
e1
,
ty
)
->
DTcast
(
dterm
uc
gvars
denv
e1
,
ty_of_pty
uc
ty
))
(* TODO
(** Export for program parsing *)
let type_term uc gvars t =
let t = dterm uc gvars denv_empty t in
Dterm.term ~strict:true ~keep_loc:true t
*)
let
type_fmla
uc
gvars
f
=
let
f
=
dterm
uc
gvars
denv_empty
f
in
...
...
@@ -365,11 +356,11 @@ let type_fmla uc gvars f =
(** Typing declarations *)
let
tyl_of_params
?
(
noop
=
false
)
uc
pl
=
let
tyl_of_params
uc
pl
=
let
ty_of_param
(
loc
,_,
gh
,
ty
)
=
if
gh
then
Loc
.
errorm
~
loc
"ghost parameters are not allowed in pure declarations"
;
ty_of_pty
~
noop
uc
ty
in
ty_of_pty
uc
ty
in
List
.
map
ty_of_param
pl
let
add_types
dl
th
=
...
...
@@ -400,7 +391,7 @@ let add_types dl th =
let
ts
=
match
d
.
td_def
with
|
TDalias
ty
->
let
rec
apply
=
function
|
PTtyvar
(
v
,
_
)
->
|
PTtyvar
v
->
begin
try
ty_var
(
Hstr
.
find
vars
v
.
id_str
)
with
Not_found
->
Loc
.
error
~
loc
:
v
.
id_loc
(
UnboundTypeVar
v
.
id_str
)
...
...
@@ -456,7 +447,6 @@ let add_types dl th =
|
TDalgebraic
cl
->
let
ht
=
Hstr
.
create
17
in
let
constr
=
List
.
length
cl
in
let
opaque
=
Stv
.
of_list
ts
.
ts_args
in
let
ty
=
ty_app
ts
(
List
.
map
ty_var
ts
.
ts_args
)
in
let
projection
(
_
,
id
,_,_
)
fty
=
match
id
with
|
None
->
None
...
...
@@ -468,16 +458,16 @@ let add_types dl th =
Some
pj
with
Not_found
->
let
fn
=
create_user_id
id
in
let
pj
=
create_fsymbol
~
opaque
fn
[
ty
]
fty
in
let
pj
=
create_fsymbol
fn
[
ty
]
fty
in
Hstr
.
replace
csymbols
x
loc
;
Hstr
.
replace
ht
x
pj
;
Some
pj
in
let
constructor
(
loc
,
id
,
pl