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
59c2242e
Commit
59c2242e
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2003-03-07 17:31:04 by cvscast] Empty log message
Original author: cvscast Date: 2003-03-07 17:31:05+00:00
parent
4380e848
Changes
23
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
59c2242e
...
...
@@ -45,7 +45,7 @@ DEBUG = -g
PACKAGES
=
pxp-engine,pxp-lex-iso88591,wlexing,camlp4,num,cgi
OCAMLCP
=
ocamlc
OCAMLC
=
ocamlfind
$(OCAMLCP)
-package
$(PACKAGES)
OCAMLOPT
=
ocamlfind ocamlopt
-package
$(PACKAGES)
OCAMLOPT
=
ocamlfind ocamlopt
-package
$(PACKAGES)
DEPEND
=
$
(
DIRS:
=
/
*
.ml
)
$
(
DIRS:
=
/
*
.mli
)
INCLUDES
=
$
(
DIRS:%
=
-I
%
)
...
...
misc/pool.ml
View file @
59c2242e
...
...
@@ -49,7 +49,8 @@ struct
let
value
n
=
match
!
values
.
(
n
)
with
Some
x
->
x
|
None
->
assert
false
let
compare
(
n1
:
int
)
(
n2
:
int
)
=
Pervasives
.
compare
n1
n2
let
compare
(
n1
:
int
)
(
n2
:
int
)
=
if
n1
<
n2
then
-
1
else
if
n1
=
n2
then
0
else
1
let
hash
n
=
n
let
equal
(
n1
:
int
)
(
n2
:
int
)
=
n1
=
n2
end
...
...
misc/pool.mli
View file @
59c2242e
...
...
@@ -23,5 +23,5 @@ sig
val
equal
:
t
->
t
->
bool
end
module
Make
(
H
:
Hashtbl
.
HashedType
)
:
T
with
type
value
=
H
.
t
module
Make
(
H
:
Hashtbl
.
HashedType
)
:
T
with
type
value
=
H
.
t
and
type
t
=
int
parser/parser.ml
View file @
59c2242e
...
...
@@ -51,7 +51,7 @@ let parse_char loc s =
let
char_list
pos
s
=
let
s
=
seq_of_string
pos
s
in
List
.
map
(
fun
(
loc
,
c
)
->
mk
loc
(
Cst
(
Types
.
Char
(
Chars
.
Unichar
.
fro
m_char
c
))))
s
List
.
map
(
fun
(
loc
,
c
)
->
mk
loc
(
Cst
(
Types
.
Char
(
Chars
.
m
k
_char
c
))))
s
EXTEND
...
...
@@ -153,7 +153,7 @@ EXTEND
|
`Explode
x
->
mk
x
.
loc
(
Op
(
"@"
,
[
x
;
q
]))
)
l
e
|
t
=
[
a
=
TAG
->
mk
loc
(
Cst
(
Types
.
Atom
(
Types
.
AtomPool
.
mk
a
)))
mk
loc
(
Cst
(
Types
.
Atom
(
Atoms
.
mk
a
)))
|
"<"
;
e
=
expr
LEVEL
"no_appl"
->
e
];
a
=
expr_attrib_spec
;
">"
;
c
=
expr
->
mk
loc
(
Xml
(
t
,
mk
loc
(
Pair
(
a
,
c
))))
...
...
@@ -238,14 +238,14 @@ EXTEND
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
Elem
(
mk
loc
(
Constant
(
a
,
c
)))
|
UIDENT
"PCDATA"
->
string_regexp
|
i
=
STRING1
;
"--"
;
j
=
STRING1
->
let
i
=
Chars
.
Unichar
.
fro
m_char
(
parse_char
loc
i
)
and
j
=
Chars
.
Unichar
.
fro
m_char
(
parse_char
loc
j
)
in
let
i
=
Chars
.
m
k
_char
(
parse_char
loc
i
)
and
j
=
Chars
.
m
k
_char
(
parse_char
loc
j
)
in
Elem
(
mk
loc
(
Internal
(
Types
.
char
(
Chars
.
char_class
i
j
))))
|
s
=
STRING1
->
let
s
=
seq_of_string
loc
s
in
List
.
fold_right
(
fun
(
loc
,
c
)
accu
->
let
c
=
Chars
.
Unichar
.
fro
m_char
c
in
let
c
=
Chars
.
m
k
_char
c
in
let
c
=
Chars
.
atom
c
in
Seq
(
Elem
(
mk
loc
(
Internal
(
Types
.
char
c
)))
,
accu
))
s
...
...
@@ -270,17 +270,17 @@ EXTEND
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
mk
loc
(
Constant
(
a
,
c
))
|
a
=
UIDENT
->
mk
loc
(
PatVar
a
)
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
Big_int
.
big_int_of_string
i
and
j
=
Big_int
.
big_int_of_string
j
in
let
i
=
Intervals
.
mk
i
and
j
=
Intervals
.
mk
j
in
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
bounded
i
j
)))
|
i
=
INT
->
let
i
=
Big_int
.
big_int_of_string
i
in
let
i
=
Intervals
.
mk
i
in
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
atom
i
)))
|
"*"
;
"--"
;
j
=
INT
->
let
j
=
Big_int
.
big_int_of_string
j
in
let
j
=
Intervals
.
mk
j
in
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
left
j
)))
|
i
=
INT
;
"--"
;
"*"
->
let
i
=
Big_int
.
big_int_of_string
i
in
let
i
=
Intervals
.
mk
i
in
mk
loc
(
Internal
(
Types
.
interval
(
Intervals
.
right
i
)))
|
i
=
char
->
mk
loc
(
Internal
(
Types
.
char
(
Chars
.
char_class
i
i
)))
...
...
@@ -296,7 +296,7 @@ EXTEND
[
"<"
;
LIDENT
"_"
->
mk
loc
(
Internal
(
Types
.
atom
(
Atoms
.
any
)))
|
a
=
TAG
->
mk
loc
(
Internal
(
Types
.
atom
(
Atoms
.
atom
(
Types
.
AtomPool
.
mk
a
))))
]
(
Internal
(
Types
.
atom
(
Atoms
.
atom
(
Atoms
.
mk
a
))))
]
|
[
"<"
;
t
=
pat
->
t
]
];
a
=
attrib_spec
;
">"
;
c
=
pat
->
...
...
@@ -308,7 +308,7 @@ EXTEND
mk
loc
(
Internal
(
Types
.
char
(
Chars
.
atom
(
Chars
.
Unichar
.
fro
m_char
c
)))))
s
in
(
Chars
.
m
k
_char
c
)))))
s
in
let
s
=
s
@
[
mk
loc
(
Internal
(
Sequence
.
nil_type
))]
in
multi_prod
loc
s
]
...
...
@@ -326,15 +326,15 @@ EXTEND
char
:
[
[
c
=
STRING1
->
Chars
.
Unichar
.
fro
m_char
(
parse_char
loc
c
)
|
"!"
;
i
=
INT
->
Chars
.
Unichar
.
fro
m_int
(
int_of_string
i
)
]
[
c
=
STRING1
->
Chars
.
m
k
_char
(
parse_char
loc
c
)
|
"!"
;
i
=
INT
->
Chars
.
m
k
_int
(
int_of_string
i
)
]
];
const
:
[
[
i
=
INT
->
Types
.
Integer
(
Big_int
.
big_int_of_string
i
)
|
"`"
;
a
=
[
LIDENT
|
UIDENT
]
->
Types
.
Atom
(
Types
.
AtomPool
.
mk
a
)
[
i
=
INT
->
Types
.
Integer
(
Intervals
.
mk
i
)
|
"`"
;
a
=
[
LIDENT
|
UIDENT
]
->
Types
.
Atom
(
Atoms
.
mk
a
)
|
c
=
char
->
Types
.
Char
c
]
];
...
...
runtime/eval.ml
View file @
59c2242e
...
...
@@ -9,7 +9,7 @@ let enter_global x v = global_env := Env.add x v !global_env
let
exn_int_of
=
CDuceExn
(
Pair
(
Atom
(
Types
.
AtomPool
.
mk
"Invalid_argument"
)
,
Atom
(
Atoms
.
mk
"Invalid_argument"
)
,
string
"int_of"
))
...
...
@@ -115,23 +115,23 @@ and eval_dot l = function
|
_
->
assert
false
and
eval_add
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
add_big_int
x
y
)
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vadd
x
y
)
|
_
->
assert
false
and
eval_mul
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
mult_big_in
t
x
y
)
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vmul
t
x
y
)
|
_
->
assert
false
and
eval_sub
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
sub_big_int
x
y
)
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vsub
x
y
)
|
_
->
assert
false
and
eval_div
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
div_big_int
x
y
)
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vdiv
x
y
)
|
_
->
assert
false
and
eval_mod
x
y
=
match
(
x
,
y
)
with
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Big_int
.
mod_big_int
x
y
)
|
(
Integer
x
,
Integer
y
)
->
Integer
(
Intervals
.
vmod
x
y
)
|
_
->
assert
false
and
eval_load_xml
e
=
...
...
@@ -142,7 +142,7 @@ and eval_load_html e =
and
eval_int_of
e
=
let
s
=
get_string
e
in
try
Integer
(
Big_int
.
big_int_of_string
s
)
try
Integer
(
Intervals
.
mk
s
)
with
Failure
_
->
raise
exn_int_of
and
eval_print_xml
v
=
...
...
runtime/load_xml.ml
View file @
59c2242e
...
...
@@ -24,7 +24,7 @@ let attrib att =
SortedMap
.
from_list
(
fun
_
_
->
assert
false
)
att
let
elem
tag
att
child
=
Xml
(
Atom
(
Types
.
AtomPool
.
mk
tag
)
,
Pair
(
Record
(
attrib
att
)
,
child
))
Xml
(
Atom
(
Atoms
.
mk
tag
)
,
Pair
(
Record
(
attrib
att
)
,
child
))
let
load_xml_aux
s
=
let
config
=
{
default_config
with
...
...
runtime/print_xml.ml
View file @
59c2242e
...
...
@@ -5,7 +5,7 @@ open Pxp_types
open
Value
let
exn_print_xml
=
CDuceExn
(
Pair
(
Atom
(
Types
.
AtomPool
.
mk
"Invalid_argument"
)
,
Atom
(
Atoms
.
mk
"Invalid_argument"
)
,
string
"print_xml"
))
...
...
@@ -42,7 +42,7 @@ let string_of_xml v=
let
rec
print_elt
=
function
|
Xml
(
Atom
tag
,
Pair
(
Record
attrs
,
content
))
->
let
tag
=
Types
.
AtomPool
.
value
tag
in
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
...
...
@@ -53,7 +53,7 @@ let string_of_xml v=
print_content
content
;
element_end
tag
)
|
Char
x
->
wds
(
String
.
make
1
(
Chars
.
Unichar
.
to_char
x
));
(* TODO: opt *)
wds
(
String
.
make
1
(
Chars
.
to_char
x
));
(* TODO: opt *)
|
_
->
raise
exn_print_xml
and
print_content
=
function
|
String
(
i
,
j
,
s
,
q
)
->
...
...
runtime/value.ml
View file @
59c2242e
...
...
@@ -2,9 +2,9 @@ type t =
|
Pair
of
t
*
t
|
Xml
of
t
*
t
|
Record
of
(
Types
.
label
,
t
)
SortedMap
.
t
|
Atom
of
Types
.
atom
|
Integer
of
Big_int
.
big_int
|
Char
of
Chars
.
Unichar
.
t
|
Atom
of
Atoms
.
v
|
Integer
of
Intervals
.
v
|
Char
of
Chars
.
v
|
Abstraction
of
(
Types
.
descr
*
Types
.
descr
)
list
*
(
t
->
t
)
|
String
of
int
*
int
*
string
*
t
...
...
@@ -25,7 +25,7 @@ let get_string e =
|
String
(
i
,
j
,_,
y
)
->
compute_len
(
accu
+
j
-
i
)
y
|
_
->
accu
in
let
rec
fill
pos
s
=
function
|
Pair
(
Char
x
,
y
)
->
s
.
[
pos
]
<-
Chars
.
Unichar
.
to_char
x
;
fill
(
pos
+
1
)
s
y
|
Pair
(
Char
x
,
y
)
->
s
.
[
pos
]
<-
Chars
.
to_char
x
;
fill
(
pos
+
1
)
s
y
|
String
(
i
,
j
,
src
,
y
)
->
String
.
blit
src
i
s
pos
(
j
-
i
);
fill
(
pos
+
j
-
i
)
s
y
|
_
->
s
in
...
...
@@ -54,15 +54,15 @@ let rec print ppf v =
|
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
|
Atom
a
->
Format
.
f
print
f
ppf
"`%s"
(
Types
.
AtomPool
.
value
a
)
|
Integer
i
->
Format
.
f
print
f
ppf
"%s"
(
Big_int
.
string_of_big_int
i
)
|
Char
c
->
Chars
.
Unichar
.
print
ppf
c
|
Atom
a
->
Atoms
.
print
_v
ppf
a
|
Integer
i
->
Intervals
.
print
_v
ppf
i
|
Char
c
->
Chars
.
print
_v
ppf
c
|
Abstraction
_
->
Format
.
fprintf
ppf
"<fun>"
|
String
(
i
,
j
,
s
,
q
)
->
Format
.
fprintf
ppf
"<string:%i-%i,%S,%a>"
i
j
s
print
q
and
print_quoted_str
ppf
=
function
|
Pair
(
Char
c
,
q
)
->
Chars
.
Unichar
.
print_in_string
ppf
c
;
Chars
.
print_
v_
in_string
ppf
c
;
print_quoted_str
ppf
q
|
String
(
i
,
j
,
s
,
q
)
->
Format
.
fprintf
ppf
"%s"
(
String
.
escaped
(
String
.
sub
s
i
(
j
-
i
)));
...
...
@@ -80,7 +80,7 @@ and print_seq ppf = function
|
_
->
()
and
print_str
ppf
=
function
|
Pair
(
Char
c
,
y
)
->
let
c
=
Chars
.
Unichar
.
to_char
c
in
let
c
=
Chars
.
to_char
c
in
Format
.
fprintf
ppf
"%s"
(
Char
.
escaped
c
);
print_str
ppf
y
|
v
->
...
...
@@ -90,7 +90,7 @@ and print_str ppf = function
and
print_xml
ppf
=
function
|
(
Atom
tag
,
Pair
(
Record
attr
,
content
))
->
Format
.
fprintf
ppf
"@[<hv2><%s%a>[@ %a@]]"
(
Types
.
AtomPool
.
value
tag
)
(
Atoms
.
value
tag
)
print_record
attr
print_seq
content
|
_
->
assert
false
...
...
@@ -107,6 +107,5 @@ and print_field ppf (l,v) =
let
normalize
=
function
|
String
(
i
,
j
,
s
,
q
)
->
if
i
=
j
then
q
else
Pair
(
Char
(
Chars
.
Unichar
.
from_char
s
.
[
i
])
,
String
(
succ
i
,
j
,
s
,
q
))
Pair
(
Char
(
Chars
.
mk_char
s
.
[
i
])
,
String
(
succ
i
,
j
,
s
,
q
))
|
v
->
assert
false
runtime/value.mli
View file @
59c2242e
...
...
@@ -3,9 +3,9 @@ type t =
|
Pair
of
t
*
t
|
Xml
of
t
*
t
|
Record
of
(
Types
.
label
,
t
)
SortedMap
.
t
|
Atom
of
Types
.
atom
|
Integer
of
Big_int
.
big_int
|
Char
of
Chars
.
Unichar
.
t
|
Atom
of
Atoms
.
v
|
Integer
of
Intervals
.
v
|
Char
of
Chars
.
v
|
Abstraction
of
(
Types
.
descr
*
Types
.
descr
)
list
*
(
t
->
t
)
(* Derived forms *)
...
...
tests/integers.cd
View file @
59c2242e
...
...
@@ -2,9 +2,10 @@ let fun facto (Int -> Int)
| 0 | 1 -> 1
| n -> n * (facto (n - 1))
in
facto
3
00;;
facto
100
00;;
(*
type Pos = 0--*;;
let fun abs (Int -> Pos)
...
...
@@ -34,3 +35,4 @@ let fun eval ( Expr -> Int )
| n -> n
in
eval (`add, 10, (`add, 20, 5));;
*)
tests/stress_opt_arg.cd
View file @
59c2242e
...
...
@@ -16,10 +16,10 @@ debug compile T
({ c = c } | ( c := `B)) &
({ d = d } | ( d := `B)) &
({ e = e } | ( e := `B)) &
({ f = f } | ( f := `B)) &
(*
({ f = f } | ( f := `B)) &
({ g = g } | ( g := `B)) &
({ h = h } | ( h := `B)) &
({ i = i } | ( i := `B)) &
({ i = i } | ( i := `B)) &
*)
(* ({ j = j } | ( j := `B)) &
({ k = k } | ( k := `B)) &
({ l = l } | ( l := `B)) &
...
...
types/atoms.ml
View file @
59c2242e
type
'
a
t
=
Finite
of
'
a
list
|
Cofinite
of
'
a
list
module
HashedString
=
struct
type
t
=
string
let
hash
=
Hashtbl
.
hash
let
equal
=
(
=
)
end
module
AtomPool
=
Pool
.
Make
(
HashedString
)
type
v
=
AtomPool
.
t
let
value
=
AtomPool
.
value
let
mk
=
AtomPool
.
mk
type
t
=
Finite
of
v
list
|
Cofinite
of
v
list
let
empty
=
Finite
[]
let
any
=
Cofinite
[]
...
...
@@ -38,23 +50,46 @@ let is_atom = function
|
Finite
[
a
]
->
Some
a
|
_
->
None
let
sample
except
=
function
let
sample
=
function
|
Finite
(
x
::
_
)
->
x
|
Cofinite
l
->
except
l
|
Cofinite
l
->
AtomPool
.
dummy_min
|
Finite
[]
->
raise
Not_found
let
print_v
ppf
a
=
if
a
=
AtomPool
.
dummy_min
then
Format
.
fprintf
ppf
"(almost any atom)"
else
Format
.
fprintf
ppf
"`%s"
(
value
a
)
let
print
any
f
=
function
|
Finite
l
->
List
.
map
(
fun
x
ppf
->
f
ppf
x
)
l
let
print
=
function
|
Finite
l
->
List
.
map
(
fun
x
ppf
->
print_v
ppf
x
)
l
|
Cofinite
[]
->
[
fun
ppf
->
Format
.
fprintf
ppf
"
%s"
any
]
[
fun
ppf
->
Format
.
fprintf
ppf
"
Atom"
]
|
Cofinite
[
h
]
->
[
fun
ppf
->
Format
.
fprintf
ppf
"@[
%s
- %a@]"
any
f
h
]
[
fun
ppf
->
Format
.
fprintf
ppf
"@[
Atom
- %a@]"
print_v
h
]
|
Cofinite
(
h
::
t
)
->
[
fun
ppf
->
Format
.
fprintf
ppf
"@[
%s
- ("
any
;
f
ppf
h
;
List
.
iter
(
fun
x
->
Format
.
fprintf
ppf
" |@ %a"
f
x
)
t
;
Format
.
fprintf
ppf
"@[
Atom
- ("
;
print_v
ppf
h
;
List
.
iter
(
fun
x
->
Format
.
fprintf
ppf
" |@ %a"
print_v
x
)
t
;
Format
.
fprintf
ppf
")@]"
]
let
rec
hash_seq
accu
=
function
|
t
::
rem
->
hash_seq
(
accu
*
17
+
t
)
rem
|
[]
->
accu
let
hash
accu
=
function
|
Finite
l
->
hash_seq
(
accu
+
1
)
l
|
Cofinite
l
->
hash_seq
(
accu
+
3
)
l
let
rec
equal_rec
l1
l2
=
(
l1
==
l2
)
||
match
(
l1
,
l2
)
with
|
(
x1
::
l1
,
x2
::
l2
)
->
(
x1
==
x2
)
&&
(
equal_rec
l1
l2
)
|
_
->
false
let
equal
t1
t2
=
match
(
t1
,
t2
)
with
|
(
Finite
l1
,
Finite
l2
)
->
equal_rec
l1
l2
|
(
Cofinite
l1
,
Cofinite
l2
)
->
equal_rec
l1
l2
|
_
->
false
types/atoms.mli
View file @
59c2242e
type
'
a
t
(* = Finite of 'a list | Cofinite of 'a list *)
type
v
val
value
:
v
->
string
val
mk
:
string
->
v
val
print_v
:
Format
.
formatter
->
v
->
unit
val
empty
:
'
a
t
val
any
:
'
a
t
val
cup
:
'
a
t
->
'
a
t
->
'
a
t
val
cap
:
'
a
t
->
'
a
t
->
'
a
t
val
diff
:
'
a
t
->
'
a
t
->
'
a
t
val
atom
:
'
a
->
'
a
t
type
t
val
hash
:
int
->
t
->
int
val
equal
:
t
->
t
->
bool
val
print
:
t
->
(
Format
.
formatter
->
unit
)
list
val
empty
:
t
val
any
:
t
val
cup
:
t
->
t
->
t
val
cap
:
t
->
t
->
t
val
diff
:
t
->
t
->
t
val
atom
:
v
->
t
val
contains
:
v
->
t
->
bool
val
is_empty
:
t
->
bool
val
is_atom
:
t
->
v
option
val
sample
:
t
->
v
val
contains
:
'
a
->
'
a
t
->
bool
val
is_empty
:
'
a
t
->
bool
val
is_atom
:
'
a
t
->
'
a
option
val
sample
:
(
'
a
list
->
'
a
)
->
'
a
t
->
'
a
val
print
:
string
->
(
Format
.
formatter
->
'
a
->
unit
)
->
'
a
t
->
(
Format
.
formatter
->
unit
)
list
types/boolean.ml
View file @
59c2242e
...
...
@@ -20,16 +20,18 @@ let cup t s =
List
.
filter
(
fun
(
p
,
n
)
->
not
(
List
.
exists
(
may_remove
(
p
,
n
))
s
))
t
in
SortedList
.
cup
s
t
let
clean
t
=
let
tot
=
ref
0
let
clean
accu
t
=
let
rec
aux
accu
=
function
|
(
p
,
n
)
::
rem
->
if
(
List
.
exists
(
may_remove
(
p
,
n
))
accu
)
||
(
List
.
exists
(
may_remove
(
p
,
n
))
rem
)
then
aux
accu
rem
else
aux
((
p
,
n
)
::
accu
)
rem
|
[]
->
accu
else
aux
((
p
,
n
)
::
accu
)
rem
|
[]
->
accu
in
List
.
rev
(
aux
[]
t
)
SortedList
.
from_list
(
aux
accu
t
)
...
...
@@ -49,17 +51,12 @@ let cap s t =
else
if
(
s
==
empty
)
||
(
t
==
empty
)
then
empty
else
let
(
lines1
,
common
,
lines2
)
=
SortedList
.
split
s
t
in
let
lines
=
fold2
(
fun
lines
(
p1
,
n1
)
(
p2
,
n2
)
->
if
(
SortedList
.
disjoint
p1
n2
)
&&
(
SortedList
.
disjoint
p2
n1
)
then
(
SortedList
.
cup
p1
p2
,
SortedList
.
cup
n1
n2
)
::
lines
else
lines
)
[]
lines1
lines2
let
rec
aux
lines
(
p1
,
n1
)
(
p2
,
n2
)
=
if
(
SortedList
.
disjoint
p1
n2
)
&&
(
SortedList
.
disjoint
p2
n1
)
then
(
SortedList
.
cup
p1
p2
,
SortedList
.
cup
n1
n2
)
::
lines
else
lines
in
clean
(
SortedList
.
cup
common
(
SortedList
.
from_list
lines
)
)
clean
common
(
fold2
aux
[]
lines1
lines
2
)
let
diff
c1
c2
=
if
c2
==
full
then
empty
...
...
types/builtin.ml
View file @
59c2242e
let
intstr
=
Sequence
.
plus
(
Types
.
char
(
Chars
.
char_class
(
Chars
.
Unichar
.
fro
m_char
'
0
'
)
(
Chars
.
Unichar
.
fro
m_char
'
9
'
)
(
Chars
.
m
k
_char
'
0
'
)
(
Chars
.
m
k
_char
'
9
'
)
)
)
...
...
types/chars.ml
View file @
59c2242e
module
Unichar
=
struct
type
t
=
int
type
v
=
int
let
max
=
0x10FFFF
let
max
_char
=
0x10FFFF
let
from_int
c
=
if
(
c
<
0
)
||
(
c
>
max
)
then
failwith
"Chars.from_int: code point out of bound"
;
c
let
from_char
c
=
Char
.
code
c
let
mk_int
c
=
if
(
c
<
0
)
||
(
c
>
max_char
)
then
failwith
"Chars.mk_int: code point out of bound"
;
c
let
to_int
c
=
c
let
mk_char
c
=
Char
.
code
c
let
to_int
c
=
c
let
to_char
c
=
if
(
c
>
255
)
then
failwith
"to_char: code-point > 255"
;
Char
.
chr
c
let
to_char
c
=
if
(
c
>
255
)
then
failwith
"
Chars.
to_char: code-point > 255"
;
Char
.
chr
c
let
print
ppf
c
=
if
(
c
<
128
)
then
Format
.
fprintf
ppf
"%C"
(
Char
.
chr
c
)
else
Format
.
fprintf
ppf
"#x%x"
c
let
print
_v
ppf
c
=
if
(
c
<
128
)
then
Format
.
fprintf
ppf
"%C"
(
Char
.
chr
c
)
else
Format
.
fprintf
ppf
"#x%x"
c
let
print_in_string
ppf
c
=
Format
.
fprintf
ppf
"%c"
(
Char
.
chr
c
)
end
let
print_v_in_string
ppf
c
=
Format
.
fprintf
ppf
"%c"
(
Char
.
chr
c
)
type
t
=
(
v
*
v
)
list
type
t
=
(
Unichar
.
t
*
Unichar
.
t
)
list
let
rec
hash
accu
=
function
|
(
i
,
j
)
::
rem
->
hash
(
accu
*
257
+
i
*
17
+
j
)
rem
|
[]
->
accu
+
3
let
max_char
=
Unichar
.
max
let
rec
equal
l1
l2
=
(
l1
==
l2
)
||
match
(
l1
,
l2
)
with
|
(
i1
,
j1
)
::
l1
,
(
i2
,
j2
)
::
l2
->
(
i1
==
i2
)
&&
(
j1
==
j2
)
&&
(
equal
l1
l2
)
|
_
->
false
let
from_int
c
=
if
(
c
<
0
)
||
(
c
>
max_char
)
then
...
...
@@ -84,8 +90,8 @@ let print =
(
fun
(
a
,
b
)
->
if
a
=
b
then
fun
ppf
->
Unichar
.
print
ppf
a
print
_v
ppf
a
else
fun
ppf
->
if
a
=
0
&&
b
=
max_char
then
Format
.
fprintf
ppf
"Char"
else
Format
.
fprintf
ppf
"%a--%a"
Unichar
.
print
a
Unichar
.
print
b
Format
.
fprintf
ppf
"%a--%a"
print
_v
a
print
_v
b
)
types/chars.mli
View file @
59c2242e
module
Unichar
:
sig
type
t
val
from_int
:
int
->
t
val
from_char
:
char
->
t
val
to_int
:
t
->
int
val
to_char
:
t
->
char
type
v
val
mk_int
:
int
->
v
val
mk_char
:
char
->
v
val
to_int
:
v
->
int
val
to_char
:
v
->
char
val
print_v
:
Format
.
formatter
->
v
->
unit
val
print_v_in_string
:
Format
.
formatter
->
v
->
unit
val
print
:
Format
.
formatter
->
t
->
unit
val
print_in_string
:
Format
.
formatter
->
t
->
unit
end
type
t
=
(
Unichar
.
t
*
Unichar
.
t
)
list
type
t
(* = (Unichar.t * Unichar.t) list *)
val
equal
:
t
->
t
->
bool
val
hash
:
int
->
t
->
int
val
print
:
t
->
(
Format
.
formatter
->
unit
)
list
val
empty
:
t
val
any
:
t
val
cup
:
t
->
t
->
t
val
cap
:
t
->
t
->
t
val
diff
:
t
->
t
->
t
val
char_class
:
Unichar
.
t
->
Unichar
.
t
->
t
val
atom
:
Unichar
.
t
->
t
val
char_class
:
v
->
v
->
t
val
atom
:
v
->
t