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
70842f4d
Commit
70842f4d
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-11-26 09:25:47 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-26 09:25:47+00:00
parent
d2480cc5
Changes
8
Hide whitespace changes
Inline
Side-by-side
parser/ast.ml
View file @
70842f4d
...
...
@@ -65,7 +65,7 @@ and ppat' =
|
Prod
of
ppat
*
ppat
|
XmlT
of
ppat
*
ppat
|
Arrow
of
ppat
*
ppat
|
Record
of
Types
.
label
*
bool
*
ppat
|
Record
of
bool
*
(
Types
.
label
*
bool
*
ppat
)
list
|
Capture
of
Patterns
.
capture
|
Constant
of
Patterns
.
capture
*
Types
.
const
|
Regexp
of
regexp
*
ppat
...
...
parser/parser.ml
View file @
70842f4d
...
...
@@ -259,7 +259,8 @@ EXTEND
|
"simple"
[
x
=
pat
;
"&"
;
y
=
pat
->
mk
loc
(
And
(
x
,
y
))
|
x
=
pat
;
"
\\
"
;
y
=
pat
->
mk
loc
(
Diff
(
x
,
y
))
]
|
[
"{"
;
r
=
record_spec
;
"}"
->
r
[
"{"
;
r
=
record_spec
;
"}"
->
mk
loc
(
Record
(
true
,
r
))
|
"{|"
;
r
=
record_spec
;
"|}"
->
mk
loc
(
Record
(
false
,
r
))
|
LIDENT
"_"
->
mk
loc
(
Internal
Types
.
any
)
|
a
=
LIDENT
->
mk
loc
(
Capture
a
)
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
mk
loc
(
Constant
(
a
,
c
))
...
...
@@ -313,12 +314,10 @@ EXTEND
record_spec
:
[
[
r
=
LIST0
[
l
=
[
LIDENT
|
UIDENT
];
"="
;
o
=
[
"?"
->
true
|
->
false
];
x
=
pat
->
mk
loc
(
Record
(
Types
.
LabelPool
.
mk
l
,
o
,
x
))
x
=
pat
->
(
Types
.
LabelPool
.
mk
l
,
o
,
x
)
]
SEP
";"
->
match
r
with
|
[]
->
mk
loc
(
Internal
Types
.
Record
.
any
)
|
h
::
t
->
List
.
fold_left
(
fun
t1
t2
->
mk
loc
(
And
(
t1
,
t2
)))
h
t
(* TODO: check here uniqueness *)
List
.
sort
(
fun
(
l1
,_,_
)
(
l2
,_,_
)
->
compare
l1
l2
)
r
]
];
char
:
...
...
@@ -337,7 +336,8 @@ EXTEND
attrib_spec
:
[
[
r
=
record_spec
->
r
|
"("
;
t
=
pat
;
")"
->
t
]
];
[
[
r
=
record_spec
->
mk
loc
(
Record
(
true
,
r
))
|
"("
;
t
=
pat
;
")"
->
t
]
];
expr_record_spec
:
[
[
r
=
LIST1
...
...
parser/wlexer.ml
View file @
70842f4d
...
...
@@ -101,63 +101,67 @@ let nb_classes = 34
let
lex_tables
=
{
Lexing
.
lex_base
=
"
\000\000\009\000\012\000\018\000\252\255\251\255\004\000\255\255
\
\005\000\254\255\014\000\013\000\00
1
\000\00
4
\000\253\255\255\255
\
\247\255\246\255\0
19
\000\047\000\051\000\01
7
\000\043\000\250\255
\
\027\000\01
0
\000\00
1
\000\0
22
\000\01
6
\000\
249\255\248\255\250
\255
\
\
058\000\061\000\053\
00
0
\06
5
\000\0
69
\000\081\000\08
5\000\098
\000
\
\10
2\000\074
\000
"
;
\005\000\254\255\014\000\013\000\00
3
\000\00
5
\000\253\255\255\255
\
\247\255\246\255\0
20
\000\047\000\051\000\01
8
\000\043\000\250\255
\
\027\000\01
7
\000\00
5
\000\0
50
\000\01
1
\000\
044\000\040\000\249
\255
\
\
250\255\248\255\064\0
00\06
6
\000\0
57\000\071
\000\081\000\08
6
\000
\
\10
1\000\090\000\119\000\062
\000
"
;
Lexing
.
lex_backtrk
=
"
\255\255\255\255\255\255\255\255\255\255\255\255\004\000\255\255
\
\002\000\255\255\004\000\002\000\004\000\004\000\255\255\255\255
\
\255\255\255\255\000\000\001\000\002\000\003\000\005\000\255\255
\
\005\000\005\000\005\000\005\000\005\000\
255\255\255\255
\255\255
\
\255\255\004\000\003\000\002\000\255\255\002\000\
001\000\255\255
\
\001\000\000\000
"
;
\005\000\005\000\005\000\005\000\005\000\
005\000\005\000
\255\255
\
\255\255\255\255
\255\255\004\000\003\000\002\000\255\255\002\000
\
\001\000\255\255
\001\000\000\000
"
;
Lexing
.
lex_default
=
"
\023\000\005\000\005\000\005\000\000\000\000\000\255\255\000\000
\
\255\255\000\000\255\255\255\255\255\255\255\255\000\000\000\000
\
\000\000\000\000\255\255\255\255\255\255\255\255\255\255\000\000
\
\255\255\255\255\255\255\255\255\255\255\
000\000\000\000
\000\000
\
\
255\255\255\255
\255\255\255\255\255\255\255\255\255\255\255\255
\
\255\255\255\255
"
;
\255\255\255\255\255\255\255\255\255\255\
255\255\255\255
\000\000
\
\
000\000\000\000
\255\255\255\255\255\255\255\255\255\255\255\255
\
\255\255\255\255
\255\255\255\255
"
;
Lexing
.
lex_trans
=
"
\016\000\017\000\017\000\018\000\019\000\020\000\021\000\019\000
\
\022\000\004\000\008\000\008\000\004\000\024\000\025\000\026\000
\
\027\000\026\000\004\000\011\000\011\000\015\000\041\000\034\000
\
\031\000\028\000\012\000\009\000\026\000\031\000\029\000\031\000
\
\029\000\030\000\013\000\009\000\009\000\031\000\031\000\014\000
\
\031\000\014\000\007\000\010\000\009\000\009\000\032\000\033\000
\
\033\000\006\000\007\000\038\000\038\000\038\000\038\000\035\000
\
\035\000\035\000\035\000\034\000\039\000\032\000\033\000\033\000
\
\036\000\033\000\033\000\033\000\033\000\035\000\035\000\035\000
\
\035\000\037\000\037\000\037\000\037\000\041\000\036\000\038\000
\
\000\000\000\000\000\000\035\000\000\000\037\000\037\000\037\000
\
\037\000\038\000\038\000\038\000\038\000\033\000\036\000\000\000
\
\000\000\035\000\039\000\000\000\000\000\037\000\040\000\040\000
\
\040\000\040\000\040\000\040\000\040\000\040\000\000\000\000\000
\
\000\000\037\000\000\000\039\000\000\000\038\000\000\000\000\000
\
\027\000\026\000\004\000\011\000\011\000\028\000\015\000\043\000
\
\036\000\029\000\012\000\030\000\026\000\009\000\031\000\032\000
\
\031\000\032\000\013\000\009\000\009\000\032\000\032\000\014\000
\
\032\000\014\000\007\000\010\000\009\000\009\000\034\000\035\000
\
\035\000\006\000\007\000\040\000\040\000\040\000\040\000\037\000
\
\037\000\037\000\037\000\032\000\041\000\033\000\032\000\036\000
\
\038\000\043\000\032\000\034\000\035\000\035\000\035\000\035\000
\
\035\000\035\000\000\000\037\000\037\000\037\000\037\000\040\000
\
\000\000\000\000\000\000\037\000\038\000\039\000\039\000\039\000
\
\039\000\000\000\039\000\039\000\039\000\039\000\042\000\042\000
\
\042\000\042\000\035\000\038\000\000\000\000\000\000\000\037\000
\
\000\000\040\000\040\000\040\000\040\000\000\000\000\000\000\000
\
\000\000\039\000\041\000\000\000\000\000\000\000\039\000\000\000
\
\000\000\000\000\042\000\042\000\042\000\042\000\042\000\000\000
\
\000\000\000\000\000\000\000\000\041\000\040\000\000\000\000\000
\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000
\
\000\000\000\000\0
4
0\000\000\000\000\000\000\000\04
0\000\000
\000
\
"
;
\000\000\000\000\0
00\000\00
0\000\000\000\000\000\000\000\04
2
\000
\
\000\000
"
;
Lexing
.
lex_check
=
"
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000
\
\000\000\001\000\006\000\008\000\002\000\000\000\000\000\000\000
\
\000\000\000\000\003\000\011\000\010\000\013\000\018\000\
021\000
\
\02
5
\000\000\000\001\000\0
12
\000\000\000\02
6
\000\000\000\02
7
\000
\
\000\000\02
8
\000\001\000\006\000\006\000\024\000\02
7
\000\001\000
\
\000\000\000\000\003\000\011\000\010\000\
000\000\
013\000\018\000
\
\02
1
\000\000\000\001\000\0
00
\000\000\000\0
1
2\000\000\000\02
5
\000
\
\000\000\02
6
\000\001\000\006\000\006\000\024\000\02
8
\000\001\000
\
\024\000\001\000\002\000\002\000\010\000\010\000\022\000\022\000
\
\022\000\003\000\003\000\019\000\019\000\019\000\019\000\020\000
\
\020\000\020\000\020\000\034\000\019\000\032\000\032\000\032\000
\
\020\000\033\000\033\000\033\000\033\000\035\000\035\000\035\000
\
\035\000\036\000\036\000\036\000\036\000\041\000\035\000\019\000
\
\255\255\255\255\255\255\020\000\255\255\037\000\037\000\037\000
\
\037\000\038\000\038\000\038\000\038\000\033\000\037\000\255\255
\
\255\255\035\000\038\000\255\255\255\255\036\000\039\000\039\000
\
\039\000\039\000\040\000\040\000\040\000\040\000\255\255\255\255
\
\255\255\037\000\255\255\040\000\255\255\038\000\255\255\255\255
\
\020\000\020\000\020\000\027\000\019\000\029\000\030\000\036\000
\
\020\000\043\000\027\000\034\000\034\000\034\000\035\000\035\000
\
\035\000\035\000\255\255\037\000\037\000\037\000\037\000\019\000
\
\255\255\255\255\255\255\020\000\037\000\038\000\038\000\038\000
\
\038\000\255\255\039\000\039\000\039\000\039\000\041\000\041\000
\
\041\000\041\000\035\000\039\000\255\255\255\255\255\255\037\000
\
\255\255\040\000\040\000\040\000\040\000\255\255\255\255\255\255
\
\255\255\038\000\040\000\255\255\255\255\255\255\039\000\255\255
\
\255\255\255\255\041\000\042\000\042\000\042\000\042\000\255\255
\
\255\255\255\255\255\255\255\255\042\000\040\000\255\255\255\255
\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255
\
\255\255\255\255\
039\000
\255\255\255\255\255\255\04
0
\000\
255\255
\
"
\255\255\255\255\
255\255\255\255
\255\255\255\255\255\255\04
2
\000
\
\255\255
"
}
let
rec
token
engine
lexbuf
=
...
...
@@ -184,10 +188,10 @@ let rec token engine lexbuf =
"TAG"
,
tag_of_tag
s
1
)
|
5
->
(
#
6
4
"parser/wlexer.mll"
#
6
5
"parser/wlexer.mll"
""
,
Lexing
.
lexeme
lexbuf
)
|
6
->
(
#
6
7
"parser/wlexer.mll"
#
6
8
"parser/wlexer.mll"
let
string_start
=
Lexing
.
lexeme_start
lexbuf
in
string_start_pos
:=
string_start
;
let
double_quote
=
Lexing
.
lexeme_char
lexbuf
0
=
'
"' in
...
...
@@ -197,15 +201,15 @@ let rec token engine lexbuf =
(if double_quote then "
STRING2
" else "
STRING1
"),
(get_stored_string()) )
| 7 -> (
# 7
7
"
parser
/
wlexer
.
mll
"
# 7
8
"
parser
/
wlexer
.
mll
"
comment_start_pos := [Lexing.lexeme_start lexbuf];
comment engine lexbuf;
token engine lexbuf )
| 8 -> (
# 8
2
"
parser
/
wlexer
.
mll
"
# 8
3
"
parser
/
wlexer
.
mll
"
"
EOI
","" )
| 9 -> (
# 8
4
"
parser
/
wlexer
.
mll
"
# 8
5
"
parser
/
wlexer
.
mll
"
error
(Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf)
(Illegal_character ((Lexing.lexeme lexbuf).[0])) )
...
...
@@ -214,17 +218,17 @@ let rec token engine lexbuf =
and comment engine lexbuf =
match engine lex_tables 1 lexbuf with
0 -> (
# 9
0
"
parser
/
wlexer
.
mll
"
# 9
1
"
parser
/
wlexer
.
mll
"
comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos;
comment engine lexbuf;
)
| 1 -> (
# 9
4
"
parser
/
wlexer
.
mll
"
# 9
5
"
parser
/
wlexer
.
mll
"
comment_start_pos := List.tl !comment_start_pos;
if !comment_start_pos <> [] then comment engine lexbuf;
)
| 2 -> (
# 9
8
"
parser
/
wlexer
.
mll
"
# 9
9
"
parser
/
wlexer
.
mll
"
string_start_pos := Lexing.lexeme_start lexbuf;
let string =
if Lexing.lexeme_char lexbuf 0 = '"
'
then
string2
else
string1
in
...
...
@@ -235,33 +239,33 @@ and comment engine lexbuf =
Buffer
.
clear
string_buff
;
comment
engine
lexbuf
)
|
3
->
(
#
10
8
"parser/wlexer.mll"
#
10
9
"parser/wlexer.mll"
let
st
=
List
.
hd
!
comment_start_pos
in
error
st
(
st
+
2
)
Unterminated_comment
)
|
4
->
(
#
11
2
"parser/wlexer.mll"
#
11
3
"parser/wlexer.mll"
comment
engine
lexbuf
)
|
_
->
failwith
"lexing: empty token [comment]"
and
string2
engine
lexbuf
=
match
engine
lex_tables
2
lexbuf
with
0
->
(
#
11
6
"parser/wlexer.mll"
#
11
7
"parser/wlexer.mll"
()
)
|
1
->
(
#
11
8
"parser/wlexer.mll"
#
11
9
"parser/wlexer.mll"
store_char
(
Lexing
.
lexeme_char
lexbuf
1
);
string2
engine
lexbuf
)
|
2
->
(
#
12
1
"parser/wlexer.mll"
#
12
2
"parser/wlexer.mll"
store_char
(
char_for_decimal_code
(
Lexing
.
lexeme
lexbuf
));
string2
engine
lexbuf
)
|
3
->
(
#
12
4
"parser/wlexer.mll"
#
12
5
"parser/wlexer.mll"
error
!
string_start_pos
(
!
string_start_pos
+
1
)
Unterminated_string
)
|
4
->
(
#
12
6
"parser/wlexer.mll"
#
12
7
"parser/wlexer.mll"
store_char
(
Lexing
.
lexeme_char
lexbuf
0
);
(* TODO: Unicode *)
string2
engine
lexbuf
)
...
...
@@ -270,28 +274,28 @@ and string2 engine lexbuf =
and
string1
engine
lexbuf
=
match
engine
lex_tables
3
lexbuf
with
0
->
(
#
13
2
"parser/wlexer.mll"
#
13
3
"parser/wlexer.mll"
()
)
|
1
->
(
#
13
4
"parser/wlexer.mll"
#
13
5
"parser/wlexer.mll"
store_char
(
Lexing
.
lexeme_char
lexbuf
1
);
string1
engine
lexbuf
)
|
2
->
(
#
13
7
"parser/wlexer.mll"
#
13
8
"parser/wlexer.mll"
store_char
(
char_for_decimal_code
(
Lexing
.
lexeme
lexbuf
));
string1
engine
lexbuf
)
|
3
->
(
#
14
0
"parser/wlexer.mll"
#
14
1
"parser/wlexer.mll"
error
!
string_start_pos
(
!
string_start_pos
+
1
)
Unterminated_string
)
|
4
->
(
#
14
2
"parser/wlexer.mll"
#
14
3
"parser/wlexer.mll"
store_char
(
Lexing
.
lexeme_char
lexbuf
0
);
string1
engine
lexbuf
)
|
_
->
failwith
"lexing: empty token [string1]"
;;
#
14
5
"parser/wlexer.mll"
#
14
6
"parser/wlexer.mll"
let
lexer_func_of_wlex
lexfun
lexengine
cs
=
...
...
parser/wlexer.mll
View file @
70842f4d
...
...
@@ -60,6 +60,7 @@ rule token = parse
}
|
[
"<>=.,:;+-*/@&{}[]()|?`!"
]
|
"->"
|
"::"
|
";;"
|
"--"
|
":="
|
"
\\
"
|
"{|"
|
"|}"
|
[
"?+*"
]
"?"
{
""
,
Lexing
.
lexeme
lexbuf
}
...
...
types/patterns.ml
View file @
70842f4d
...
...
@@ -999,6 +999,7 @@ struct
if
x
==
ab
then
aux_ab
else
aux
x
fields
))
pr
in
`Label
(
l1
,
pr
,
aux_ab
)
|
_
->
assert
false
in
let
line
accu
((
res
,
fields
)
,
acc
)
=
...
...
types/types.ml
View file @
70842f4d
...
...
@@ -30,7 +30,6 @@ module I = struct
times
:
(
'
a
*
'
a
)
Boolean
.
t
;
xml
:
(
'
a
*
'
a
)
Boolean
.
t
;
arrow
:
(
'
a
*
'
a
)
Boolean
.
t
;
(* record: (label * bool * 'a) Boolean.t; *)
record
:
(
bool
*
(
label
,
(
bool
*
'
a
))
SortedMap
.
t
)
Boolean
.
t
;
}
...
...
@@ -61,6 +60,8 @@ module I = struct
let
arrow
x
y
=
{
empty
with
arrow
=
Boolean
.
atom
(
x
,
y
)
}
let
record
label
opt
t
=
{
empty
with
record
=
Boolean
.
atom
(
true
,
[
label
,
(
opt
,
t
)])
}
let
record'
x
=
{
empty
with
record
=
Boolean
.
atom
x
}
let
atom
a
=
{
empty
with
atoms
=
a
}
let
char
c
=
{
empty
with
chars
=
c
}
let
constant
=
function
...
...
@@ -690,8 +691,8 @@ struct
Format
.
fprintf
ppf
"@[{%s"
o
;
let
first
=
ref
true
in
List
.
iter
(
fun
(
l
,
(
o
,
t
))
->
let
sep
=
if
!
first
then
(
first
:=
false
;
"
"
)
else
";
@
"
in
Format
.
fprintf
ppf
"%s@[%s =%s@] %a"
sep
let
sep
=
if
!
first
then
(
first
:=
false
;
""
)
else
";"
in
Format
.
fprintf
ppf
"%s@
@
[%s =%s@] %a"
sep
(
LabelPool
.
value
l
)
(
if
o
then
"?"
else
""
)
print
t
)
r
;
Format
.
fprintf
ppf
" %s}@]"
o
...
...
@@ -1040,6 +1041,8 @@ struct
type
normal
=
[
`Success
|
`Fail
|
`NoField
|
`SomeField
|
`Label
of
label
*
(
descr
*
normal
)
list
*
normal
]
let
first_label
t
=
...
...
@@ -1079,7 +1082,8 @@ struct
normal_aux
absent
)
|
`Fail
->
`Fail
|
`Success
->
`Success
|
_
->
assert
false
|
`NoField
->
`NoField
|
`SomeField
->
`SomeField
let
normal
t
=
normal_aux
(
get
t
)
...
...
types/types.mli
View file @
70842f4d
...
...
@@ -47,6 +47,7 @@ val times : node -> node -> descr
val
xml
:
node
->
node
->
descr
val
arrow
:
node
->
node
->
descr
val
record
:
label
->
bool
->
node
->
descr
val
record'
:
bool
*
(
label
,
(
bool
*
node
))
SortedMap
.
t
->
descr
val
char
:
Chars
.
t
->
descr
val
constant
:
const
->
descr
...
...
@@ -117,8 +118,10 @@ module Record : sig
*)
type
normal
=
[
`Success
|
`Fail
[
`Success
(* { } *)
|
`Fail
(* Empty *)
|
`NoField
(* {| |} *)
|
`SomeField
(* { } \ {| |} *)
|
`Label
of
label
*
(
descr
*
normal
)
list
*
normal
]
val
normal
:
descr
->
normal
...
...
typing/typer.ml
View file @
70842f4d
...
...
@@ -38,7 +38,7 @@ and descr =
|
`Times
of
ti
*
ti
|
`Xml
of
ti
*
ti
|
`Arrow
of
ti
*
ti
|
`Record
of
Types
.
label
*
bool
*
ti
|
`Record
of
bool
*
(
Types
.
label
*
bool
*
ti
)
list
|
`Capture
of
Patterns
.
capture
|
`Constant
of
Patterns
.
capture
*
Types
.
const
]
...
...
@@ -261,7 +261,8 @@ let rec compile env { loc = loc; descr = d } : ti =
|
Prod
(
t1
,
t2
)
->
cons
loc
(
`Times
(
compile
env
t1
,
compile
env
t2
))
|
XmlT
(
t1
,
t2
)
->
cons
loc
(
`Xml
(
compile
env
t1
,
compile
env
t2
))
|
Arrow
(
t1
,
t2
)
->
cons
loc
(
`Arrow
(
compile
env
t1
,
compile
env
t2
))
|
Record
(
l
,
o
,
t
)
->
cons
loc
(
`Record
(
l
,
o
,
compile
env
t
))
|
Record
(
o
,
r
)
->
cons
loc
(
`Record
(
o
,
List
.
map
(
fun
(
l
,
o
,
t
)
->
l
,
o
,
compile
env
t
)
r
))
|
Constant
(
x
,
v
)
->
cons
loc
(
`Constant
(
x
,
v
))
|
Capture
x
->
cons
loc
(
`Capture
x
)
...
...
@@ -294,7 +295,7 @@ let rec comp_fv s =
|
`Diff
(
s1
,
s2
)
|
`Times
(
s1
,
s2
)
|
`Xml
(
s1
,
s2
)
|
`Arrow
(
s1
,
s2
)
->
comp_fv
s1
;
comp_fv
s2
|
`Record
(
l
,
opt
,
s
)
->
comp_fv
s
|
`Record
(
_
,
r
)
->
List
.
iter
(
fun
(
l
,
opt
,
s
)
->
comp_fv
s
)
r
|
`Type
_
->
()
|
`Capture
x
|
`Constant
(
x
,_
)
->
comp_fv_res
:=
StringSet
.
add
x
!
comp_fv_res
...
...
@@ -327,7 +328,9 @@ let rec typ seen s : Types.descr =
|
`Times
(
s1
,
s2
)
->
Types
.
times
(
typ_node
s1
)
(
typ_node
s2
)
|
`Xml
(
s1
,
s2
)
->
Types
.
xml
(
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
)
|
`Record
(
o
,
r
)
->
Types
.
record'
(
o
,
List
.
map
(
fun
(
l
,
o
,
s
)
->
(
l
,
(
o
,
typ_node
s
)))
r
)
|
`Capture
x
|
`Constant
(
x
,_
)
->
assert
false
and
typ_node
s
:
Types
.
node
=
...
...
@@ -371,9 +374,24 @@ and pat_aux seen s = match s.descr' with
raise
(
Patterns
.
Error
"Difference not allowed in patterns"
)
|
`Times
(
s1
,
s2
)
->
Patterns
.
times
(
pat_node
s1
)
(
pat_node
s2
)
|
`Xml
(
s1
,
s2
)
->
Patterns
.
xml
(
pat_node
s1
)
(
pat_node
s2
)
|
`Record
(
l
,
false
,
s
)
->
Patterns
.
record
l
(
pat_node
s
)
|
`Record
_
->
raise
(
Patterns
.
Error
"Optional field not allowed in record patterns"
)
|
`Record
(
false
,_
)
->
(* TODO: handle this case with a type constraint ... *)
raise
(
Patterns
.
Error
"Closed records are not allowed in record patterns"
);
|
`Record
(
true
,
r
)
->
let
l
=
List
.
map
(
fun
(
l
,
o
,
s
)
->
if
o
then
raise
(
Patterns
.
Error
"Optional field not allowed in record patterns"
);
Patterns
.
record
l
(
pat_node
s
)
)
r
in
(
match
l
with
|
[]
->
Patterns
.
constr
Types
.
Record
.
any
|
h
::
t
->
List
.
fold_left
Patterns
.
cap
h
t
)
|
`Capture
x
->
Patterns
.
capture
x
|
`Constant
(
x
,
c
)
->
Patterns
.
constant
x
c
|
`Arrow
_
->
...
...
@@ -595,6 +613,8 @@ and type_check' loc env e constr precise = match e with
type_check_pair
loc
env
e1
e2
constr
precise
|
Xml
(
e1
,
e2
)
->
type_check_pair
~
kind
:
`XML
loc
env
e1
e2
constr
precise
(*
| RecordLitt r ->
let rconstr = Types.Record.get constr in
if Types.Record.is_empty rconstr then
...
...
@@ -628,6 +648,7 @@ and type_check' loc env e constr precise = match e with
in
(* check loc res constr ""; *)
res
*)
|
Map
(
e
,
b
)
->
let
t
=
type_check
env
e
(
Sequence
.
star
b
.
br_accept
)
true
in
...
...
@@ -770,14 +791,11 @@ and compute_type' loc env = function
and
t2
=
compute_type
env
e2
in
Types
.
times
(
Types
.
cons
t1
)
(
Types
.
cons
t2
)
|
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
let
r
=
List
.
map
(
fun
(
l
,
e
)
->
(
l
,
(
false
,
Types
.
cons
(
compute_type
env
e
))))
r
in
Types
.
record'
(
false
,
r
)
|
_
->
assert
false
and
type_check_branches
loc
env
targ
brs
constr
precise
=
...
...
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