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
a054f94b
Commit
a054f94b
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-10-23 09:22:04 by cvscast] Empty log message
Original author: cvscast Date: 2002-10-23 09:22:04+00:00
parent
d799eb13
Changes
3
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
a054f94b
...
...
@@ -127,12 +127,25 @@ struct
]
type
result
=
(
capture
,
source
)
sm
type
'
a
line
=
(
result
*
'
a
,
Types
.
descr
)
sm
type
nf
=
{
v
:
fv
;
a
:
Types
.
descr
;
basic
:
(
result
,
Types
.
descr
)
sm
;
prod
:
(
result
*
Types
.
descr
*
node
sl
*
node
sl
)
sl
;
record
:
(
result
*
Types
.
descr
*
(
Types
.
label
,
node
sl
)
sm
)
sl
;
basic
:
unit
line
;
prod
:
(
node
sl
*
node
sl
)
line
;
record
:
((
Types
.
label
,
node
sl
)
sm
)
line
}
type
'
a
nline
=
(
result
*
'
a
)
list
type
record
=
[
`Success
|
`Fail
|
`Dispatch
of
(
nf
*
record
)
list
|
`Label
of
Types
.
label
*
(
nf
*
record
)
list
*
record
]
type
normal
=
{
nbasic
:
Types
.
descr
nline
;
nprod
:
(
nf
*
nf
)
nline
;
nrecord
:
record
nline
}
let
empty
=
{
v
=
[]
;
a
=
Types
.
empty
;
basic
=
[]
;
prod
=
[]
;
record
=
[]
}
...
...
@@ -140,70 +153,55 @@ struct
let
restrict
t
nf
=
let
map_filter
f
l
=
let
g
accu
x
=
match
f
x
with
Some
y
->
y
::
accu
|
None
->
accu
in
SortedList
.
from_list
(
List
.
fold_left
g
[]
l
)
in
let
aux_basic
(
res
,
bt
)
=
let
bt
=
Types
.
cap
t
bt
in
if
Types
.
is_empty
bt
then
None
else
Some
(
res
,
bt
)
in
let
aux_prod
(
res
,
bt
,
p
,
q
)
=
let
bt
=
Types
.
cap
t
bt
in
if
Types
.
is_empty
bt
then
None
else
Some
(
res
,
bt
,
p
,
q
)
in
let
aux_record
(
res
,
bt
,
r
)
=
let
bt
=
Types
.
cap
t
bt
in
if
Types
.
is_empty
bt
then
None
else
Some
(
res
,
bt
,
r
)
in
let
rec
filter
=
function
|
(
key
,
acc
)
::
rem
->
let
acc
=
Types
.
cap
t
acc
in
if
Types
.
is_empty
acc
then
filter
rem
else
(
key
,
acc
)
::
(
filter
rem
)
|
[]
->
[]
in
{
v
=
nf
.
v
;
a
=
Types
.
cap
t
nf
.
a
;
basic
=
map_
filter
aux_basic
nf
.
basic
;
prod
=
map_
filter
aux_prod
nf
.
prod
;
record
=
map_
filter
aux_record
nf
.
record
;
basic
=
filter
nf
.
basic
;
prod
=
filter
nf
.
prod
;
record
=
filter
nf
.
record
;
}
let
fus
=
SortedMap
.
union_disj
let
slcup
=
SortedList
.
cup
let
cap
nf1
nf2
=
let
aux
f
x1
x2
=
SortedList
.
from_list
(
List
.
fold_left
(
fun
accu
a
->
List
.
fold_left
(
f
a
)
accu
x2
)
[]
x1
)
in
let
aux_basic
(
res1
,
t1
)
accu
(
res2
,
t2
)
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
(
fus
res1
res2
,
t
)
::
accu
in
let
aux_prod
(
res1
,
t1
,
p1
,
q1
)
accu
(
res2
,
t2
,
p2
,
q2
)
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
(
fus
res1
res2
,
t
,
slcup
p1
p2
,
slcup
q1
q2
)
::
accu
in
let
aux_record
(
res1
,
t1
,
r1
)
accu
(
res2
,
t2
,
r2
)
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
(
fus
res1
res2
,
t
,
SortedMap
.
union
slcup
r1
r2
)
::
accu
in
let
merge
f
lines1
lines2
=
let
m
=
List
.
fold_left
(
fun
accu
((
res1
,
x1
)
,
acc1
)
->
List
.
fold_left
(
fun
accu
((
res2
,
x2
)
,
acc2
)
->
let
acc
=
Types
.
cap
acc1
acc2
in
if
Types
.
is_empty
acc
then
accu
else
((
fus
res1
res2
,
f
x1
x2
)
,
acc
)
::
accu
)
accu
lines2
)
[]
lines1
in
SortedMap
.
from_list
Types
.
cup
m
in
let
merge_basic
()
()
=
()
and
merge_prod
(
p1
,
q1
)
(
p2
,
q2
)
=
slcup
p1
p1
,
slcup
q1
q2
and
merge_record
r1
r2
=
SortedMap
.
union
slcup
r1
r2
in
{
v
=
SortedList
.
cup
nf1
.
v
nf2
.
v
;
a
=
Types
.
cap
nf1
.
a
nf2
.
a
;
basic
=
SortedMap
.
from_sorted_list
Types
.
cup
(
aux
aux_basic
nf1
.
basic
nf2
.
basic
);
prod
=
aux
aux_prod
nf1
.
prod
nf2
.
prod
;
record
=
aux
aux_record
nf1
.
record
nf2
.
record
;
basic
=
merge
merge_basic
nf1
.
basic
nf2
.
basic
;
prod
=
merge
merge_prod
nf1
.
prod
nf2
.
prod
;
record
=
merge
merge_record
nf1
.
record
nf2
.
record
;
}
let
cup
acc1
nf1
nf2
=
let
nf2
=
restrict
(
Types
.
neg
acc1
)
nf2
in
{
v
=
SortedList
.
cup
nf1
.
v
nf2
.
v
;
{
v
=
nf1
.
v
;
(* =
nf2.v
*)
a
=
Types
.
cup
nf1
.
a
nf2
.
a
;
basic
=
SortedMap
.
union
Types
.
cup
nf1
.
basic
nf2
.
basic
;
prod
=
Sorted
List
.
cup
nf1
.
prod
nf2
.
prod
;
record
=
Sorted
List
.
cup
nf1
.
record
nf2
.
record
;
prod
=
Sorted
Map
.
union
Types
.
cup
nf1
.
prod
nf2
.
prod
;
record
=
Sorted
Map
.
union
Types
.
cup
nf1
.
record
nf2
.
record
;
}
let
times
acc
p
q
=
...
...
@@ -213,47 +211,47 @@ struct
{
empty
with
v
=
SortedList
.
cup
p
.
fv
q
.
fv
;
a
=
acc
;
prod
=
[
src
,
acc
,
[
p
]
,
[
q
]
]
}
prod
=
[
(
src
,
(
[
p
]
,
[
q
]
))
,
acc
]
}
let
record
acc
l
p
=
let
src
=
List
.
map
(
fun
v
->
(
v
,
`Field
l
))
p
.
fv
in
{
empty
with
v
=
p
.
fv
;
a
=
acc
;
record
=
[
src
,
acc
,
[
l
,
[
p
]]
]
}
record
=
[
(
src
,
[
l
,
[
p
]]
)
,
acc
]
}
let
any
=
{
v
=
[]
;
a
=
Types
.
any
;
basic
=
[
[]
,
any_basic
];
prod
=
[
[]
,
Types
.
Product
.
any
,
[]
,
[]
];
record
=
[
[]
,
Types
.
Record
.
any
,
[]
];
basic
=
[
(
[]
,
()
)
,
any_basic
];
prod
=
[
(
[]
,
([]
,
[]
))
,
Types
.
Product
.
any
];
record
=
[
(
[]
,
[]
)
,
Types
.
Record
.
any
];
}
let
capture
x
=
let
l
=
[
x
,
`Catch
]
in
{
v
=
[
x
];
a
=
Types
.
any
;
basic
=
[
l
,
any_basic
];
prod
=
[
l
,
Types
.
Product
.
any
,
[]
,
[]
];
record
=
[
l
,
Types
.
Record
.
any
,
[]
];
basic
=
[
(
l
,
()
)
,
any_basic
];
prod
=
[
(
l
,
([]
,
[]
))
,
Types
.
Product
.
any
];
record
=
[
(
l
,
[]
)
,
Types
.
Record
.
any
];
}
let
constant
x
c
=
let
l
=
[
x
,
`Const
c
]
in
{
v
=
[
x
];
a
=
Types
.
any
;
basic
=
[
l
,
any_basic
];
prod
=
[
l
,
Types
.
Product
.
any
,
[]
,
[]
];
record
=
[
l
,
Types
.
Record
.
any
,
[]
];
basic
=
[
(
l
,
()
)
,
any_basic
];
prod
=
[
(
l
,
([]
,
[]
))
,
Types
.
Product
.
any
];
record
=
[
(
l
,
[]
)
,
Types
.
Record
.
any
];
}
let
constr
t
=
{
v
=
[]
;
a
=
t
;
basic
=
[
[]
,
Types
.
cap
t
any_basic
];
prod
=
[
[]
,
Types
.
cap
t
Types
.
Product
.
any
,
[]
,
[]
];
record
=
[
[]
,
Types
.
cap
t
Types
.
Record
.
any
,
[]
];
basic
=
[
(
[]
,
()
)
,
Types
.
cap
t
any_basic
];
prod
=
[
(
[]
,
([]
,
[]
))
,
Types
.
cap
t
Types
.
Product
.
any
];
record
=
[
(
[]
,
[]
)
,
Types
.
cap
t
Types
.
Record
.
any
];
}
(* Put a pattern in normal form *)
...
...
@@ -280,7 +278,7 @@ struct
masks
:
(
mask
*
int
)
list
;
basic
:
(
Types
.
descr
*
(
result
option
list
))
list
;
prod
:
prod
;
record
:
record
;
record
:
record
option
;
}
and
prod
=
disp
*
(
mask
*
disp
*
(
mask
*
prod_result
)
list
)
list
and
prod_result
=
(
result
*
(
int
*
int
))
option
list
...
...
@@ -293,7 +291,51 @@ struct
and
mask
=
bool
list
and
disp
=
Types
.
descr
*
nf
SortedList
.
t
end
let
normal
nf
=
let
basic
=
List
.
map
(
fun
((
res
,
()
)
,
acc
)
->
(
res
,
acc
))
and
prod
=
let
line
accu
(((
res
,
(
pl
,
ql
))
,
acc
))
=
let
p
=
bigcap
pl
and
q
=
bigcap
ql
in
let
aux
accu
(
t1
,
t2
)
=
(
res
,
(
restrict
t1
p
,
restrict
t2
q
))
::
accu
in
List
.
fold_left
aux
accu
(
Types
.
Product
.
normal
acc
)
in
List
.
fold_left
line
[]
and
record
=
let
rec
aux
nr
fields
=
match
(
nr
,
fields
)
with
|
(
`Success
,
[]
)
->
`Success
|
(
`Fail
,_
)
->
`Fail
|
(
`Success
,
(
l2
,
pl
)
::
fields
)
->
`Label
(
l2
,
[
bigcap
pl
,
aux
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
_
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l2
<
l1
->
`Label
(
l2
,
[
bigcap
pl
,
aux
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l1
=
l2
->
let
p
=
bigcap
pl
in
let
pr
=
List
.
map
(
fun
(
t
,
x
)
->
(
restrict
t
p
,
aux
x
fields
))
pr
in
`Label
(
l1
,
pr
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
ab
)
,_
)
->
let
pr
=
List
.
map
(
fun
(
t
,
x
)
->
(
constr
t
,
aux
x
fields
))
pr
in
`Label
(
l1
,
pr
,
aux
ab
fields
)
in
let
line
accu
((
res
,
fields
)
,
acc
)
=
let
nr
=
Types
.
Record
.
normal
acc
in
let
x
=
aux
nr
fields
in
match
x
with
|
`Fail
->
accu
|
x
->
(
res
,
x
)
::
accu
in
List
.
fold_left
line
[]
in
{
nbasic
=
basic
nf
.
basic
;
nprod
=
prod
nf
.
prod
;
nrecord
=
record
nf
.
record
;
}
let
collect
f
pp
=
let
aux
accu
(
res
,
x
)
=
(
f
x
)
::
accu
in
SortedList
.
from_list
(
List
.
fold_left
(
List
.
fold_left
aux
)
[]
pp
)
...
...
@@ -326,7 +368,7 @@ struct
let
accu
=
aux
pl
accu
(
Types
.
diff
t
ty
)
rem
in
accu
in
let
pl
=
List
.
map
(
fun
p
->
p
.
basic
)
pl
in
let
pl
=
List
.
map
(
fun
p
->
p
.
n
basic
)
pl
in
let
tests
=
collect
(
fun
x
->
x
)
pl
in
let
t
=
Types
.
cap
any_basic
t
in
aux
pl
[]
t
tests
...
...
@@ -341,15 +383,8 @@ struct
let
aux
(
res
,
(
i
,
q
))
=
(
res
,
(
i
,
List
.
assoc
q
success
))
in
List
.
map
(
extract_unique
aux
)
let
prepare_prod
p
=
let
line
accu
(
res
,
t
,
pl
,
ql
)
=
let
p
=
bigcap
pl
and
q
=
bigcap
ql
in
let
aux
accu
(
t1
,
t2
)
=
(
res
,
(
restrict
t1
p
,
restrict
t2
q
))
::
accu
in
List
.
fold_left
aux
accu
(
Types
.
Product
.
normal
t
)
in
List
.
fold_left
line
[]
p
.
prod
let
rec
dispatch_prod
t
pl
=
let
pl
=
List
.
map
prepare_
prod
pl
in
let
pl
=
List
.
map
(
fun
p
->
p
.
n
prod
)
pl
in
let
tests
=
collect
(
fun
(
p
,_
)
->
p
)
pl
in
let
t
=
Types
.
Product
.
get
t
in
let
disp
=
aux_prod1
t
pl
[]
[]
[]
0
tests
in
...
...
@@ -392,11 +427,6 @@ struct
(* Record types *)
type
record
=
[
`Success
|
`Fail
|
`Dispatch
of
(
nf
*
record
)
list
|
`Label
of
Types
.
label
*
(
nf
*
record
)
list
*
record
]
let
map_record
f
=
let
rec
aux
=
function
...
...
@@ -453,41 +483,13 @@ struct
|
_
->
assert
false
in
List
.
map
aux
let
rec
cap_record
nr
fields
=
match
(
nr
,
fields
)
with
|
(
`Success
,
[]
)
->
`Success
|
(
`Fail
,_
)
->
`Fail
|
(
`Success
,
(
l2
,
pl
)
::
fields
)
->
`Label
(
l2
,
[
bigcap
pl
,
cap_record
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
_
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l2
<
l1
->
`Label
(
l2
,
[
bigcap
pl
,
cap_record
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l1
=
l2
->
let
p
=
bigcap
pl
in
let
pr
=
List
.
map
(
fun
(
t
,
x
)
->
(
restrict
t
p
,
cap_record
x
fields
))
pr
in
`Label
(
l1
,
pr
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
ab
)
,_
)
->
let
pr
=
List
.
map
(
fun
(
t
,
x
)
->
(
constr
t
,
cap_record
x
fields
))
pr
in
`Label
(
l1
,
pr
,
cap_record
ab
fields
)
let
prepare_record
=
map_record
(
function
(
res
,
t
,
fields
)
->
let
nr
=
Types
.
Record
.
normal
t
in
let
x
=
cap_record
nr
fields
in
(
res
,
[]
,
x
)
)
(* combiner les restrict field, ... *)
let
rec
dispatch_record
t
pl
=
let
pl
=
prepare_record
(
List
.
map
(
fun
p
->
p
.
record
)
pl
)
in
let
pl
=
List
.
map
(
fun
p
->
List
.
map
(
fun
(
res
,
r
)
->
(
res
,
[]
,
r
))
p
.
nrecord
)
pl
in
let
t
=
Types
.
Record
.
get
t
in
aux_record1
t
pl
if
Types
.
Record
.
is_empty
t
then
None
else
Some
(
aux_record1
t
pl
)
and
aux_record1
t
pl
=
match
collect_first_label
pl
with
...
...
@@ -523,11 +525,12 @@ struct
let
t
=
Types
.
Record
.
restrict_field
t
l
(
Types
.
neg
p
.
a
)
in
aux_record2
t
pl
l
accu
(
false
::
mask
)
success
(
i
+
1
)
rem
in
accu
let
mask
l
=
List
.
map
(
function
None
->
false
|
Some
_
->
true
)
l
let
rec
dispatch
(
t
:
Types
.
descr
)
(
pl
:
nf
list
)
=
let
pl
=
List
.
map
(
restrict
t
)
pl
in
let
fv
=
List
.
map
(
fun
p
->
p
.
v
)
pl
in
let
pl
=
List
.
map
(
fun
p
->
normal
(
restrict
t
p
))
pl
in
let
basic
=
dispatch_basic
t
pl
and
prod
=
dispatch_prod
t
pl
and
record
=
dispatch_record
t
pl
in
...
...
@@ -540,7 +543,7 @@ struct
num
0
(
SortedList
.
from_list
!
accu
)
in
{
Dispatch
.
fv
=
List
.
map
(
fun
p
->
p
.
v
)
pl
;
Dispatch
.
fv
=
fv
;
Dispatch
.
masks
=
masks
;
Dispatch
.
basic
=
basic
;
Dispatch
.
prod
=
prod
;
...
...
@@ -651,9 +654,11 @@ struct
(
no
t2
pl2
);
List
.
iter
(
case_prod2
ppf
pl2
)
cases2
and
show_record
ppf
r
=
Format
.
fprintf
ppf
" | Record r -> @
\n
"
;
Format
.
fprintf
ppf
" @[%a@]@
\n
"
show_record_aux
r
and
show_record
ppf
=
function
|
None
->
()
|
Some
r
->
Format
.
fprintf
ppf
" | Record r -> @
\n
"
;
Format
.
fprintf
ppf
" @[%a@]@
\n
"
show_record_aux
r
and
show_record_aux
ppf
=
function
|
`Result
r
->
...
...
@@ -739,3 +744,5 @@ showt " [ (1 3?)* ]" [ " [(1 (x::3)?)*] " ];;
#install_printer Types.Print.print_descr;;
let (t,[p1;p2]) = Patterns.NF.get 5;;
*)
types/sortedMap.ml
View file @
a054f94b
...
...
@@ -61,3 +61,6 @@ let rec from_sorted_list f = function
from_sorted_list
f
((
x1
,
(
f
y1
y2
))
::
q
)
|
(
x
,
y
)
::
q
->
(
x
,
y
)
::
(
from_sorted_list
f
q
)
|
l
->
l
let
from_list
f
l
=
from_sorted_list
f
(
List
.
sort
(
fun
(
a1
,
b1
)
(
a2
,
b2
)
->
compare
a1
a2
)
l
)
types/sortedMap.mli
View file @
a054f94b
...
...
@@ -16,3 +16,4 @@ val iter2:
val
from_sorted_list
:
(
'
b
->
'
b
->
'
b
)
->
(
'
a
*
'
b
)
SortedList
.
t
->
(
'
a
,
'
b
)
t
val
from_list
:
(
'
b
->
'
b
->
'
b
)
->
(
'
a
*
'
b
)
list
->
(
'
a
,
'
b
)
t
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