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
b6113d26
Commit
b6113d26
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-12-24 17:39:42 by afrisch] Empty log message
Original author: afrisch Date: 2004-12-24 17:39:42+00:00
parent
c2244da2
Changes
1
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
b6113d26
...
...
@@ -1690,10 +1690,8 @@ x=(1,2)
|
TCapt
of
TargExpr
.
t
*
t
|
TAlt
of
descr
*
Types
.
t
*
t
*
t
|
TConj
of
Types
.
t
*
fv
*
t
*
t
|
TOther
of
descr
*
Types
.
t
*
fv
*
atoms
|
TTimes
of
Types
.
pair_kind
*
int
*
descr
*
Types
.
t
*
fv
*
node
*
node
and
atoms
=
|
TRecord
of
label
*
node
|
TRecord
of
int
*
descr
*
Types
.
t
*
fv
*
label
*
node
let
capt
pr
p
=
if
IdMap
.
is_empty
pr
then
p
else
match
p
with
...
...
@@ -1732,20 +1730,16 @@ x=(1,2)
Format
.
fprintf
ppf
"(%a | %a)"
print
l
print
r
|
TConj
(
_
,_,
l
,
r
)
->
Format
.
fprintf
ppf
"(%a & %a)"
print
l
print
r
|
T
Other
(
_
,
t
,
xs
,
x
)
->
Format
.
fprintf
ppf
"<t=%a;xs=%a;
%a
>"
|
T
Record
(
_
,
_,
t
,
xs
,
l
,
q
)
->
Format
.
fprintf
ppf
"<t=%a;xs=%a;
{_}
>"
Types
.
Print
.
print
t
Print
.
print_xs
xs
print_atom
(
t
,
xs
,
x
)
|
TTimes
(
kind
,_,_,
t
,
xs
,
q1
,
q2
)
->
Format
.
fprintf
ppf
"<t=%a;xs=%a;(%a,%a)>"
Types
.
Print
.
print
t
Print
.
print_xs
xs
Print
.
print
q1
.
descr
Print
.
print
q2
.
descr
and
print_atom
ppf
(
t
,
xs
,
d
)
=
match
d
with
|
TRecord
_
->
Format
.
fprintf
ppf
"{_}"
let
get_result
=
function
|
TSucceed
->
Some
TargExpr
.
empty
...
...
@@ -1761,20 +1755,19 @@ x=(1,2)
let
uid
=
ref
0
let
rec
mk
((
a
,
fv
,
d
)
as
p
)
=
let
oth
x
=
TOther
(
p
,
Types
.
any
,
fv
,
x
)
in
match
d
with
|
Constr
t
->
TConstr
(
t
,
Types
.
any
)
|
Cup
((
a1
,_,_
)
as
p1
,
p2
)
->
TAlt
(
p
,
a1
,
mk
p1
,
mk
p2
)
|
Cap
((
a1
,
fv1
,_
)
as
p1
,
p2
)
->
TConj
(
a1
,
fv1
,
mk
p1
,
mk
p2
)
|
Capture
x
->
success
(
TargExpr
.
capture
x
)
|
Constant
(
x
,
c
)
->
success
(
TargExpr
.
cst
x
c
)
|
Times
(
q1
,
q2
)
->
TTimes
(
`Normal
,
(
incr
uid
;
!
uid
)
,
p
,
Types
.
any
,
fv
,
q1
,
q2
)
|
Xml
(
q1
,
q2
)
->
TTimes
(
`XML
,
(
incr
uid
;
!
uid
)
,
p
,
Types
.
any
,
fv
,
q1
,
q2
)
|
Record
(
l
,
q
)
->
oth
(
TRecord
(
l
,
q
))
|
Dummy
->
assert
false
let
rec
mk
((
a
,
fv
,
d
)
as
p
)
=
match
d
with
|
Constr
t
->
TConstr
(
t
,
Types
.
any
)
|
Cup
((
a1
,_,_
)
as
p1
,
p2
)
->
TAlt
(
p
,
a1
,
mk
p1
,
mk
p2
)
|
Cap
((
a1
,
fv1
,_
)
as
p1
,
p2
)
->
TConj
(
a1
,
fv1
,
mk
p1
,
mk
p2
)
|
Capture
x
->
success
(
TargExpr
.
capture
x
)
|
Constant
(
x
,
c
)
->
success
(
TargExpr
.
cst
x
c
)
|
Times
(
q1
,
q2
)
->
TTimes
(
`Normal
,
(
incr
uid
;
!
uid
)
,
p
,
Types
.
any
,
fv
,
q1
,
q2
)
|
Xml
(
q1
,
q2
)
->
TTimes
(
`XML
,
(
incr
uid
;
!
uid
)
,
p
,
Types
.
any
,
fv
,
q1
,
q2
)
|
Record
(
l
,
q
)
->
TRecord
((
incr
uid
;
!
uid
)
,
p
,
Types
.
any
,
fv
,
l
,
q
)
|
Dummy
->
assert
false
let
constr
a
t
=
if
Types
.
disjoint
a
t
then
TFail
...
...
@@ -1814,8 +1807,8 @@ x=(1,2)
|
TConstr
(
a
,_
)
->
constr
a
t
|
TTimes
(
kind
,
uid
,
p
,_,_,
q1
,
q2
)
->
factorize
p
t
xs
(
fun
xs
->
TTimes
(
kind
,
uid
,
p
,
t
,
xs
,
q1
,
q2
))
|
T
Other
(
p
,_,_,
x
)
->
factorize
p
t
xs
(
fun
xs
->
T
Other
(
p
,
t
,
xs
,
x
))
|
T
Record
(
uid
,
p
,_,_,
l
,
q
)
->
factorize
p
t
xs
(
fun
xs
->
T
Record
(
uid
,
p
,
t
,
xs
,
l
,
q
))
|
TSucceed
->
if
Types
.
is_empty
t
then
TFail
else
TSucceed
|
TFail
->
TFail
...
...
@@ -1852,19 +1845,17 @@ x=(1,2)
try
TargExpr
.
merge
r
(
find_binds
q
(
PatList
.
Map
.
get
reqs
)
binds
fetch
)
with
Not_found
->
r
let
pair
swap
l
r
=
let
(
l
,
r
)
=
swap
(
l
,
r
)
in
TargExpr
.
SrcPair
(
l
,
r
)
let
rec
set_times
k
swap
swap'
extra1
extra2
reqs1
reqs2
binds1
binds2
=
let
rec
aux
=
function
|
TTimes
(
kind
,
uid
,_,
t
,
xs
,
q1
,
q2
)
when
k
==
kind
->
let
(
q1
,
q2
)
=
swap
(
q1
,
q2
)
in
let
r1
=
find_binds
q1
reqs1
binds1
TargExpr
.
fetch_left
uid
extra1
and
r2
=
find_binds
q2
reqs2
binds2
TargExpr
.
fetch_right
uid
extra2
in
let
r
=
IdMap
.
merge
(
fun
l
r
->
let
(
l
,
r
)
=
swap'
(
l
,
r
)
in
TargExpr
.
SrcPair
(
l
,
r
))
r1
r2
in
success
(
IdMap
.
restrict
r
xs
)
|
x
->
map
aux
x
let
rec
aux
=
function
|
TTimes
(
kind
,
uid
,_,
t
,
xs
,
q1
,
q2
)
when
k
==
kind
->
let
(
q1
,
q2
)
=
swap
(
q1
,
q2
)
in
let
r1
=
find_binds
q1
reqs1
binds1
TargExpr
.
fetch_left
uid
extra1
and
r2
=
find_binds
q2
reqs2
binds2
TargExpr
.
fetch_right
uid
extra2
in
let
r
=
IdMap
.
merge
(
pair
swap'
)
r1
r2
in
success
(
IdMap
.
restrict
r
xs
)
|
x
->
map
aux
x
in
aux
...
...
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