Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
e0185eef
Commit
e0185eef
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-10-21 18:58:02 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-21 18:58:02+00:00
parent
898cb1fb
Changes
4
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
e0185eef
...
...
@@ -21,6 +21,9 @@ let prog () =
with
|
Stdpp
.
Exc_located
(
loc
,
e
)
->
raise
(
Location
(
loc
,
e
))
let
print_norm
ppf
d
=
Types
.
Print
.
print_descr
ppf
(
Types
.
normalize
d
)
let
rec
print_exn
ppf
=
function
|
Location
((
i
,
j
)
,
exn
)
->
if
source
=
""
then
...
...
@@ -40,26 +43,26 @@ let rec print_exn ppf = function
Format
.
fprintf
ppf
"Wrong record selection: the label %s@
\n
"
(
Types
.
label_name
l
);
Format
.
fprintf
ppf
"applied to an expression of type %a@
\n
"
Types
.
Print
.
print_descr
t
print_norm
t
|
Typer
.
MultipleLabel
l
->
Format
.
fprintf
ppf
"Multiple occurences for the record label %s@
\n
"
(
Types
.
label_name
l
);
|
Typer
.
ShouldHave
(
t
,
msg
)
->
Format
.
fprintf
ppf
"This expression should have type %a@
\n
%s@
\n
"
Types
.
Print
.
print_descr
t
print_norm
t
msg
|
Typer
.
Constraint
(
s
,
t
,
msg
)
->
Format
.
fprintf
ppf
"This expression should have type %a@
\n
"
Types
.
Print
.
print_descr
t
;
print_norm
t
;
Format
.
fprintf
ppf
"but its infered type is: %a@
\n
"
Types
.
Print
.
print_descr
s
;
print_norm
s
;
Format
.
fprintf
ppf
"which is not a subtype, as shown by the value %a@
\n
"
Types
.
Print
.
print_sample
(
Types
.
Sample
.
get
(
Types
.
diff
s
t
));
Format
.
fprintf
ppf
"%s@
\n
"
msg
|
Typer
.
NonExhaustive
t
->
Format
.
fprintf
ppf
"This pattern matching is not exhaustive@
\n
"
;
Format
.
fprintf
ppf
"Residual type: %a@
\n
"
Types
.
Print
.
print_descr
t
;
print_norm
t
;
Format
.
fprintf
ppf
"Sample value: %a@
\n
"
Types
.
Print
.
print_sample
(
Types
.
Sample
.
get
t
)
|
exn
->
...
...
types/types.ml
View file @
e0185eef
...
...
@@ -454,8 +454,13 @@ struct
let
restrict_label_present
t
l
=
let
aux
=
SortedMap
.
change
l
(
fun
(
_
,
d
)
->
(
false
,
d
))
(
false
,
any
)
in
List
.
map
aux
t
let
restr
=
function
|
(
true
,
d
)
->
if
non_empty
d
then
(
false
,
d
)
else
raise
Exit
|
x
->
x
in
let
aux
accu
r
=
try
SortedMap
.
change
l
restr
(
false
,
any
)
r
::
accu
with
Exit
->
accu
in
List
.
fold_left
aux
[]
t
let
restrict_label_absent
t
l
=
let
restr
=
function
(
true
,
_
)
->
(
true
,
empty
)
|
_
->
raise
Exit
in
...
...
@@ -481,6 +486,9 @@ struct
in
List
.
fold_left
aux
empty
t
let
project
d
l
=
project_field
(
get_record
d
.
record
)
l
type
normal
=
[
`Success
|
`Fail
...
...
@@ -519,31 +527,33 @@ struct
let
normal
d
=
List
.
fold_left
merge_record
`Fail
(
get
d
)
let
project
d
l
=
let
aux
accu
x
=
match
List
.
assoc
l
x
with
|
(
false
,
t
)
->
cup
accu
t
|
_
->
raise
Not_found
in
List
.
fold_left
aux
empty
(
get_record
d
.
record
)
let
any
=
{
empty
with
record
=
any
.
record
}
let
is_empty
d
=
d
=
[]
end
module
DescrHash
=
Hashtbl
.
Make
(
struct
type
t
=
descr
let
hash
=
hash_descr
let
equal
=
equal_descr
end
)
module
MapDescr
=
Map
.
Make
(
struct
type
t
=
descr
let
compare
=
compare
end
)
let
memo_normalize
=
ref
MapDescr
.
empty
let
memo_normalize
=
DescrHash
.
create
17
let
map_sort
f
l
=
SortedList
.
from_list
(
List
.
map
f
l
)
let
rec
rec_normalize
d
=
try
Map
Descr
.
find
d
!
memo_normalize
try
Descr
Hash
.
find
memo_normalize
d
with
Not_found
->
let
n
=
make
()
in
memo_normalize
:=
Map
Descr
.
add
d
n
!
memo_normalize
;
Descr
Hash
.
add
memo_normalize
d
n
;
let
times
=
map_sort
(
fun
(
d1
,
d2
)
->
[(
rec_normalize
d1
,
rec_normalize
d2
)]
,
[]
)
...
...
@@ -558,16 +568,7 @@ let rec rec_normalize d =
n
let
normalize
n
=
internalize
(
rec_normalize
(
descr
n
))
module
DescrHash
=
Hashtbl
.
Make
(
struct
type
t
=
descr
let
hash
=
hash_descr
let
equal
=
equal_descr
end
)
descr
(
internalize
(
rec_normalize
n
))
module
Print
=
struct
...
...
types/types.mli
View file @
e0185eef
...
...
@@ -151,7 +151,7 @@ module Atom : sig
val
has_atom
:
descr
->
atom
->
bool
end
val
normalize
:
node
->
node
val
normalize
:
descr
->
descr
(** Subtyping and sample values **)
...
...
typing/typer.ml
View file @
e0185eef
...
...
@@ -333,7 +333,10 @@ let rec expr { loc = loc; descr = d } =
let
(
fv
,
e
)
=
expr
e
in
(
fv
,
Typed
.
Dot
(
e
,
l
))
|
RecordLitt
r
->
(* XXX TODO: check that no label appears twice *)
(* Note: quadratic check for non duplication of labels.
Should improve that to O(n log n) for dealing
with huge number of attributes ?
*)
let
fv
=
ref
Fv
.
empty
in
let
labs
=
ref
[]
in
let
r
=
List
.
map
...
...
@@ -435,6 +438,35 @@ and type_check' loc env e constr precise = match e with
Types
.
times
(
Types
.
cons
t1
)
(
Types
.
cons
t2
)
else
constr
|
RecordLitt
r
->
let
rconstr
=
Types
.
Record
.
get
constr
in
if
Types
.
Record
.
is_empty
rconstr
then
raise_loc
loc
(
ShouldHave
(
constr
,
"but it is a record."
));
let
(
rconstr
,
res
)
=
List
.
fold_left
(
fun
(
rconstr
,
res
)
(
l
,
e
)
->
let
rconstr
=
Types
.
Record
.
restrict_label_present
rconstr
l
in
let
pi
=
Types
.
Record
.
project_field
rconstr
l
in
if
Types
.
Record
.
is_empty
rconstr
then
raise_loc
loc
(
ShouldHave
(
constr
,
(
Printf
.
sprintf
"Field %s is not allowed here."
(
Types
.
label_name
l
)
)
));
let
t
=
type_check
env
e
pi
true
in
let
rconstr
=
Types
.
Record
.
restrict_field
rconstr
l
t
in
let
res
=
if
precise
then
Types
.
cap
res
(
Types
.
record
l
false
(
Types
.
cons
t
))
else
res
in
(
rconstr
,
res
)
)
(
rconstr
,
if
precise
then
Types
.
Record
.
any
else
constr
)
r
in
res
|
_
->
let
t
:
Types
.
descr
=
compute_type'
loc
env
e
in
check
loc
t
constr
""
;
...
...
@@ -460,13 +492,6 @@ and compute_type' loc env = function
let
t
=
type_check
env
e
Types
.
Record
.
any
true
in
(
try
(
Types
.
Record
.
project
t
l
)
with
Not_found
->
raise_loc
loc
(
WrongLabel
(
t
,
l
)))
|
RecordLitt
r
->
List
.
fold_left
(
fun
accu
(
l
,
e
)
->
let
t
=
compute_type
env
e
in
let
t
=
Types
.
record
l
false
(
Types
.
cons
t
)
in
Types
.
cap
accu
t
)
Types
.
Record
.
any
r
|
Op
(
op
,
el
)
->
let
args
=
List
.
map
(
fun
e
->
(
e
.
exp_loc
,
compute_type
env
e
))
el
in
type_op
loc
op
args
...
...
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