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
bb227958
Commit
bb227958
authored
8 years ago
by
Mario Pereira
Browse files
Options
Downloads
Patches
Plain Diff
Coercions (wip)
parent
5d20ed14
Branches
Branches containing commit
Tags
Tags containing commit
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
src/core/dterm.ml
+26
-32
26 additions, 32 deletions
src/core/dterm.ml
src/core/theory.ml
+7
-9
7 additions, 9 deletions
src/core/theory.ml
with
33 additions
and
41 deletions
src/core/dterm.ml
+
26
−
32
View file @
bb227958
...
...
@@ -303,42 +303,36 @@ let dpattern ?loc node =
let
dty
,
vars
=
Loc
.
try1
?
loc
get_dty
node
in
{
dp_node
=
node
;
dp_dty
=
dty
;
dp_vars
=
vars
;
dp_loc
=
loc
}
let
dterm
tuc
?
loc
node
=
let
rec
dterm_expected
dt
dty
=
let
rec
dterm_expected
dt
dty
=
match
dt
.
dt_dty
with
|
Some
dt_dty
->
begin
try
dty_unify
dt_dty
dty
;
dt
with
Exit
->
begin
match
ty_of_dty
false
dt_dty
,
ty_of_dty
false
dty
with
|
{
ty_node
=
Tyapp
(
ts1
,
_
)
}
,
{
ty_node
=
Tyapp
(
ts2
,
_
)
}
->
begin
try
let
ls
=
Mts
.
find
ts2
(
Mts
.
find
ts1
tuc
.
Theory
.
uc_crcmap
)
in
dterm_node
loc
(
DTapp
(
ls
,
[
dt
]))
with
Not_found
->
Loc
.
errorm
?
loc
:
dt
.
dt_loc
"This term has type %a,@ but is expected to have type %a"
print_dty
dt_dty
print_dty
dty
end
|
_
->
Loc
.
errorm
?
loc
:
dt
.
dt_loc
"This term has type %a,@ but is expected to have type %a"
print_dty
dt_dty
print_dty
dty
end
end
begin
try
dty_unify
dt_dty
dty
;
dt
with
Exit
->
begin
match
ty_of_dty
false
dt_dty
,
ty_of_dty
false
dty
with
|
{
ty_node
=
Tyapp
(
ts1
,
_
)
}
,
{
ty_node
=
Tyapp
(
ts2
,
_
)
}
->
begin
try
let
ls
=
Mts
.
find
ts2
(
Mts
.
find
ts1
tuc
.
Theory
.
uc_crcmap
)
in
dterm_node
loc
(
DTapp
(
ls
,
[
dt
]))
with
Not_found
->
Loc
.
errorm
?
loc
:
dt
.
dt_loc
"This term has type %a,@ but is expected to have type %a"
print_dty
dt_dty
print_dty
dty
end
|
_
->
Loc
.
errorm
?
loc
:
dt
.
dt_loc
"This term has type %a,@ but is expected to have type %a"
print_dty
dt_dty
print_dty
dty
end
end
|
None
->
try
dty_unify
dty_bool
dty
;
dt
with
Exit
->
Loc
.
error
?
loc
:
dt
.
dt_loc
TermExpected
try
dty_unify
dty_bool
dty
;
dt
with
Exit
->
Loc
.
error
?
loc
:
dt
.
dt_loc
TermExpected
and
dterm_node
loc
node
=
let
f
ty
=
{
dt_node
=
node
;
dt_dty
=
ty
;
dt_loc
=
loc
}
in
...
...
This diff is collapsed.
Click to expand it.
src/core/theory.ml
+
7
−
9
View file @
bb227958
...
...
@@ -348,15 +348,15 @@ let known_meta kn al =
let
add_coercion
crcmap
m
al
=
match
al
with
|
[
MAls
({
ls_args
=
[{
ty_node
=
Tyapp
(
ty1
,_
)
}];
ls_value
=
Some
{
ty_node
=
Tyapp
(
ty2
,_
)
}}
as
ls
)]
->
let
crcmap1
=
try
Mts
.
find
ty1
crcmap
with
Not_found
->
Mts
.
empty
in
|
[
MAls
({
ls_args
=
[{
ty_node
=
Tyapp
(
ty1
,_
)
}];
ls_value
=
Some
{
ty_node
=
Tyapp
(
ty2
,_
)
}}
as
ls
)]
->
let
crcmap1
=
try
Mts
.
find
ty1
crcmap
with
Not_found
->
Mts
.
empty
in
let
crcmap2
=
Mts
.
add
ty2
ls
crcmap1
in
Mts
.
add
ty1
crcmap2
crcmap
|
_
->
assert
false
let
meta_coercion
=
register_meta
~
desc
:
"coercion"
"coercion"
[
MTlsymbol
]
let
add_tdecl
uc
td
=
match
td
.
td_node
with
|
Decl
d
->
{
uc
with
uc_decls
=
td
::
uc
.
uc_decls
;
...
...
@@ -369,10 +369,9 @@ let add_tdecl uc td = match td.td_node with
uc_used
=
Sid
.
union
uc
.
uc_used
(
Sid
.
add
th
.
th_name
th
.
th_used
)
}
|
Clone
(
_
,
sm
)
->
known_clone
uc
.
uc_known
sm
;
{
uc
with
uc_decls
=
td
::
uc
.
uc_decls
}
|
Meta
(
m
,
al
)
when
m
.
meta_
name
=
"
coercion
"
->
|
Meta
(
m
,
al
)
when
meta_
equal
m
meta_
coercion
->
known_meta
uc
.
uc_known
al
;
{
uc
with
uc_decls
=
td
::
uc
.
uc_decls
;
uc_crcmap
=
add_coercion
uc
.
uc_crcmap
m
al
}
{
uc
with
uc_crcmap
=
add_coercion
uc
.
uc_crcmap
m
al
}
|
Meta
(
_
,
al
)
->
known_meta
uc
.
uc_known
al
;
{
uc
with
uc_decls
=
td
::
uc
.
uc_decls
}
...
...
@@ -839,7 +838,6 @@ let builtin_theory =
let
uc
=
add_ty_decl
uc
ts_int
in
let
uc
=
add_ty_decl
uc
ts_real
in
let
uc
=
add_param_decl
uc
ps_equ
in
let
_
=
register_meta
~
desc
:
"coercion"
"coercion"
[
MTlsymbol
]
in
close_theory
uc
let
create_theory
?
(
path
=
[]
)
n
=
...
...
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