Mentions légales du service
Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
why3
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Deploy
Releases
Container registry
Monitor
Service Desk
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Why3
why3
Commits
f9932cac
Commit
f9932cac
authored
13 years ago
by
Andrei Paskevich
Browse files
Options
Downloads
Patches
Plain Diff
whyml: typing
parent
3e70b6b9
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
src/whyml/mlw_dty.ml
+25
-13
25 additions, 13 deletions
src/whyml/mlw_dty.ml
tests/test-pgm-jcf.mlx
+4
-2
4 additions, 2 deletions
tests/test-pgm-jcf.mlx
with
29 additions
and
15 deletions
src/whyml/mlw_dty.ml
+
25
−
13
View file @
f9932cac
...
@@ -42,8 +42,9 @@ and dity_desc = {
...
@@ -42,8 +42,9 @@ and dity_desc = {
and
dity_node
=
and
dity_node
=
|
Duvar
of
Ptree
.
ident
(* user type variable *)
|
Duvar
of
Ptree
.
ident
(* user type variable *)
|
Dvar
|
Dvar
|
Dits
of
itysymbol
*
dity
list
*
dreg
list
|
Dskip
of
dity
|
Dts
of
tysymbol
*
dity
list
|
Dits
of
itysymbol
*
dity
list
*
dreg
list
|
Dts
of
tysymbol
*
dity
list
and
dreg
=
dreg_desc
ref
and
dreg
=
dreg_desc
ref
...
@@ -70,6 +71,8 @@ let ity_of_dity d = Lazy.force !d.ity
...
@@ -70,6 +71,8 @@ let ity_of_dity d = Lazy.force !d.ity
let
reg_of_dreg
d
=
Lazy
.
force
!
d
.
reg
let
reg_of_dreg
d
=
Lazy
.
force
!
d
.
reg
let
create_skip
d
=
create
(
Dskip
d
)
(
lazy
(
ity_of_dity
d
))
let
create_dreg
~
user
dity
=
let
create_dreg
~
user
dity
=
ref
{
rid
=
unique
()
;
rity
=
dity
;
ruser
=
user
;
ref
{
rid
=
unique
()
;
rity
=
dity
;
ruser
=
user
;
reg
=
lazy
(
create_region
(
id_fresh
"rho"
)
(
ity_of_dity
dity
))
}
reg
=
lazy
(
create_region
(
id_fresh
"rho"
)
(
ity_of_dity
dity
))
}
...
@@ -127,27 +130,32 @@ let ts_app ts dl = match ts.ts_def with
...
@@ -127,27 +130,32 @@ let ts_app ts dl = match ts.ts_def with
(* unification *)
(* unification *)
let
rec
unify
d1
d2
=
let
rec
unify
d1
d2
=
if
!
d1
.
uid
<>
!
d2
.
uid
then
begin
if
!
d1
.
uid
<>
!
d2
.
uid
then
begin
match
!
d1
.
node
,
!
d2
.
node
with
match
!
d1
.
node
,
!
d2
.
node
with
|
Dskip
d1
,
_
->
unify
d1
d2
|
_
,
Dskip
d2
->
unify
d1
d2
|
Dvar
,
Dvar
->
d1
:=
!
(
create_skip
d2
)
|
Dvar
,
_
->
|
Dvar
,
_
->
()
d1
:=
!
d2
|
_
,
Dvar
->
|
_
,
Dvar
->
d2
:=
!
d1
d2
:=
!
d1
|
Duvar
s1
,
Duvar
s2
when
s1
.
id
=
s2
.
id
->
|
Duvar
s1
,
Duvar
s2
when
s1
.
id
=
s2
.
id
->
()
d1
:=
!
d2
|
Dits
(
its1
,
dl1
,
rl1
)
,
Dits
(
its2
,
dl2
,
rl2
)
when
its_equal
its1
its2
->
|
Dits
(
its1
,
dl1
,
rl1
)
,
Dits
(
its2
,
dl2
,
rl2
)
when
its_equal
its1
its2
->
assert
(
List
.
length
rl1
=
List
.
length
rl2
);
assert
(
List
.
length
rl1
=
List
.
length
rl2
);
assert
(
List
.
length
dl1
=
List
.
length
dl2
);
assert
(
List
.
length
dl1
=
List
.
length
dl2
);
List
.
iter2
unify
dl1
dl2
;
List
.
iter2
unify
dl1
dl2
;
List
.
iter2
unify_reg
rl1
rl2
List
.
iter2
unify_reg
rl1
rl2
;
d1
:=
!
d2
|
Dts
(
ts1
,
dl1
)
,
Dts
(
ts2
,
dl2
)
when
ts_equal
ts1
ts2
->
|
Dts
(
ts1
,
dl1
)
,
Dts
(
ts2
,
dl2
)
when
ts_equal
ts1
ts2
->
assert
(
List
.
length
dl1
=
List
.
length
dl2
);
assert
(
List
.
length
dl1
=
List
.
length
dl2
);
List
.
iter2
unify
dl1
dl2
List
.
iter2
unify
dl1
dl2
;
d1
:=
!
d2
|
_
->
|
_
->
raise
Exit
raise
Exit
end
;
d1
:=
!
d2
end
and
unify_reg
r1
r2
=
and
unify_reg
r1
r2
=
if
!
r1
.
rid
<>
!
r2
.
rid
then
if
!
r1
.
rid
<>
!
r2
.
rid
then
...
@@ -185,6 +193,7 @@ let empty_tvars = Sint.empty
...
@@ -185,6 +193,7 @@ let empty_tvars = Sint.empty
let
rec
add_tvars
tvs
d
=
match
!
d
.
node
with
let
rec
add_tvars
tvs
d
=
match
!
d
.
node
with
|
Duvar
_
|
Dvar
->
Sint
.
add
!
d
.
uid
tvs
|
Duvar
_
|
Dvar
->
Sint
.
add
!
d
.
uid
tvs
|
Dskip
d
->
add_tvars
tvs
d
|
Dits
(
_
,
dl
,
rl
)
->
|
Dits
(
_
,
dl
,
rl
)
->
let
add_reg
tvs
r
=
add_tvars
(
Sint
.
add
!
r
.
rid
tvs
)
!
r
.
rity
in
let
add_reg
tvs
r
=
add_tvars
(
Sint
.
add
!
r
.
rid
tvs
)
!
r
.
rity
in
List
.
fold_left
add_reg
(
List
.
fold_left
add_tvars
tvs
dl
)
rl
List
.
fold_left
add_reg
(
List
.
fold_left
add_tvars
tvs
dl
)
rl
...
@@ -196,6 +205,7 @@ let specialize_scheme tvs dity =
...
@@ -196,6 +205,7 @@ let specialize_scheme tvs dity =
let
hr
=
Hashtbl
.
create
17
in
let
hr
=
Hashtbl
.
create
17
in
let
rec
specialize
d
=
match
!
d
.
node
with
let
rec
specialize
d
=
match
!
d
.
node
with
|
Duvar
_
|
Dvar
when
Sint
.
mem
!
d
.
uid
tvs
->
d
|
Duvar
_
|
Dvar
when
Sint
.
mem
!
d
.
uid
tvs
->
d
|
Dskip
d
->
specialize
d
|
Duvar
id
->
begin
|
Duvar
id
->
begin
try
Hashtbl
.
find
huv
id
.
id
try
Hashtbl
.
find
huv
id
.
id
with
Not_found
->
with
Not_found
->
...
@@ -231,8 +241,10 @@ let find_type_variable htv tv =
...
@@ -231,8 +241,10 @@ let find_type_variable htv tv =
dtv
dtv
let
rec
dity_of_ity
~
user
htv
hreg
ity
=
match
ity
.
ity_node
with
let
rec
dity_of_ity
~
user
htv
hreg
ity
=
match
ity
.
ity_node
with
|
Ityvar
tv
->
assert
(
not
user
);
find_type_variable
htv
tv
|
Ityvar
tv
->
|
Itypur
(
ts
,
ityl
)
->
ts_app
ts
(
List
.
map
(
dity_of_ity
~
user
htv
hreg
)
ityl
)
assert
(
not
user
);
find_type_variable
htv
tv
|
Itypur
(
ts
,
ityl
)
->
ts_app_real
ts
(
List
.
map
(
dity_of_ity
~
user
htv
hreg
)
ityl
)
|
Ityapp
(
its
,
ityl
,
rl
)
->
|
Ityapp
(
its
,
ityl
,
rl
)
->
its_app_real
its
(
List
.
map
(
dity_of_ity
~
user
htv
hreg
)
ityl
)
its_app_real
its
(
List
.
map
(
dity_of_ity
~
user
htv
hreg
)
ityl
)
(
List
.
map
(
dreg_of_reg
~
user
htv
hreg
)
rl
)
(
List
.
map
(
dreg_of_reg
~
user
htv
hreg
)
rl
)
...
...
This diff is collapsed.
Click to expand it.
tests/test-pgm-jcf.mlx
+
4
−
2
View file @
f9932cac
...
@@ -19,9 +19,11 @@ module N
...
@@ -19,9 +19,11 @@ module N
type tree 'a = Node 'a (forest 'a) | Leaf
type tree 'a = Node 'a (forest 'a) | Leaf
with forest 'a = Cons (tree 'a) (forest 'a) | Nil
with forest 'a = Cons (tree 'a) (forest 'a) | Nil
type ref '
a
= {| ghost mutable contents : '
a
|}
type ref '
b
= {| ghost mutable contents : '
b
|}
let f x = x.contents + zero
function id (tree 'c) : (tree 'c)
let h (x : tree 'd) = ((id x) : tree 'd)
end
end
(*
(*
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment