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
a6cb749d
Commit
a6cb749d
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-12-23 18:38:55 by afrisch] Continuing compilation
Original author: afrisch Date: 2004-12-23 18:38:55+00:00
parent
2ab48a3e
Changes
1
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
a6cb749d
...
...
@@ -1676,9 +1676,8 @@ x=(1,2)
|
TAlt
of
descr
*
Types
.
t
*
t
*
t
|
TConj
of
Types
.
t
*
fv
*
t
*
t
|
TOther
of
descr
*
Types
.
t
*
fv
*
atoms
(*
| TTimes of descr * Types.t * fv * node * node
*)
|
TTimes
of
descr
*
Types
.
t
*
fv
*
node
*
node
and
atoms
=
|
TTimes
of
node
*
node
|
TXml
of
node
*
node
|
TRecord
of
label
*
node
...
...
@@ -1688,6 +1687,9 @@ x=(1,2)
|
TFail
->
TFail
|
p
->
TCapt
(
pr
,
p
)
let
success
pr
=
capt
pr
TSucceed
let
rec
conj
a1
fv1
r1
r2
=
match
(
r1
,
r2
)
with
|
TSucceed
,
r
|
r
,
TSucceed
->
r
|
TFail
,
r
|
r
,
TFail
->
TFail
...
...
@@ -1721,16 +1723,14 @@ x=(1,2)
Types
.
Print
.
print
t
Print
.
print_xs
xs
print_atom
(
t
,
xs
,
x
)
|
TTimes
(
_
,
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
|
TTimes
(
q1
,
q2
)
->
if
IdSet
.
is_empty
xs
then
Format
.
fprintf
ppf
"(%a,%a)"
Types
.
Print
.
print_node
q1
.
accept
Types
.
Print
.
print_node
q2
.
accept
else
Format
.
fprintf
ppf
"(%a,%a)"
Print
.
print
q1
.
descr
Print
.
print
q2
.
descr
|
TXml
_
->
Format
.
fprintf
ppf
"<_>_"
|
TRecord
_
->
Format
.
fprintf
ppf
"{_}"
...
...
@@ -1753,9 +1753,9 @@ x=(1,2)
|
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
->
TCapt
(
TargExpr
.
capture
x
,
TSucceed
)
|
Constant
(
x
,
c
)
->
TCapt
(
TargExpr
.
cst
x
c
,
TSucceed
)
|
Times
(
q1
,
q2
)
->
oth
(
TTimes
(
q1
,
q2
)
)
|
Capture
x
->
success
(
TargExpr
.
capture
x
)
|
Constant
(
x
,
c
)
->
success
(
TargExpr
.
cst
x
c
)
|
Times
(
q1
,
q2
)
->
TTimes
(
p
,
Types
.
any
,
fv
,
q1
,
q2
)
|
Xml
(
q1
,
q2
)
->
oth
(
TXml
(
q1
,
q2
))
|
Record
(
l
,
q
)
->
oth
(
TRecord
(
l
,
q
))
|
Dummy
->
assert
false
...
...
@@ -1791,6 +1791,8 @@ x=(1,2)
(
optimize
t
(
IdSet
.
cap
xs
fv1
)
p1
)
(
optimize
(
Types
.
cap
t
a1
)
(
IdSet
.
diff
xs
fv1
)
p2
)
|
TConstr
(
a
,_
)
->
constr
a
t
|
TTimes
(
p
,_,_,
q1
,
q2
)
->
factorize
p
t
xs
(
fun
xs
->
TTimes
(
p
,
t
,
xs
,
q1
,
q2
))
|
TOther
(
p
,_,_,
x
)
->
factorize
p
t
xs
(
fun
xs
->
TOther
(
p
,
t
,
xs
,
x
))
|
TSucceed
->
if
Types
.
is_empty
t
then
TFail
else
TSucceed
...
...
@@ -1799,20 +1801,45 @@ x=(1,2)
let
rec
fold
f
accu
=
function
|
TCapt
(
_
,
p
)
->
fold
f
accu
p
|
TAlt
(
_
,_,
p1
,
p2
)
|
TConj
(
_
,_,
p1
,
p2
)
->
fold
f
(
fold
f
accu
p1
)
p2
|
TOther
(
_
,
t
,
xs
,
x
)
->
f
accu
t
xs
x
let
fold
f
accu
=
function
|
TCapt
(
_
,
p
)
->
f
accu
p
|
TAlt
(
_
,_,
p1
,
p2
)
|
TConj
(
_
,_,
p1
,
p2
)
->
f
(
f
accu
p1
)
p2
|
_
->
accu
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
|
TCapt
(
_
,
p
)
->
collect_constr
accu
p
|
TAlt
(
_
,_,
p1
,
p2
)
|
TConj
(
_
,_,
p1
,
p2
)
->
collect_constr
(
collect_constr
accu
p1
)
p2
|
TConstr
(
t
,
s
)
->
(
t
,
s
)
::
accu
|
_
->
accu
|
p
->
fold
collect_constr
accu
p
let
collect_basic
=
collect_constr
let
rec
collect_times
accu
=
function
|
TTimes
(
_
,
t
,
xs
,
q1
,
q2
)
->
(
t
,
xs
,
q1
,
q2
)
::
accu
|
p
->
fold
collect_times
accu
p
let
rec
find_binds
q
reqs
binds
ofs
=
match
(
reqs
,
binds
)
with
|
(
p2
,_
)
::_,
Some
b
::_
when
Pat
.
equal
q
.
descr
p2
->
IdMap
.
map
(
fun
i
->
TargExpr
.
SrcFetch
(
i
+
ofs
))
b
|
_
::
reqs
,
_
::
binds
->
find_binds
q
reqs
binds
ofs
|
_
->
assert
false
let
find_binds
q
reqs
binds
=
find_binds
q
(
PatList
.
Map
.
get
reqs
)
binds
let
rec
set_times
reqs1
reqs2
binds1
binds2
ar1
=
let
rec
aux
=
function
|
TTimes
(
_
,
t
,
xs
,
q1
,
q2
)
->
let
r1
=
find_binds
q1
reqs1
binds1
0
and
r2
=
find_binds
q2
reqs2
binds2
ar1
in
let
r
=
IdMap
.
merge
(
fun
l
r
->
TargExpr
.
SrcPair
(
l
,
r
))
r1
r2
in
success
(
IdMap
.
restrict
r
xs
)
|
x
->
map
aux
x
in
aux
let
mkopt
p
t
xs
=
optimize
t
xs
(
mk
p
)
...
...
@@ -1820,19 +1847,13 @@ x=(1,2)
let
p
=
mkopt
p
t
fv
in
print
ppf
p
;
let
qs
=
collect_basic
[]
p
in
let
part
=
Types
.
cond_partition
Types
.
non_constructed
qs
in
let
t
=
Types
.
cap
t
Types
.
non_constructed
in
Format
.
fprintf
ppf
"@.Partition:@."
;
List
.
iter
(
fun
t'
->
let
t
=
Types
.
cap
t
t'
in
let
r
=
optimize
t
fv
p
in
Format
.
fprintf
ppf
"%a => %a@."
Types
.
Print
.
print
t
print
r
;
Format
.
fprintf
ppf
" => %a@."
print_result
(
get_result
r
)
)
part
let
ts
=
collect_times
[]
p
in
Format
.
fprintf
ppf
"@.First component:@."
;
List
.
iter
(
fun
(
t
,
xs
,
q1
,
q2
)
->
Format
.
fprintf
ppf
"%a / %a"
Print
.
print
q1
.
descr
Types
.
Print
.
print
(
pi1
t
)
)
ts
end
...
...
@@ -1844,15 +1865,28 @@ x=(1,2)
|
RCode
of
int
|
RSwitch
of
rescode
*
rescode
type
t
=
{
type
result
=
int
*
TargExpr
.
source
array
type
actions
=
|
AIgnore
of
result
|
AKind
of
actions_kind
and
actions_kind
=
{
basic
:
(
Types
.
t
*
result
)
list
;
prod
:
result
dispatch
dispatch
;
}
and
'
a
dispatch
=
|
Dispatch
of
dispatcher
*
'
a
array
|
TailCall
of
dispatcher
|
Ignore
of
'
a
|
Impossible
and
dispatcher
=
{
id
:
int
;
outputs
:
output
array
;
rescode
:
rescode
;
reqs
:
(
Derivation
.
t
*
Types
.
t
*
fv
)
list
;
assumpt
:
Types
.
t
;
mutable
actions
:
actions
option
;
}
type
basic_disp
=
(
Types
.
t
*
int
*
TargExpr
.
source
array
)
list
let
print
ppf
r
=
Format
.
fprintf
ppf
"Request@."
;
Array
.
iteri
...
...
@@ -1860,26 +1894,78 @@ x=(1,2)
Format
.
fprintf
ppf
"[%i] %a@."
i
Types
.
Print
.
print
t
)
r
.
outputs
let
print_result
ppf
(
code
,
a
)
=
Format
.
fprintf
ppf
"$%i("
code
;
Array
.
iter
(
fun
x
->
Format
.
fprintf
ppf
"%a;"
TargExpr
.
print_src
x
)
a
;
Format
.
fprintf
ppf
")"
let
print_basic_disp
ppf
l
=
List
.
iter
(
fun
(
t
,
code
,
a
)
->
Format
.
fprintf
ppf
"%a => $%i("
Types
.
Print
.
print
t
code
;
Array
.
iter
(
fun
x
->
Format
.
fprintf
ppf
"%a;"
TargExpr
.
print_src
x
)
a
;
Format
.
fprintf
ppf
")@."
;
(
fun
(
t
,
res
)
->
Format
.
fprintf
ppf
" | %a -> %a@."
Types
.
Print
.
print
t
print_result
res
)
l
let
print_prod2
ppf
=
function
|
Dispatch
(
d
,
branches
)
->
Format
.
fprintf
ppf
" Right(disp_%i)@
\n
"
d
.
id
;
Array
.
iteri
(
fun
code
res
->
Format
.
fprintf
ppf
" | $%i -> %a@."
code
print_result
res
)
branches
|
Ignore
res
->
Format
.
fprintf
ppf
" Ignore Right@."
;
Format
.
fprintf
ppf
" %a@."
print_result
res
|
_
->
assert
false
let
print_prod
ppf
=
function
|
Dispatch
(
d
,
branches
)
->
Format
.
fprintf
ppf
" | Pair@."
;
Format
.
fprintf
ppf
" Left(disp_%i)@."
d
.
id
;
Array
.
iteri
(
fun
code
d2
->
Format
.
fprintf
ppf
" | $%i -> %a@."
code
print_prod2
d2
)
branches
|
Ignore
d2
->
Format
.
fprintf
ppf
" | Pair@."
;
Format
.
fprintf
ppf
" Ignore Left@."
;
Format
.
fprintf
ppf
" %a@."
print_prod2
d2
|
_
->
assert
false
let
rec
print_rescode
ppf
=
function
|
RFail
->
Format
.
fprintf
ppf
"Fail"
|
RCode
i
->
Format
.
fprintf
ppf
"(%i)"
i
|
RSwitch
(
a
,
b
)
->
Format
.
fprintf
ppf
"S(%a,%a)"
print_rescode
a
print_rescode
b
let
rec
find_code
bl
rc
=
match
(
bl
,
rc
)
with
|
Some
_
::
bl
,
RSwitch
(
rc
,_
)
|
None
::
bl
,
RSwitch
(
_
,
rc
)
->
find_code
bl
rc
|
([]
,
RCode
i
)
->
i
|
_
->
assert
false
(*
let find_code bl rc =
Format.fprintf Format.std_formatter "%a@." print_rescode rc;
List.iter (fun x ->
Format.fprintf Format.std_formatter "%b "
(x != None)) bl;
Format.fprintf Format.std_formatter "@.";
find_code bl rc
*)
let
alloc
pos
fv
=
let
i
=
ref
(
pos
-
1
)
in
let
r
=
IdMap
.
map_from_slist
(
fun
x
->
incr
i
;
!
i
)
fv
in
(
r
,!
i
+
1
)
let
mk
reqs
t0
=
let
disp_id
=
ref
0
let
mk
reqs
=
let
nb
=
ref
(
-
1
)
in
let
codes
=
ref
[]
in
let
rec
aux
t0
ar
binds
l
=
...
...
@@ -1895,62 +1981,116 @@ x=(1,2)
ar
(
None
::
binds
)
rem
)
in
let
reqs
=
PatList
.
Map
.
get
reqs
in
(*
let t0 =
let
t0
=
List
.
fold_left
(
fun
accu
(
_
,
(
t
,_
))
->
Types
.
cup
accu
t
)
Types
.
empty
reqs in
*)
reqs
in
let
rc
=
aux
t0
0
[]
reqs
in
let
os
=
Array
.
of_list
(
List
.
rev
!
codes
)
in
let
ders
=
List
.
map
(
fun
(
p
,
(
t
,
xs
))
->
(
Derivation
.
mkopt
p
t
xs
,
t
,
xs
))
reqs
in
{
outputs
=
os
;
{
id
=
(
incr
disp_id
;
!
disp_id
);
outputs
=
os
;
rescode
=
rc
;
reqs
=
ders
;
assumpt
=
t0
}
assumpt
=
t0
;
actions
=
None
}
module
ReqTable
=
Hashtbl
.
Make
(
Req
)
let
disps
=
ReqTable
.
create
1023
let
mk
reqs
=
try
ReqTable
.
find
disps
reqs
with
Not_found
->
let
d
=
mk
reqs
in
ReqTable
.
add
disps
reqs
d
;
d
let
opt_all
t0
=
List
.
map
(
fun
(
p
,
t
,
xs
)
->
if
Types
.
subtype
t
t0
then
(
p
,
t
,
xs
)
else
let
t
=
Types
.
cap
t
t0
in
(
Derivation
.
optimize
t
xs
p
,
t
,
xs
))
if
Types
.
subtype
t
t0
then
(
p
,
t
,
xs
)
else
let
t
=
Types
.
cap
t
t0
in
(
Derivation
.
optimize
t
xs
p
,
t
,
xs
))
let
get_results
reqs
=
List
.
map
(
fun
(
p
,_,_
)
->
Derivation
.
get_result
p
)
reqs
let
basic_disp
r
:
basic_disp
=
let
collect_all
f
reqs
=
List
.
fold_left
(
fun
accu
(
p
,_,_
)
->
f
accu
p
)
[]
reqs
let
mk_res
r
reqs
=
let
res
=
get_results
reqs
in
let
code
=
find_code
res
r
.
rescode
in
let
(
_
,
ar
,
fill
)
=
r
.
outputs
.
(
code
)
in
let
o
=
Array
.
make
ar
(
TargExpr
.
SrcFetch
(
-
1
))
in
List
.
iter2
(
fun
res
fill
->
match
(
res
,
fill
)
with
|
Some
res
,
Some
fill
->
IdMap
.
collide
(
fun
i
r
->
o
.
(
i
)
<-
r
)
fill
res
|
None
,
None
->
()
|
_
->
assert
false
)
res
fill
;
(
code
,
o
)
let
basic_disp
r
=
let
t0
=
Types
.
cap
r
.
assumpt
Types
.
non_constructed
in
if
Types
.
is_empty
t0
then
[]
else
let
reqs
=
opt_all
t0
r
.
reqs
in
let
qs
=
collect_all
Derivation
.
collect_constr
reqs
in
let
part
=
Types
.
cond_partition
t0
qs
in
List
.
map
(
fun
t
->
(
t
,
mk_res
r
(
opt_all
t
reqs
)))
part
let
prod_types
pi
sel
accu
reqs
=
let
aux2
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
aux
accu
(
t
,
s
)
=
List
.
fold_left
(
aux2
(
pi
s
))
accu
(
Types
.
Product
.
get
t
)
in
List
.
fold_left
aux
accu
(
collect_all
Derivation
.
collect_constr
reqs
)
let
prod_pat
pi
selq
reqs
=
let
aux
accu
(
t
,
xs
,
q1
,
q2
)
=
let
q
=
selq
(
q1
,
q2
)
in
add_req
accu
q
.
descr
(
pi
t
)
(
IdSet
.
cap
xs
q
.
fv
)
in
List
.
fold_left
aux
empty_reqs
(
collect_all
Derivation
.
collect_times
reqs
)
let
prod_all
pi
sel
selq
reqs
=
prod_types
pi
sel
(
prod_pat
pi
selq
reqs
)
reqs
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
)
let
times_disp
r
=
let
t0
=
Types
.
cap
r
.
assumpt
Types
.
Product
.
any
in
let
reqs
=
opt_all
t0
r
.
reqs
in
let
qs
=
List
.
fold_left
(
fun
accu
(
p
,_,_
)
->
Derivation
.
collect_basic
accu
p
)
[]
reqs
in
let
part
=
Types
.
cond_partition
t0
qs
in
List
.
map
(
fun
t
->
let
reqs
=
opt_all
t
reqs
in
let
res
=
get_results
reqs
in
let
code
=
find_code
res
r
.
rescode
in
let
(
_
,
ar
,
fill
)
=
r
.
outputs
.
(
code
)
in
let
o
=
Array
.
make
ar
(
TargExpr
.
SrcFetch
(
-
1
))
in
List
.
iter2
(
fun
res
fill
->
match
(
res
,
fill
)
with
|
Some
res
,
Some
fill
->
IdMap
.
iteri
(
fun
x
i
->
o
.
(
i
)
<-
IdMap
.
assoc
x
res
)
fill
|
None
,
None
->
()
|
_
->
assert
false
)
res
fill
;
(
t
,
code
,
o
)
)
part
let
reqs1
=
prod_all
pi1
fst
fst
reqs
in
let
second
(
t1
,
ar1
,
binds1
)
=
let
t0
=
Types
.
cap
t0
(
Types
.
times
(
Types
.
cons
t1
)
Types
.
any_node
)
in
let
reqs
=
opt_all
t0
reqs
in
let
reqs2
=
prod_all
pi2
snd
snd
reqs
in
let
final
(
t2
,
ar2
,
binds2
)
=
let
t0
=
Types
.
cap
t0
(
Types
.
times
Types
.
any_node
(
Types
.
cons
t2
))
in
let
reqs
=
opt_all
t0
reqs
in
let
aux
=
Derivation
.
set_times
reqs1
reqs2
binds1
binds2
ar1
in
let
reqs
=
List
.
map
(
fun
(
p
,
t
,
xs
)
->
(
aux
p
,
t
,
xs
))
reqs
in
mk_res
r
reqs
in
call_disp
reqs2
final
in
call_disp
reqs1
second
let
demo
ppf
t
pl
=
let
(
reqs
,_
)
=
List
.
fold_left
(
fun
(
reqs
,
t
)
((
a
,
fv
,_
)
as
p
)
->
(
add_req
reqs
p
t
fv
,
Types
.
diff
t
a
))
(
empty_reqs
,
t
)
pl
in
let
r
=
mk
reqs
t
in
let
r
=
mk
reqs
in
print
ppf
r
;
print_basic_disp
ppf
(
basic_disp
r
)
print_basic_disp
ppf
(
basic_disp
r
);
print_prod
ppf
(
times_disp
r
)
end
...
...
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