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
cd44cecf
Commit
cd44cecf
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-06-13 20:47:31 by afrisch] Cleanup
Original author: afrisch Date: 2005-06-13 20:47:31+00:00
parent
79bec74f
Changes
1
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
cd44cecf
...
...
@@ -587,15 +587,6 @@ module Normal = struct
let
compare_result
r1
r2
=
IdMap
.
compare
compare_source
r1
r2
let
hash_result
r
=
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
)
module
Nnf
=
struct
...
...
@@ -625,99 +616,39 @@ module Normal = struct
end
module
NBasic
=
struct
include
Custom
.
Dummy
let
serialize
s
_
=
failwith
"Patterns.NLineBasic.serialize"
type
t
=
result
*
Types
.
t
let
compare
(
r1
,
t1
)
(
r2
,
t2
)
=
let
c
=
compare_result
r1
r2
in
if
c
<>
0
then
c
else
Types
.
compare
t1
t2
let
equal
x
y
=
compare
x
y
==
0
let
hash
(
r
,
t
)
=
hash_result
r
+
17
*
Types
.
hash
t
end
module
NProd
=
struct
type
t
=
result
*
Nnf
.
t
*
Nnf
.
t
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
Nnf
.
print
x
Nnf
.
print
y
let
compare
(
r1
,
x1
,
y1
)
(
r2
,
x2
,
y2
)
=
let
c
=
compare_result
r1
r2
in
if
c
<>
0
then
c
else
let
c
=
Nnf
.
compare
x1
x2
in
if
c
<>
0
then
c
else
Nnf
.
compare
y1
y2
let
equal
x
y
=
compare
x
y
==
0
let
hash
(
r
,
x
,
y
)
=
hash_result
r
+
17
*
(
Nnf
.
hash
x
)
+
267
*
(
Nnf
.
hash
y
)
end
module
NLineBasic
=
S
ortedLis
t
.
Make
(
NBasic
)
module
NLineProd
=
S
ortedLis
t
.
Make
(
NProd
)
module
NLineBasic
=
S
e
t
.
Make
(
NBasic
)
module
NLineProd
=
S
e
t
.
Make
(
NProd
)
type
record
=
|
RecNolabel
of
result
option
*
result
option
|
RecLabel
of
label
*
NLineProd
.
t
type
t
=
{
nfv
:
fv
;
na
:
Types
.
t
;
nbasic
:
NLineBasic
.
t
;
nprod
:
NLineProd
.
t
;
nxml
:
NLineProd
.
t
;
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;@ @[nprod=@ @[%a@]@]};@ @[nrecord=@ @[%a@]@]}@]"
Types
.
Print
.
print
nf
.
na
NLineProd
.
dump
nf
.
nprod
print_record
nf
.
nrecord
include
Custom
.
Dummy
let
compare_record
t1
t2
=
match
t1
,
t2
with
|
RecNolabel
(
s1
,
n1
)
,
RecNolabel
(
s2
,
n2
)
->
(
match
(
s1
,
s2
,
n1
,
n2
)
with
|
Some
r1
,
Some
r2
,
_
,
_
->
compare_result
r1
r2
|
None
,
Some
_
,
_
,
_
->
-
1
|
Some
_
,
None
,
_
,
_
->
1
|
None
,
None
,
Some
r1
,
Some
r2
->
compare_result
r1
r2
|
None
,
None
,
None
,
Some
_
->
-
1
|
None
,
None
,
Some
_
,
None
->
1
|
None
,
None
,
None
,
None
->
0
)
|
RecNolabel
(
_
,_
)
,
_
->
-
1
|
_
,
RecNolabel
(
_
,_
)
->
1
|
RecLabel
(
l1
,
p1
)
,
RecLabel
(
l2
,
p2
)
->
let
c
=
LabelPool
.
compare
l1
l2
in
if
c
<>
0
then
c
else
NLineProd
.
compare
p1
p2
let
compare
t1
t2
=
if
t1
==
t2
then
0
else
(* TODO: reorder; remove comparison of nfv ? *)
let
c
=
IdSet
.
compare
t1
.
nfv
t2
.
nfv
in
if
c
<>
0
then
c
else
let
c
=
Types
.
compare
t1
.
na
t2
.
na
in
if
c
<>
0
then
c
else
let
c
=
NLineBasic
.
compare
t1
.
nbasic
t2
.
nbasic
in
if
c
<>
0
then
c
else
let
c
=
NLineProd
.
compare
t1
.
nprod
t2
.
nprod
in
if
c
<>
0
then
c
else
let
c
=
NLineProd
.
compare
t1
.
nxml
t2
.
nxml
in
if
c
<>
0
then
c
else
compare_record
t1
.
nrecord
t2
.
nrecord
let
fus
=
IdMap
.
union_disj
let
nempty
lab
=
{
nfv
=
IdSet
.
empty
;
na
=
Types
.
empty
;
nbasic
=
NLineBasic
.
empty
;
{
nbasic
=
NLineBasic
.
empty
;
nprod
=
NLineProd
.
empty
;
nxml
=
NLineProd
.
empty
;
nrecord
=
(
match
lab
with
...
...
@@ -728,51 +659,49 @@ module Normal = struct
let
ncup
nf1
nf2
=
(* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
(* assert (nf1.nfv = nf2.nfv); *)
{
nfv
=
nf1
.
nfv
;
na
=
Types
.
cup
nf1
.
na
nf2
.
na
;
nbasic
=
NLineBasic
.
cup
nf1
.
nbasic
nf2
.
nbasic
;
nprod
=
NLineProd
.
cup
nf1
.
nprod
nf2
.
nprod
;
nxml
=
NLineProd
.
cup
nf1
.
nxml
nf2
.
nxml
;
{
nbasic
=
NLineBasic
.
union
nf1
.
nbasic
nf2
.
nbasic
;
nprod
=
NLineProd
.
union
nf1
.
nprod
nf2
.
nprod
;
nxml
=
NLineProd
.
union
nf1
.
nxml
nf2
.
nxml
;
nrecord
=
(
match
(
nf1
.
nrecord
,
nf2
.
nrecord
)
with
|
RecLabel
(
l1
,
r1
)
,
RecLabel
(
l2
,
r2
)
->
(* assert (l1 = l2); *)
RecLabel
(
l1
,
NLineProd
.
cup
r1
r2
)
RecLabel
(
l1
,
NLineProd
.
union
r1
r2
)
|
RecNolabel
(
x1
,
y1
)
,
RecNolabel
(
x2
,
y2
)
->
RecNolabel
((
if
x1
==
None
then
x2
else
x1
)
,
(
if
y1
==
None
then
y2
else
y1
))
|
_
->
assert
false
)
}
let
double_fold
f
l1
l2
=
Li
st
.
fold_left
(
fun
accu
x1
->
Li
st
.
fold_left
(
fun
accu
x2
->
f
accu
x1
x2
)
accu
l2
)
[]
l1
let
double_fold
_basic
f
l1
l2
=
N
Li
neBasic
.
fold
(
fun
x1
accu
->
N
Li
neBasic
.
fold
(
fun
x2
accu
->
f
accu
x1
x2
)
l2
accu
)
l1
NLineBasic
.
empty
let
double_fold_prod
f
l1
l2
=
double_fold
f
(
NLineProd
.
get
l1
)
(
NLineProd
.
get
l2
)
NLineProd
.
fold
(
fun
x1
accu
->
NLineProd
.
fold
(
fun
x2
accu
->
f
accu
x1
x2
)
l2
accu
)
l1
NLineProd
.
empty
let
ncap
nf1
nf2
=
let
prod
accu
(
res1
,
(
pl1
,
t1
,
xs1
)
,
(
ql1
,
s1
,
ys1
))
(
res2
,
(
pl2
,
t2
,
xs2
)
,
(
ql2
,
s2
,
ys2
))
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
let
s
=
Types
.
cap
s1
s2
in
if
Types
.
is_empty
s
then
accu
else
(
fus
res1
res2
,
NLineProd
.
add
(
fus
res1
res2
,
(
NodeSet
.
cup
pl1
pl2
,
t
,
IdSet
.
cup
xs1
xs2
)
,
(
NodeSet
.
cup
ql1
ql2
,
s
,
IdSet
.
cup
ys1
ys2
))
::
accu
accu
in
let
basic
accu
(
res1
,
t1
)
(
res2
,
t2
)
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
(
fus
res1
res2
,
t
)
::
accu
NLineBasic
.
add
(
fus
res1
res2
,
t
)
accu
in
let
record
r1
r2
=
match
r1
,
r2
with
|
RecLabel
(
l1
,
r1
)
,
RecLabel
(
l2
,
r2
)
->
(* assert (l1 = l2); *)
RecLabel
(
l1
,
NLineProd
.
from_list
(
double_fold_prod
prod
r1
r2
)
)
RecLabel
(
l1
,
double_fold_prod
prod
r1
r2
)
|
RecNolabel
(
x1
,
y1
)
,
RecNolabel
(
x2
,
y2
)
->
let
x
=
match
x1
,
x2
with
|
Some
res1
,
Some
res2
->
Some
(
fus
res1
res2
)
...
...
@@ -783,13 +712,9 @@ module Normal = struct
RecNolabel
(
x
,
y
)
|
_
->
assert
false
in
{
nfv
=
IdSet
.
cup
nf1
.
nfv
nf2
.
nfv
;
na
=
Types
.
cap
nf1
.
na
nf2
.
na
;
nbasic
=
NLineBasic
.
from_list
(
double_fold
basic
(
NLineBasic
.
get
nf1
.
nbasic
)
(
NLineBasic
.
get
nf2
.
nbasic
));
nprod
=
NLineProd
.
from_list
(
double_fold_prod
prod
nf1
.
nprod
nf2
.
nprod
);
nxml
=
NLineProd
.
from_list
(
double_fold_prod
prod
nf1
.
nxml
nf2
.
nxml
);
{
nbasic
=
double_fold_basic
basic
nf1
.
nbasic
nf2
.
nbasic
;
nprod
=
double_fold_prod
prod
nf1
.
nprod
nf2
.
nprod
;
nxml
=
double_fold_prod
prod
nf1
.
nxml
nf2
.
nxml
;
nrecord
=
record
nf1
.
nrecord
nf2
.
nrecord
;
}
...
...
@@ -809,8 +734,6 @@ module Normal = struct
and
src_q
=
IdMap
.
constant
SRight
xsq
in
let
src
=
IdMap
.
merge_elem
SRecompose
src_p
src_q
in
{
(
nempty
lab
)
with
nfv
=
xs
;
na
=
acc
;
nprod
=
single_prod
src
(
nnode
p
xsp
)
(
nnode
q
xsq
)
}
...
...
@@ -820,8 +743,6 @@ module Normal = struct
and
src_q
=
IdMap
.
constant
SRight
xsq
in
let
src
=
IdMap
.
merge_elem
SRecompose
src_p
src_q
in
{
(
nempty
lab
)
with
nfv
=
xs
;
na
=
acc
;
nxml
=
single_prod
src
(
nnode
p
xsp
)
(
nnode
q
xsq
)
}
...
...
@@ -837,13 +758,13 @@ module Normal = struct
in
let
src
=
IdMap
.
constant
src
xs
in
{
(
nempty
lab
)
with
nfv
=
xs
;
na
=
acc
;
nrecord
=
RecLabel
(
label
,
single_prod
src
lft
rgt
)
}
let
nconstr
lab
t
=
let
aux
l
=
NLineProd
.
from_list
(
List
.
map
(
fun
(
t1
,
t2
)
->
empty_res
,
nc
t1
,
nc
t2
)
l
)
in
let
aux
l
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
NLineProd
.
add
(
empty_res
,
nc
t1
,
nc
t2
)
accu
)
NLineProd
.
empty
l
in
let
record
=
match
lab
with
|
None
->
let
(
x
,
y
)
=
Types
.
Record
.
empty_cases
t
in
...
...
@@ -852,7 +773,6 @@ module Normal = struct
|
Some
l
->
RecLabel
(
l
,
aux
(
Types
.
Record
.
split_normal
t
l
))
in
{
(
nempty
lab
)
with
na
=
t
;
nbasic
=
single_basic
empty_res
(
Types
.
cap
t
any_basic
);
nprod
=
aux
(
Types
.
Product
.
normal
t
);
nxml
=
aux
(
Types
.
Product
.
normal
~
kind
:
`XML
t
);
...
...
@@ -860,9 +780,7 @@ module Normal = struct
}
let
nany
lab
res
=
{
nfv
=
IdMap
.
domain
res
;
na
=
Types
.
any
;
nbasic
=
single_basic
res
any_basic
;
{
nbasic
=
single_basic
res
any_basic
;
nprod
=
single_prod
res
ncany
ncany
;
nxml
=
single_prod
res
ncany
ncany
;
nrecord
=
match
lab
with
...
...
@@ -875,12 +793,6 @@ module Normal = struct
let
rec
nnormal
lab
((
acc
,
fv
,
d
)
as
p
)
xs
=
let
xs
=
IdSet
.
cap
xs
fv
in
(*
if not (IdSet.equal xs fv) then
(Format.fprintf Format.std_formatter
"ERR: p=%a xs=%a fv=%a@." Print.print p Print.print_xs xs Print.print_xs fv;
exit 1);
*)
if
Types
.
is_empty
acc
then
nempty
lab
else
if
IdSet
.
is_empty
xs
then
nconstr
lab
acc
else
match
d
with
...
...
@@ -901,10 +813,6 @@ module Normal = struct
directly shift it*)
let
print_node_list
ppf
pl
=
List
.
iter
(
fun
p
->
Format
.
fprintf
ppf
"%a;"
Node
.
dump
p
)
pl
let
facto
f
t
xs
pl
=
List
.
fold_left
(
fun
vs
p
->
IdSet
.
cup
vs
(
f
(
descr
p
)
t
(
IdSet
.
cap
(
fv
p
)
xs
)))
...
...
@@ -919,50 +827,12 @@ module Normal = struct
(
vs_var
,
vs_nil
,
(
pl
,
t
,
xs
))
let
normal
l
t
pl
xs
=
let
a
=
nconstr
l
t
in
(* let vs_var = facto Factorize.var t xs pl in
let xs = IdSet.diff xs vs_var in
let vs_var,a =
if f then vs_var,a
else
IdSet.empty,
List.fold_left (fun a x -> ncap a (ncapture l x)) a vs_var in
let vs_nil = facto Factorize.nil t xs pl in
let xs = IdSet.diff xs vs_nil in
let vs_nil,a =
if f then vs_nil,a
else
IdSet.empty,
List.fold_left
(fun a x -> ncap a (nconstant l x Sequence.nil_cst)) a vs_nil in
*)
List
.
fold_left
(
fun
a
p
->
ncap
a
(
nnormal
l
(
descr
p
)
xs
))
a
pl
List
.
fold_left
(
fun
a
p
->
ncap
a
(
nnormal
l
(
descr
p
)
xs
))
(
nconstr
l
t
)
pl
let
nnf
lab
t0
(
pl
,
t
,
xs
)
=
let
t
=
if
Types
.
subtype
t
t0
then
t
else
Types
.
cap
t
t0
in
normal
lab
t
(
NodeSet
.
get
pl
)
xs
(*
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
...
...
@@ -1337,8 +1207,8 @@ struct
let
rec
dispatch_prod
?
(
kind
=
`Normal
)
disp
pl
=
let
extr
=
match
kind
with
|
`Normal
->
fun
p
->
Normal
.
NLineProd
.
get
p
.
Normal
.
nprod
|
`XML
->
fun
p
->
Normal
.
NLineProd
.
get
p
.
Normal
.
nxml
in
|
`Normal
->
fun
p
->
Normal
.
NLineProd
.
elements
p
.
Normal
.
nprod
|
`XML
->
fun
p
->
Normal
.
NLineProd
.
elements
p
.
Normal
.
nxml
in
let
t
=
Types
.
Product
.
get
~
kind
disp
.
t
in
dispatch_prod0
disp
t
(
Array
.
map
extr
pl
)
and
dispatch_prod0
disp
t
pl
=
...
...
@@ -1389,7 +1259,7 @@ struct
let
t
=
Types
.
Record
.
split
t
lab
in
let
pl
=
Array
.
map
(
fun
p
->
match
p
.
Normal
.
nrecord
with
|
Normal
.
RecLabel
(
_
,
l
)
->
Normal
.
NLineProd
.
get
l
Normal
.
NLineProd
.
elements
l
|
_
->
assert
false
)
pl
in
Some
(
RecLabel
(
lab
,
dispatch_prod0
disp
t
pl
))
...
...
@@ -1912,9 +1782,6 @@ struct
let
cur_id
=
State
.
ref
"Patterns.cur_id"
0
(* TODO: save dispatchers ? *)
module
NfMap
=
Map
.
Make
(
Normal
)
module
NfSet
=
Set
.
Make
(
Normal
)
module
DispMap
=
Map
.
Make
(
Custom
.
Pair
(
Types
)(
Custom
.
Array
(
Req
)))
(* Try with a hash-table ! *)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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