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
fb452183
Commit
fb452183
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-10-17 12:30:01 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-17 12:30:46+00:00
parent
f8cf6268
Changes
15
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
fb452183
...
...
@@ -5,8 +5,9 @@ TYPING = typing/typed.cmo typing/typer.cmo
TYPES
=
types/recursive.cmo types/sortedList.cmo
\
types/sortedMap.cmo types/boolean.cmo
\
types/intervals.cmo types/chars.cmo types/atoms.cmo
\
types/strings.cmo types/types.cmo
\
types/patterns.cmo
types/types.cmo
\
types/patterns.cmo
\
types/op.cmo
DRIVER
=
driver/cduce.cmo
...
...
@@ -19,7 +20,7 @@ INCLUDES = -I +camlp4 -I parser -I types -I typing
SYNTAX_PARSER
=
-pp
'camlp4o pa_extend.cmo'
all.cma
:
$(OBJECTS)
ocamlc
-o
all.cma
-I
+camlp4 gramlib.cma
-a
$(OBJECTS)
ocamlc
-o
all.cma
-I
+camlp4 gramlib.cma
nums.cma
-a
$(OBJECTS)
cduce
:
all.cma $(DRIVER)
ocamlc
-o
cduce all.cma
$(DRIVER)
...
...
depend
View file @
fb452183
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: parser/location.cmi types/op.cmi types/patterns.cmi \
types/types.cmi
parser/ast.cmx: parser/location.cmx types/op.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 types/chars.cmi parser/location.cmi \
...
...
@@ -7,8 +9,10 @@ parser/parser.cmo: parser/ast.cmo types/chars.cmi parser/location.cmi \
parser/parser.cmx: parser/ast.cmx types/chars.cmx parser/location.cmx \
types/types.cmx parser/parser.cmi
parser/parser.cmi: parser/ast.cmo
typing/typed.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
typing/typed.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
typing/typed.cmo: parser/location.cmi types/op.cmi types/patterns.cmi \
types/types.cmi
typing/typed.cmx: parser/location.cmx types/op.cmx types/patterns.cmx \
types/types.cmx
typing/typer.cmo: parser/ast.cmo parser/location.cmi types/patterns.cmi \
types/sortedList.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx parser/location.cmx types/patterns.cmx \
...
...
@@ -22,6 +26,8 @@ types/chars.cmo: types/chars.cmi
types/chars.cmx: types/chars.cmi
types/intervals.cmo: types/intervals.cmi
types/intervals.cmx: types/intervals.cmi
types/op.cmo: parser/location.cmi types/types.cmi types/op.cmi
types/op.cmx: parser/location.cmx types/types.cmx types/op.cmi
types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi types/types.cmi \
types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx types/types.cmx \
...
...
@@ -45,6 +51,7 @@ types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx types/recursive.cmx types/sortedList.cmx \
types/sortedMap.cmx types/strings.cmx types/types.cmi
types/boolean.cmi: types/sortedList.cmi
types/op.cmi: parser/location.cmi types/types.cmi
types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
...
...
parser/ast.ml
View file @
fb452183
...
...
@@ -27,7 +27,8 @@ and pexpr' =
|
RecordLitt
of
(
Types
.
label
*
pexpr
)
list
(* Data destructors *)
|
Op
of
op
*
pexpr
|
UnaryOp
of
Op
.
unary
*
pexpr
|
BinaryOp
of
Op
.
binary
*
pexpr
*
pexpr
|
Match
of
pexpr
*
branches
|
Map
of
pexpr
*
branches
...
...
@@ -39,8 +40,6 @@ and abstr = {
and
branches
=
(
ppat
*
pexpr
)
list
and
op
=
string
(* A common syntactic class for patterns and types *)
and
ppat
=
ppat'
located
...
...
parser/parser.ml
View file @
fb452183
...
...
@@ -47,6 +47,9 @@ open Ast
[
e1
=
expr
;
e2
=
expr
->
mk
loc
(
Apply
(
e1
,
e2
))
]
|
[
e1
=
expr
;
"+"
;
e2
=
expr
->
mk
loc
(
BinaryOp
(
Op
.
add
,
e1
,
e2
))
]
|
"no_appl"
[
c
=
const
->
mk
loc
(
Cst
c
)
|
"("
;
l
=
LIST1
expr
SEP
","
;
")"
->
tuple
loc
l
...
...
@@ -117,7 +120,8 @@ open Ast
|
"("
;
a
=
LIDENT
;
":="
;
c
=
const
;
")"
->
mk
loc
(
Constant
(
a
,
c
))
|
a
=
UIDENT
->
mk
loc
(
PatVar
a
)
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
int_of_string
i
and
j
=
int_of_string
j
in
let
i
=
Big_int
.
big_int_of_string
i
and
j
=
Big_int
.
big_int_of_string
j
in
mk
loc
(
Internal
(
Types
.
interval
i
j
))
|
i
=
char
;
"--"
;
j
=
char
->
mk
loc
(
Internal
(
Types
.
char_class
i
j
))
...
...
@@ -153,8 +157,8 @@ open Ast
const
:
[
[
i
=
INT
->
Types
.
Integer
(
int_of_string
i
)
|
x
=
STRING
->
Types
.
String
(
Token
.
eval_string
x
)
[
i
=
INT
->
Types
.
Integer
(
Big_int
.
big_
int_of_string
i
)
(*
| x = STRING -> Types.String (Token.eval_string x)
*)
|
"`"
;
a
=
[
LIDENT
|
UIDENT
]
->
Types
.
Atom
(
Types
.
mk_atom
a
)
|
c
=
char
->
Types
.
Char
c
]
];
...
...
types/IDEAS
View file @
fb452183
...
...
@@ -10,3 +10,11 @@
Need to benchmark and define heuristics to know when to apply
this mechanism => empirical.
- Remember compiled regexp when printing; same with XML sugar
- When an arrow constraint is not satisfied when typing a function,
point to the specific branch ...
Better: alternate mode of typing << check that this expression
has at most this type >>
types/intervals.ml
View file @
fb452183
type
t
=
(
int
*
int
)
list
open
Big_int
type
interval
=
|
Bounded
of
big_int
*
big_int
|
Left
of
big_int
|
Right
of
big_int
|
Any
type
t
=
interval
list
let
rec
equal
l1
l2
=
match
(
l1
,
l2
)
with
|
(
Bounded
(
a1
,
b1
)
::
l1
,
Bounded
(
a2
,
b2
)
::
l2
)
->
(
eq_big_int
a1
a2
)
&&
(
eq_big_int
b1
b2
)
&&
(
equal
l1
l2
)
|
(
Left
b1
::
l1
,
Left
b2
::
l2
)
->
(
eq_big_int
b1
b2
)
&&
(
equal
l1
l2
)
|
(
Right
a1
::
l1
,
Right
a2
::
l2
)
->
(
eq_big_int
a1
a2
)
&&
(
equal
l1
l2
)
|
(
Any
::
_
,
Any
::
_
)
->
true
|
_
->
false
let
hash
=
function
|
Bounded
(
a
,
b
)
::
_
->
1
+
2
*
(
num_digits_big_int
a
)
+
3
*
(
num_digits_big_int
b
)
|
Left
b
::
_
->
3
*
num_digits_big_int
b
|
Right
a
::
_
->
2
*
(
num_digits_big_int
a
)
|
Any
::
_
->
1234
|
[]
->
0
let
empty
=
[]
let
full
=
[
min_int
,
max_int
]
let
atom
(
a
,
b
)
=
if
a
<=
b
then
[
a
,
b
]
else
empty
let
any
=
[
Any
]
let
atom
a
b
=
if
a
<=
b
then
[
Bounded
(
a
,
b
)]
else
empty
let
rec
add_left
l
b
=
match
l
with
|
[]
->
[
Left
b
]
|
(
Bounded
(
a1
,_
)
|
Right
a1
)
::
_
when
(
lt_big_int
b
(
pred_big_int
a1
))
->
Left
b
::
l
|
Bounded
(
_
,
b1
)
::
l'
->
add_left
l'
(
max_big_int
b
b1
)
|
Left
b1
::
_
when
le_big_int
b
b1
->
l
|
Left
_
::
l'
->
add_left
l'
b
|
_
->
any
let
rec
add
l
((
a
,
b
)
as
i
)
=
match
l
with
let
rec
add
_bounded
l
a
b
=
match
l
with
|
[]
->
[
i
]
|
((
a1
,_
)
::
_
)
as
l
when
(
a1
<>
min_int
)
&&
(
b
<
(
pred
a1
))
->
i
::
l
|
((
a1
,
b1
)
as
i'
::
l'
)
when
(
b1
<>
max_int
)
&&
(
a
>
(
succ
b1
))
->
i'
::
(
add
l'
i
)
|
(
a1
,
b1
)
::
l'
->
add
l'
(
min
a
a1
,
max
b
b1
)
let
rec
neg
start
l
=
match
l
with
|
[]
->
[
start
,
max_int
]
|
(
a
,
b
)
::
l'
when
a
<>
min_int
->
if
b
=
max_int
then
[
start
,
pred
a
]
else
(
start
,
pred
a
)
::
(
neg
(
succ
b
)
l'
)
|
(
_
,
b
)
::
l'
->
if
b
=
max_int
then
[]
else
(
neg
(
succ
b
)
l'
)
let
neg
l
=
neg
min_int
l
[
Bounded
(
a
,
b
)]
|
(
Bounded
(
a1
,_
)
|
Right
a1
)
::
_
when
(
lt_big_int
b
(
pred_big_int
a1
))
->
Bounded
(
a
,
b
)
::
l
|
((
Bounded
(
_
,
b1
)
|
Left
b1
)
as
i'
)
::
l'
when
(
lt_big_int
(
succ_big_int
b1
)
a
)
->
i'
::
(
add_bounded
l'
a
b
)
|
Bounded
(
a1
,
b1
)
::
l'
->
add_bounded
l'
(
min_big_int
a
a1
)
(
max_big_int
b
b1
)
|
Left
b1
::
l'
->
add_left
l'
b
|
Right
a1
::
_
->
[
Right
a
]
|
Any
::
_
->
any
let
rec
add_right
l
a
=
match
l
with
|
[]
->
[
Right
a
]
|
((
Bounded
(
_
,
b1
)
|
Left
b1
)
as
i'
)
::
l'
when
(
lt_big_int
(
succ_big_int
b1
)
a
)
->
i'
::
(
add_right
l'
a
)
|
(
Bounded
(
a1
,_
)
|
Right
a1
)
::
_
->
[
Right
(
min_big_int
a
a1
)]
|
_
->
any
let
add
l
=
function
|
Bounded
(
a
,
b
)
->
add_bounded
l
a
b
|
Left
b
->
add_left
l
b
|
Right
a
->
add_right
l
a
|
Any
->
any
let
rec
neg'
start
l
=
match
l
with
|
[]
->
[
Right
start
]
|
Bounded
(
a
,
b
)
::
l'
->
Bounded
(
start
,
pred_big_int
a
)
::
(
neg'
(
succ_big_int
b
)
l'
)
|
Right
a
::
l'
->
[
Bounded
(
start
,
pred_big_int
a
)]
|
_
->
assert
false
let
neg
=
function
|
Any
::
_
->
[]
|
[]
->
any
|
Left
b
::
l
->
neg'
(
succ_big_int
b
)
l
|
Right
a
::
_
->
[
Left
(
pred_big_int
a
)]
|
Bounded
(
a
,
b
)
::
l
->
Left
(
pred_big_int
a
)
::
neg'
(
succ_big_int
b
)
l
let
cup
i1
i2
=
List
.
fold_left
add
i1
i2
...
...
@@ -35,22 +107,42 @@ let cap i1 i2 =
let
diff
i1
i2
=
neg
(
cup
(
neg
i1
)
i2
)
let
is_empty
i
=
i
=
[]
(* representation unique ! *)
let
is_empty
i
=
i
=
[]
(* TODO: can optimize this to stop running through the list earlier *)
let
contains
n
=
List
.
exists
(
fun
(
a
,
b
)
->
(
n
>=
a
)
&&
(
n
<=
b
))
List
.
exists
(
function
|
Any
->
true
|
Left
b
->
le_big_int
n
b
|
Right
a
->
le_big_int
a
n
|
Bounded
(
a
,
b
)
->
(
le_big_int
a
n
)
&&
(
le_big_int
n
b
)
)
let
sample
=
function
|
(
i
,
j
)
::
_
->
i
|
_
->
raise
Not_found
|
(
Left
x
|
Right
x
|
Bounded
(
x
,_
))
::
_
->
x
|
Any
::
_
->
zero_big_int
|
[]
->
raise
Not_found
let
print
=
List
.
map
(
fun
(
a
,
b
)
->
if
a
=
b
then
fun
ppf
->
Format
.
fprintf
ppf
"%i"
a
else
fun
ppf
->
Format
.
fprintf
ppf
"%i--%i"
a
b
(
fun
x
ppf
->
match
x
with
|
Any
->
Format
.
fprintf
ppf
"Int"
|
Left
b
->
Format
.
fprintf
ppf
"minfty--%s"
(
string_of_big_int
b
)
|
Right
a
->
Format
.
fprintf
ppf
"%s--infy"
(
string_of_big_int
a
)
|
Bounded
(
a
,
b
)
when
eq_big_int
a
b
->
Format
.
fprintf
ppf
"%s"
(
string_of_big_int
a
)
|
Bounded
(
a
,
b
)
->
Format
.
fprintf
ppf
"%s--%s"
(
string_of_big_int
a
)
(
string_of_big_int
b
)
)
types/intervals.mli
View file @
fb452183
(* Combinaisons booléennes d'intervalles d'entiers;
type
t
elle sont representées comme des réunions disjointes d'intervalles,
sous la forme de listes de couples (ai,bi) tq ai<=bi, (bi)+1<a(i+1)
Note: il y a representation unique
*)
type
t
=
(
int
*
int
)
list
val
equal
:
t
->
t
->
bool
val
hash
:
t
->
int
val
empty
:
t
val
full
:
t
val
any
:
t
val
cup
:
t
->
t
->
t
val
cap
:
t
->
t
->
t
val
diff
:
t
->
t
->
t
val
atom
:
int
*
int
->
t
val
atom
:
Big_int
.
big_int
->
Big_int
.
big_int
->
t
val
is_empty
:
t
->
bool
val
contains
:
int
->
t
->
bool
val
sample
:
t
->
int
val
contains
:
Big_int
.
big_
int
->
t
->
bool
val
sample
:
t
->
Big_int
.
big_
int
val
print
:
t
->
(
Format
.
formatter
->
unit
)
list
types/op.ml
0 → 100644
View file @
fb452183
type
unary
=
{
un_type
:
Location
.
loc
->
(* location of the whole operator node *)
Location
.
loc
->
Types
.
descr
->
(* first argument *)
Types
.
descr
;
(* result *)
}
type
binary
=
{
bin_type
:
Location
.
loc
->
(* location of the whole operator node *)
Location
.
loc
->
Types
.
descr
->
(* first argument *)
Location
.
loc
->
Types
.
descr
->
(* second argument *)
Types
.
descr
;
(* result *)
}
let
add
=
{
bin_type
=
fun
loc
loc1
t1
loc2
t2
->
failwith
"add not implemented"
}
types/op.mli
0 → 100644
View file @
fb452183
type
unary
=
{
un_type
:
Location
.
loc
->
(* location of the whole operator node *)
Location
.
loc
->
Types
.
descr
->
(* first argument *)
Types
.
descr
;
(* result *)
}
type
binary
=
{
bin_type
:
Location
.
loc
->
(* location of the whole operator node *)
Location
.
loc
->
Types
.
descr
->
(* first argument *)
Location
.
loc
->
Types
.
descr
->
(* second argument *)
Types
.
descr
;
(* result *)
}
val
add
:
binary
types/recursive.ml
View file @
fb452183
(* $Id: recursive.ml,v 1.
1.1.1
2002/10/1
0 09:11:23
cvscast Exp $ *)
(* $Id: recursive.ml,v 1.
2
2002/10/1
7 12:30:02
cvscast Exp $ *)
exception
NotEqual
exception
Incomplete
...
...
@@ -160,4 +160,5 @@ struct
ignore
(
internalize
nr
)
with
Exit
->
()
let
hash_descr
d
=
X
.
hash
(
fun
n
->
!
n
.
id
)
d
end
types/recursive.mli
View file @
fb452183
(* $Id: recursive.mli,v 1.
1.1.1
2002/10/1
0 09:11:23
cvscast Exp $ *)
(* $Id: recursive.mli,v 1.
2
2002/10/1
7 12:30:02
cvscast Exp $ *)
exception
NotEqual
exception
Incomplete
...
...
@@ -43,5 +43,7 @@ sig
val
id
:
node
->
int
val
descr
:
node
->
descr
val
hash_descr
:
descr
->
int
end
types/types.ml
View file @
fb452183
...
...
@@ -6,7 +6,7 @@ open Printf
type
label
=
int
type
atom
=
int
type
const
=
Integer
of
int
|
Atom
of
atom
|
String
of
string
|
Char
of
Chars
.
Unichar
.
t
type
const
=
Integer
of
Big_int
.
big_
int
|
Atom
of
atom
|
Char
of
Chars
.
Unichar
.
t
module
I
=
struct
type
'
a
t
=
{
...
...
@@ -16,9 +16,8 @@ module I = struct
arrow
:
(
'
a
*
'
a
)
Boolean
.
t
;
record
:
(
label
*
bool
*
'
a
)
Boolean
.
t
;
chars
:
Chars
.
t
;
strs
:
Strings
.
t
;
}
let
empty
=
{
times
=
Boolean
.
empty
;
arrow
=
Boolean
.
empty
;
...
...
@@ -26,30 +25,27 @@ module I = struct
ints
=
Intervals
.
empty
;
atoms
=
Atoms
.
empty
;
chars
=
Chars
.
empty
;
strs
=
Strings
.
empty
;
}
let
any
=
{
times
=
Boolean
.
full
;
arrow
=
Boolean
.
full
;
record
=
Boolean
.
full
;
ints
=
Intervals
.
full
;
ints
=
Intervals
.
any
;
atoms
=
Atoms
.
full
;
chars
=
Chars
.
full
;
strs
=
Strings
.
any
;
}
let
interval
i
j
=
{
empty
with
ints
=
Intervals
.
atom
(
i
,
j
)
}
let
interval
i
j
=
{
empty
with
ints
=
Intervals
.
atom
i
j
}
let
times
x
y
=
{
empty
with
times
=
Boolean
.
atom
(
x
,
y
)
}
let
arrow
x
y
=
{
empty
with
arrow
=
Boolean
.
atom
(
x
,
y
)
}
let
record
label
opt
t
=
{
empty
with
record
=
Boolean
.
atom
(
label
,
opt
,
t
)
}
let
atom
a
=
{
empty
with
atoms
=
Atoms
.
atom
a
}
let
string
r
=
{
empty
with
strs
=
Strings
.
Regexp
.
compile
r
}
let
char
c
=
{
empty
with
chars
=
Chars
.
atom
c
}
let
char_class
c1
c2
=
{
empty
with
chars
=
Chars
.
char_class
c1
c2
}
let
constant
=
function
|
Integer
i
->
interval
i
i
|
Atom
a
->
atom
a
|
String
s
->
string
(
Strings
.
Regexp
.
str
s
)
|
Char
c
->
char
c
...
...
@@ -63,7 +59,6 @@ module I = struct
ints
=
Intervals
.
cup
x
.
ints
y
.
ints
;
atoms
=
Atoms
.
cup
x
.
atoms
y
.
atoms
;
chars
=
Chars
.
cup
x
.
chars
y
.
chars
;
strs
=
Strings
.
cup
x
.
strs
y
.
strs
;
}
let
cap
x
y
=
...
...
@@ -74,7 +69,6 @@ module I = struct
ints
=
Intervals
.
cap
x
.
ints
y
.
ints
;
atoms
=
Atoms
.
cap
x
.
atoms
y
.
atoms
;
chars
=
Chars
.
cap
x
.
chars
y
.
chars
;
strs
=
Strings
.
cap
x
.
strs
y
.
strs
;
}
let
diff
x
y
=
...
...
@@ -85,16 +79,14 @@ module I = struct
ints
=
Intervals
.
diff
x
.
ints
y
.
ints
;
atoms
=
Atoms
.
diff
x
.
atoms
y
.
atoms
;
chars
=
Chars
.
diff
x
.
chars
y
.
chars
;
strs
=
Strings
.
diff
x
.
strs
y
.
strs
;
}
let
neg
x
=
diff
any
x
let
equal
e
a
b
=
if
a
.
ints
<>
b
.
ints
then
raise
NotEqual
;
if
not
(
Intervals
.
equal
a
.
ints
b
.
ints
)
then
raise
NotEqual
;
if
a
.
atoms
<>
b
.
atoms
then
raise
NotEqual
;
if
a
.
chars
<>
b
.
chars
then
raise
NotEqual
;
if
a
.
strs
<>
b
.
strs
then
raise
NotEqual
;
Boolean
.
equal
(
fun
(
x1
,
x2
)
(
y1
,
y2
)
->
e
x1
y1
;
e
x2
y2
)
a
.
times
b
.
times
;
Boolean
.
equal
(
fun
(
x1
,
x2
)
(
y1
,
y2
)
->
e
x1
y1
;
e
x2
y2
)
a
.
arrow
b
.
arrow
;
Boolean
.
equal
(
fun
(
l1
,
o1
,
x1
)
(
l2
,
o2
,
x2
)
->
...
...
@@ -108,11 +100,11 @@ module I = struct
ints
=
a
.
ints
;
atoms
=
a
.
atoms
;
chars
=
a
.
chars
;
strs
=
a
.
strs
;
}
let
hash
h
a
=
Hashtbl
.
hash
(
map
h
a
)
(
Hashtbl
.
hash
{
map
h
a
with
ints
=
Intervals
.
empty
})
+
(
Intervals
.
hash
a
.
ints
)
let
iter
f
a
=
ignore
(
map
f
a
)
...
...
@@ -232,7 +224,6 @@ let rec empty_rec d =
else
if
not
(
Intervals
.
is_empty
d
.
ints
)
then
false
else
if
not
(
Atoms
.
is_empty
d
.
atoms
)
then
false
else
if
not
(
Chars
.
is_empty
d
.
chars
)
then
false
else
if
not
(
Strings
.
is_empty
d
.
strs
)
then
false
else
(
let
backup
=
!
memo
in
memo
:=
Assumptions
.
add
d
backup
;
...
...
@@ -308,10 +299,9 @@ let rec find f = function
|
x
::
r
->
try
f
x
with
Not_found
->
find
f
r
type
t
=
|
Int
of
int
|
Int
of
Big_int
.
big_
int
|
Atom
of
atom
|
Char
of
Chars
.
Unichar
.
t
|
String
of
string
|
Pair
of
t
*
t
|
Record
of
(
label
*
t
)
list
|
Fun
of
(
node
*
node
)
list
...
...
@@ -325,7 +315,6 @@ let rec sample_rec memo d =
try
Int
(
Intervals
.
sample
d
.
ints
)
with
Not_found
->
try
Atom
(
Atoms
.
sample
(
gen_atom
0
)
d
.
atoms
)
with
Not_found
->
try
Char
(
Chars
.
sample
d
.
chars
)
with
Not_found
->
try
String
(
Strings
.
sample
d
.
strs
)
with
Not_found
->
try
sample_rec_arrow
d
.
arrow
with
Not_found
->
let
memo
=
Assumptions
.
add
d
memo
in
...
...
@@ -567,7 +556,19 @@ let normalize n =
module
Print
=
struct
let
marks
=
Hashtbl
.
create
63
module
DescrHash
=
Hashtbl
.
Make
(
struct
type
t
=
descr
let
hash
=
hash_descr
let
equal
=
(
=
)
end
)
let
named
=
DescrHash
.
create
10
let
register_global
name
d
=
DescrHash
.
add
named
d
name
let
marks
=
DescrHash
.
create
63
let
wh
=
ref
[]
let
count_name
=
ref
0
let
name
()
=
...
...
@@ -584,22 +585,20 @@ struct
let
worth_abbrev
d
=
not
(
trivial
d
.
times
&&
trivial
d
.
arrow
&&
trivial
d
.
record
)
let
rec
mark
n
=
let
i
=
id
n
and
d
=
descr
n
in
try
let
r
=
Hashtbl
.
find
marks
i
in
if
(
!
r
=
None
)
&&
(
worth_abbrev
d
)
then
(
let
na
=
name
()
in
r
:=
Some
na
;
wh
:=
(
na
,
d
)
::
!
wh
)
with
Not_found
->
Hashtbl
.
add
marks
i
(
ref
None
);
mark_descr
d
and
mark_descr
d
=
bool_iter
(
fun
(
n1
,
n2
)
->
mark
n1
;
mark
n2
)
d
.
times
;
bool_iter
(
fun
(
n1
,
n2
)
->
mark
n1
;
mark
n2
)
d
.
arrow
;
bool_iter
(
fun
(
l
,
o
,
n
)
->
mark
n
)
d
.
record
let
rec
mark
n
=
mark_descr
(
descr
n
)
and
mark_descr
d
=
if
not
(
DescrHash
.
mem
named
d
)
then
try
let
r
=
DescrHash
.
find
marks
d
in
if
(
!
r
=
None
)
&&
(
worth_abbrev
d
)
then
let
na
=
name
()
in
r
:=
Some
na
;
wh
:=
(
na
,
d
)
::
!
wh
with
Not_found
->
DescrHash
.
add
marks
d
(
ref
None
);
bool_iter
(
fun
(
n1
,
n2
)
->
mark
n1
;
mark
n2
)
d
.
times
;
bool_iter
(
fun
(
n1
,
n2
)
->
mark
n1
;
mark
n2
)
d
.
arrow
;
bool_iter
(
fun
(
l
,
o
,
n
)
->
mark
n
)
d
.
record
let
rec
print_union
ppf
=
function
...
...
@@ -609,22 +608,25 @@ struct
let
print_atom
ppf
a
=
Format
.
fprintf
ppf
"`%s"
(
atom_name
a
)
let
rec
print
ppf
n
=
(* Format.fprintf ppf "[%i]" (id n); *)
match
!
(
Hashtbl
.
find
marks
(
id
n
))
with
|
Some
n
->
Format
.
fprintf
ppf
"%s"
n
|
None
->
print_descr
ppf
(
descr
n
)
let
rec
print
ppf
n
=
print_descr
ppf
(
descr
n
)
and
print_descr
ppf
d
=
try
let
name
=
DescrHash
.
find
named
d
in
Format
.
fprintf
ppf
"%s"
name
with
Not_found
->
match
!
(
DescrHash
.
find
marks
d
)
with
|
Some
n
->
Format
.
fprintf
ppf
"%s"
n
|
None
->
real_print_descr
ppf
d
and
real_print_descr
ppf
d
=
if
d
=
any
then
Format
.
fprintf
ppf
"Any"
else
print_union
ppf
(
Intervals
.
print
d
.
ints
@
Chars
.
print
d
.
chars
@
Strings
.
print
d
.
strs
@
Atoms
.
print
"AnyAtom"
print_atom
d
.
atoms
@
Boolean
.
print
"(Any,Any)"
print_times
d
.
times
@
Boolean
.
print
"(Empty -> Any)"
print_arrow
d
.
arrow
@
Boolean
.
print
"{ }"
print_record
d
.
record
)
print_union
ppf
(
Intervals
.
print
d
.
ints
@
Chars
.
print
d
.
chars
@
Atoms
.
print
"AnyAtom"
print_atom
d
.
atoms
@