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
ee99af04
Commit
ee99af04
authored
Aug 29, 2018
by
Andrei Paskevich
Browse files
Parser: admit qualifiers M.() in types and patterns
Also fix the suboptimal handling of casts in "returns { }".
parent
68a92927
Changes
4
Expand all
Hide whitespace changes
Inline
Side-by-side
src/parser/handcrafted.messages
View file @
ee99af04
This diff is collapsed.
Click to expand it.
src/parser/parser.mly
View file @
ee99af04
...
...
@@ -112,13 +112,25 @@
if
ql
=
[]
then
[]
else
let
ri
loc
=
{
id_str
=
"result"
;
id_loc
=
loc
;
id_ats
=
[]
}
in
let
rt
loc
=
{
term_desc
=
Tident
(
Qident
(
ri
loc
));
term_loc
=
loc
}
in
let
rec
case
(
loc
,
pfl
)
=
match
pfl
with
|
[{
pat_desc
=
Ptree
.
Pparen
p
;
pat_loc
=
loc
}
,
f
]
->
case
(
loc
,
[
p
,
f
])
|
[{
pat_desc
=
Ptree
.
Pwild
|
Ptree
.
Ptuple
[]
}
,
f
]
->
f
|
[{
pat_desc
=
Ptree
.
Pvar
{
id_str
=
"result"
}
}
,
f
]
->
f
|
[{
pat_desc
=
Ptree
.
Pvar
id
}
,
f
]
->
{
term_desc
=
Tlet
(
id
,
rt
loc
,
f
);
term_loc
=
loc
}
|
_
->
{
term_desc
=
Tcase
(
rt
loc
,
pfl
);
term_loc
=
loc
}
in
let
cast
t
ty
=
{
t
with
term_desc
=
Tcast
(
t
,
ty
)
}
in
let
case
(
loc
,
pfl
)
=
let
mk_t
d
=
{
term_desc
=
d
;
term_loc
=
loc
}
in
match
pfl
with
|
[
pat
,
f
]
->
let
rec
unfold
d
p
=
match
p
.
pat_desc
with
|
Pparen
p
|
Pscope
(
_
,
p
)
->
unfold
d
p
|
Pcast
(
p
,
ty
)
->
unfold
(
cast
d
ty
)
p
|
Ptuple
[]
->
unfold
(
cast
d
(
PTtuple
[]
))
{
p
with
pat_desc
=
Pwild
}
|
Pvar
{
id_str
=
"result"
}
|
Pwild
->
begin
match
d
.
term_desc
with
|
Tident
(
Qident
_
)
->
f
(* no type casts on d *)
|
_
->
mk_t
(
Tlet
(
id_anonymous
p
.
pat_loc
,
d
,
f
))
end
|
Pvar
id
->
mk_t
(
Tlet
(
id
,
d
,
f
))
|
_
->
mk_t
(
Tcase
(
d
,
pfl
))
in
unfold
(
rt
loc
)
pat
|
_
->
mk_t
(
Tcase
(
rt
loc
,
pfl
))
in
let
mk_t
desc
=
{
term_desc
=
desc
;
term_loc
=
any_loc
}
in
let
rec
join
ql
=
match
ql
with
|
[]
->
assert
false
(* never *)
...
...
@@ -457,6 +469,10 @@ ty:
ty_arg
:
|
lqualid
{
PTtyapp
(
$
1
,
[]
)
}
|
quote_lident
{
PTtyvar
$
1
}
|
uqualid
DOT
ty_block
{
PTscope
(
$
1
,
$
3
)
}
|
ty_block
{
$
1
}
ty_block
:
|
LEFTPAR
comma_list2
(
ty
)
RIGHTPAR
{
PTtuple
$
2
}
|
LEFTPAR
RIGHTPAR
{
PTtuple
[]
}
|
LEFTPAR
ty
RIGHTPAR
{
PTparen
$
2
}
...
...
@@ -605,7 +621,7 @@ single_term_:
{
let
re_pat
pat
d
=
{
pat
with
pat_desc
=
d
}
in
let
cast
t
ty
=
{
t
with
term_desc
=
Tcast
(
t
,
ty
)
}
in
let
rec
unfold
d
p
=
match
p
.
pat_desc
with
|
Pparen
p
->
unfold
d
p
|
Pparen
p
|
Pscope
(
_
,
p
)
->
unfold
d
p
|
Pcast
(
p
,
ty
)
->
unfold
(
cast
d
ty
)
p
|
Ptuple
[]
->
unfold
(
cast
d
(
PTtuple
[]
))
(
re_pat
p
Pwild
)
|
Pvar
id
->
Tlet
(
id
,
d
,
$
6
)
...
...
@@ -651,7 +667,7 @@ term_dot_:
|
o
=
oppref
;
a
=
term_dot
{
Tidapp
(
Qident
o
,
[
a
])
}
|
term_sub_
{
$
1
}
term_block
:
term_block
_
:
|
BEGIN
term
END
{
$
2
.
term_desc
}
|
LEFTPAR
term
RIGHTPAR
{
$
2
.
term_desc
}
|
BEGIN
END
{
Ttuple
[]
}
...
...
@@ -660,8 +676,8 @@ term_block:
|
LEFTBRC
term_arg
WITH
field_list1
(
term
)
RIGHTBRC
{
Tupdate
(
$
2
,$
4
)
}
term_sub_
:
|
term_block
{
$
1
}
|
uqualid
DOT
mk_term
(
term_block
)
{
Tscope
(
$
1
,
$
3
)
}
|
term_block
_
{
$
1
}
|
uqualid
DOT
mk_term
(
term_block
_
)
{
Tscope
(
$
1
,
$
3
)
}
|
term_dot
DOT
lqualid_rich
{
Tidapp
(
$
3
,
[
$
1
])
}
|
term_arg
LEFTSQ
term
rightsq
{
Tidapp
(
get_op
$
4
$
startpos
(
$
2
)
$
endpos
(
$
2
)
,
[
$
1
;
$
3
])
}
...
...
@@ -852,7 +868,7 @@ single_expr_:
|
_
->
Pghost
pat
)
in
let
pat
=
if
$
2
then
push
$
4
else
$
4
in
let
rec
unfold
gh
d
p
=
match
p
.
pat_desc
with
|
Pparen
p
->
unfold
gh
d
p
|
Pparen
p
|
Pscope
(
_
,
p
)
->
unfold
gh
d
p
|
Pghost
p
->
unfold
true
d
p
|
Pcast
(
p
,
ty
)
->
unfold
gh
(
cast
d
ty
)
p
|
Ptuple
[]
->
unfold
gh
(
cast
d
(
PTtuple
[]
))
(
re_pat
p
Pwild
)
...
...
@@ -971,14 +987,14 @@ expr_arg_:
|
TRUE
{
Etrue
}
|
FALSE
{
Efalse
}
|
o
=
oppref
;
a
=
expr_arg
{
Eidapp
(
Qident
o
,
[
a
])
}
|
expr_sub
{
$
1
}
|
expr_sub
_
{
$
1
}
expr_dot_
:
|
lqualid
{
Eident
$
1
}
|
o
=
oppref
;
a
=
expr_dot
{
Eidapp
(
Qident
o
,
[
a
])
}
|
expr_sub
{
$
1
}
|
expr_sub
_
{
$
1
}
expr_block
:
expr_block
_
:
|
BEGIN
single_spec
spec
seq_expr
END
{
Efun
([]
,
None
,
Ity
.
MaskVisible
,
spec_union
$
2
$
3
,
$
4
)
}
|
BEGIN
single_spec
spec
END
...
...
@@ -991,15 +1007,15 @@ expr_block:
|
LEFTBRC
field_list1
(
expr
)
RIGHTBRC
{
Erecord
$
2
}
|
LEFTBRC
expr_arg
WITH
field_list1
(
expr
)
RIGHTBRC
{
Eupdate
(
$
2
,
$
4
)
}
expr_pure
:
expr_pure
_
:
|
LEFTBRC
qualid
RIGHTBRC
{
Eidpur
$
2
}
|
uqualid
DOT
LEFTBRC
ident
RIGHTBRC
{
Eidpur
(
Qdot
(
$
1
,
$
4
))
}
expr_sub
:
|
expr_block
{
$
1
}
|
expr_pure
{
$
1
}
|
uqualid
DOT
mk_expr
(
expr_block
)
{
Escope
(
$
1
,
$
3
)
}
|
expr_dot
DOT
mk_expr
(
expr_pure
)
{
Eapply
(
$
3
,
$
1
)
}
expr_sub
_
:
|
expr_block
_
{
$
1
}
|
expr_pure
_
{
$
1
}
|
uqualid
DOT
mk_expr
(
expr_block
_
)
{
Escope
(
$
1
,
$
3
)
}
|
expr_dot
DOT
mk_expr
(
expr_pure
_
)
{
Eapply
(
$
3
,
$
1
)
}
|
expr_dot
DOT
lqualid_rich
{
Eidapp
(
$
3
,
[
$
1
])
}
|
PURE
LEFTBRC
term
RIGHTBRC
{
Epure
$
3
}
|
expr_arg
LEFTSQ
expr
rightsq
...
...
@@ -1171,6 +1187,10 @@ pat_arg_:
|
UNDERSCORE
{
Pwild
}
|
attrs
(
lident_nq
)
{
Pvar
(
add_model_trace_attr
$
1
)
}
|
uqualid
{
Papp
(
$
1
,
[]
)
}
|
uqualid
DOT
mk_pat
(
pat_block_
)
{
Pscope
(
$
1
,$
3
)
}
|
pat_block_
{
$
1
}
pat_block_
:
|
LEFTPAR
RIGHTPAR
{
Ptuple
[]
}
|
LEFTPAR
pattern
RIGHTPAR
{
Pparen
$
2
}
|
LEFTBRC
field_list1
(
pattern
)
RIGHTBRC
{
Prec
$
2
}
...
...
src/parser/ptree.ml
View file @
ee99af04
...
...
@@ -32,6 +32,7 @@ type pty =
|
PTtyapp
of
qualid
*
pty
list
|
PTtuple
of
pty
list
|
PTarrow
of
pty
*
pty
|
PTscope
of
qualid
*
pty
|
PTparen
of
pty
|
PTpure
of
pty
...
...
@@ -53,8 +54,9 @@ and pat_desc =
|
Pas
of
pattern
*
ident
*
ghost
|
Por
of
pattern
*
pattern
|
Pcast
of
pattern
*
pty
|
P
ghost
of
pattern
|
P
scope
of
qualid
*
pattern
|
Pparen
of
pattern
|
Pghost
of
pattern
(*s Logical terms and formulas *)
...
...
src/parser/typing.ml
View file @
ee99af04
...
...
@@ -105,23 +105,23 @@ let find_prog_symbol_ns ns p =
(** Parsing types *)
let
ty_of_pty
ns
pty
=
let
rec
get_ty
=
function
|
PT
tyvar
{
id_str
=
x
}
->
ty_var
(
tv_of_string
x
)
|
PTtyapp
(
q
,
tyl
)
->
let
t
s
=
find_tysymbol_ns
ns
q
in
let
tyl
=
List
.
map
get_ty
tyl
in
Loc
.
try2
~
loc
:
(
qloc
q
)
ty_app
ts
tyl
|
PTtuple
tyl
->
let
s
=
its_t
uple
(
List
.
length
tyl
)
in
ty_app
s
.
its_ts
(
List
.
map
get_ty
tyl
)
|
PTarrow
(
ty1
,
ty2
)
->
ty_func
(
get_ty
ty
1
)
(
get_ty
ty2
)
|
PTpure
ty
|
PTparen
ty
->
get_ty
ty
in
get_ty
p
ty
let
rec
ty_of_pty
ns
=
function
|
PTtyvar
{
id_str
=
x
}
->
ty
_
var
(
tv_of_string
x
)
|
PTtyapp
(
q
,
tyl
)
->
let
ts
=
find_tysymbol_ns
ns
q
in
let
t
yl
=
List
.
map
(
ty_of_pty
ns
)
tyl
in
Loc
.
try2
~
loc
:
(
qloc
q
)
ty_app
ts
tyl
|
PTtuple
tyl
->
let
s
=
its_tuple
(
List
.
length
tyl
)
in
ty_app
s
.
its_t
s
(
List
.
map
(
ty_of_pty
ns
)
tyl
)
|
PTarrow
(
ty1
,
ty2
)
->
ty_func
(
ty_of_pty
ns
ty1
)
(
ty_of_pty
ns
ty2
)
|
PTscope
(
q
,
ty
)
->
let
ns
=
import_namespace
ns
(
string_list_of_qualid
q
)
in
ty_of_pty
ns
ty
|
PTpure
ty
|
PTparen
ty
->
ty_of_pty
ns
ty
let
dty_of_pty
ns
pty
=
Dterm
.
dty_of_ty
(
ty_of_pty
ns
pty
)
...
...
@@ -156,10 +156,14 @@ let parse_record ~loc ns km get_val fl =
let
rec
dpattern
ns
km
{
pat_desc
=
desc
;
pat_loc
=
loc
}
=
match
desc
with
|
Ptree
.
Pparen
p
->
dpattern
ns
km
p
|
Ptree
.
Pscope
(
q
,
p
)
->
let
ns
=
import_namespace
ns
(
string_list_of_qualid
q
)
in
dpattern
ns
km
p
|
_
->
(* creative indentation ahead *)
Dterm
.
dpattern
~
loc
(
match
desc
with
|
Ptree
.
Pparen
_
|
Ptree
.
Pscope
_
->
assert
false
(* never *)
|
Ptree
.
Pwild
->
DPwild
|
Ptree
.
Pparen
_
->
assert
false
(* never *)
|
Ptree
.
Pvar
x
->
DPvar
(
create_user_id
x
)
|
Ptree
.
Papp
(
q
,
pl
)
->
let
pl
=
List
.
map
(
dpattern
ns
km
)
pl
in
...
...
@@ -422,25 +426,25 @@ let find_special muc test nm q =
end
|
_
->
Loc
.
errorm
~
loc
:
(
qloc
q
)
"Not a %s: %a"
nm
print_qualid
q
let
ity_of_pty
muc
pty
=
let
rec
get_ity
=
function
|
PT
tyvar
{
id_str
=
x
}
->
ity_var
(
tv_of_string
x
)
|
PTtyapp
(
q
,
tyl
)
->
let
s
=
find_itysymbol_ns
(
get_namespace
muc
)
q
in
let
tyl
=
List
.
map
get_ity
tyl
in
Loc
.
try3
~
loc
:
(
qloc
q
)
ity_app
s
tyl
[]
|
PTtuple
tyl
->
ity_tuple
(
List
.
map
get_ity
tyl
)
|
PTarrow
(
ty1
,
ty2
)
->
ity_func
(
get_ity
ty1
)
(
get_ity
ty2
)
|
PTpure
ty
->
ity_purify
(
get_ity
ty
)
|
PTparen
ty
->
get_ity
ty
in
get_ity
pty
let
rec
ity_of_pty
muc
=
function
|
PTtyvar
{
id_str
=
x
}
->
i
ty
_
var
(
tv_of_string
x
)
|
PTtyapp
(
q
,
tyl
)
->
let
s
=
find_itysymbol
muc
q
in
let
tyl
=
List
.
map
(
ity_of_pty
muc
)
tyl
in
Loc
.
try3
~
loc
:
(
qloc
q
)
ity_app
s
tyl
[]
|
PTtuple
tyl
->
ity_tuple
(
List
.
map
(
ity_of_pty
muc
)
tyl
)
|
PTarrow
(
ty1
,
ty2
)
->
ity_func
(
ity_of_pty
muc
ty1
)
(
ity_of_pty
muc
ty2
)
|
PTpure
ty
->
ity_purify
(
ity_of_pty
muc
ty
)
|
PTscope
(
q
,
ty
)
->
let
muc
=
open_scope
muc
"dummy"
in
let
muc
=
import_scope
muc
(
string_list_of_qualid
q
)
in
ity_of_pty
muc
ty
|
PTparen
ty
->
ity_of_pty
muc
ty
let
dity_of_pty
muc
pty
=
Dexpr
.
dity_of_ity
(
ity_of_pty
muc
pty
)
...
...
@@ -499,10 +503,15 @@ let rec dpattern muc gh { pat_desc = desc; pat_loc = loc } =
match
desc
with
|
Ptree
.
Pparen
p
->
dpattern
muc
gh
p
|
Ptree
.
Pghost
p
->
dpattern
muc
true
p
|
Ptree
.
Pscope
(
q
,
p
)
->
let
muc
=
open_scope
muc
"dummy"
in
let
muc
=
import_scope
muc
(
string_list_of_qualid
q
)
in
dpattern
muc
gh
p
|
_
->
(* creative indentation ahead *)
Dexpr
.
dpattern
~
loc
(
match
desc
with
|
Ptree
.
Pparen
_
|
Ptree
.
Pscope
_
|
Ptree
.
Pghost
_
->
assert
false
(* never *)
|
Ptree
.
Pwild
->
DPwild
|
Ptree
.
Pparen
_
|
Ptree
.
Pghost
_
->
assert
false
|
Ptree
.
Pvar
x
->
DPvar
(
create_user_id
x
,
gh
)
|
Ptree
.
Papp
(
q
,
pl
)
->
DPapp
(
find_constructor
muc
q
,
List
.
map
(
dpattern
muc
gh
)
pl
)
...
...
@@ -557,23 +566,34 @@ let dpre muc pl lvm old =
List
.
map
dpre
pl
let
dpost
muc
ql
lvm
old
ity
=
let
rec
dpost
(
loc
,
pfl
)
=
match
pfl
with
|
[{
pat_desc
=
Ptree
.
Pparen
p
;
pat_loc
=
loc
}
,
f
]
->
dpost
(
loc
,
[
p
,
f
])
|
[{
pat_desc
=
Ptree
.
Pwild
|
Ptree
.
Ptuple
[]
}
,
f
]
->
let
v
=
create_pvsymbol
(
id_fresh
"result"
)
ity
in
v
,
Loc
.
try3
~
loc
type_fmla
muc
lvm
old
f
|
[{
pat_desc
=
Ptree
.
Pvar
id
}
,
f
]
->
let
v
=
create_pvsymbol
(
create_user_id
id
)
ity
in
let
lvm
=
Mstr
.
add
id
.
id_str
v
lvm
in
v
,
Loc
.
try3
~
loc
type_fmla
muc
lvm
old
f
|
_
->
let
v
=
create_pvsymbol
(
id_fresh
"result"
)
ity
in
let
i
=
{
id_str
=
"(null)"
;
id_loc
=
loc
;
id_ats
=
[]
}
in
let
t
=
{
term_desc
=
Tident
(
Qident
i
);
term_loc
=
loc
}
in
let
f
=
{
term_desc
=
Ptree
.
Tcase
(
t
,
pfl
);
term_loc
=
loc
}
in
let
lvm
=
Mstr
.
add
"(null)"
v
lvm
in
v
,
Loc
.
try3
~
loc
type_fmla
muc
lvm
old
f
in
let
mk_case
loc
pfl
=
let
v
=
create_pvsymbol
(
id_fresh
"result"
)
ity
in
let
i
=
{
id_str
=
"(null)"
;
id_loc
=
loc
;
id_ats
=
[]
}
in
let
t
=
{
term_desc
=
Tident
(
Qident
i
);
term_loc
=
loc
}
in
let
f
=
{
term_desc
=
Ptree
.
Tcase
(
t
,
pfl
);
term_loc
=
loc
}
in
let
lvm
=
Mstr
.
add
"(null)"
v
lvm
in
v
,
Loc
.
try3
~
loc
type_fmla
muc
lvm
old
f
in
let
dpost
(
loc
,
pfl
)
=
match
pfl
with
|
[
pat
,
f
]
->
let
rec
unfold
p
=
match
p
.
pat_desc
with
|
Ptree
.
Pparen
p
|
Ptree
.
Pscope
(
_
,
p
)
->
unfold
p
|
Ptree
.
Pcast
(
p
,
pty
)
->
let
ty
=
ty_of_ity
(
ity_of_pty
muc
pty
)
in
Loc
.
try2
~
loc
:
p
.
pat_loc
ty_equal_check
(
ty_of_ity
ity
)
ty
;
unfold
p
|
Ptree
.
Ptuple
[]
->
Loc
.
try2
~
loc
:
p
.
pat_loc
ity_equal_check
ity
ity_unit
;
unfold
{
p
with
pat_desc
=
Ptree
.
Pwild
}
|
Ptree
.
Pwild
->
let
v
=
create_pvsymbol
(
id_fresh
"result"
)
ity
in
v
,
Loc
.
try3
~
loc
type_fmla
muc
lvm
old
f
|
Ptree
.
Pvar
id
->
let
v
=
create_pvsymbol
(
create_user_id
id
)
ity
in
let
lvm
=
Mstr
.
add
id
.
id_str
v
lvm
in
v
,
Loc
.
try3
~
loc
type_fmla
muc
lvm
old
f
|
_
->
mk_case
loc
pfl
in
unfold
pat
|
_
->
mk_case
loc
pfl
in
List
.
map
dpost
ql
let
dxpost
muc
ql
lvm
xsm
old
=
...
...
@@ -1107,7 +1127,7 @@ let add_types muc tdl =
Hstr
.
add
hts
x
itd
.
itd_its
;
Hstr
.
add
htd
x
itd
and
parse
~
loc
~
alias
~
alg
pty
=
let
rec
down
=
function
let
rec
down
muc
=
function
|
PTtyvar
id
->
ity_var
(
tv_of_string
id
.
id_str
)
|
PTtyapp
(
q
,
tyl
)
->
...
...
@@ -1127,12 +1147,16 @@ let add_types muc tdl =
Hstr
.
find
hts
x
|
_
->
find_itysymbol
muc
q
in
Loc
.
try3
~
loc
:
(
qloc
q
)
ity_app
s
(
List
.
map
down
tyl
)
[]
|
PTtuple
tyl
->
ity_tuple
(
List
.
map
down
tyl
)
|
PTarrow
(
ty1
,
ty2
)
->
ity_func
(
down
ty1
)
(
down
ty2
)
|
PTpure
ty
->
ity_purify
(
down
ty
)
|
PTparen
ty
->
down
ty
in
down
pty
in
Loc
.
try3
~
loc
:
(
qloc
q
)
ity_app
s
(
List
.
map
(
down
muc
)
tyl
)
[]
|
PTtuple
tyl
->
ity_tuple
(
List
.
map
(
down
muc
)
tyl
)
|
PTarrow
(
ty1
,
ty2
)
->
ity_func
(
down
muc
ty1
)
(
down
muc
ty2
)
|
PTpure
ty
->
ity_purify
(
down
muc
ty
)
|
PTscope
(
q
,
ty
)
->
let
muc
=
open_scope
muc
"dummy"
in
let
muc
=
import_scope
muc
(
string_list_of_qualid
q
)
in
down
muc
ty
|
PTparen
ty
->
down
muc
ty
in
down
muc
pty
in
Mstr
.
iter
(
visit
~
alias
:
Mstr
.
empty
~
alg
:
Mstr
.
empty
)
def
;
let
tdl
=
List
.
map
(
fun
d
->
Hstr
.
find
htd
d
.
td_ident
.
id_str
)
tdl
in
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment