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
0b7dd234
Commit
0b7dd234
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-10-16 08:58:50 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-16 08:58:50+00:00
parent
26567975
Changes
4
Hide whitespace changes
Inline
Side-by-side
parser/parser.ml
View file @
0b7dd234
...
...
@@ -24,8 +24,7 @@ open Ast
GLOBAL
:
prog
expr
pat
regexp
const
;
prog
:
[
[
l
=
LIST0
[
e
=
expr
->
mk
loc
(
EvalStatement
e
)
]
SEP
";;"
;
"EOF"
->
l
]
[
l
=
LIST0
[
e
=
expr
;
";;"
->
mk
loc
(
EvalStatement
e
)
]
->
l
]
];
expr
:
[
...
...
types/types.ml
View file @
0b7dd234
...
...
@@ -551,44 +551,6 @@ let rec rec_normalize d =
let
normalize
n
=
internalize
(
rec_normalize
(
descr
n
))
let
apply_simple
result
left
t
=
let
ok
=
ref
false
in
let
rec
aux
result
accu1
accu2
=
function
|
(
t1
,
s1
)
::
left
->
let
result
=
let
accu1
=
diff_t
accu1
t1
in
if
non_empty
accu1
then
aux
result
accu1
accu2
left
else
(
ok
:=
true
;
result
)
in
let
result
=
let
accu2
=
cap_t
accu2
s1
in
aux
result
accu1
accu2
left
in
result
|
[]
->
if
subtype
accu2
result
then
result
else
cup
result
accu2
in
let
result
=
aux
result
t
any
left
in
if
!
ok
then
result
else
raise
Not_found
let
apply
t1
t2
=
if
is_empty
t2
then
empty
else
if
non_empty
{
t1
with
arrow
=
[]
}
then
raise
Not_found
else
List
.
fold_left
(
fun
accu
(
left
,
right
)
->
if
Sample
.
check_empty_arrow_line
left
right
then
accu
else
apply_simple
accu
left
t2
)
empty
t1
.
arrow
module
Print
=
struct
let
marks
=
Hashtbl
.
create
63
...
...
@@ -596,7 +558,9 @@ struct
let
count_name
=
ref
0
let
name
()
=
incr
count_name
;
"'a"
^
(
string_of_int
!
count_name
)
"X"
^
(
string_of_int
!
count_name
)
(* TODO:
check that these generated names does not conflict with declared types *)
let
bool_iter
f
b
=
List
.
iter
(
fun
(
p
,
n
)
->
List
.
iter
f
p
;
List
.
iter
f
n
)
b
...
...
@@ -715,6 +679,54 @@ struct
)
iface
end
module
Arrow
=
struct
type
t
=
descr
*
(
descr
*
descr
)
list
list
let
get
t
=
List
.
fold_left
(
fun
((
dom
,
arr
)
as
accu
)
(
left
,
right
)
->
if
Sample
.
check_empty_arrow_line
left
right
then
accu
else
(
let
left
=
List
.
map
(
fun
(
t
,
s
)
->
(
descr
t
,
descr
s
))
left
in
let
d
=
List
.
fold_left
(
fun
d
(
t
,_
)
->
cup
d
t
)
empty
left
in
(
cap
dom
d
,
left
::
arr
)
)
)
(
any
,
[]
)
t
.
arrow
let
domain
(
dom
,_
)
=
dom
let
apply_simple
t
result
left
=
let
rec
aux
result
accu1
accu2
=
function
|
(
t1
,
s1
)
::
left
->
let
result
=
let
accu1
=
diff
accu1
t1
in
if
non_empty
accu1
then
aux
result
accu1
accu2
left
else
result
in
let
result
=
let
accu2
=
cap
accu2
s1
in
aux
result
accu1
accu2
left
in
result
|
[]
->
if
subtype
accu2
result
then
result
else
cup
result
accu2
in
aux
result
t
any
left
let
apply
(
_
,
arr
)
t
=
List
.
fold_left
(
apply_simple
t
)
empty
arr
let
any
=
{
empty
with
arrow
=
any
.
arrow
}
end
(*
let rec print_normal_record ppf = function
| Success -> Format.fprintf ppf "Yes"
...
...
types/types.mli
View file @
0b7dd234
...
...
@@ -100,10 +100,20 @@ module Record : sig
(* Raise Not_found if label is not necessarily present *)
end
module
Arrow
:
sig
val
any
:
descr
val
normalize
:
node
->
node
type
t
val
get
:
descr
->
t
(* Always succeed; no check <= Arrow.any *)
val
apply
:
descr
->
descr
->
descr
val
domain
:
t
->
descr
val
apply
:
t
->
descr
->
descr
(* Always succeed; no check on the domain *)
end
val
normalize
:
node
->
node
(** Subtyping and sample values **)
...
...
typing/typer.ml
View file @
0b7dd234
...
...
@@ -366,7 +366,23 @@ and compute_type' loc env = function
|
Var
s
->
Env
.
find
s
env
|
Apply
(
e1
,
e2
)
->
let
t1
=
compute_type
env
e1
and
t2
=
compute_type
env
e2
in
Types
.
apply
t1
t2
if
Types
.
is_empty
t2
then
Types
.
empty
else
if
Types
.
subtype
t1
Types
.
Arrow
.
any
then
let
t1
=
Types
.
Arrow
.
get
t1
in
let
dom
=
Types
.
Arrow
.
domain
t1
in
if
Types
.
subtype
t2
dom
then
Types
.
Arrow
.
apply
t1
t2
else
raise_loc
loc
(
Constraint
(
t2
,
dom
,
"The argument is not in the domain of the function"
))
else
raise_loc
loc
(
Constraint
(
t1
,
Types
.
Arrow
.
any
,
"The expression in function position is not necessarily a function"
))
|
Abstraction
a
->
let
env
=
match
a
.
fun_name
with
|
None
->
env
...
...
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