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
2c52fed9
Commit
2c52fed9
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-12-25 05:09:22 by afrisch] Records
Original author: afrisch Date: 2004-12-25 05:09:22+00:00
parent
f44e60be
Changes
3
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
2c52fed9
...
...
@@ -1657,6 +1657,9 @@ x=(1,2)
|
SrcPair
of
source
*
source
|
SrcFetchLeft
of
int
|
SrcFetchRight
of
int
|
SrcLocal
of
int
type
push
=
PushConst
of
Types
.
const
|
PushField
|
PushCapture
let
capture
x
=
IdMap
.
singleton
x
SrcCapture
let
captures
xs
=
IdMap
.
constant
SrcCapture
xs
...
...
@@ -1664,6 +1667,7 @@ x=(1,2)
let
constants
cs
=
IdMap
.
map
(
fun
c
->
SrcCst
c
)
cs
let
fetch_left
f
=
SrcFetchLeft
f
let
fetch_right
f
=
SrcFetchRight
f
let
fetch_local
ofs
i
=
SrcLocal
(
ofs
+
i
)
let
empty
=
IdMap
.
empty
let
merge
e1
e2
=
IdMap
.
merge
(
fun
s1
s2
->
SrcPair
(
s1
,
s2
))
e1
e2
let
captures_left
xs
=
IdMap
.
constant
SrcLeft
xs
...
...
@@ -1678,6 +1682,7 @@ x=(1,2)
Format
.
fprintf
ppf
"(%a,%a)"
print_src
s1
print_src
s2
|
SrcFetchLeft
x
->
Format
.
fprintf
ppf
"x%i"
x
|
SrcFetchRight
x
->
Format
.
fprintf
ppf
"y%i"
x
|
SrcLocal
x
->
Format
.
fprintf
ppf
"local(%i)"
x
let
print
ppf
r
=
Format
.
fprintf
ppf
"{ "
;
...
...
@@ -1699,6 +1704,28 @@ x=(1,2)
|
TTimes
of
Types
.
pair_kind
*
int
*
descr
*
Types
.
t
*
fv
*
node
*
node
|
TRecord
of
int
*
descr
*
Types
.
t
*
fv
*
label
*
node
(* TODO: allocate the stack locations by sorting the ids
(to allow ({ l = (x,y) } | (x:=1)&(y:=2))) *)
let
push_csts
pushes
locals
=
let
push
x
=
pushes
:=
x
::
!
pushes
;
let
loc
=
TargExpr
.
SrcLocal
!
locals
in
incr
locals
;
loc
in
let
reloc
=
function
|
TargExpr
.
SrcCst
c
->
push
(
TargExpr
.
PushConst
c
)
|
TargExpr
.
SrcLeft
->
push
TargExpr
.
PushField
|
TargExpr
.
SrcCapture
->
push
TargExpr
.
PushCapture
|
TargExpr
.
SrcLocal
_
as
s
->
s
|
_
->
assert
false
in
let
rec
aux
=
function
|
TCapt
(
pr
,
p
)
->
TCapt
(
IdMap
.
map
reloc
pr
,
p
)
|
TAlt
(
p
,
a1
,
p1
,
p2
)
->
TAlt
(
p
,
a1
,
aux
p1
,
aux
p2
)
|
TConj
(
a1
,
fv1
,
p1
,
p2
)
->
TConj
(
a1
,
fv1
,
aux
p1
,
aux
p2
)
|
p
->
p
in
aux
let
capt
pr
p
=
if
IdMap
.
is_empty
pr
then
p
else
match
p
with
|
TCapt
(
pr2
,
p
)
->
TCapt
(
TargExpr
.
merge
pr
pr2
,
p
)
...
...
@@ -1782,17 +1809,24 @@ x=(1,2)
else
if
Types
.
subtype
t
a
then
TSucceed
else
TConstr
(
a
,
t
)
let
factorize
((
a
,_,_
)
as
p
)
t
xs
f
=
if
Types
.
disjoint
a
t
then
TFail
else
let
vs
=
Approx
.
approx_var
p
t
xs
in
let
xs
=
IdSet
.
diff
xs
vs
in
let
pr
=
TargExpr
.
captures
vs
in
let
approx_var
p
t
xs
f
=
let
vs
=
Approx
.
approx_var
p
t
xs
in
let
xs
=
IdSet
.
diff
xs
vs
in
let
pr
=
f
vs
in
(
pr
,
xs
)
let
vs
=
Approx
.
approx_cst
p
t
xs
in
let
xs
=
IdSet
.
diff
xs
(
IdMap
.
domain
vs
)
in
let
pr
=
TargExpr
.
merge
(
TargExpr
.
constants
vs
)
pr
in
let
approx_cst
p
t
xs
f
=
let
vs
=
Approx
.
approx_cst
p
t
xs
in
let
xs
=
IdSet
.
diff
xs
(
IdMap
.
domain
vs
)
in
let
pr
=
f
vs
in
(
pr
,
xs
)
let
factorize
((
a
,_,_
)
as
p
)
t
xs
f
=
if
Types
.
disjoint
a
t
then
TFail
else
let
pr
,
xs
=
approx_var
p
t
xs
TargExpr
.
captures
in
let
pr'
,
xs
=
approx_cst
p
t
xs
TargExpr
.
constants
in
let
pr
=
TargExpr
.
merge
pr
pr'
in
capt
pr
(
if
(
IdSet
.
is_empty
xs
)
then
constrain
a
t
else
f
xs
)
...
...
@@ -1827,24 +1861,41 @@ x=(1,2)
|
TCapt
(
_
,
p
)
->
f
accu
p
|
TAlt
(
_
,_,
p1
,
p2
)
|
TConj
(
_
,_,
p1
,
p2
)
->
f
(
f
accu
p1
)
p2
|
_
->
accu
let
iter
f
=
function
|
TCapt
(
_
,
p
)
->
f
p
|
TAlt
(
_
,_,
p1
,
p2
)
|
TConj
(
_
,_,
p1
,
p2
)
->
f
p1
;
f
p2
|
_
->
()
let
map
f
=
function
|
TCapt
(
pr
,
p
)
->
capt
pr
(
f
p
)
|
TAlt
(
p
,
a1
,
p1
,
p2
)
->
alt
p
a1
(
f
p1
)
(
f
p2
)
|
TConj
(
a1
,
fv1
,
p1
,
p2
)
->
conj
a1
fv1
(
f
p1
)
(
f
p2
)
|
x
->
x
let
rec
collect_constr
accu
=
function
|
TConstr
(
t
,
s
)
->
(
t
,
s
)
::
accu
|
p
->
fold
collect_constr
accu
p
let
iter_constr
f
=
let
rec
aux
=
function
|
TConstr
(
t
,
s
)
->
f
(
t
,
s
)
|
p
->
iter
aux
p
in
aux
let
rec
collect_times
k
accu
=
function
|
TTimes
(
kind
,
uid
,_,
t
,
xs
,
q1
,
q2
)
when
k
==
kind
->
(
uid
,
t
,
xs
,
q1
,
q2
)
::
accu
|
p
->
fold
(
collect_times
k
)
accu
p
let
iter_times
k
f
=
let
rec
aux
=
function
|
TTimes
(
kind
,
uid
,_,
t
,
xs
,
q1
,
q2
)
when
k
==
kind
->
f
(
uid
,
t
,
xs
,
q1
,
q2
)
|
p
->
iter
aux
p
in
aux
let
rec
collect_record
accu
=
function
|
TRecord
(
uid
,_,
t
,
xs
,
l
,
q
)
->
(
uid
,
t
,
xs
,
l
,
q
)
::
accu
|
p
->
fold
collect_record
accu
p
let
iter_records
f
=
let
rec
aux
=
function
|
TRecord
(
uid
,_,
t
,
xs
,
l
,
q
)
->
f
(
uid
,
t
,
xs
,
l
,
q
)
|
p
->
iter
aux
p
in
aux
let
iter_field
l
f
=
let
rec
aux
=
function
|
TRecord
(
uid
,_,
t
,
xs
,
l'
,
q
)
when
l
==
l'
->
f
(
uid
,
t
,
xs
,
q
)
|
p
->
iter
aux
p
in
aux
let
opt_all
t0
=
List
.
map
...
...
@@ -1855,49 +1906,55 @@ x=(1,2)
let
get_results
reqs
=
List
.
map
(
fun
(
p
,_,_
)
->
get_result
p
)
reqs
let
collect
_all
f
reqs
=
List
.
fold_left
(
fun
accu
(
p
,_,_
)
->
f
accu
p
)
[]
reqs
let
iter
_all
f
g
reqs
=
List
.
iter
(
fun
(
p
,_,_
)
->
f
g
p
)
reqs
let
prod
_all
k
side
pi
sel
selq
reqs
=
let
get
_all
pi
get
sel
extract
iter
side
reqs
=
let
extra
=
ref
[]
in
let
aux3
s1
accu
t12
=
let
res
=
ref
empty_reqs
in
let
aux3
s1
t12
=
let
t1
=
sel
t12
in
if
(
Types
.
subtype
s1
t1
)
||
(
Types
.
disjoint
s1
t1
)
then
accu
else
add_req
accu
(
constr
t1
)
s1
IdSet
.
empty
in
let
aux2
accu
(
t
,
s
)
=
List
.
fold_left
(
aux3
(
pi
s
))
accu
(
Types
.
Product
.
get
~
kind
:
k
t
)
in
let
aux
accu
(
uid
,
t
,
xs
,
q1
,
q2
)
=
let
q
=
selq
(
q1
,
q2
)
in
let
xs
=
IdSet
.
cap
xs
q
.
fv
in
let
p
=
q
.
descr
in
let
t
=
pi
t
in
let
vs
=
Approx
.
approx_var
p
t
xs
in
let
xs
=
IdSet
.
diff
xs
vs
in
let
pr
=
side
vs
in
if
not
((
Types
.
subtype
s1
t1
)
||
(
Types
.
disjoint
s1
t1
))
then
res
:=
add_req
!
res
(
constr
t1
)
s1
IdSet
.
empty
in
let
aux2
(
t
,
s
)
=
List
.
iter
(
aux3
(
pi
s
))
(
get
t
)
in
let
aux
z
=
let
uid
,
t
,
xs
,
q
=
extract
z
in
let
xs
=
IdSet
.
cap
xs
q
.
fv
and
p
=
q
.
descr
and
t
=
pi
t
in
let
pr
,
xs
=
approx_var
p
t
xs
side
in
extra
:=
(
uid
,
pr
)
::!
extra
;
if
not
((
IdSet
.
is_empty
xs
)
&&
(
Types
.
subtype
t
(
Types
.
descr
q
.
accept
)))
then
res
:=
add_req
!
res
p
t
xs
in
iter_all
iter
aux
reqs
;
iter_all
iter_constr
aux2
reqs
;
!
extra
,!
res
let
prod_all
k
side
pi
sel
selq
reqs
=
get_all
pi
(
Types
.
Product
.
get
~
kind
:
k
)
sel
(
fun
(
uid
,
t
,
xs
,
q1
,
q2
)
->
uid
,
t
,
xs
,
selq
(
q1
,
q2
))
(
iter_times
k
)
side
reqs
let
all_labels
reqs
=
let
res
=
ref
LabelSet
.
empty
in
let
aux2
(
t
,_
)
=
res
:=
LabelSet
.
cup
!
res
(
Types
.
Record
.
all_labels
t
)
in
let
aux
(
_
,_,_,
l
,_
)
=
res
:=
LabelSet
.
add
l
!
res
in
iter_all
iter_records
aux
reqs
;
iter_all
iter_constr
aux2
reqs
;
LabelSet
.
get
!
res
let
record_all
l
reqs
=
let
extra
,
res
=
get_all
(
Types
.
Record
.
pi
l
)
(
fun
t
->
Types
.
Record
.
split
t
l
)
fst
(
fun
z
->
z
)
(
iter_field
l
)
TargExpr
.
captures_left
reqs
in
extra
,
res
if
(
IdSet
.
is_empty
xs
)
&&
(
Types
.
subtype
t
(
Types
.
descr
q
.
accept
))
then
accu
else
add_req
accu
p
t
xs
in
let
accu
=
List
.
fold_left
aux
empty_reqs
(
collect_all
(
collect_times
k
)
reqs
)
in
let
accu
=
List
.
fold_left
aux2
accu
(
collect_all
collect_constr
reqs
)
in
!
extra
,
accu
let
first_label
reqs
=
let
min
=
ref
LabelPool
.
dummy_max
in
let
f
l
=
if
l
<
!
min
then
min
:=
l
in
let
aux2
(
t
,_
)
=
f
(
Types
.
Record
.
first_label
t
)
in
let
aux
(
_
,_,_,
l
,_
)
=
f
l
in
List
.
iter
aux
(
collect_all
collect_record
reqs
);
List
.
iter
aux2
(
collect_all
collect_constr
reqs
);
!
min
let
rec
find_binds
q
reqs
binds
fetch
=
let
rec
find_binds
q
reqs
binds
fetch
=
match
(
reqs
,
binds
)
with
|
(
p2
,_
)
::_,
Some
b
::_
when
Pat
.
equal
q
.
descr
p2
->
IdMap
.
map
fetch
b
...
...
@@ -1922,6 +1979,18 @@ x=(1,2)
in
aux
let
rec
set_field
l
locals
extra1
reqs1
binds1
=
let
rec
aux
=
function
|
TRecord
(
uid
,_,
t
,
xs
,
l'
,
q
)
when
l
==
l'
->
let
r
=
find_binds
q
reqs1
binds1
(
TargExpr
.
fetch_local
locals
)
uid
extra1
in
success
(
IdMap
.
restrict
r
xs
)
|
x
->
map
aux
x
in
aux
let
mkopt
p
t
xs
=
optimize
t
xs
(
mk
p
)
let
demo
ppf
((
_
,
fv
,_
)
as
p
)
t
=
...
...
@@ -1929,14 +1998,14 @@ x=(1,2)
(* Format.fprintf ppf "%a@." print p; *)
let
p
=
optimize
t
fv
p
in
Format
.
fprintf
ppf
"%a@."
print
p
;
let
ts
=
collect_record
[]
p
in
Format
.
fprintf
ppf
"@.Fields:@."
;
List
.
iter
(
fun
(
_
,
t
,
xs
,
l
,
q
)
->
Format
.
fprintf
ppf
"(%a=%a) / %a@."
print_lab
l
Print
.
print
q
.
descr
Types
.
Print
.
print
(
Types
.
Record
.
project_opt
t
l
)
)
ts
iter_records
(
fun
(
_
,
t
,
xs
,
l
,
q
)
->
Format
.
fprintf
ppf
"(%a=%a) / %a@."
print_lab
l
Print
.
print
q
.
descr
Types
.
Print
.
print
(
Types
.
Record
.
project_opt
t
l
)
)
p
end
...
...
@@ -1956,8 +2025,14 @@ x=(1,2)
basic
:
(
Types
.
t
*
result
)
list
;
prod
:
actions_prod
;
xml
:
actions_prod
;
record
:
label
;
record
:
actions_record
;
}
and
actions_record
=
|
RecordLabel
of
label
*
dispatcher
*
record_tr
array
|
RecordLabelSkip
of
label
*
record_tr
|
RecordNolabel
of
result
|
RecordImpossible
and
record_tr
=
(
TargExpr
.
push
list
*
actions_record
)
and
actions_prod
=
|
LeftRight
of
result
dispatch
dispatch
|
RightLeft
of
result
dispatch
dispatch
...
...
@@ -2076,8 +2151,36 @@ x=(1,2)
|
Impossible
->
()
let
print_record
ppf
l
=
Format
.
fprintf
ppf
"First label = %a@."
print_lab
l
let
print_pushes
ppf
l
=
List
.
iter
(
function
|
TargExpr
.
PushConst
c
->
Format
.
fprintf
ppf
"{push %a}"
Types
.
Print
.
print_const
c
|
TargExpr
.
PushField
->
Format
.
fprintf
ppf
"{push field}"
|
TargExpr
.
PushCapture
->
Format
.
fprintf
ppf
"{push record}"
)
l
let
rec
print_field
ppf
=
function
|
RecordImpossible
->
()
|
RecordLabel
(
l
,
d
,
cts
)
->
to_print
d
;
Format
.
fprintf
ppf
"(label:%a,disp_%i"
print_lab
l
d
.
id
;
Array
.
iteri
(
fun
i
(
pushes
,
x
)
->
Format
.
fprintf
ppf
";%i->%a%a"
i
print_pushes
pushes
print_field
x
)
cts
;
Format
.
fprintf
ppf
")"
|
RecordLabelSkip
(
l
,
(
pushes
,
cts
))
->
Format
.
fprintf
ppf
"(label:%a;%a%a)"
print_lab
l
print_pushes
pushes
print_field
cts
|
RecordNolabel
res
->
Format
.
fprintf
ppf
"[%a]"
print_result
res
let
print_record
ppf
r
=
Format
.
fprintf
ppf
"Record:%a@."
print_field
r
let
rec
print_rescode
ppf
=
function
|
RFail
->
Format
.
fprintf
ppf
"Fail"
...
...
@@ -2193,41 +2296,12 @@ x=(1,2)
if
Types
.
is_empty
t0
then
[]
else
let
reqs
=
Derivation
.
opt_all
t0
r
.
reqs
in
let
qs
=
Derivation
.
collect_all
Derivation
.
collect_constr
reqs
in
let
part
=
Types
.
cond_partition
t0
qs
in
let
qs
=
ref
[]
in
let
aux
x
=
qs
:=
x
::!
qs
in
Derivation
.
iter_all
Derivation
.
iter_constr
aux
reqs
;
let
part
=
Types
.
cond_partition
t0
!
qs
in
List
.
map
(
fun
t
->
(
t
,
mk_res
t
r
(
Derivation
.
opt_all
t
reqs
)))
part
let
prod_all
k
side
pi
sel
selq
reqs
=
let
extra
=
ref
[]
in
let
aux3
s1
accu
t12
=
let
t1
=
sel
t12
in
if
(
Types
.
subtype
s1
t1
)
||
(
Types
.
disjoint
s1
t1
)
then
accu
else
add_req
accu
(
constr
t1
)
s1
IdSet
.
empty
in
let
aux2
accu
(
t
,
s
)
=
List
.
fold_left
(
aux3
(
pi
s
))
accu
(
Types
.
Product
.
get
~
kind
:
k
t
)
in
let
aux
accu
(
uid
,
t
,
xs
,
q1
,
q2
)
=
let
q
=
selq
(
q1
,
q2
)
in
let
xs
=
IdSet
.
cap
xs
q
.
fv
in
let
p
=
q
.
descr
in
let
t
=
pi
t
in
let
vs
=
Approx
.
approx_var
p
t
xs
in
let
xs
=
IdSet
.
diff
xs
vs
in
let
pr
=
side
vs
in
extra
:=
(
uid
,
pr
)
::!
extra
;
if
(
IdSet
.
is_empty
xs
)
&&
(
Types
.
subtype
t
(
Types
.
descr
q
.
accept
))
then
accu
else
add_req
accu
p
t
xs
in
let
accu
=
List
.
fold_left
aux
empty_reqs
(
Derivation
.
collect_all
(
Derivation
.
collect_times
k
)
reqs
)
in
let
accu
=
List
.
fold_left
aux2
accu
(
Derivation
.
collect_all
Derivation
.
collect_constr
reqs
)
in
!
extra
,
accu
let
call_disp
reqs
f
=
if
PatList
.
Map
.
is_empty
reqs
then
Ignore
(
f
(
Types
.
any
,
0
,
[]
))
else
let
d
=
mk
reqs
in
Dispatch
(
d
,
Array
.
map
f
d
.
outputs
)
...
...
@@ -2267,24 +2341,32 @@ x=(1,2)
let
swap
(
x
,
y
)
=
(
y
,
x
)
let
noswap
(
x
,
y
)
=
(
x
,
y
)
let
times_disp
direction
k
r
=
let
c
=
match
k
with
`XML
->
Types
.
xml
|
`Normal
->
Types
.
times
in
let
pi1
,
pi2
,
fst
,
fst'
,
snd
,
snd'
,
restr1
,
restr2
,
swap
,
swap'
=
match
direction
with
|
`LeftRight
->
pi1
~
kind
:
k
,
pi2
~
kind
:
k
,
fst
,
fst
,
snd
,
snd
,
restr1
c
,
restr2
c
,
noswap
,
noswap
|
`RightLeft
->
pi2
~
kind
:
k
,
pi1
~
kind
:
k
,
snd
,
snd
,
fst
,
fst
,
restr2
c
,
restr1
c
,
swap
,
swap
in
|
`LeftRight
->
pi1
~
kind
:
k
,
pi2
~
kind
:
k
,
fst
,
fst
,
snd
,
snd
,
restr1
c
,
restr2
c
,
noswap
,
noswap
|
`RightLeft
->
pi2
~
kind
:
k
,
pi1
~
kind
:
k
,
snd
,
snd
,
fst
,
fst
,
restr2
c
,
restr1
c
,
swap
,
swap
in
let
t0
=
Types
.
cap
r
.
assumpt
(
Types
.
Product
.
any_of
k
)
in
if
Types
.
is_empty
t0
then
Impossible
else
let
reqs
=
Derivation
.
opt_all
t0
r
.
reqs
in
let
extra1
,
reqs1
=
prod_all
k
TargExpr
.
captures_left
pi1
fst
fst'
reqs
in
let
extra1
,
reqs1
=
Derivation
.
prod_all
k
TargExpr
.
captures_left
pi1
fst
fst'
reqs
in
let
second
(
t1
,
ar1
,
binds1
)
=
let
t0
=
restr1
t0
t1
in
let
reqs
=
Derivation
.
opt_all
t0
reqs
in
let
extra2
,
reqs2
=
prod_all
k
TargExpr
.
captures_right
pi2
snd
snd'
reqs
in
let
extra2
,
reqs2
=
Derivation
.
prod_all
k
TargExpr
.
captures_right
pi2
snd
snd'
reqs
in
let
final
(
t2
,
ar2
,
binds2
)
=
let
t0
=
restr2
t0
t2
in
let
reqs
=
Derivation
.
opt_all
t0
reqs
in
let
aux
=
Derivation
.
set_times
k
swap
swap'
extra1
extra2
reqs1
reqs2
binds1
binds2
in
let
aux
=
Derivation
.
set_times
k
swap
swap'
extra1
extra2
reqs1
reqs2
binds1
binds2
in
let
reqs
=
List
.
map
(
fun
(
p
,
t
,
xs
)
->
(
aux
p
,
t
,
xs
))
reqs
in
mk_res
t0
r
reqs
in
opt_tail_call2
(
call_disp
reqs2
final
)
in
...
...
@@ -2295,8 +2377,38 @@ x=(1,2)
let
record_disp
r
=
let
t0
=
Types
.
cap
r
.
assumpt
Types
.
Record
.
any
in
if
Types
.
is_empty
t0
then
RecordImpossible
else
let
reqs
=
Derivation
.
opt_all
t0
r
.
reqs
in
Derivation
.
first_label
reqs
let
labs
=
Derivation
.
all_labels
reqs
in
(* TODO: memoize the field function *)
let
rec
field
t0
reqs
locals
=
function
|
[]
->
(* TODO: distinguish between More / No more fields *)
RecordNolabel
(
mk_res
t0
r
reqs
)
|
l
::
labs
->
let
extra1
,
reqs1
=
Derivation
.
record_all
l
reqs
in
let
contin
(
t1
,
ar1
,
binds1
)
=
let
t0
=
Types
.
cap
t0
(
Types
.
record
l
(
Types
.
cons
t1
))
in
let
reqs
=
Derivation
.
opt_all
t0
reqs
in
let
aux
=
Derivation
.
set_field
l
locals
extra1
reqs1
binds1
in
let
reqs
=
List
.
map
(
fun
(
p
,
t
,
xs
)
->
(
aux
p
,
t
,
xs
))
reqs
in
let
locals
=
ref
(
locals
+
ar1
)
in
let
pushes
=
ref
[]
in
let
aux
=
Derivation
.
push_csts
pushes
locals
in
let
reqs
=
List
.
map
(
fun
(
p
,
t
,
xs
)
->
(
aux
p
,
t
,
xs
))
reqs
in
(
List
.
rev
!
pushes
,
field
t0
reqs
!
locals
labs
)
in
if
PatList
.
Map
.
is_empty
reqs1
then
match
contin
(
Types
.
any
,
0
,
[]
)
with
|
[]
,
c
->
c
|
x
->
RecordLabelSkip
(
l
,
x
)
else
let
d
=
mk
reqs1
in
RecordLabel
(
l
,
d
,
Array
.
map
contin
d
.
outputs
)
in
field
t0
reqs
0
labs
let
print_disp
ppf
r
=
match
r
.
actions
with
...
...
types/types.ml
View file @
2c52fed9
...
...
@@ -1176,13 +1176,15 @@ struct
TR
.
boolean_normal
(
aux_split
d
l
)
let
pi
l
d
=
TR
.
pi1
(
split
d
l
)
let
project
d
l
=
let
t
=
TR
.
pi1
(
split
d
l
)
in
let
t
=
pi
l
d
in
if
t
.
absent
then
raise
Not_found
;
t
let
project_opt
d
l
=
let
t
=
TR
.
pi1
(
split
d
l
)
in
let
t
=
pi
l
d
in
{
t
with
hash
=
0
;
absent
=
false
}
let
condition
d
l
t
=
...
...
@@ -1194,6 +1196,14 @@ struct
let
remove_field
d
l
=
cap
(
TR
.
pi2
(
split
d
l
))
(
record
l
only_absent_node
)
let
all_labels
d
=
let
res
=
ref
LabelSet
.
empty
in
let
aux
(
_
,
r
)
=
let
ls
=
LabelMap
.
domain
r
in
res
:=
LabelSet
.
cup
ls
!
res
in
BoolRec
.
iter
aux
d
.
record
;
!
res
let
first_label
d
=
let
min
=
ref
LabelPool
.
dummy_max
in
let
aux
(
_
,
r
)
=
...
...
types/types.mli
View file @
2c52fed9
...
...
@@ -169,6 +169,9 @@ module Record : sig
val
split
:
t
->
label
->
Product
.
t
val
split_normal
:
t
->
label
->
Product
.
normal
val
pi
:
label
->
t
->
t
(* May contain absent *)
val
project
:
t
->
label
->
t
(* Raise Not_found if label is not necessarily present *)
...
...
@@ -179,6 +182,7 @@ module Record : sig
val
first_label
:
t
->
label
val
all_labels
:
t
->
LabelSet
.
t
val
empty_cases
:
t
->
bool
*
bool
...
...
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