Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
why3
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
126
Issues
126
List
Boards
Labels
Service Desk
Milestones
Merge Requests
16
Merge Requests
16
Operations
Operations
Incidents
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Why3
why3
Commits
bb227958
Commit
bb227958
authored
Feb 07, 2017
by
Mário Pereira
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Coercions (wip)
parent
5d20ed14
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
33 additions
and
41 deletions
+33
-41
src/core/dterm.ml
src/core/dterm.ml
+26
-32
src/core/theory.ml
src/core/theory.ml
+7
-9
No files found.
src/core/dterm.ml
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
...
...
src/core/theory.ml
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
m
eta_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
=
...
...
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