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
b042385c
Commit
b042385c
authored
Feb 17, 2010
by
Jean-Christophe Filliâtre
Browse files
noms qualifies (mais pas encore de uses)
parent
bdb46dc5
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/parser.mly
View file @
b042385c
...
...
@@ -167,6 +167,15 @@ list0_decl:
{
$
1
}
;
ident
:
|
IDENT
{
{
id
=
$
1
;
id_loc
=
loc
()
}
}
;
qualid
:
|
ident
{
Qident
$
1
}
|
ident
DOT
ident
{
Qdot
(
$
1
,
$
3
)
}
;
decl
:
|
external_
LOGIC
list1_ident_sep_comma
COLON
logic_type
{
Logic
(
loc_i
3
,
$
1
,
$
3
,
$
5
)
}
...
...
@@ -266,13 +275,13 @@ primitive_type:
{
PPTunit
}
*/
|
type_var
{
PPTvarid
(
$
1
,
loc
()
)
}
|
ident
{
PPTexternal
([]
,
$
1
,
loc
()
)
}
|
primitive_type
ident
{
PPTexternal
([
$
1
]
,
$
2
,
loc_i
2
)
}
|
LEFTPAR
primitive_type
COMMA
list1_primitive_type_sep_comma
RIGHTPAR
ident
{
PPTexternal
(
$
2
::
$
4
,
$
6
,
loc_i
6
)
}
{
PPTvarid
$
1
}
|
qualid
{
PPTexternal
([]
,
$
1
)
}
|
primitive_type
qualid
{
PPTexternal
([
$
1
]
,
$
2
)
}
|
LEFTPAR
primitive_type
COMMA
list1_primitive_type_sep_comma
RIGHTPAR
qualid
{
PPTexternal
(
$
2
::
$
4
,
$
6
)
}
/*
|
LEFTPAR
list1_primitive_type_sep_comma
RIGHTPAR
{
match
$
2
with
[
p
]
->
p
|
_
->
raise
Parse_error
}
...
...
@@ -350,9 +359,9 @@ lexpr:
{
infix_pp
$
1
PPmod
$
3
}
|
MINUS
lexpr
%
prec
uminus
{
prefix_pp
PPneg
$
2
}
|
ident
|
qualid
{
mk_pp
(
PPvar
$
1
)
}
|
ident
LEFTPAR
list1_lexpr_sep_comma
RIGHTPAR
|
qualid
LEFTPAR
list1_lexpr_sep_comma
RIGHTPAR
{
mk_pp
(
PPapp
(
$
1
,
$
3
))
}
/***
|
qualid_ident
LEFTSQ
lexpr
RIGHTSQ
...
...
@@ -361,14 +370,14 @@ lexpr:
|
IF
lexpr
THEN
lexpr
ELSE
lexpr
%
prec
prec_if
{
mk_pp
(
PPif
(
$
2
,
$
4
,
$
6
))
}
|
FORALL
list1_ident_sep_comma
COLON
primitive_type
triggers
DOT
lexpr
%
prec
prec_forall
COMMA
lexpr
%
prec
prec_forall
{
let
rec
mk
=
function
|
[]
->
assert
false
|
[
id
]
->
mk_pp
(
PPforall
(
id
,
$
4
,
$
5
,
$
7
))
|
id
::
l
->
mk_pp
(
PPforall
(
id
,
$
4
,
[]
,
mk
l
))
in
mk
$
2
}
|
EXISTS
ident
COLON
primitive_type
DOT
lexpr
%
prec
prec_exists
|
EXISTS
ident
COLON
primitive_type
COMMA
lexpr
%
prec
prec_exists
{
mk_pp
(
PPexists
(
$
2
,
$
4
,
$
6
))
}
|
INTEGER
{
mk_pp
(
PPconst
(
ConstInt
$
1
))
}
...
...
@@ -402,8 +411,8 @@ match_case:
;
pattern
:
|
ident
{
(
$
1
,
[]
,
loc
()
)
}
|
ident
LEFTPAR
list1_ident_sep_comma
RIGHTPAR
{
(
$
1
,
$
3
,
loc
()
)
}
|
qualid
{
(
$
1
,
[]
,
loc
()
)
}
|
qualid
LEFTPAR
list1_ident_sep_comma
RIGHTPAR
{
(
$
1
,
$
3
,
loc
()
)
}
;
triggers
:
...
...
@@ -443,15 +452,13 @@ list1_type_var_sep_comma:
|
type_var
COMMA
list1_type_var_sep_comma
{
$
1
::
$
3
}
;
ident
:
|
IDENT
{
$
1
}
;
/***
qualid_ident
:
|
IDENT
{
$
1
,
None
}
|
IDENT
AT
{
$
1
,
Some
""
}
|
IDENT
AT
IDENT
{
$
1
,
Some
$
3
}
;
***/
ident_or_string
:
|
IDENT
{
$
1
}
...
...
src/ptree.mli
View file @
b042385c
...
...
@@ -36,6 +36,12 @@ type pp_infix =
type
pp_prefix
=
PPneg
|
PPnot
type
ident
=
{
id
:
string
;
id_loc
:
loc
}
type
qualid
=
|
Qident
of
ident
|
Qdot
of
ident
*
ident
type
ppure_type
=
(*
| PPTint
...
...
@@ -43,26 +49,26 @@ type ppure_type =
| PPTreal
| PPTunit
*)
|
PPTvarid
of
string
*
Loc
.
position
|
PPTexternal
of
ppure_type
list
*
string
*
Loc
.
position
|
PPTvarid
of
ident
|
PPTexternal
of
ppure_type
list
*
qualid
type
lexpr
=
{
pp_loc
:
loc
;
pp_desc
:
pp_desc
}
and
pp_desc
=
|
PPvar
of
string
|
PPapp
of
string
*
lexpr
list
|
PPvar
of
qualid
|
PPapp
of
qualid
*
lexpr
list
|
PPtrue
|
PPfalse
|
PPconst
of
constant
|
PPinfix
of
lexpr
*
pp_infix
*
lexpr
|
PPprefix
of
pp_prefix
*
lexpr
|
PPif
of
lexpr
*
lexpr
*
lexpr
|
PPforall
of
string
*
ppure_type
*
lexpr
list
list
*
lexpr
|
PPexists
of
string
*
ppure_type
*
lexpr
|
PPforall
of
ident
*
ppure_type
*
lexpr
list
list
*
lexpr
|
PPexists
of
ident
*
ppure_type
*
lexpr
|
PPnamed
of
string
*
lexpr
|
PPlet
of
string
*
lexpr
*
lexpr
|
PPmatch
of
lexpr
*
((
string
*
string
list
*
loc
)
*
lexpr
)
list
|
PPlet
of
ident
*
lexpr
*
lexpr
|
PPmatch
of
lexpr
*
((
qualid
*
ident
list
*
loc
)
*
lexpr
)
list
(*s Declarations. *)
...
...
@@ -72,19 +78,19 @@ type plogic_type =
|
PPredicate
of
ppure_type
list
|
PFunction
of
ppure_type
list
*
ppure_type
type
uses
=
string
type
uses
=
ident
type
logic_decl
=
|
Logic
of
loc
*
external_
*
string
list
*
plogic_type
|
Predicate_def
of
loc
*
string
*
(
loc
*
string
*
ppure_type
)
list
*
lexpr
|
Inductive_def
of
loc
*
string
*
plogic_type
*
(
loc
*
string
*
lexpr
)
list
|
Logic
of
loc
*
external_
*
ident
list
*
plogic_type
|
Predicate_def
of
loc
*
ident
*
(
loc
*
ident
*
ppure_type
)
list
*
lexpr
|
Inductive_def
of
loc
*
ident
*
plogic_type
*
(
loc
*
ident
*
lexpr
)
list
|
Function_def
of
loc
*
string
*
(
loc
*
string
*
ppure_type
)
list
*
ppure_type
*
lexpr
|
Axiom
of
loc
*
string
*
lexpr
|
Goal
of
loc
*
string
*
lexpr
|
TypeDecl
of
loc
*
external_
*
string
list
*
string
|
AlgType
of
(
loc
*
string
list
*
string
*
(
loc
*
string
*
ppure_type
list
)
list
)
list
|
Theory
of
loc
*
string
*
uses
list
*
logic_decl
list
of
loc
*
ident
*
(
loc
*
ident
*
ppure_type
)
list
*
ppure_type
*
lexpr
|
Axiom
of
loc
*
ident
*
lexpr
|
Goal
of
loc
*
ident
*
lexpr
|
TypeDecl
of
loc
*
external_
*
ident
list
*
ident
|
AlgType
of
(
loc
*
ident
list
*
ident
*
(
loc
*
ident
*
ppure_type
list
)
list
)
list
|
Theory
of
loc
*
ident
*
uses
list
*
logic_decl
list
type
logic_file
=
logic_decl
list
src/test.why
View file @
b042385c
(* test file *)
theory test
theory int
type int
end
theory list
type 'a list
...
...
@@ -9,24 +15,40 @@ theory test
logic cons : 'a, 'a list -> 'a list
type int
logic is_nil : 'a list -> prop
logic length : 'a list -> int
logic length : 'a list -> int
.int
logic is_nil : 'a list -> prop
end
logic eq : 'a, 'a -> prop
theory eq
axiom a : forall x : 'a. not eq(nil, cons(nil, nil))
logic eq : 'a, 'a -> prop
end
theory
test2
theory
set
type elt
type t
logic In : elt, t -> prop
logic empty : t
axiom empty_def1 : forall x:elt, not In(x, empty)
logic add : elt, t -> t
axiom add_def1 : forall x,y:elt, forall s:t,
In(x, add(y, s)) <-> (eq.eq(x, y) or In(x, s))
end
theory test
axiom a : forall x : 'a, not eq.eq(list.nil, list.cons(list.nil, list.nil))
end
src/typing.ml
View file @
b042385c
...
...
@@ -25,16 +25,17 @@ open Ptree
type
error
=
|
ClashType
of
string
|
BadTypeArity
of
string
|
UnboundType
of
string
|
TypeArity
of
string
*
int
*
int
|
UnboundType
of
qualid
|
TypeArity
of
qualid
*
int
*
int
|
Clash
of
string
|
PredicateExpected
|
TermExpected
|
UnboundSymbol
of
string
|
UnboundSymbol
of
qualid
|
TermExpectedType
of
(
formatter
->
unit
)
*
(
formatter
->
unit
)
(* actual / expected *)
|
BadNumberOfArguments
of
Name
.
t
*
int
*
int
|
ClashTheory
of
string
|
UnboundTheory
of
string
exception
Error
of
error
...
...
@@ -42,15 +43,19 @@ let error ?loc e = match loc with
|
None
->
raise
(
Error
e
)
|
Some
loc
->
raise
(
Loc
.
Located
(
loc
,
Error
e
))
let
print_qualid
fmt
=
function
|
Qident
s
->
fprintf
fmt
"%s"
s
.
id
|
Qdot
(
m
,
s
)
->
fprintf
fmt
"%s.%s"
m
.
id
s
.
id
let
report
fmt
=
function
|
ClashType
s
->
fprintf
fmt
"clash with previous type %s"
s
|
BadTypeArity
s
->
fprintf
fmt
"duplicate type parameter %s"
s
|
UnboundType
s
->
fprintf
fmt
"Unbound type '%
s
'"
s
fprintf
fmt
"Unbound type '%
a
'"
print_qualid
s
|
TypeArity
(
id
,
a
,
n
)
->
fprintf
fmt
"@[The type %
s
expects %d argument(s),@ "
id
a
;
fprintf
fmt
"@[The type %
a
expects %d argument(s),@ "
print_qualid
id
a
;
fprintf
fmt
"but is applied to %d argument(s)@]"
n
|
Clash
id
->
fprintf
fmt
"Clash with previous constant %s"
id
...
...
@@ -59,7 +64,7 @@ let report fmt = function
|
TermExpected
->
fprintf
fmt
"syntax error: term expected"
|
UnboundSymbol
s
->
fprintf
fmt
"Unbound symbol '%
s
'"
s
fprintf
fmt
"Unbound symbol '%
a
'"
print_qualid
s
|
BadNumberOfArguments
(
s
,
n
,
m
)
->
fprintf
fmt
"@[Symbol `%a' is aplied to %d terms,@ "
Name
.
print
s
n
;
fprintf
fmt
"but is expecting %d arguments@]"
m
...
...
@@ -68,6 +73,8 @@ let report fmt = function
fprintf
fmt
"@ but is expected to have type@ "
;
ty2
fmt
;
fprintf
fmt
"@]"
|
ClashTheory
s
->
fprintf
fmt
"clash with previous theory %s"
s
|
UnboundTheory
s
->
fprintf
fmt
"unbound theory %s"
s
(** typing environments *)
...
...
@@ -193,34 +200,11 @@ let find_user_type_var x env =
Hashtbl
.
add
env
.
utyvars
x
v
;
v
(** Typing types *)
(* parsed types -> intermediate types *)
let
rec
dty
env
=
function
|
PPTvarid
(
x
,
_
)
->
Tyvar
(
find_user_type_var
x
env
)
|
PPTexternal
(
p
,
id
,
loc
)
->
if
not
(
M
.
mem
id
env
.
env
.
tysymbols
)
then
error
~
loc
(
UnboundType
id
);
let
s
=
M
.
find
id
env
.
env
.
tysymbols
in
let
np
=
List
.
length
p
in
let
a
=
List
.
length
s
.
Ty
.
ts_args
in
if
np
<>
a
then
error
~
loc
(
TypeArity
(
id
,
a
,
np
));
Tyapp
(
s
,
List
.
map
(
dty
env
)
p
)
(* intermediate types -> types *)
let
rec
ty
=
function
|
Tyvar
{
type_val
=
Some
t
}
->
ty
t
|
Tyvar
{
tvsymbol
=
tv
}
->
Ty
.
ty_var
tv
|
Tyapp
(
s
,
tl
)
->
Ty
.
ty_app
s
(
List
.
map
ty
tl
)
(* Specialize *)
module
Htv
=
Hashtbl
.
Make
(
Name
)
let
find_type_var
tv
en
v
=
let
find_type_var
env
t
v
=
try
Htv
.
find
env
tv
with
Not_found
->
...
...
@@ -230,21 +214,67 @@ let find_type_var tv env =
let
rec
specialize
env
t
=
match
t
.
Ty
.
ty_node
with
|
Ty
.
Tyvar
tv
->
Tyvar
(
find_type_var
tv
en
v
)
Tyvar
(
find_type_var
env
t
v
)
|
Ty
.
Tyapp
(
s
,
tl
)
->
Tyapp
(
s
,
List
.
map
(
specialize
env
)
tl
)
let
find_theory
t
env
=
try
M
.
find
t
.
id
env
.
theories
with
Not_found
->
error
~
loc
:
t
.
id_loc
(
UnboundTheory
t
.
id
)
let
find
f
q
env
=
match
q
with
|
Qident
x
->
f
x
.
id
env
|
Qdot
(
m
,
x
)
->
let
env
=
find_theory
m
env
in
f
x
.
id
env
let
specialize_tysymbol
x
env
=
let
s
=
find
find_tysymbol
x
env
.
env
in
let
env
=
Htv
.
create
17
in
s
,
List
.
map
(
find_type_var
env
)
s
.
Ty
.
ts_args
let
specialize_fsymbol
x
env
=
let
s
=
find_fsymbol
x
env
.
env
in
let
s
=
find
find_fsymbol
x
env
.
env
in
let
tl
,
t
=
s
.
fs_scheme
in
let
env
=
Htv
.
create
17
in
s
,
List
.
map
(
specialize
env
)
tl
,
specialize
env
t
let
specialize_psymbol
x
env
=
let
s
=
find_psymbol
x
env
.
env
in
let
s
=
find
find_psymbol
x
env
.
env
in
let
env
=
Htv
.
create
17
in
s
,
List
.
map
(
specialize
env
)
s
.
ps_scheme
(** Typing types *)
let
qloc
=
function
|
Qident
x
->
x
.
id_loc
|
Qdot
(
m
,
x
)
->
Loc
.
join
m
.
id_loc
x
.
id_loc
(* parsed types -> intermediate types *)
let
rec
dty
env
=
function
|
PPTvarid
{
id
=
x
}
->
Tyvar
(
find_user_type_var
x
env
)
|
PPTexternal
(
p
,
x
)
->
let
loc
=
qloc
x
in
let
s
,
tv
=
try
specialize_tysymbol
x
env
with
Not_found
->
error
~
loc
:
loc
(
UnboundType
x
);
in
let
np
=
List
.
length
p
in
let
a
=
List
.
length
tv
in
if
np
<>
a
then
error
~
loc
(
TypeArity
(
x
,
a
,
np
));
Tyapp
(
s
,
List
.
map
(
dty
env
)
p
)
(* intermediate types -> types *)
let
rec
ty
=
function
|
Tyvar
{
type_val
=
Some
t
}
->
ty
t
|
Tyvar
{
tvsymbol
=
tv
}
->
Ty
.
ty_var
tv
|
Tyapp
(
s
,
tl
)
->
Ty
.
ty_app
s
(
List
.
map
ty
tl
)
(** Typing terms and formulas *)
type
dterm
=
{
dt_node
:
dterm_node
;
dt_ty
:
dty
}
...
...
@@ -280,13 +310,13 @@ let rec dterm env t =
{
dt_node
=
n
;
dt_ty
=
ty
}
and
dterm_node
loc
env
=
function
|
PPvar
x
->
begin
try
(* local variable *)
let
ty
=
M
.
find
x
env
.
dvars
in
T
var
x
,
ty
with
Not_found
->
try
(* 0-arity symbol (constant) *)
|
PPvar
(
Qident
{
id
=
x
})
when
M
.
mem
x
env
.
dvars
->
(* local variable *)
let
ty
=
M
.
find
x
env
.
dvars
in
Tvar
x
,
ty
|
PP
var
x
->
(* 0-arity symbol (constant) *)
begin
try
let
s
,
tyl
,
ty
=
specialize_fsymbol
x
env
in
let
n
=
List
.
length
tyl
in
if
n
>
0
then
error
~
loc
(
BadNumberOfArguments
(
s
.
fs_name
,
0
,
n
));
...
...
@@ -318,14 +348,14 @@ and dfmla env e = match e.pp_desc with
error
~
loc
:
e
.
pp_loc
PredicateExpected
|
PPif
(
a
,
b
,
c
)
->
Fif
(
dfmla
env
a
,
dfmla
env
b
,
dfmla
env
c
)
|
PPforall
(
id
,
ty
,
_
,
a
)
->
(* TODO: triggers *)
|
PPforall
(
{
id
=
x
}
,
ty
,
_
,
a
)
->
(* TODO: triggers *)
let
ty
=
dty
env
ty
in
let
env
=
{
env
with
dvars
=
M
.
add
id
ty
env
.
dvars
}
in
Fquant
(
Fforall
,
id
,
ty
,
dfmla
env
a
)
|
PPexists
(
id
,
ty
,
a
)
->
(* TODO: triggers *)
let
env
=
{
env
with
dvars
=
M
.
add
x
ty
env
.
dvars
}
in
Fquant
(
Fforall
,
x
,
ty
,
dfmla
env
a
)
|
PPexists
(
{
id
=
x
}
,
ty
,
a
)
->
(* TODO: triggers *)
let
ty
=
dty
env
ty
in
let
env
=
{
env
with
dvars
=
M
.
add
id
ty
env
.
dvars
}
in
Fquant
(
Fexists
,
id
,
ty
,
dfmla
env
a
)
let
env
=
{
env
with
dvars
=
M
.
add
x
ty
env
.
dvars
}
in
Fquant
(
Fexists
,
x
,
ty
,
dfmla
env
a
)
|
PPapp
(
x
,
tl
)
->
let
s
,
tyl
=
try
...
...
@@ -387,19 +417,19 @@ and fmla env = function
open
Ptree
let
add_type
loc
ext
sl
s
env
=
if
M
.
mem
s
env
.
tysymbols
then
error
~
loc
(
ClashType
s
);
if
M
.
mem
s
.
id
env
.
tysymbols
then
error
~
loc
(
ClashType
s
.
id
);
let
tyvars
=
ref
M
.
empty
in
let
add_ty_var
x
=
let
add_ty_var
{
id
=
x
}
=
if
M
.
mem
x
!
tyvars
then
error
~
loc
(
BadTypeArity
x
);
let
v
=
Name
.
from_string
x
in
tyvars
:=
M
.
add
x
v
!
tyvars
;
v
in
let
vl
=
List
.
map
add_ty_var
sl
in
let
ty
=
Ty
.
create_tysymbol
(
Name
.
from_string
s
)
vl
None
in
add_tysymbol
s
ty
env
let
ty
=
Ty
.
create_tysymbol
(
Name
.
from_string
s
.
id
)
vl
None
in
add_tysymbol
s
.
id
ty
env
let
add_function
loc
pl
t
env
id
=
let
add_function
loc
pl
t
env
{
id
=
id
}
=
if
M
.
mem
id
env
.
fsymbols
then
error
~
loc
(
Clash
id
);
let
denv
=
create_denv
env
in
let
pl
=
List
.
map
(
dty
denv
)
pl
and
t
=
dty
denv
t
in
...
...
@@ -407,7 +437,7 @@ let add_function loc pl t env id =
let
s
=
create_fsymbol
(
Name
.
from_string
id
)
(
pl
,
t
)
false
in
{
env
with
fsymbols
=
M
.
add
id
s
env
.
fsymbols
}
let
add_predicate
loc
pl
env
id
=
let
add_predicate
loc
pl
env
{
id
=
id
}
=
if
M
.
mem
id
env
.
psymbols
then
error
~
loc
(
Clash
id
);
let
denv
=
create_denv
env
in
let
pl
=
List
.
map
(
dty
denv
)
pl
in
...
...
@@ -447,7 +477,12 @@ and add_decls env = List.fold_left add_decl env
and
add_theory
loc
s
u
dl
env
=
assert
(
is_empty
env
);
if
M
.
mem
s
env
.
theories
then
error
~
loc
(
ClashTheory
s
);
if
M
.
mem
s
.
id
env
.
theories
then
error
~
loc
:
s
.
id_loc
(
ClashTheory
s
.
id
);
let
env
=
add_decls
env
dl
in
{
empty
with
theories
=
M
.
add
s
env
env
.
theories
}
{
empty
with
theories
=
M
.
add
s
.
id
env
env
.
theories
}
(*
Local Variables:
compile-command: "make -C .. test"
End:
*)
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