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
e2cc58c4
Commit
e2cc58c4
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-09-24 23:21:08 by cvscast] Cleaning
Original author: cvscast Date: 2003-09-24 23:21:10+00:00
parent
100aebe4
Changes
13
Expand all
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
e2cc58c4
...
...
@@ -72,6 +72,7 @@ CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
OBJECTS
=
\
misc/stats.cmo
\
misc/serialize.cmo misc/custom.cmo
\
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo
\
misc/pretty.cmo misc/ns.cmo
\
...
...
depend
View file @
e2cc58c4
misc/stats.cmo: misc/q_symbol.cmo misc/stats.cmi
misc/stats.cmx: misc/q_symbol.cmo misc/stats.cmi
misc/serialize.cmo: misc/q_symbol.cmo misc/serialize.cmi
misc/serialize.cmx: misc/q_symbol.cmo misc/serialize.cmi
misc/custom.cmo: misc/q_symbol.cmo misc/serialize.cmi
...
...
driver/run.ml
View file @
e2cc58c4
...
...
@@ -34,6 +34,8 @@ let specs =
" suppress normal output (typing, results)"
;
"--stdin"
,
Arg
.
Unit
(
fun
()
->
src
:=
""
::
!
src
)
,
" read CDuce script on standard input"
;
"--verbose"
,
Arg
.
Unit
(
fun
()
->
Stats
.
set_verbosity
Stats
.
Summary
)
,
"print profiling/debugging information"
;
"-v"
,
Arg
.
Unit
version
,
" print CDuce version"
;
"--version"
,
Arg
.
Unit
version
,
...
...
@@ -165,5 +167,8 @@ let main () =
let
()
=
main
()
let
()
=
at_exit
(
fun
()
->
Stats
.
dump
Format
.
std_formatter
);
main
()
misc/stats.ml
0 → 100644
View file @
e2cc58c4
type
verbosity
=
Quiet
|
Summary
|
Details
let
verbosity
=
ref
Quiet
let
set_verbosity
=
(
:=
)
verbosity
let
todo
=
ref
[]
let
register
level
f
=
todo
:=
(
level
,
f
)
::
!
todo
let
dump
ppf
=
List
.
iter
(
function
|
(
level
,
f
)
when
level
<=
!
verbosity
->
f
ppf
|
_
->
()
)
!
todo
module
Timer
=
struct
type
t
=
{
name
:
string
;
mutable
count
:
int
;
mutable
total
:
float
;
mutable
last
:
float
;
mutable
is_in
:
bool
;
}
let
print
ppf
c
=
Format
.
fprintf
ppf
"Timer %s@
\n
Total time: %f@
\n
Count: %i@
\n
"
c
.
name
c
.
total
c
.
count
let
create
s
=
let
c
=
{
name
=
s
;
count
=
0
;
total
=
0
.;
last
=
0
.;
is_in
=
false
}
in
register
Summary
(
fun
ppf
->
print
ppf
c
);
c
let
start
c
=
assert
(
not
c
.
is_in
);
c
.
is_in
<-
true
;
c
.
last
<-
Unix
.
gettimeofday
()
;
c
.
count
<-
c
.
count
+
1
let
stop
c
=
assert
(
c
.
is_in
);
c
.
is_in
<-
false
;
c
.
total
<-
c
.
total
+.
(
Unix
.
gettimeofday
()
-.
c
.
last
)
end
misc/stats.mli
0 → 100644
View file @
e2cc58c4
type
verbosity
=
Quiet
|
Summary
|
Details
val
set_verbosity
:
verbosity
->
unit
val
register
:
verbosity
->
(
Format
.
formatter
->
unit
)
->
unit
val
dump
:
Format
.
formatter
->
unit
module
Timer
:
sig
type
t
val
create
:
string
->
t
val
start
:
t
->
unit
val
stop
:
t
->
unit
val
print
:
Format
.
formatter
->
t
->
unit
end
parser/ast.ml
View file @
e2cc58c4
...
...
@@ -9,7 +9,7 @@ type pprog = pmodule_item list
and
pmodule_item
=
pmodule_item'
located
and
pmodule_item'
=
|
TypeDecl
of
U
.
t
*
ppat
|
TypeDecl
of
id
*
ppat
|
SchemaDecl
of
string
*
Schema_types
.
schema
(* name, schema *)
|
LetDecl
of
ppat
*
pexpr
|
FunDecl
of
pexpr
...
...
@@ -82,12 +82,12 @@ and branches = (ppat * pexpr) list
and
ppat
=
ppat'
located
and
ppat'
=
|
PatVar
of
U
.
t
|
PatVar
of
id
|
SchemaVar
of
(* type/pattern schema variable *)
schema_item_kind
*
string
*
string
|
Cst
of
pexpr
|
NsT
of
U
.
t
|
Recurs
of
ppat
*
(
U
.
t
*
ppat
)
list
|
Recurs
of
ppat
*
(
id
*
ppat
)
list
|
Internal
of
Types
.
descr
|
Or
of
ppat
*
ppat
|
And
of
ppat
*
ppat
...
...
parser/parser.ml
View file @
e2cc58c4
...
...
@@ -92,7 +92,7 @@ EXTEND
[
l
=
LIST0
[
p
=
phrase
;
OPT
";;"
->
p
];
EOI
->
List
.
flatten
l
]
];
uident
:
[
[
x
=
IDENT
->
parse_
ident
x
]
];
uident
:
[
[
x
=
IDENT
->
ident
x
]
];
phrase
:
[
[
(
f
,
p
,
e
)
=
let_binding
->
...
...
@@ -192,7 +192,6 @@ EXTEND
typ
=
[
IDENT
|
keyword
]
->
exp
loc
(
Validate
(
e
,
schema
,
typ
))
|
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
let
f
=
match
f
with
Some
x
->
Some
(
Ident
.
ident
x
)
|
None
->
None
in
exp
loc
(
Abstraction
{
fun_name
=
f
;
fun_iface
=
a
;
fun_body
=
b
})
|
(
_
,
p
,
e1
)
=
let_binding
;
"in"
;
e2
=
expr
LEVEL
"top"
->
exp
loc
(
Match
(
e1
,
[
p
,
e2
]))
...
...
@@ -289,7 +288,7 @@ EXTEND
|
s
=
STRING2
->
let
s
=
U
.
mk
s
in
exp
loc
(
String
(
U
.
start_index
s
,
U
.
end_index
s
,
s
,
cst_nil
))
|
a
=
IDENT
->
exp
loc
(
Var
(
ident
a
)
)
|
a
=
uident
->
exp
loc
(
Var
a
)
|
"!"
;
e
=
expr
->
exp
loc
(
Apply
(
Dot
(
e
,
U
.
mk
"get"
)
,
cst_nil
))
|
i
=
INT
->
exp
loc
(
Integer
(
Intervals
.
V
.
mk
i
))
...
...
@@ -333,7 +332,7 @@ EXTEND
[
"let"
;
is_fun_decl
;
OPT
"fun"
;
(
f
,
a
,
b
)
=
fun_decl
->
let
f
=
match
f
with
Some
x
->
x
|
None
->
assert
false
in
let
p
=
mk
loc
(
PatVar
f
)
in
let
abst
=
{
fun_name
=
Some
(
Ident
.
ident
f
)
;
fun_iface
=
a
;
fun_body
=
b
}
in
let
abst
=
{
fun_name
=
Some
f
;
fun_iface
=
a
;
fun_body
=
b
}
in
let
e
=
exp
loc
(
Abstraction
abst
)
in
(
true
,
p
,
e
)
|
"let"
;
p
=
pat
;
"="
;
e
=
expr
->
(
false
,
p
,
e
)
...
...
@@ -366,8 +365,9 @@ EXTEND
fun_decl
:
[
[
f
=
OPT
uident
;
"("
;
(
a
,
b
)
=
fun_decl_after_lparen
->
(
f
,
a
,
b
)
[
f
=
OPT
IDENT
;
"("
;
(
a
,
b
)
=
fun_decl_after_lparen
->
let
f
=
match
f
with
Some
x
->
Some
(
ident
x
)
|
None
->
None
in
(
f
,
a
,
b
)
]
];
...
...
@@ -399,8 +399,8 @@ EXTEND
|
x
=
regexp
;
"?"
->
Alt
(
x
,
Epsilon
)
|
x
=
regexp
;
"??"
->
Alt
(
Epsilon
,
x
)
]
|
[
"("
;
x
=
regexp
;
")"
->
x
|
"("
;
a
=
IDENT
;
":="
;
c
=
expr
;
")"
->
Elem
(
mk
loc
(
Constant
((
ident
a
,
c
))))
|
"("
;
a
=
uident
;
":="
;
c
=
expr
;
")"
->
Elem
(
mk
loc
(
Constant
((
a
,
c
))))
|
IDENT
"PCDATA"
->
string_regexp
|
i
=
STRING1
;
"--"
;
j
=
STRING1
->
let
i
=
Chars
.
V
.
mk_int
(
parse_char
loc
i
)
...
...
@@ -413,8 +413,8 @@ EXTEND
let
c
=
Chars
.
atom
c
in
Seq
(
Elem
(
mknoloc
(
Internal
(
Types
.
char
c
)))
,
accu
))
(
seq_of_string
s
)
Epsilon
|
e
=
pat
LEVEL
"simple"
->
Elem
e
Epsilon
]
|
[
e
=
pat
LEVEL
"simple"
->
Elem
e
]
];
...
...
types/builtin.ml
View file @
e2cc58c4
...
...
@@ -22,7 +22,7 @@ let () =
List
.
iter
(
fun
(
n
,
t
)
->
Typer
.
register_global_types
[
Ident
.
U
.
mk
n
,
[
Ident
.
ident
(
Ident
.
U
.
mk
n
)
,
Location
.
mknoloc
(
Ast
.
Internal
t
)])
types
...
...
types/ident.ml
View file @
e2cc58c4
...
...
@@ -9,6 +9,11 @@ type fv = IdSet.t
let
ident
=
Id
.
mk
let
to_string
id
=
U
.
to_string
(
Id
.
value
id
)
let
print
ppf
id
=
Format
.
fprintf
ppf
"%s"
(
to_string
id
)
module
Label
=
struct
type
t
=
Ns
.
qname
...
...
types/sequence.ml
View file @
e2cc58c4
...
...
@@ -68,7 +68,7 @@ let approx t =
let
map_tree
f
seq
=
let
memo
=
ref
H
.
empty
in
let
rec
aux
t
=
(*
Printf.eprintf "A"; flush stderr; *)
(* Printf.eprintf "A"; flush stderr; *)
try
H
.
find
t
!
memo
with
Not_found
->
let
v
=
V
.
forward
()
in
...
...
types/types.ml
View file @
e2cc58c4
open
Ident
open
Encodings
(* TODO:
- I store hash in types to avoid computing it several times.
Does not seem to help a lot.
*)
(*
To be sure not to use generic comparison ...
*)
...
...
@@ -76,6 +81,7 @@ sig
but a bug in OCaml 3.07+beta 2 makes it impossible
*)
type
t
=
{
mutable
hash
:
int
;
atoms
:
Atoms
.
t
;
ints
:
Intervals
.
t
;
chars
:
Chars
.
t
;
...
...
@@ -96,6 +102,7 @@ end =
struct
include
Custom
.
Dummy
type
t
=
{
mutable
hash
:
int
;
atoms
:
Atoms
.
t
;
ints
:
Intervals
.
t
;
chars
:
Chars
.
t
;
...
...
@@ -106,14 +113,16 @@ struct
absent
:
bool
}
let
equal
a
b
=
(
Atoms
.
equal
a
.
atoms
b
.
atoms
)
&&
(
Chars
.
equal
a
.
chars
b
.
chars
)
&&
(
Intervals
.
equal
a
.
ints
b
.
ints
)
&&
(
BoolPair
.
equal
a
.
times
b
.
times
)
&&
(
BoolPair
.
equal
a
.
xml
b
.
xml
)
&&
(
BoolPair
.
equal
a
.
arrow
b
.
arrow
)
&&
(
BoolRec
.
equal
a
.
record
b
.
record
)
&&
(
a
.
absent
==
b
.
absent
)
(
a
==
b
)
||
(
(
Atoms
.
equal
a
.
atoms
b
.
atoms
)
&&
(
Chars
.
equal
a
.
chars
b
.
chars
)
&&
(
Intervals
.
equal
a
.
ints
b
.
ints
)
&&
(
BoolPair
.
equal
a
.
times
b
.
times
)
&&
(
BoolPair
.
equal
a
.
xml
b
.
xml
)
&&
(
BoolPair
.
equal
a
.
arrow
b
.
arrow
)
&&
(
BoolRec
.
equal
a
.
record
b
.
record
)
&&
(
a
.
absent
==
b
.
absent
)
)
let
compare
a
b
=
if
a
==
b
then
0
...
...
@@ -129,15 +138,18 @@ struct
else
0
let
hash
a
=
let
accu
=
Chars
.
hash
a
.
chars
in
let
accu
=
17
*
accu
+
Intervals
.
hash
a
.
ints
in
let
accu
=
17
*
accu
+
Atoms
.
hash
a
.
atoms
in
let
accu
=
17
*
accu
+
BoolPair
.
hash
a
.
times
in
let
accu
=
17
*
accu
+
BoolPair
.
hash
a
.
xml
in
let
accu
=
17
*
accu
+
BoolPair
.
hash
a
.
arrow
in
let
accu
=
17
*
accu
+
BoolRec
.
hash
a
.
record
in
let
accu
=
if
a
.
absent
then
accu
+
5
else
accu
in
accu
if
a
.
hash
<>
0
then
a
.
hash
else
(
let
accu
=
Chars
.
hash
a
.
chars
in
let
accu
=
17
*
accu
+
Intervals
.
hash
a
.
ints
in
let
accu
=
17
*
accu
+
Atoms
.
hash
a
.
atoms
in
let
accu
=
17
*
accu
+
BoolPair
.
hash
a
.
times
in
let
accu
=
17
*
accu
+
BoolPair
.
hash
a
.
xml
in
let
accu
=
17
*
accu
+
BoolPair
.
hash
a
.
arrow
in
let
accu
=
17
*
accu
+
BoolRec
.
hash
a
.
record
in
let
accu
=
if
a
.
absent
then
accu
+
5
else
accu
in
a
.
hash
<-
accu
;
accu
)
let
serialize
t
a
=
Chars
.
serialize
t
a
.
chars
;
...
...
@@ -158,7 +170,8 @@ struct
let
arrow
=
BoolPair
.
deserialize
t
in
let
record
=
BoolRec
.
deserialize
t
in
let
absent
=
Serialize
.
Get
.
bool
t
in
{
chars
=
chars
;
ints
=
ints
;
atoms
=
atoms
;
times
=
times
;
xml
=
xml
;
{
hash
=
0
;
chars
=
chars
;
ints
=
ints
;
atoms
=
atoms
;
times
=
times
;
xml
=
xml
;
arrow
=
arrow
;
record
=
record
;
absent
=
absent
}
...
...
@@ -213,6 +226,7 @@ type node = Node.t
include
Descr
let
empty
=
{
hash
=
0
;
times
=
BoolPair
.
empty
;
xml
=
BoolPair
.
empty
;
arrow
=
BoolPair
.
empty
;
...
...
@@ -224,6 +238,7 @@ let empty = {
}
let
any
=
{
hash
=
0
;
times
=
BoolPair
.
full
;
xml
=
BoolPair
.
full
;
arrow
=
BoolPair
.
full
;
...
...
@@ -235,22 +250,26 @@ let any = {
}
let
non_constructed
=
{
any
with
times
=
empty
.
times
;
xml
=
empty
.
xml
;
record
=
empty
.
record
}
{
any
with
hash
=
0
;
times
=
empty
.
times
;
xml
=
empty
.
xml
;
record
=
empty
.
record
}
let
interval
i
=
{
empty
with
ints
=
i
}
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
interval
i
=
{
empty
with
hash
=
0
;
ints
=
i
}
let
times
x
y
=
{
empty
with
hash
=
0
;
times
=
BoolPair
.
atom
(
x
,
y
)
}
let
xml
x
y
=
{
empty
with
hash
=
0
;
xml
=
BoolPair
.
atom
(
x
,
y
)
}
let
arrow
x
y
=
{
empty
with
hash
=
0
;
arrow
=
BoolPair
.
atom
(
x
,
y
)
}
let
record
label
t
=
{
empty
with
record
=
BoolRec
.
atom
(
true
,
LabelMap
.
singleton
label
t
)
}
{
empty
with
hash
=
0
;
record
=
BoolRec
.
atom
(
true
,
LabelMap
.
singleton
label
t
)
}
let
record'
(
x
:
bool
*
node
Ident
.
label_map
)
=
{
empty
with
record
=
BoolRec
.
atom
x
}
let
atom
a
=
{
empty
with
atoms
=
a
}
let
char
c
=
{
empty
with
chars
=
c
}
{
empty
with
hash
=
0
;
record
=
BoolRec
.
atom
x
}
let
atom
a
=
{
empty
with
hash
=
0
;
atoms
=
a
}
let
char
c
=
{
empty
with
hash
=
0
;
chars
=
c
}
let
cup
x
y
=
if
x
==
y
then
x
else
{
hash
=
0
;
times
=
BoolPair
.
cup
x
.
times
y
.
times
;
xml
=
BoolPair
.
cup
x
.
xml
y
.
xml
;
arrow
=
BoolPair
.
cup
x
.
arrow
y
.
arrow
;
...
...
@@ -263,6 +282,7 @@ let cup x y =
let
cap
x
y
=
if
x
==
y
then
x
else
{
hash
=
0
;
times
=
BoolPair
.
cap
x
.
times
y
.
times
;
xml
=
BoolPair
.
cap
x
.
xml
y
.
xml
;
record
=
BoolRec
.
cap
x
.
record
y
.
record
;
...
...
@@ -275,6 +295,7 @@ let cap x y =
let
diff
x
y
=
if
x
==
y
then
empty
else
{
hash
=
0
;
times
=
BoolPair
.
diff
x
.
times
y
.
times
;
xml
=
BoolPair
.
diff
x
.
xml
y
.
xml
;
arrow
=
BoolPair
.
diff
x
.
arrow
y
.
arrow
;
...
...
@@ -305,18 +326,26 @@ module DescrMap = Map.Make(Descr)
module
DescrSet
=
Set
.
Make
(
Descr
)
module
DescrSList
=
SortedList
.
Make
(
Descr
)
(*
let hash_cons = DescrHash.create 17000
*)
let
hash_cons
=
DescrHash
.
create
17000
let
count
=
State
.
ref
"Types.count"
0
let
()
=
Stats
.
register
Stats
.
Summary
(
fun
ppf
->
Format
.
fprintf
ppf
"Allocated type nodes:%i@
\n
"
!
count
)
let
make
()
=
incr
count
;
{
Node
.
id
=
!
count
;
Node
.
descr
=
empty
}
let
define
n
d
=
(*
DescrHash.add hash_cons d n;
*)
DescrHash
.
add
hash_cons
d
n
;
n
.
Node
.
descr
<-
d
let
cons
d
=
(* try DescrHash.find hash_cons d with Not_found ->
incr count; let n = { id = !count; descr = d } in
DescrHash.add hash_cons d n; n *)
incr
count
;
{
Node
.
id
=
!
count
;
Node
.
descr
=
d
}
try
DescrHash
.
find
hash_cons
d
with
Not_found
->
incr
count
;
let
n
=
{
Node
.
id
=
!
count
;
Node
.
descr
=
d
}
in
DescrHash
.
add
hash_cons
d
n
;
n
let
descr
n
=
n
.
Node
.
descr
let
internalize
n
=
n
let
id
n
=
n
.
Node
.
id
...
...
@@ -342,6 +371,9 @@ let any_node = cons any
module
LabelS
=
Set
.
Make
(
LabelPool
)
let
any_or_absent
=
{
any
with
hash
=
0
;
absent
=
true
}
let
only_absent
=
{
empty
with
hash
=
0
;
absent
=
true
}
let
get_record
r
=
let
labs
accu
(
_
,
r
)
=
List
.
fold_left
...
...
@@ -356,8 +388,8 @@ let get_record r =
descrs
.
(
i
)
<-
cap
descrs
.
(
i
)
(
descr
x
);
aux
(
i
+
1
)
labs
r
|
r
->
if
not
o
then
descrs
.
(
i
)
<-
cap
descrs
.
(
i
)
{
empty
with
absent
=
true
}
;
(* TODO:OPT *)
if
not
o
then
descrs
.
(
i
)
<-
cap
descrs
.
(
i
)
only_absent
;
(* TODO:OPT *)
aux
(
i
+
1
)
labs
r
in
aux
0
labs
(
LabelMap
.
get
r
);
...
...
@@ -368,7 +400,7 @@ let get_record r =
List
.
fold_left
labs
(
List
.
fold_left
labs
LabelS
.
empty
p
)
n
in
let
labels
=
LabelS
.
elements
labels
in
let
nlab
=
List
.
length
labels
in
let
mk
()
=
Array
.
create
nlab
{
any
with
absent
=
true
}
in
let
mk
()
=
Array
.
create
nlab
any
_or_absent
in
let
pos
=
mk
()
in
let
opos
=
List
.
fold_left
...
...
@@ -400,7 +432,7 @@ let cap_product any_left any_right l =
(
fun
(
d1
,
d2
)
(
t1
,
t2
)
->
(
cap_t
d1
t1
,
cap_t
d2
t2
))
(
any_left
,
any_right
)
l
let
any_pair
=
{
empty
with
times
=
any
.
times
}
let
any_pair
=
{
empty
with
hash
=
0
;
times
=
any
.
times
}
let
rec
exists
max
f
=
...
...
@@ -553,6 +585,8 @@ let clearly_disjoint t1 t2 =
*)
trivially_disjoint
t1
t2
||
ClearlyEmpty
.
is_empty
(
cap
t1
t2
)
(* TODO: need to invesigate when ClearEmpty is a good thing... *)
let
memo
=
DescrHash
.
create
33000
let
marks
=
ref
[]
...
...
@@ -659,13 +693,17 @@ and check_record (labels,(oleft,left),rights) s =
start
(
Array
.
length
left
-
1
)
s
let
timer_subtype
=
Stats
.
Timer
.
create
"Types.is_empty"
let
is_empty
d
=
Stats
.
Timer
.
start
timer_subtype
;
let
s
=
slot
d
in
List
.
iter
(
fun
s'
->
if
s'
.
status
==
Maybe
then
s'
.
status
<-
Empty
;
s'
.
notify
<-
Nothing
)
!
marks
;
marks
:=
[]
;
Stats
.
Timer
.
stop
timer_subtype
;
s
.
status
==
Empty
(*
...
...
@@ -690,8 +728,8 @@ struct
let
other
?
(
kind
=
`Normal
)
d
=
match
kind
with
|
`Normal
->
{
d
with
times
=
empty
.
times
}
|
`XML
->
{
d
with
xml
=
empty
.
xml
}
|
`Normal
->
{
d
with
hash
=
0
;
times
=
empty
.
times
}
|
`XML
->
{
d
with
hash
=
0
;
xml
=
empty
.
xml
}
let
is_product
?
kind
d
=
is_empty
(
other
?
kind
d
)
...
...
@@ -828,19 +866,19 @@ struct
any
n
let
any
=
{
empty
with
times
=
any
.
times
}
and
any_xml
=
{
empty
with
xml
=
any
.
xml
}
let
any
=
{
empty
with
hash
=
0
;
times
=
any
.
times
}
and
any_xml
=
{
empty
with
hash
=
0
;
xml
=
any
.
xml
}
let
is_empty
d
=
d
==
[]
end
module
Record
=
struct
let
has_record
d
=
not
(
is_empty
{
empty
with
record
=
d
.
record
})
let
or_absent
d
=
{
d
with
absent
=
true
}
let
has_record
d
=
not
(
is_empty
{
empty
with
hash
=
0
;
record
=
d
.
record
})
let
or_absent
d
=
{
d
with
hash
=
0
;
absent
=
true
}
let
any_or_absent
=
or_absent
any
let
has_absent
d
=
d
.
absent
let
only_absent
=
{
empty
with
absent
=
true
}
let
only_absent
=
{
empty
with
hash
=
0
;
absent
=
true
}
let
only_absent_node
=
cons
only_absent
module
T
=
struct
...
...
@@ -854,7 +892,7 @@ struct
end
module
R
=
struct
type
t
=
descr
let
any
=
{
empty
with
record
=
any
.
record
}
let
any
=
{
empty
with
hash
=
0
;
record
=
any
.
record
}
let
cap
=
cap
let
cup
=
cup
let
diff
=
diff
...
...
@@ -863,11 +901,11 @@ struct
end
module
TR
=
Normal
.
Make
(
T
)(
R
)
let
any_record
=
{
empty
with
record
=
BoolRec
.
full
}
let
any_record
=
{
empty
with
hash
=
0
;
record
=
BoolRec
.
full
}
let
atom
o
l
=
if
o
&&
LabelMap
.
is_empty
l
then
any_record
else
{
empty
with
record
=
BoolRec
.
atom
(
o
,
l
)
}
{
empty
with
hash
=
0
;
record
=
BoolRec
.
atom
(
o
,
l
)
}
type
zor
=
Pair
of
descr
*
descr
|
Any
...
...
@@ -879,10 +917,10 @@ struct
with
Not_found
->
if
o
then
if
LabelMap
.
is_empty
r
then
Any
else
Pair
(
any_or_absent
,
{
empty
with
record
=
BoolRec
.
atom
(
o
,
r
)
})
Pair
(
any_or_absent
,
{
empty
with
hash
=
0
;
record
=
BoolRec
.
atom
(
o
,
r
)
})
else
Pair
(
only_absent
,
{
empty
with
record
=
BoolRec
.
atom
(
o
,
r
)
})
{
empty
with
hash
=
0
;
record
=
BoolRec
.
atom
(
o
,
r
)
})
in
List
.
fold_left
(
fun
b
(
p
,
n
)
->
...
...
@@ -916,7 +954,7 @@ struct
let
project_opt
d
l
=
let
t
=
TR
.
pi1
(
split
d
l
)
in
{
t
with
absent
=
false
}
{
t
with
hash
=
0
;
absent
=
false
}
let
condition
d
l
t
=
TR
.
pi2_restricted
t
(
split
d
l
)
...
...
@@ -979,7 +1017,7 @@ struct
let
loop
(
t1
,
d1
)
(
t2
,
d2
)
=
let
t
=
if
t2
.
absent
then
cup
t1
{
t2
with
absent
=
false
}
then
cup
t1
{
t2
with
hash
=
0
;
absent
=
false
}
else
t2
in
aux
((
l
,
cons
t
)
::
accu
)
d1
d2
...
...
@@ -990,7 +1028,7 @@ struct
aux
[]
d1
d2
;
!
res
let
any
=
{
empty
with
record
=
any
.
record
}
let
any
=
{
empty
with
hash
=
0
;
record
=
any
.
record
}
let
get
d
=
let
rec
aux
r
accu
d
=
...
...
@@ -1001,7 +1039,7 @@ struct
else
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
let
x
=
(
t1
.
absent
,
{
t1
with
absent
=
false
})
in
let
x
=
(
t1
.
absent
,
{
t1
with
hash
=
0
;
absent
=
false
})
in
aux
((
l
,
x
)
::
r
)
accu
t2
)
accu
(
split
d
l
)
...
...
@@ -1066,7 +1104,7 @@ struct
let
named
=
State
.
ref
"Types.Print.named"
DescrMap
.
empty
let
named_xml
=
State
.
ref
"Types.Print.named_xml"
DescrPairMap
.
empty
let
register_global
(
name
:
U
.
t
)
d
=
if
equal
{
d
with
xml
=
BoolPair
.
empty
}
empty
then
if
equal
{
d
with
hash
=
0
;
xml
=
BoolPair
.
empty
}
empty
then
(
let
l
=
(*Product.merge_same_2*)
(
Product
.
get
~
kind
:
`XML
d
)
in
match
l
with
|
[(
t1
,
t2
)]
->
named_xml
:=
DescrPairMap
.
add
(
t1
,
t2
)
name
!
named_xml
...
...
@@ -1086,7 +1124,7 @@ struct
let
trivial_rec
b
=
b
==
BoolRec
.
empty
||
(
is_empty
{
empty
with
record
=
BoolRec
.
diff
BoolRec
.
full
b
})
(
is_empty
{
empty
with
hash
=
0
;
record
=
BoolRec
.
diff
BoolRec
.
full
b
})
let
trivial_pair
b
=
b
==
BoolPair
.
empty
||
b
==
BoolPair
.
full
...
...
@@ -1123,7 +1161,7 @@ struct
if
not
(
worth_abbrev
d
)
then
slot
.
state
<-
`Expand
;
DescrHash
.
add
memo
d
slot
;
let
(
seq
,
not_seq
)
=
if
(
subtype
{
empty
with
times
=
d
.
times
}
seqs_descr
)
then
if
(
subtype
{
empty
with
hash
=
0
;
times
=
d
.
times
}
seqs_descr
)
then
(
cap
d
seqs_descr
,
diff
d
seqs_descr
)
else
(
empty
,
d
)
in
...
...
@@ -1143,9 +1181,9 @@ struct
Not_found
->
let
tag
=
match
Atoms
.
print_tag
t1
.
atoms
with
|
Some
a
when
is_empty
{
t1
with
atoms
=
Atoms
.
empty
}
->
`Tag
a
|
Some
a
when
is_empty
{
t1
with
hash
=
0
;
atoms
=
Atoms
.
empty
}
->
`Tag
a
|
_
->
`Type
(
prepare
t1
)
in
assert
(
equal
{
t2
with
times
=
empty
.
times
}
empty
);
assert
(
equal
{
t2
with
hash
=
0
;
times
=
empty
.
times
}
empty
);
List
.
iter
(
fun
(
ta
,
tb
)
->
add
(
Xml
(
tag
,
prepare
ta
,
prepare
tb
)))