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
f2eb8125
Commit
f2eb8125
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-03-10 22:35:20 by cvscast] De nouveau rapides, les records
Original author: cvscast Date: 2003-03-10 22:35:21+00:00
parent
68ce5b26
Changes
21
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
f2eb8125
...
...
@@ -39,12 +39,9 @@ let rec print_exn ppf = function
print_value
v
|
Typer
.
WrongLabel
(
t
,
l
)
->
Format
.
fprintf
ppf
"Wrong record selection: the label %s@
\n
"
(
Types
.
LabelPool
.
value
l
);
(
LabelPool
.
value
l
);
Format
.
fprintf
ppf
"applied to an expression of type %a@
\n
"
print_norm
t
|
Typer
.
MultipleLabel
l
->
Format
.
fprintf
ppf
"Multiple occurences for the record label %s@
\n
"
(
Types
.
LabelPool
.
value
l
);
|
Typer
.
ShouldHave
(
t
,
msg
)
->
Format
.
fprintf
ppf
"This expression should have type %a@
\n
%s@
\n
"
print_norm
t
...
...
parser/ast.ml
View file @
f2eb8125
...
...
@@ -35,13 +35,13 @@ and pexpr' =
|
Cst
of
Types
.
const
|
Pair
of
pexpr
*
pexpr
|
Xml
of
pexpr
*
pexpr
|
RecordLitt
of
(
Types
.
label
*
pexpr
)
list
|
RecordLitt
of
pexpr
label_map
(* Data destructors *)
|
Op
of
string
*
pexpr
list
|
Match
of
pexpr
*
branches
|
Map
of
pexpr
*
branches
|
Dot
of
(
pexpr
*
Types
.
label
)
|
Dot
of
(
pexpr
*
label
)
(* Exceptions *)
|
Try
of
pexpr
*
branches
...
...
@@ -68,7 +68,7 @@ and ppat' =
|
XmlT
of
ppat
*
ppat
|
Arrow
of
ppat
*
ppat
|
Optional
of
ppat
|
Record
of
bool
*
(
Types
.
label
*
ppat
)
list
|
Record
of
bool
*
ppat
label_map
|
Capture
of
id
|
Constant
of
id
*
Types
.
const
|
Regexp
of
regexp
*
ppat
...
...
parser/parser.ml
View file @
f2eb8125
...
...
@@ -28,6 +28,8 @@ let rec tuple loc = function
let
tuple_queue
=
List
.
fold_right
(
fun
x
q
->
mk
x
.
loc
(
Pair
(
x
,
q
)))
let
char
=
mk
noloc
(
Internal
(
Types
.
char
Chars
.
any
))
let
string_regexp
=
Star
(
Elem
char
)
...
...
@@ -44,6 +46,9 @@ let seq_of_string pos s =
exception
Error
of
string
let
error
loc
s
=
raise
(
Location
(
loc
,
Error
s
))
let
make_record
loc
r
=
LabelMap
.
from_list
(
fun
_
_
->
error
loc
"Duplicated record field"
)
r
let
parse_char
loc
s
=
(* TODO: Unicode *)
if
String
.
length
s
<>
1
then
...
...
@@ -126,7 +131,7 @@ EXTEND
]
|
[
e
=
expr
;
"."
;
l
=
[
LIDENT
|
UIDENT
]
->
mk
loc
(
Dot
(
e
,
Types
.
LabelPool
.
mk
l
))
mk
loc
(
Dot
(
e
,
LabelPool
.
mk
l
))
]
|
...
...
@@ -163,7 +168,7 @@ EXTEND
|
"<"
;
e
=
expr
LEVEL
"no_appl"
->
e
];
a
=
expr_attrib_spec
;
">"
;
c
=
expr
->
mk
loc
(
Xml
(
t
,
mk
loc
(
Pair
(
a
,
c
))))
|
"{"
;
r
=
[
expr_record_spec
|
->
mk
loc
(
RecordLitt
[]
)
];
"}"
->
r
|
"{"
;
r
=
[
expr_record_spec
|
->
mk
loc
(
RecordLitt
LabelMap
.
empty
)
];
"}"
->
r
|
s
=
STRING2
->
tuple
loc
(
char_list
loc
s
@
[
cst_nil
])
|
a
=
LIDENT
->
mk
loc
(
Var
(
ident
a
))
...
...
@@ -328,10 +333,9 @@ EXTEND
o
=
[
"?"
->
true
|
->
false
];
x
=
pat
->
let
x
=
if
o
then
mk
loc
(
Optional
x
)
else
x
in
(
Types
.
LabelPool
.
mk
l
,
x
)
(
LabelPool
.
mk
l
,
x
)
]
SEP
";"
->
(* TODO: check here uniqueness *)
List
.
sort
(
fun
(
l1
,_
)
(
l2
,_
)
->
compare
l1
l2
)
r
make_record
loc
r
]
];
char
:
...
...
@@ -356,15 +360,15 @@ EXTEND
expr_record_spec
:
[
[
r
=
LIST1
[
l
=
[
LIDENT
|
UIDENT
];
"="
;
x
=
expr
->
(
Types
.
LabelPool
.
mk
l
,
x
)
]
(
LabelPool
.
mk
l
,
x
)
]
SEP
";"
->
mk
loc
(
RecordLitt
r
)
mk
loc
(
RecordLitt
(
make_record
loc
r
)
)
]
];
expr_attrib_spec
:
[
[
r
=
expr_record_spec
->
r
]
|
[
e
=
expr
LEVEL
"no_appl"
->
e
|
->
mk
loc
(
RecordLitt
[]
)
|
->
mk
loc
(
RecordLitt
(
LabelMap
.
empty
)
)
]
];
END
...
...
runtime/eval.ml
View file @
f2eb8125
...
...
@@ -43,10 +43,10 @@ let rec eval env e0 =
self
(* Optimizations:
- for the non-recursive case, use eval_branches
- for the recursive case, could cheat b
t
pathing self afterwards:
- for the recursive case, could cheat b
y
pat
c
hing self afterwards:
(Obj.magic self).(1) <- ....
*)
|
Typed
.
RecordLitt
r
->
Record
(
L
ist
.
map
(
fun
(
l
,
e
)
->
(
l
,
eval
env
e
)
)
r
)
|
Typed
.
RecordLitt
r
->
Record
(
L
abelMap
.
map
(
eval
env
)
r
)
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Xml
(
e1
,
e2
)
->
Xml
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Cst
c
->
const
c
...
...
@@ -112,7 +112,7 @@ and eval_concat l1 l2 = match l1 with
|
q
->
l2
and
eval_dot
l
=
function
|
Record
r
->
L
ist
.
assoc
l
r
|
Record
r
->
L
abelMap
.
assoc
l
r
|
_
->
assert
false
and
eval_add
x
y
=
match
(
x
,
y
)
with
...
...
runtime/load_xml.ml
View file @
f2eb8125
...
...
@@ -6,6 +6,7 @@ open Pxp_yacc
open
Pxp_lexer_types
open
Pxp_types
open
Value
open
Ident
let
is_ws
s
=
let
rec
check
i
=
...
...
@@ -20,8 +21,8 @@ let string s q =
String
(
0
,
String
.
length
s
,
s
,
q
)
let
attrib
att
=
let
att
=
List
.
map
(
fun
(
l
,
v
)
->
Types
.
LabelPool
.
mk
l
,
string
v
nil
)
att
in
Sorted
Map
.
from_list
(
fun
_
_
->
assert
false
)
att
let
att
=
List
.
map
(
fun
(
l
,
v
)
->
LabelPool
.
mk
l
,
string
v
nil
)
att
in
Label
Map
.
from_list
(
fun
_
_
->
assert
false
)
att
let
elem
tag
att
child
=
Xml
(
Atom
(
Atoms
.
mk
tag
)
,
Pair
(
Record
(
attrib
att
)
,
child
))
...
...
runtime/print_xml.ml
View file @
f2eb8125
...
...
@@ -3,6 +3,7 @@
open
Pxp_aux
open
Pxp_types
open
Value
open
Ident
let
exn_print_xml
=
CDuceExn
(
Pair
(
Atom
(
Atoms
.
mk
"Invalid_argument"
)
,
...
...
@@ -43,9 +44,10 @@ let string_of_xml v=
let
rec
print_elt
=
function
|
Xml
(
Atom
tag
,
Pair
(
Record
attrs
,
content
))
->
let
tag
=
Atoms
.
value
tag
in
let
attrs
=
List
.
map
(
fun
(
n
,
v
)
->
if
not
(
is_str
v
)
then
raise
exn_print_xml
;
(
Types
.
LabelPool
.
value
n
,
get_string
v
))
attrs
in
let
attrs
=
LabelMap
.
mapi_to_list
(
fun
n
v
->
if
not
(
is_str
v
)
then
raise
exn_print_xml
;
(
LabelPool
.
value
n
,
get_string
v
))
attrs
in
(
match
content
with
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
empty_element
tag
attrs
|
_
->
...
...
runtime/run_dispatch.ml
View file @
f2eb8125
(* Running dispatchers *)
open
Value
open
Ident
open
Patterns
.
Compile
let
make_result_prod
v1
r1
v2
r2
v
(
code
,
r
)
=
...
...
@@ -71,7 +72,7 @@ and run_disp_kind actions v =
match
v
with
|
Pair
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
prod
|
Xml
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
xml
|
Record
r
->
run_disp_record
false
v
r
actions
.
record
|
Record
r
->
run_disp_record
false
v
(
LabelMap
.
get
r
)
actions
.
record
|
String
(
i
,
j
,
s
,
q
)
->
run_disp_string
i
j
s
q
actions
|
Atom
a
->
run_disp_basic
v
(
fun
t
->
Types
.
Atom
.
has_atom
t
a
)
actions
.
basic
...
...
runtime/value.ml
View file @
f2eb8125
open
Ident
type
t
=
|
Pair
of
t
*
t
|
Xml
of
t
*
t
|
Record
of
(
Types
.
label
,
t
)
SortedMap
.
t
|
Record
of
t
label_map
|
Atom
of
Atoms
.
v
|
Integer
of
Intervals
.
v
|
Char
of
Chars
.
v
...
...
@@ -54,7 +56,7 @@ let rec print ppf v =
else
match
v
with
|
Pair
(
x
,
y
)
->
Format
.
fprintf
ppf
"(%a,%a)"
print
x
print
y
|
Xml
(
x
,
y
)
->
print_xml
ppf
(
x
,
y
)
|
Record
l
->
Format
.
fprintf
ppf
"{%a }"
print_record
l
|
Record
l
->
Format
.
fprintf
ppf
"{%a }"
print_record
(
LabelMap
.
get
l
)
|
Atom
a
->
Atoms
.
print_v
ppf
a
|
Integer
i
->
Intervals
.
print_v
ppf
i
|
Char
c
->
Chars
.
print_v
ppf
c
...
...
@@ -94,7 +96,7 @@ and print_xml ppf = function
|
(
Atom
tag
,
Pair
(
Record
attr
,
content
))
->
Format
.
fprintf
ppf
"@[<hv2><%s%a>[@ %a@]]"
(
Atoms
.
value
tag
)
print_record
attr
print_record
(
LabelMap
.
get
attr
)
print_seq
content
|
_
->
assert
false
...
...
@@ -104,7 +106,7 @@ and print_record ppf = function
|
f
::
rem
->
Format
.
fprintf
ppf
" %a;%a"
print_field
f
print_record
rem
and
print_field
ppf
(
l
,
v
)
=
Format
.
fprintf
ppf
"%s=%a"
(
Types
.
LabelPool
.
value
l
)
print
v
Format
.
fprintf
ppf
"%s=%a"
(
LabelPool
.
value
l
)
print
v
let
normalize
=
function
...
...
runtime/value.mli
View file @
f2eb8125
open
Ident
type
t
=
(* Canonical representation *)
|
Pair
of
t
*
t
|
Xml
of
t
*
t
|
Record
of
(
Types
.
label
,
t
)
SortedMap
.
t
|
Record
of
t
label_map
|
Atom
of
Atoms
.
v
|
Integer
of
Intervals
.
v
|
Char
of
Chars
.
v
...
...
types/ident.ml
View file @
f2eb8125
...
...
@@ -6,3 +6,11 @@ type 'a id_map = (unit,'a) IdMap.map
type
fv
=
unit
IdSet
.
t
let
ident
=
Id
.
mk
module
LabelPool
=
Pool
.
Make
(
SortedList
.
String
)
module
LabelSet
=
SortedList
.
Make
(
SortedList
.
Lift
(
LabelPool
))
module
LabelMap
=
LabelSet
.
Map
type
label
=
LabelPool
.
t
type
'
a
label_map
=
(
unit
,
'
a
)
LabelMap
.
map
types/normal.ml
View file @
f2eb8125
...
...
@@ -10,6 +10,8 @@ sig
val
is_empty
:
t
->
bool
end
type
'
a
bool
=
(
'
a
list
*
'
a
list
)
list
module
Make
(
X1
:
S
)(
X2
:
S
)
=
struct
type
t
=
(
X1
.
t
*
X2
.
t
)
list
...
...
types/normal.mli
View file @
f2eb8125
...
...
@@ -10,6 +10,7 @@ sig
val
is_empty
:
t
->
bool
end
type
'
a
bool
=
(
'
a
list
*
'
a
list
)
list
module
Make
(
X1
:
S
)(
X2
:
S
)
:
sig
type
t
=
(
X1
.
t
*
X2
.
t
)
list
...
...
@@ -20,10 +21,10 @@ sig
(t1,t2) => t1 <> 0, t2 <> 0
*)
val
boolean_normal
:
(
X1
.
t
*
X2
.
t
)
B
ool
ean
.
t
->
t
val
boolean_normal
:
(
X1
.
t
*
X2
.
t
)
b
ool
->
t
(* return a normalized form *)
val
boolean
:
(
X1
.
t
*
X2
.
t
)
B
ool
ean
.
t
->
t
val
boolean
:
(
X1
.
t
*
X2
.
t
)
b
ool
->
t
val
pi1
:
t
->
X1
.
t
val
pi2_restricted
:
X1
.
t
->
t
->
X2
.
t
...
...
types/patterns.ml
View file @
f2eb8125
...
...
@@ -9,7 +9,7 @@ type d =
|
Cap
of
descr
*
descr
|
Times
of
node
*
node
|
Xml
of
node
*
node
|
Record
of
Types
.
label
*
node
|
Record
of
label
*
node
|
Capture
of
id
|
Constant
of
id
*
Types
.
const
and
node
=
{
...
...
@@ -39,7 +39,7 @@ let rec print ppf (a,_,d) =
Format
.
fprintf
ppf
"XML(P%i,P%i)"
n1
.
id
n2
.
id
;
to_print
:=
n1
::
n2
::
!
to_print
|
Record
(
l
,
n
)
->
Format
.
fprintf
ppf
"{ %s = P%i }"
(
Types
.
LabelPool
.
value
l
)
n
.
id
;
Format
.
fprintf
ppf
"{ %s = P%i }"
(
LabelPool
.
value
l
)
n
.
id
;
to_print
:=
n
::
!
to_print
|
Capture
x
->
Format
.
fprintf
ppf
"%s"
(
Id
.
value
x
)
...
...
@@ -188,7 +188,7 @@ module Normal : sig
type
'
a
nline
=
(
result
*
'
a
)
list
type
record
=
|
RecNolabel
of
result
option
*
result
option
|
RecLabel
of
Types
.
label
*
(
nnf
*
nnf
)
nline
|
RecLabel
of
label
*
(
nnf
*
nnf
)
nline
type
t
=
{
nfv
:
fv
;
ncatchv
:
fv
;
...
...
@@ -200,8 +200,8 @@ module Normal : sig
}
val
any_basic
:
Types
.
descr
val
first_label
:
descr
->
Types
.
label
val
normal
:
Types
.
label
option
->
Types
.
descr
->
node
list
->
t
val
first_label
:
descr
->
label
val
normal
:
label
option
->
Types
.
descr
->
node
list
->
t
end
=
struct
let
any_basic
=
...
...
@@ -224,7 +224,7 @@ struct
type
'
a
nline
=
(
result
*
'
a
)
sl
type
record
=
|
RecNolabel
of
result
option
*
result
option
|
RecLabel
of
Types
.
label
*
(
nnf
*
nnf
)
nline
|
RecLabel
of
label
*
(
nnf
*
nnf
)
nline
type
t
=
{
nfv
:
fv
;
ncatchv
:
fv
;
...
...
@@ -342,8 +342,8 @@ struct
|
None
->
assert
false
|
Some
label
->
(* Printf.eprintf "[ l = %s; label = %s ]\n"
(
Types.
LabelPool.value l)
(
Types.
LabelPool.value label); *)
(LabelPool.value l)
(LabelPool.value label); *)
assert
(
label
<=
l
);
if
l
==
label
then
let
src
=
IdMap
.
constant
SLeft
p
.
fv
in
...
...
@@ -434,14 +434,14 @@ struct
let
rec
first_label
(
acc
,
fv
,
d
)
=
if
Types
.
is_empty
acc
then
Types
.
LabelPool
.
dummy_max
then
LabelPool
.
dummy_max
else
match
d
with
|
Constr
t
->
Types
.
Record
.
first_label
t
|
Cap
(
p
,
q
)
->
min
(
first_label
p
)
(
first_label
q
)
|
Cup
((
acc1
,_,_
)
as
p
,
q
)
->
min
(
first_label
p
)
(
first_label
q
)
(* should "first_label_type acc1" ? *)
|
Record
(
l
,
p
)
->
l
|
_
->
Types
.
LabelPool
.
dummy_max
|
_
->
LabelPool
.
dummy_max
let
remove_catchv
n
=
...
...
@@ -489,7 +489,7 @@ struct
record
:
record
option
;
}
and
record
=
|
RecLabel
of
Types
.
label
*
result
dispatch
dispatch
|
RecLabel
of
label
*
result
dispatch
dispatch
|
RecNolabel
of
result
option
*
result
option
and
'
a
dispatch
=
...
...
@@ -516,7 +516,7 @@ struct
id
:
int
;
t
:
Types
.
descr
;
pl
:
Normal
.
t
array
;
label
:
Types
.
label
option
;
label
:
label
option
;
interface
:
interface
;
codes
:
return_code
array
;
mutable
actions
:
actions
option
;
...
...
@@ -739,8 +739,8 @@ struct
(
fun
l
p
->
min
l
(
Normal
.
first_label
(
descr
p
)))
(
min
l
(
Types
.
Record
.
first_label
ty
))
pl
)
Types
.
LabelPool
.
dummy_max
!
accu
in
let
lab
=
if
lab
=
Types
.
LabelPool
.
dummy_max
then
None
else
Some
lab
in
)
LabelPool
.
dummy_max
!
accu
in
let
lab
=
if
lab
=
LabelPool
.
dummy_max
then
None
else
Some
lab
in
let
accu
=
List
.
map
(
fun
(
ty
,
pl
,
i
,
info
)
->
...
...
@@ -965,7 +965,7 @@ struct
Format
.
fprintf
ppf
"SomeField:%a;NoField:%a"
print_ret_opt
r1
print_ret_opt
r2
|
RecLabel
(
l
,
d
)
->
let
l
=
Types
.
LabelPool
.
value
l
in
let
l
=
LabelPool
.
value
l
in
Format
.
fprintf
ppf
"check label %s:@
\n
"
l
;
Format
.
fprintf
ppf
"Present => @[%a@]@
\n
"
(
print_prod
"record"
)
d
in
...
...
@@ -1024,7 +1024,7 @@ struct
List
.
fold_left
(
fun
l
p
->
min
l
(
Normal
.
first_label
(
descr
p
)))
(
Types
.
Record
.
first_label
t
)
pl
in
let
lab
=
if
lab
=
Types
.
LabelPool
.
dummy_max
then
None
else
Some
lab
in
let
lab
=
if
lab
=
LabelPool
.
dummy_max
then
None
else
Some
lab
in
let
pl
=
Array
.
of_list
(
List
.
map
(
fun
p
->
Normal
.
normal
lab
Types
.
Record
.
any_or_absent
[
p
])
pl
)
in
...
...
types/patterns.mli
View file @
f2eb8125
...
...
@@ -15,7 +15,7 @@ val cap : descr -> descr -> descr
val
times
:
node
->
node
->
descr
val
xml
:
node
->
node
->
descr
val
record
:
Types
.
label
->
node
->
descr
val
record
:
label
->
node
->
descr
val
capture
:
id
->
descr
val
constant
:
id
->
Types
.
const
->
descr
...
...
@@ -56,7 +56,7 @@ module Compile: sig
record
:
record
option
;
}
and
record
=
|
RecLabel
of
Types
.
label
*
result
dispatch
dispatch
|
RecLabel
of
label
*
result
dispatch
dispatch
|
RecNolabel
of
result
option
*
result
option
and
'
a
dispatch
=
|
Dispatch
of
dispatcher
*
'
a
array
...
...
types/sortedList.ml
View file @
f2eb8125
...
...
@@ -60,8 +60,10 @@ sig
type
(
'
a
,
'
b
)
map
external
get
:
(
'
a
,
'
b
)
map
->
(
'
a
elem
*
'
b
)
list
=
"%identity"
val
empty
:
(
'
a
,
'
b
)
map
val
iter
:
(
'
b
->
unit
)
->
(
'
a
,
'
b
)
map
->
unit
val
is_empty
:
(
'
a
,
'
b
)
map
->
bool
val
singleton
:
'
a
elem
->
'
b
->
(
'
a
,
'
b
)
map
val
assoc_remove
:
'
a
elem
->
(
'
a
,
'
b
)
map
->
'
b
*
(
'
a
,
'
b
)
map
val
merge
:
(
'
b
->
'
b
->
'
b
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
merge_elem
:
'
b
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
union_disj
:
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
...
...
@@ -70,6 +72,7 @@ sig
val
map_from_slist
:
(
'
a
elem
->
'
b
)
->
'
a
t
->
(
'
a
,
'
b
)
map
val
collide
:
(
'
b
->
'
c
->
unit
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
c
)
map
->
unit
val
map
:
(
'
b
->
'
c
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
c
)
map
val
mapi
:
(
'
a
elem
->
'
b
->
'
c
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
c
)
map
val
constant
:
'
b
->
'
a
t
->
(
'
a
,
'
b
)
map
val
num
:
int
->
'
a
t
->
(
'
a
,
int
)
map
val
map_to_list
:
(
'
b
->
'
c
)
->
(
'
a
,
'
b
)
map
->
'
c
list
...
...
@@ -219,6 +222,23 @@ module Map = struct
let
is_empty
l
=
l
=
[]
let
singleton
x
y
=
[
(
x
,
y
)
]
let
rec
iter
f
=
function
|
(
_
,
y
)
::
l
->
f
y
;
iter
f
l
|
[]
->
()
let
rec
assoc_remove_aux
v
r
=
function
|
((
x
,
y
)
as
a
)
::
l
->
let
c
=
X
.
compare
x
v
in
if
c
=
0
then
(
r
:=
y
;
l
)
else
if
c
<
0
then
a
::
(
assoc_remove_aux
v
r
l
)
else
raise
Not_found
|
[]
->
raise
Not_found
let
assoc_remove
v
l
=
let
r
=
ref
(
Obj
.
magic
0
)
in
let
l
=
assoc_remove_aux
v
r
l
in
(
!
r
,
l
)
let
rec
merge
f
l1
l2
=
match
(
l1
,
l2
)
with
|
((
x1
,
y1
)
as
t1
)
::
q1
,
((
x2
,
y2
)
as
t2
)
::
q2
->
...
...
@@ -278,6 +298,10 @@ module Map = struct
|
(
x
,
y
)
::
l
->
(
x
,
f
y
)
::
(
map
f
l
)
|
[]
->
[]
let
rec
mapi
f
=
function
|
(
x
,
y
)
::
l
->
(
x
,
f
x
y
)
::
(
mapi
f
l
)
|
[]
->
[]
let
rec
mapi_to_list
f
=
function
|
(
x
,
y
)
::
l
->
(
f
x
y
)
::
(
mapi_to_list
f
l
)
|
[]
->
[]
...
...
types/sortedList.mli
View file @
f2eb8125
...
...
@@ -56,8 +56,10 @@ sig
type
(
'
a
,
'
b
)
map
external
get
:
(
'
a
,
'
b
)
map
->
(
'
a
elem
*
'
b
)
list
=
"%identity"
val
empty
:
(
'
a
,
'
b
)
map
val
iter
:
(
'
b
->
unit
)
->
(
'
a
,
'
b
)
map
->
unit
val
is_empty
:
(
'
a
,
'
b
)
map
->
bool
val
singleton
:
'
a
elem
->
'
b
->
(
'
a
,
'
b
)
map
val
assoc_remove
:
'
a
elem
->
(
'
a
,
'
b
)
map
->
'
b
*
(
'
a
,
'
b
)
map
val
merge
:
(
'
b
->
'
b
->
'
b
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
merge_elem
:
'
b
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
val
union_disj
:
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
b
)
map
...
...
@@ -67,6 +69,7 @@ sig
val
map_from_slist
:
(
'
a
elem
->
'
b
)
->
'
a
t
->
(
'
a
,
'
b
)
map
val
collide
:
(
'
b
->
'
c
->
unit
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
c
)
map
->
unit
val
map
:
(
'
b
->
'
c
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
c
)
map
val
mapi
:
(
'
a
elem
->
'
b
->
'
c
)
->
(
'
a
,
'
b
)
map
->
(
'
a
,
'
c
)
map
val
constant
:
'
b
->
'
a
t
->
(
'
a
,
'
b
)
map
val
num
:
int
->
'
a
t
->
(
'
a
,
int
)
map
val
map_to_list
:
(
'
b
->
'
c
)
->
(
'
a
,
'
b
)
map
->
'
c
list
...
...
types/types.ml
View file @
f2eb8125
open
Recursive
open
Printf
open
Ident
let
map_sort
f
l
=
SortedList
.
from_list
(
List
.
map
f
l
)
...
...
@@ -12,10 +12,6 @@ struct
let
equal
=
(
=
)
end
module
LabelPool
=
Pool
.
Make
(
SortedList
.
String
)
module
X
=
SortedList
.
Make
(
SortedList
.
Lift
(
LabelPool
))
type
label
=
LabelPool
.
t
type
const
=
|
Integer
of
Intervals
.
v
...
...
@@ -36,7 +32,45 @@ module NodePair = struct
let
hash
(
x
,
y
)
=
x
.
id
+
17
*
y
.
id
end
module
RecArg
=
struct
type
'
a
t
=
bool
*
'
a
node0
label_map
let
rec
compare_rec
r1
r2
=
if
r1
==
r2
then
0
else
match
(
r1
,
r2
)
with
|
(
l1
,
x1
)
::
r1
,
(
l2
,
x2
)
::
r2
->
if
((
l1
:
int
)
<
l2
)
then
-
1
else
if
(
l1
>
l2
)
then
1
else
if
x1
.
id
<
x2
.
id
then
-
1
else
if
x1
.
id
>
x2
.
id
then
1
else
compare_rec
r1
r2
|
([]
,_
)
->
-
1
|
_
->
1
let
compare
(
o1
,
r1
)
(
o2
,
r2
)
=
if
o1
&&
not
o2
then
-
1
else
if
o2
&&
not
o1
then
1
else
compare_rec
(
LabelMap
.
get
r1
)
(
LabelMap
.
get
r2
)
let
rec
equal_rec
r1
r2
=
(
r1
==
r2
)
||
match
(
r1
,
r2
)
with
|
(
l1
,
x1
)
::
r1
,
(
l2
,
x2
)
::
r2
->
(
x1
.
id
==
x2
.
id
)
&&
(
l1
==
l2
)
&&
(
equal_rec
r1
r2
)
|
_
->
false
let
equal
(
o1
,
r1
)
(
o2
,
r2
)
=
(
o1
==
o2
)
&&
(
equal_rec
(
LabelMap
.
get
r1
)
(
LabelMap
.
get
r2
))
let
rec
hash_rec
accu
=
function
|
(
l
,
x
)
::
rem
->
hash_rec
(
257
*
accu
+
17
*
l
+
x
.
id
)
rem
|
[]
->
accu
+
5
let
hash
(
o
,
r
)
=
hash_rec
(
if
o
then
2
else
1
)
(
LabelMap
.
get
r
)
end
module
BoolPair
=
Boolean
.
Make
(
NodePair
)
module
BoolRec
=
Boolean
.
Make
(
RecArg
)
type
descr
=
{
atoms
:
Atoms
.
t
;
...
...
@@ -45,7 +79,7 @@ type descr = {
times
:
descr
BoolPair
.
t
;
xml
:
descr
BoolPair
.
t
;
arrow
:
descr
BoolPair
.
t
;
record
:
(
bool
*
(
label
,
node
)
SortedMap
.
t
)
Bool
ean
.
t
;
record
:
descr
Bool
Rec
.
t
;
absent
:
bool
}
and
node
=
descr
node0
...
...
@@ -54,7 +88,7 @@ let empty = {
times
=
BoolPair
.
empty
;
xml
=
BoolPair
.
empty
;
arrow
=
BoolPair
.
empty
;
record
=
Bool
ean
.
empty
;
record
=
Bool
Rec
.
empty
;
ints
=
Intervals
.
empty
;
atoms
=
Atoms
.
empty
;
chars
=
Chars
.
empty
;
...
...
@@ -65,7 +99,7 @@ let any = {
times
=
BoolPair
.
full
;
xml
=
BoolPair
.
full
;
arrow
=
BoolPair
.
full
;
record
=
Bool
ean
.
full
;
record
=
Bool
Rec
.
full
;
ints
=
Intervals
.
any
;
atoms
=
Atoms
.
any
;
chars
=
Chars
.
any
;
...
...
@@ -78,9 +112,9 @@ let times x y = { empty with times = BoolPair.atom (x,y) }
let
xml
x
y
=
{
empty
with
xml
=
BoolPair
.
atom
(
x
,
y
)
}
let
arrow
x
y
=
{
empty
with
arrow
=
BoolPair
.
atom
(
x
,
y
)
}
let
record
label
t
=
{
empty
with
record
=
Bool
ean
.
atom
(
true
,
[
label
,
t
]
)
}
let
record'
x
=
{
empty
with
record
=
Bool
ean
.
atom
x
}
{
empty
with
record
=
Bool
Rec
.
atom
(
true
,
LabelMap
.
singleton
label
t
)
}
let
record'
(
x
:
bool
*
node
Ident
.
label_map
)
=
{
empty
with
record
=
Bool
Rec
.
atom
x
}
let
atom
a
=
{
empty
with
atoms
=
a
}
let
char
c
=
{
empty
with
chars
=
c
}
let
constant
=
function
...
...
@@ -93,7 +127,7 @@ let cup x y =
times
=
BoolPair
.
cup
x
.
times
y
.
times
;
xml
=
BoolPair
.
cup
x
.
xml
y
.
xml
;
arrow
=
BoolPair
.
cup
x
.
arrow
y
.
arrow
;
record
=
Bool
ean
.
cup
x
.
record
y
.
record
;
record
=
Bool
Rec
.
cup
x
.
record
y
.
record
;