Skip to content
GitLab
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
d68414df
Commit
d68414df
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-10-14 22:05:40 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-14 22:05:40+00:00
parent
f2814134
Changes
5
Hide whitespace changes
Inline
Side-by-side
depend
View file @
d68414df
parser/ast.cmo:
parser/location.cmi
types/patterns.cmi types/types.cmi
parser/ast.cmx:
parser/location.cmx
types/patterns.cmx types/types.cmx
parser/ast.cmo: types/patterns.cmi types/types.cmi
parser/ast.cmx: types/patterns.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo parser/location.cmi types/types.cmi \
...
...
parser/parser.ml
View file @
d68414df
...
...
@@ -66,7 +66,7 @@ module P = struct
];
arrow
:
[
[
t1
=
pat
LEVEL
"
p
ro
d
"
;
"->"
;
t2
=
pat
->
(
t1
,
t2
)]
[
t1
=
pat
LEVEL
"
no_ar
ro
w
"
;
"->"
;
t2
=
pat
->
(
t1
,
t2
)]
];
branches
:
[
...
...
@@ -130,8 +130,8 @@ module P = struct
mk
loc
(
Record
(
Types
.
label
l
,
o
,
x
))
]
SEP
";"
->
match
r
with
|
[]
->
mk
no
loc
(
Internal
Types
.
Record
.
any
)
|
h
::
t
->
List
.
fold_left
(
fun
t1
t2
->
mk
no
loc
(
And
(
t1
,
t2
)))
h
t
|
[]
->
mk
loc
(
Internal
Types
.
Record
.
any
)
|
h
::
t
->
List
.
fold_left
(
fun
t1
t2
->
mk
loc
(
And
(
t1
,
t2
)))
h
t
]
];
const
:
...
...
typing/typed.ml
View file @
d68414df
...
...
@@ -14,7 +14,7 @@ open Location
type
tpat
=
Patterns
.
node
type
ttyp
=
Types
.
node
type
texpr
=
{
exp_loc
:
Location
.
loc
;
type
texpr
=
{
exp_loc
:
loc
;
mutable
exp_typ
:
Types
.
descr
;
exp_descr
:
texpr'
;
}
...
...
@@ -36,18 +36,21 @@ and texpr' =
and
abstr
=
{
fun_name
:
string
option
;
fun_iface
:
(
ttyp
*
ttyp
)
list
;
fun_iface
:
(
Types
.
descr
*
Types
.
descr
)
list
;
fun_body
:
branches
;
fun_typ
:
Types
.
descr
;
fun_fv
:
string
list
;
}
and
branches
=
branch
list
and
branch
=
{
mutable
br_used
:
bool
;
mutable
br_typ
:
Types
.
descr
;
(* TODO: move to branches and update *)
br_pat
:
tpat
;
br_body
:
texpr
}
and
branches
=
{
mutable
br_typ
:
Types
.
descr
;
br_branches
:
branch
list
}
and
branch
=
{
mutable
br_used
:
bool
;
br_pat
:
tpat
;
br_body
:
texpr
}
and
op
=
string
typing/typer.ml
View file @
d68414df
...
...
@@ -3,14 +3,17 @@
open
Location
open
Ast
exception
ParsingPattern
of
string
let
raise_loc
loc
msg
=
raise
(
Location
loc
(
ParsingPattern
msg
))
exception
Pattern
of
string
exception
NonExhaustive
of
Types
.
descr
exception
Constraint
of
Types
.
descr
*
Types
.
descr
*
string
let
raise_loc
loc
exn
=
raise
(
Location
(
loc
,
exn
))
(* Internal representation as a graph (desugar recursive types and regexp),
to compute freevars, etc... *)
type
ti
=
{
type
ti
=
{
id
:
int
;
mutable
loc'
:
loc
;
mutable
fv
:
string
SortedList
.
t
option
;
...
...
@@ -19,7 +22,7 @@ type ti = {
mutable
pat_node
:
Patterns
.
node
option
}
and
descr
=
[
`Alias
of
ti
[
`Alias
of
string
*
ti
|
`Type
of
Types
.
descr
|
`Or
of
ti
*
ti
|
`And
of
ti
*
ti
...
...
@@ -41,8 +44,14 @@ let mk' =
let
counter
=
ref
0
in
fun
()
->
incr
counter
;
let
rec
x
=
{
id
=
!
counter
;
loc'
=
noloc
;
fv
=
None
;
descr'
=
`Alias
x
;
type_node
=
None
;
pat_node
=
None
}
in
let
rec
x
=
{
id
=
!
counter
;
loc'
=
noloc
;
fv
=
None
;
descr'
=
`Alias
(
"__dummy__"
,
x
);
type_node
=
None
;
pat_node
=
None
}
in
x
let
cons
loc
d
=
...
...
@@ -146,13 +155,16 @@ let rec compile env { loc = loc; descr = d } : ti =
match
(
d
:
Ast
.
ppat'
)
with
|
PatVar
s
->
(
try
StringMap
.
find
s
env
with
Not_found
->
raise_loc
loc
"Undefined variable"
with
Not_found
->
raise_loc
loc
(
Pattern
(
"Undefined type variable "
^
s
))
)
|
Recurs
(
t
,
b
)
->
let
b
=
List
.
map
(
fun
(
v
,
t
)
->
(
v
,
t
,
mk'
()
))
b
in
let
env
=
List
.
fold_left
(
fun
env
(
v
,
t
,
x
)
->
StringMap
.
add
v
x
env
)
env
b
in
List
.
iter
(
fun
(
v
,
t
,
x
)
->
x
.
descr'
<-
`Alias
(
compile
env
t
))
b
;
List
.
iter
(
fun
(
v
,
t
,
x
)
->
x
.
loc'
<-
t
.
loc
;
x
.
descr'
<-
`Alias
(
v
,
compile
env
t
))
b
;
compile
env
t
|
Regexp
(
r
,
q
)
->
compile
env
(
Regexp
.
compile
r
q
)
|
Internal
t
->
cons
loc
(
`Type
t
)
...
...
@@ -171,7 +183,7 @@ let rec comp_fv seen s =
|
None
->
let
l
=
match
s
.
descr'
with
|
`Alias
x
->
if
List
.
memq
s
seen
then
[]
else
comp_fv
(
s
::
seen
)
x
|
`Alias
(
_
,
x
)
->
if
List
.
memq
s
seen
then
[]
else
comp_fv
(
s
::
seen
)
x
|
`Or
(
s1
,
s2
)
|
`And
(
s1
,
s2
)
|
`Diff
(
s1
,
s2
)
...
...
@@ -190,8 +202,11 @@ let fv = comp_fv []
let
rec
typ
seen
s
:
Types
.
descr
=
match
s
.
descr'
with
|
`Alias
x
->
if
List
.
memq
s
seen
then
failwith
"Unguarded recursion in this type"
|
`Alias
(
v
,
x
)
->
if
List
.
memq
s
seen
then
raise_loc
s
.
loc'
(
Pattern
(
"Unguarded recursion on variable "
^
v
^
" in this type"
))
else
typ
(
s
::
seen
)
x
|
`Type
t
->
t
|
`Or
(
s1
,
s2
)
->
Types
.
cup
(
typ
seen
s1
)
(
typ
seen
s2
)
...
...
@@ -200,7 +215,7 @@ let rec typ seen s : Types.descr =
|
`Times
(
s1
,
s2
)
->
Types
.
times
(
typ_node
s1
)
(
typ_node
s2
)
|
`Arrow
(
s1
,
s2
)
->
Types
.
arrow
(
typ_node
s1
)
(
typ_node
s2
)
|
`Record
(
l
,
o
,
s
)
->
Types
.
record
l
o
(
typ_node
s
)
|
_
->
failwith
"This is not a type"
|
`Capture
_
|
`Constant
_
->
assert
false
and
typ_node
s
:
Types
.
node
=
match
s
.
type_node
with
...
...
@@ -217,19 +232,29 @@ let type_node s = Types.internalize (typ_node s)
let
rec
pat
seen
s
:
Patterns
.
descr
=
if
fv
s
=
[]
then
Patterns
.
constr
(
type_node
s
)
else
match
s
.
descr'
with
|
`Alias
x
->
if
List
.
memq
s
seen
then
failwith
"Unguarded recursion in this pattern"
|
`Alias
(
v
,
x
)
->
if
List
.
memq
s
seen
then
raise_loc
s
.
loc'
(
Pattern
(
"Unguarded recursion on variable "
^
v
^
" in this pattern"
))
else
pat
(
s
::
seen
)
x
|
`Or
(
s1
,
s2
)
->
Patterns
.
cup
(
pat
seen
s1
)
(
pat
seen
s2
)
|
`And
(
s1
,
s2
)
->
Patterns
.
cap
(
pat
seen
s1
)
(
pat
seen
s2
)
|
`Diff
(
s1
,
s2
)
when
fv
s2
=
[]
->
let
s2
=
Types
.
cons
(
Types
.
neg
(
Types
.
descr
(
type_node
s2
)))
in
Patterns
.
cap
(
pat
seen
s1
)
(
Patterns
.
constr
s2
)
|
`Diff
_
->
raise_loc
s
.
loc'
(
Pattern
"Difference not allowed in patterns"
)
|
`Times
(
s1
,
s2
)
->
Patterns
.
times
(
pat_node
s1
)
(
pat_node
s2
)
|
`Record
(
l
,
false
,
s
)
->
Patterns
.
record
l
(
pat_node
s
)
|
`Record
_
->
raise_loc
s
.
loc'
(
Pattern
"Optional field not allowed in record patterns"
)
|
`Capture
x
->
Patterns
.
capture
x
|
`Constant
(
x
,
c
)
->
Patterns
.
constant
x
c
|
_
->
failwith
"This is not a pattern"
|
`Arrow
_
->
raise_loc
s
.
loc'
(
Pattern
"Arrow not allowed in patterns"
)
|
`Type
_
->
assert
false
and
pat_node
s
:
Patterns
.
node
=
match
s
.
pat_node
with
...
...
@@ -243,7 +268,9 @@ and pat_node s : Patterns.node =
let
typ
e
=
let
e
=
compile
StringMap
.
empty
e
in
if
fv
e
=
[]
then
type_node
e
else
failwith
"This is not a type"
if
fv
e
=
[]
then
type_node
e
else
(
raise_loc
e
.
loc'
(
Pattern
"Capture variables are not allowed in types"
))
let
pat
e
=
let
e
=
compile
StringMap
.
empty
e
in
...
...
@@ -267,6 +294,9 @@ let rec expr { loc = loc; descr = d } =
let
t
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
Types
.
cap
accu
(
Types
.
arrow
t1
t2
))
Types
.
any
iface
in
let
iface
=
List
.
map
(
fun
(
t1
,
t2
)
->
(
Types
.
descr
t1
,
Types
.
descr
t2
))
iface
in
let
(
fv0
,
body
)
=
branches
a
.
fun_body
in
let
fv
=
match
a
.
fun_name
with
|
None
->
fv0
...
...
@@ -318,11 +348,10 @@ let rec expr { loc = loc; descr = d } =
let
(
fv2
,
e
)
=
expr
e
in
fv
:=
Fv
.
union
!
fv
fv2
;
{
Typed
.
br_used
=
false
;
Typed
.
br_typ
=
Types
.
empty
;
Typed
.
br_pat
=
pat
p
;
Typed
.
br_body
=
e
}
)
b
in
(
!
fv
,
b
)
(
!
fv
,
{
Typed
.
br_typ
=
Types
.
empty
;
Typed
.
br_branches
=
b
}
)
module
Env
=
StringMap
...
...
@@ -343,9 +372,9 @@ and compute_type' loc env = function
|
None
->
env
|
Some
f
->
Env
.
add
f
a
.
fun_typ
env
in
List
.
iter
(
fun
(
t1
,
t2
)
->
let
t
=
type_branches
env
(
Types
.
descr
t1
)
a
.
fun_body
in
if
not
(
Types
.
subtype
t
(
Types
.
descr
t2
)
)
then
f
ai
lwith
"Constraint not satisfied
"
let
t
=
type_branches
loc
env
t1
a
.
fun_body
in
if
not
(
Types
.
subtype
t
t2
)
then
r
ai
se_loc
loc
(
Constraint
(
t
,
t2
,
"Constraint not satisfied
in interface"
))
)
a
.
fun_iface
;
a
.
fun_typ
|
Cst
c
->
Types
.
constant
c
...
...
@@ -363,22 +392,25 @@ and compute_type' loc env = function
|
Op
(
op
,
e
)
->
assert
false
|
Match
(
e
,
b
)
->
let
t
=
compute_type
env
e
in
type_branches
env
t
b
type_branches
loc
env
t
b
|
Map
(
e
,
b
)
->
assert
false
and
type_branches
env
targ
br
anche
s
=
and
type_branches
loc
env
targ
brs
=
if
Types
.
is_empty
targ
then
Types
.
empty
else
branches_aux
env
targ
Types
.
empty
branches
else
(
brs
.
br_typ
<-
Types
.
cup
brs
.
br_typ
targ
;
branches_aux
loc
env
targ
Types
.
empty
brs
.
br_branches
)
and
branches_aux
env
targ
tres
=
function
|
[]
->
f
ai
lwith
"
Non
-e
xhaustive
pattern matching"
and
branches_aux
loc
env
targ
tres
=
function
|
[]
->
r
ai
se_loc
loc
(
Non
E
xhaustive
targ
)
|
b
::
rem
->
let
p
=
b
.
br_pat
in
let
acc
=
Types
.
descr
(
Patterns
.
accept
p
)
in
let
targ'
=
Types
.
cap
targ
acc
in
if
Types
.
is_empty
targ'
then
branches_aux
env
targ
tres
rem
then
branches_aux
loc
env
targ
tres
rem
else
(
b
.
br_used
<-
true
;
let
res
=
Patterns
.
filter
targ'
p
in
...
...
@@ -386,7 +418,10 @@ and branches_aux env targ tres = function
(
fun
env
(
x
,
t
)
->
Env
.
add
x
(
Types
.
descr
t
)
env
)
env
res
in
let
t
=
compute_type
env'
b
.
br_body
in
branches_aux
env
(
Types
.
diff
targ
acc
)
(
Types
.
cup
t
tres
)
rem
let
tres
=
Types
.
cup
t
tres
in
let
targ''
=
Types
.
diff
targ
acc
in
if
(
Types
.
non_empty
targ''
)
then
branches_aux
loc
env
targ''
(
Types
.
cup
t
tres
)
rem
else
tres
)
typing/typer.mli
View file @
d68414df
exception
ParsingPattern
of
string
exception
Pattern
of
string
exception
NonExhaustive
of
Types
.
descr
exception
Constraint
of
Types
.
descr
*
Types
.
descr
*
string
val
compile_regexp
:
Ast
.
regexp
->
Ast
.
ppat
->
Ast
.
ppat
...
...
Write
Preview
Supports
Markdown
0%
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!
Cancel
Please
register
or
sign in
to comment