Skip to content
GitLab
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
6dda32d0
Commit
6dda32d0
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-12-20 16:47:07 by afrisch] Fix bug reported by JP Bodeveix
Original author: afrisch Date: 2004-12-20 16:47:07+00:00
parent
16b3a234
Changes
4
Hide whitespace changes
Inline
Side-by-side
types/intervals.ml
View file @
6dda32d0
...
...
@@ -378,13 +378,14 @@ let mul l1 l2 =
)
empty
l1
(*
let d
u
mp s i =
let
dmp
s
i
=
let
ppf
=
Format
.
std_formatter
in
Format
.
fprintf
ppf
"%s = [ "
s
;
List
.
iter
(
fun
x
->
x
ppf
;
Format
.
fprintf
ppf
" "
)
(
print
i
);
Format
.
fprintf
ppf
"] "
(*
let diff i1 i2 =
let ppf = Format.std_formatter in
Format.fprintf ppf "Intervals.diff:";
...
...
@@ -393,5 +394,15 @@ let diff i1 i2 =
dump "i1-i2" (diff i1 i2);
Format.fprintf ppf "@\n";
diff i1 i2
*)
(*
let cap i1 i2 =
let ppf = Format.std_formatter in
Format.fprintf ppf "Intervals.cap:";
dmp "i1" i1;
dmp "i2" i2;
dmp "i1*i2" (cap i1 i2);
Format.fprintf ppf "@.";
cap i1 i2
*)
types/normal.ml
View file @
6dda32d0
...
...
@@ -30,7 +30,9 @@ struct
let
k
=
X1
.
diff
s1
t1
in
let
root
=
if
not
(
X1
.
is_empty
k
)
then
(
k
,
s2
)
::
root
else
root
in
let
j
=
X1
.
diff
t1
s1
in
if
not
(
X1
.
is_empty
j
)
then
add
root
j
t2
rem
else
root
if
not
(
X1
.
is_empty
j
)
then
add
root
j
t2
rem
else
List
.
rev_append
root
rem
)
let
normal
x
=
...
...
types/patterns.ml
View file @
6dda32d0
...
...
@@ -75,6 +75,11 @@ let print ppf d =
Format
.
fprintf
ppf
"%a@
\n
"
print
d
;
dump_print
ppf
let
print_node
ppf
n
=
Format
.
fprintf
ppf
"P%i"
n
.
id
;
to_print
:=
n
::
!
to_print
;
dump_print
ppf
let
counter
=
State
.
ref
"Patterns.counter"
0
...
...
@@ -130,7 +135,7 @@ module Node = struct
let
hash
n
=
n
.
id
let
check
n
=
()
let
dump
ppf
_
=
Format
.
fprintf
ppf
"<Patterns.N
ode
>"
let
dump
=
print_n
ode
module
SMemo
=
Set
.
Make
(
Custom
.
Int
)
...
...
@@ -333,12 +338,25 @@ module Normal = struct
IdMap
.
hash
hash_source
r
let
print_result
ppf
r
=
Format
.
fprintf
ppf
"<result>"
let
print_result_option
ppf
=
function
|
Some
x
->
Format
.
fprintf
ppf
"Some(%a)"
print_result
x
|
None
->
Format
.
fprintf
ppf
"None"
module
NodeSet
=
SortedList
.
Make
(
Node
)
type
nnf
=
NodeSet
.
t
*
Types
.
t
(* pl,t; t <= \accept{pl} *)
let
check_nnf
(
pl
,
t
)
=
List
.
iter
(
fun
p
->
assert
(
Types
.
subtype
t
(
Types
.
descr
p
.
accept
)))
(
NodeSet
.
get
pl
)
let
print_nnf
ppf
(
pl
,
t
)
=
Format
.
fprintf
ppf
"@[(pl=%a;t=%a)@]"
NodeSet
.
dump
pl
Types
.
Print
.
print
t
let
compare_nnf
(
l1
,
t1
)
(
l2
,
t2
)
=
let
c
=
NodeSet
.
compare
l1
l2
in
if
c
<>
0
then
c
else
Types
.
compare
t1
t2
...
...
@@ -363,8 +381,15 @@ module Normal = struct
module
NLineProd
=
SortedList
.
Make
(
struct
include
Custom
.
Dummy
(*
include Custom.Dummy
*)
let
serialize
s
_
=
failwith
"Patterns.NLineProd.serialize"
let
deserialize
s
=
failwith
"Patterns.NLineProd.deserialize"
let
check
x
=
()
let
dump
ppf
(
r
,
x
,
y
)
=
Format
.
fprintf
ppf
"@[(result=%a;x=%a;y=%a)@]"
print_result
r
print_nnf
x
print_nnf
y
type
t
=
result
*
nnf
*
nnf
let
compare
(
r1
,
x1
,
y1
)
(
r2
,
x2
,
y2
)
=
let
c
=
compare_result
r1
r2
in
if
c
<>
0
then
c
...
...
@@ -389,6 +414,21 @@ module Normal = struct
nrecord
:
record
}
let
print_record
ppf
=
function
|
RecLabel
(
lab
,
l
)
->
Format
.
fprintf
ppf
"RecLabel(@[%a@],@ @[%a@])"
Label
.
print
(
LabelPool
.
value
lab
)
NLineProd
.
dump
l
|
RecNolabel
(
a
,
b
)
->
Format
.
fprintf
ppf
"RecNolabel(@[%a@],@[%a@])"
print_result_option
a
print_result_option
b
let
print
ppf
nf
=
Format
.
fprintf
ppf
"@[NF{na=%a;@[nrecord=@ @[%a@]@]}@]"
Types
.
Print
.
print
nf
.
na
print_record
nf
.
nrecord
let
compare_nf
t1
t2
=
if
t1
==
t2
then
0
else
...
...
@@ -560,6 +600,16 @@ module Normal = struct
RecNolabel
((
if
x
then
Some
empty_res
else
None
)
,
(
if
y
then
Some
empty_res
else
None
))
|
Some
l
->
(*
let ppf = Format.std_formatter in
Format.fprintf ppf "Constr record t=%a l=%a@."
Types.Print.print t Label.print (LabelPool.value l);
let sp = Types.Record.split_normal t l in
List.iter (fun (t1,t2) ->
Format.fprintf ppf "t1=%a t2=%a@."
Types.Print.print t1
Types.Print.print t2) sp;
*)
RecLabel
(
l
,
aux
(
Types
.
Record
.
split_normal
t
l
))
in
{
nempty
lab
with
...
...
@@ -657,12 +707,33 @@ module Normal = struct
|
RecLabel
(
lab
,
l
)
->
RecLabel
(
lab
,
nlinesprod
l
))
}
let
print_node_list
ppf
pl
=
List
.
iter
(
fun
p
->
Format
.
fprintf
ppf
"%a;"
Node
.
dump
p
)
pl
let
normal
l
t
pl
=
remove_catchv
(
List
.
fold_left
(
fun
a
p
->
ncap
a
(
nnormal
l
(
descr
p
)))
(
nconstr
l
t
)
pl
)
(*
let normal l t pl =
let nf = normal l t pl in
(match l with Some l ->
Format.fprintf Format.std_formatter
"normal(l=%a;t=%a;pl=%a)=%a@."
Label.print (LabelPool.value l)
Types.Print.print t
print_node_list pl
print nf
| None -> Format.fprintf Format.std_formatter
"normal(t=%a;pl=%a)=%a@."
Types.Print.print t
print_node_list pl
print nf);
nf
*)
end
...
...
@@ -868,10 +939,20 @@ struct
let
dispatchers
=
ref
DispMap
.
empty
let
timer_disp
=
Stats
.
Timer
.
create
"Patterns.dispatcher loop"
let
rec
print_iface
ppf
=
function
|
`Result
i
->
Format
.
fprintf
ppf
"Result(%i)"
i
|
`Switch
(
yes
,
no
)
->
Format
.
fprintf
ppf
"Switch(%a,%a)"
print_iface
yes
print_iface
no
|
`None
->
Format
.
fprintf
ppf
"None"
let
dispatcher
t
pl
lab
:
dispatcher
=
try
DispMap
.
find
(
t
,
pl
)
!
dispatchers
with
Not_found
->
(* let ppf = Format.std_formatter in
Format.fprintf ppf "dispatcher %i:" !cur_id;
Array.iter (fun x -> Format.fprintf ppf "%a;" Normal.print x) pl;
Format.fprintf ppf "@."; *)
let
nb
=
ref
0
in
let
codes
=
ref
[]
in
let
rec
aux
t
arity
i
accu
=
...
...
@@ -880,7 +961,7 @@ struct
else
let
p
=
pl
.
(
i
)
in
let
tp
=
p
.
Normal
.
na
in
(* let tp = Types.normalize tp in *)
(* let tp = Types.normalize tp in *)
let
a1
=
Types
.
cap
t
tp
in
if
Types
.
is_empty
a1
then
...
...
@@ -904,15 +985,18 @@ struct
*)
in
(* Array.iteri (fun i p ->
(*
Array.iteri (fun i p ->
Format.fprintf Format.std_formatter
"Pattern %i/%i accepts %a@." i (Array.length pl)
Types.Print.print p.Normal.na) pl; *)
Types.Print.print p.Normal.na) pl;
*)
Stats
.
Timer
.
start
timer_disp
;
let
iface
=
if
Types
.
is_empty
t
then
`None
else
aux
t
0
0
[]
in
Stats
.
Timer
.
stop
timer_disp
()
;
(* Format.fprintf Format.std_formatter "iface=%a@." print_iface iface;*)
let
res
=
{
id
=
!
cur_id
;
t
=
t
;
label
=
lab
;
...
...
@@ -931,6 +1015,18 @@ struct
|
`Switch
(
yes
,_
)
when
a
.
(
i
)
!=
None
->
aux
(
i
+
1
)
yes
|
`Switch
(
_
,
no
)
->
aux
(
i
+
1
)
no
in
(*
let ppf = Format.std_formatter in
Format.fprintf ppf "find_code iface=%a [ "
print_iface d.interface;
for i = 0 to Array.length a - 1 do
if (a.(i) != None) then
Format.fprintf ppf "+ "
else
Format.fprintf ppf "- "
done;
Format.fprintf ppf "]@.";
*)
aux
0
d
.
interface
let
create_result
pl
=
...
...
@@ -1031,6 +1127,7 @@ struct
let
disp
=
dispatcher
t
ps
lab
in
let
result
(
t
,_,
m
)
=
(* Format.fprintf Format.std_formatter "Result=%a@." Types.Print.print t;*)
let
selected
=
Array
.
create
(
Array
.
length
pl
)
[]
in
let
add
r
(
i
,
ncv
,
inf
)
=
selected
.
(
i
)
<-
(
r
,
ncv
,
inf
)
::
selected
.
(
i
)
in
List
.
iter
(
fun
(
j
,
r
)
->
List
.
iter
(
add
r
)
infos
.
(
j
))
m
;
...
...
@@ -1102,7 +1199,7 @@ struct
return
disp
pl
aux_final
let
rec
dispatch_record
disp
:
record
option
=
let
dispatch_record
disp
:
record
option
=
let
t
=
disp
.
t
in
if
not
(
Types
.
Record
.
has_record
t
)
then
None
else
...
...
@@ -1129,7 +1226,12 @@ struct
in
Some
(
RecNolabel
(
some
,
none
))
|
Some
lab
->
(* Format.fprintf Format.std_formatter "lab=%a Split:@." Label.print (LabelPool.value lab);*)
let
t
=
Types
.
Record
.
split
t
lab
in
(* List.iter (fun (t1,t2) ->
Format.fprintf Format.std_formatter "t1=%a t2=%a@."
Types.Print.print t1
Types.Print.print t2) t; *)
let
pl
=
Array
.
map
(
fun
p
->
match
p
.
Normal
.
nrecord
with
|
Normal
.
RecLabel
(
_
,
l
)
->
Normal
.
NLineProd
.
get
l
...
...
@@ -1246,18 +1348,14 @@ struct
in
let
rec
print_record_opt
ppf
=
function
|
None
->
()
|
Some
r
->
Format
.
fprintf
ppf
" | Record -> @
\n
"
;
Format
.
fprintf
ppf
" @[%a@]@
\n
"
print_record
r
and
print_record
ppf
=
function
|
RecNolabel
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"SomeField:%a;NoField:%a"
print_ret_opt
r1
print_ret_opt
r2
|
RecLabel
(
l
,
d
)
->
|
Some
(
RecLabel
(
l
,
d
))
->
let
l
=
LabelPool
.
value
l
in
Format
.
fprintf
ppf
"check label %a:@
\n
"
Label
.
print
l
;
Format
.
fprintf
ppf
"Present => @[%a@]@
\n
"
(
print_prod
"record"
)
d
in
print_prod
(
"record:"
^
(
Label
.
to_string
l
))
ppf
d
|
Some
(
RecNolabel
(
r1
,
r2
))
->
Format
.
fprintf
ppf
" | Record -> @
\n
"
;
Format
.
fprintf
ppf
" SomeField:%a;NoField:%a@
\n
"
print_ret_opt
r1
print_ret_opt
r2
in
List
.
iter
print_basic
actions
.
basic
;
print_prod
""
ppf
actions
.
prod
;
...
...
@@ -1269,7 +1367,7 @@ struct
|
AIgnore
r
->
Format
.
fprintf
ppf
"v -> %a@
\n
"
print_ret
r
let
print_dispatcher
ppf
d
=
(*
Format.fprintf ppf "Dispatcher %i accepts [%a]@\n"
Format
.
fprintf
ppf
"Dispatcher %i accepts [%a]@
\n
"
d
.
id
Types
.
Print
.
print
(
Types
.
normalize
d
.
t
);
let
print_code
code
(
t
,
arity
,
m
)
=
Format
.
fprintf
ppf
" Returns $%i(arity=%i) for [%a]"
...
...
@@ -1287,7 +1385,7 @@ struct
Format
.
fprintf
ppf
"@
\n
"
;
in
Array.iteri print_code d.codes;
*)
Array
.
iteri
print_code
d
.
codes
;
Format
.
fprintf
ppf
"let disp_%i = function@
\n
"
d
.
id
;
print_actions
ppf
(
actions
d
);
Format
.
fprintf
ppf
"====================================@
\n
"
...
...
types/types.ml
View file @
6dda32d0
...
...
@@ -891,7 +891,7 @@ and check_arrow (left,right) s =
big_conj
single_right
right
s
and
check_record
(
labels
,
(
oleft
,
left
)
,
rights
)
s
=
let
rec
aux
rights
s
=
match
rights
with
let
rec
aux
left
rights
s
=
match
rights
with
|
[]
->
set
s
|
(
oright
,
right
)
::
rights
->
let
next
=
...
...
@@ -899,21 +899,17 @@ and check_record (labels,(oleft,left),rights) s =
exists
(
Array
.
length
left
)
(
fun
i
->
trivially_disjoint
left
.
(
i
)
right
.
(
i
))
in
if
next
then
aux
rights
s
if
next
then
aux
left
rights
s
else
for
i
=
0
to
Array
.
length
left
-
1
do
let
back
=
left
.
(
i
)
in
let
di
=
diff
back
right
.
(
i
)
in
guard
(
slot
di
)
(
fun
s
->
left
.
(
i
)
<-
di
;
aux
rights
s
;
left
.
(
i
)
<-
back
;
)
s
(* TODO: are side effects correct ? *)
let
left'
=
Array
.
copy
left
in
let
di
=
diff
left
.
(
i
)
right
.
(
i
)
in
left'
.
(
i
)
<-
di
;
guard
(
slot
di
)
(
aux
left'
rights
)
s
;
done
in
let
rec
start
i
s
=
if
(
i
<
0
)
then
aux
rights
s
if
(
i
<
0
)
then
aux
left
rights
s
else
guard
(
slot
left
.
(
i
))
(
start
(
i
-
1
))
s
in
...
...
@@ -1295,7 +1291,7 @@ struct
(
LabelMap
.
get
r
);
Format
.
fprintf
ppf
"}"
|
String
(
i
,
j
,
s
,
c
)
->
Format
.
fprintf
ppf
"
\"
%a
\"
@
%a"
Format
.
fprintf
ppf
"
\"
%a
\"
%a"
U
.
print
(
U
.
mk
(
U
.
get_substr
s
i
j
))
print_const
c
...
...
@@ -1323,6 +1319,7 @@ struct
|
Record
of
(
bool
*
t
)
label_map
*
bool
*
bool
|
Arrows
of
(
t
*
t
)
list
*
(
t
*
t
)
list
|
Neg
of
t
|
Abs
of
t
let
compare
x
y
=
x
.
id
-
y
.
id
end
module
Decompile
=
Pretty
.
Decompile
(
DescrHash
)(
S
)
...
...
@@ -1385,6 +1382,8 @@ struct
DescrHash
.
add
memo
d
s
;
s
with
Not_found
->
if
d
.
absent
then
alloc
[
Abs
(
prepare
({
d
with
hash
=
0
;
absent
=
false
}))]
else
if
worth_complement
d
then
alloc
[
Neg
(
prepare
(
neg
d
))]
else
...
...
@@ -1438,6 +1437,7 @@ struct
let
p
=
List
.
map
aux
p
and
n
=
List
.
map
aux
n
in
add
(
Arrows
(
p
,
n
)))
(
BoolPair
.
get
not_seq
.
arrow
);
if
not_seq
.
absent
then
add
(
Atomic
(
fun
ppf
->
Format
.
fprintf
ppf
"#ABSENT"
));
slot
.
def
<-
List
.
rev
slot
.
def
;
slot
...
...
@@ -1464,6 +1464,7 @@ struct
|
_
->
()
and
assign_name_rec
=
function
|
Neg
t
->
assign_name
t
|
Abs
t
->
assign_name
t
|
Name
_
|
Char
_
|
Atomic
_
->
()
|
Regexp
r
->
assign_name_regexp
r
|
Pair
(
t1
,
t2
)
->
assign_name
t1
;
assign_name
t2
...
...
@@ -1497,7 +1498,9 @@ struct
then
Format
.
fprintf
ppf
"@[(%a)@]"
aux
def
else
aux
ppf
def
and
do_print
ppf
=
function
(* | Neg { def = [] } -> Format.fprintf ppf "Any" *)
|
Neg
t
->
Format
.
fprintf
ppf
"Any
\\
(@[%a@])"
(
do_print_slot
0
)
t
|
Abs
t
->
Format
.
fprintf
ppf
"?(@[%a@])"
(
do_print_slot
0
)
t
|
Name
n
->
Format
.
fprintf
ppf
"%a"
U
.
print
n
|
Char
c
->
Chars
.
V
.
print
ppf
c
|
Regexp
r
->
Format
.
fprintf
ppf
"@[[ %a ]@]"
(
do_print_regexp
0
)
r
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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