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
08e0fe01
Commit
08e0fe01
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-12-23 21:26:54 by afrisch] Empty log message
Original author: afrisch Date: 2004-12-23 21:26:54+00:00
parent
a6cb749d
Changes
1
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
08e0fe01
...
...
@@ -1633,7 +1633,8 @@ x=(1,2)
else
accu
in
IdMap
.
from_list_disj
(
List
.
fold_left
aux
[]
(
filter_descr
t
p
))
let
approx_var
((
a
,_,_
)
as
p
)
t
=
approx_var
NodeSet
.
empty
p
(
Types
.
cap
t
a
)
let
approx_var
((
a
,_,_
)
as
p
)
t
=
approx_var
NodeSet
.
empty
p
(
Types
.
cap
t
a
)
end
module
TargExpr
=
struct
...
...
@@ -1647,6 +1648,7 @@ x=(1,2)
let
capture
x
=
IdMap
.
singleton
x
SrcCapture
let
captures
xs
=
IdMap
.
constant
SrcCapture
xs
let
cst
x
c
=
IdMap
.
singleton
x
(
SrcCst
c
)
let
constants
cs
=
IdMap
.
map
(
fun
c
->
SrcCst
c
)
cs
let
fetch
x
f
=
IdMap
.
singleton
x
(
SrcFetch
f
)
let
empty
=
IdMap
.
empty
let
merge
e1
e2
=
IdMap
.
merge
(
fun
s1
s2
->
SrcPair
(
s1
,
s2
))
e1
e2
...
...
@@ -1771,6 +1773,11 @@ x=(1,2)
let
vs
=
Approx
.
approx_var
p
t
xs
in
let
xs
=
IdSet
.
diff
xs
vs
in
let
pr
=
TargExpr
.
captures
vs
in
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
capt
pr
(
if
(
IdSet
.
is_empty
xs
)
then
constr
a
t
else
f
xs
)
...
...
@@ -1825,16 +1832,17 @@ x=(1,2)
|
(
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
|
_
->
raise
Not_found
let
find_binds
q
reqs
binds
ofs
=
try
find_binds
q
(
PatList
.
Map
.
get
reqs
)
binds
ofs
with
Not_found
->
IdMap
.
empty
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
and
r2
=
find_binds
q2
reqs2
binds2
100
(* 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
...
...
@@ -1865,7 +1873,7 @@ x=(1,2)
|
RCode
of
int
|
RSwitch
of
rescode
*
rescode
type
result
=
int
*
TargExpr
.
source
array
type
result
=
int
*
TargExpr
.
source
array
type
actions
=
|
AIgnore
of
result
|
AKind
of
actions_kind
...
...
@@ -1887,12 +1895,33 @@ x=(1,2)
mutable
actions
:
actions
option
;
}
let
print_queue
=
Queue
.
create
()
let
to_print
d
=
Queue
.
push
d
print_queue
let
print_binds
ppf
binds
=
List
.
iter
(
function
|
None
->
Format
.
fprintf
ppf
"* "
|
Some
m
->
Format
.
fprintf
ppf
"( "
;
IdMap
.
iteri
(
fun
x
i
->
Format
.
fprintf
Format
.
std_formatter
"%a:%i "
Ident
.
print
x
i
)
m
;
Format
.
fprintf
ppf
") "
;)
binds
let
print
ppf
r
=
Format
.
fprintf
ppf
"
Request@."
;
Format
.
fprintf
ppf
"
disp_%i:@."
r
.
id
;
Array
.
iteri
(
fun
i
(
t
,
ar
,_
)
->
Format
.
fprintf
ppf
"[%i] %a@."
i
Types
.
Print
.
print
t
)
r
.
outputs
(
fun
i
(
t
,
ar
,
binds
)
->
Format
.
fprintf
ppf
"[%i]{%i}{%a} %a@."
i
ar
print_binds
binds
Types
.
Print
.
print
t
)
r
.
outputs
;
List
.
iter
(
fun
(
p
,
t
,
xs
)
->
Format
.
fprintf
ppf
"%a. t=%a. xs=%a@."
Derivation
.
print
p
Types
.
Print
.
print
t
Print
.
print_xs
xs
)
r
.
reqs
let
print_result
ppf
(
code
,
a
)
=
Format
.
fprintf
ppf
"$%i("
code
;
...
...
@@ -1910,6 +1939,7 @@ x=(1,2)
let
print_prod2
ppf
=
function
|
Dispatch
(
d
,
branches
)
->
to_print
d
;
Format
.
fprintf
ppf
" Right(disp_%i)@
\n
"
d
.
id
;
Array
.
iteri
(
fun
code
res
->
...
...
@@ -1925,6 +1955,7 @@ x=(1,2)
let
print_prod
ppf
=
function
|
Dispatch
(
d
,
branches
)
->
to_print
d
;
Format
.
fprintf
ppf
" | Pair@."
;
Format
.
fprintf
ppf
" Left(disp_%i)@."
d
.
id
;
Array
.
iteri
...
...
@@ -1937,6 +1968,8 @@ x=(1,2)
Format
.
fprintf
ppf
" | Pair@."
;
Format
.
fprintf
ppf
" Ignore Left@."
;
Format
.
fprintf
ppf
" %a@."
print_prod2
d2
|
Impossible
->
()
|
_
->
assert
false
let
rec
print_rescode
ppf
=
function
...
...
@@ -1948,7 +1981,8 @@ x=(1,2)
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
|
_
->
(
-
1
)
(* assert false *)
(*
let find_code bl rc =
Format.fprintf Format.std_formatter "%a@." print_rescode rc;
...
...
@@ -1959,6 +1993,15 @@ x=(1,2)
find_code bl rc
*)
let
find_code_t0
t0
r
=
let
rec
aux
i
=
if
i
=
Array
.
length
r
.
outputs
then
(
-
1
)
else
let
(
t
,_,_
)
=
r
.
outputs
.
(
i
)
in
if
Types
.
subtype
t0
t
then
i
else
aux
(
succ
i
)
in
aux
0
let
alloc
pos
fv
=
let
i
=
ref
(
pos
-
1
)
in
let
r
=
IdMap
.
map_from_slist
(
fun
x
->
incr
i
;
!
i
)
fv
in
...
...
@@ -1973,11 +2016,11 @@ x=(1,2)
else
match
l
with
|
[]
->
incr
nb
;
codes
:=
(
t0
,
ar
,
List
.
rev
binds
)
::
!
codes
;
RCode
!
nb
|
((
a
,
fv
,_
)
,
(
t
,
xs
))
::
rem
->
let
(
alc
,
ar'
)
=
alloc
ar
fv
in
let
(
alc
,
ar'
)
=
alloc
ar
xs
in
RSwitch
(
aux
(
Types
.
cap
t0
a
)
(
aux
(
Types
.
diff
t0
(
Types
.
diff
t
a
)
)
ar'
(
Some
alc
::
binds
)
rem
,
aux
(
Types
.
diff
t0
a
)
aux
(
Types
.
diff
t0
(
Types
.
cap
t
a
)
)
ar
(
None
::
binds
)
rem
)
in
let
reqs
=
PatList
.
Map
.
get
reqs
in
...
...
@@ -1985,6 +2028,7 @@ x=(1,2)
List
.
fold_left
(
fun
accu
(
_
,
(
t
,_
))
->
Types
.
cup
accu
t
)
Types
.
empty
reqs
in
(* let t0 = Types.any in *)
let
rc
=
aux
t0
0
[]
reqs
in
let
os
=
Array
.
of_list
(
List
.
rev
!
codes
)
in
let
ders
=
List
.
map
...
...
@@ -2019,14 +2063,26 @@ x=(1,2)
let
collect_all
f
reqs
=
List
.
fold_left
(
fun
accu
(
p
,_,_
)
->
f
accu
p
)
[]
reqs
let
mk_res
r
reqs
=
let
mk_res
t0
r
reqs
=
(* Format.fprintf Format.std_formatter "mk_res t=%a@." Types.Print.print t0;
List.iter (fun (p,_,_) ->
Format.fprintf Format.std_formatter "%a@."
Derivation.print p) reqs; *)
let
res
=
get_results
reqs
in
let
code
=
find_code
res
r
.
rescode
in
(* let code = find_code_t0 t0 r in *)
if
(
code
<
0
)
then
(
code
,
[
||
])
else
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
->
(* Format.fprintf Format.std_formatter "Res=%a@."
TargExpr.print res;
IdMap.iteri (fun x i ->
Format.fprintf Format.std_formatter "%a->%i@."
Ident.print x i) fill;*)
(* let fill = IdMap.restrict fill (IdMap.domain res) in *)
IdMap
.
collide
(
fun
i
r
->
o
.
(
i
)
<-
r
)
fill
res
|
None
,
None
->
()
|
_
->
assert
false
)
...
...
@@ -2040,26 +2096,27 @@ x=(1,2)
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
List
.
map
(
fun
t
->
(
t
,
mk_res
t
r
(
opt_all
t
reqs
)))
part
let
prod_
types
pi
sel
accu
reqs
=
let
aux
2
s1
accu
t12
=
let
prod_
all
pi
sel
selq
reqs
=
let
aux
3
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
aux2
accu
(
t
,
s
)
=
List
.
fold_left
(
aux3
(
pi
s
))
accu
(
Types
.
Product
.
get
t
)
in
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
xs
=
IdSet
.
cap
xs
q
.
fv
in
let
t
=
pi
t
in
if
(
IdSet
.
is_empty
xs
)
&&
(
Types
.
subtype
t
(
Types
.
descr
q
.
accept
))
then
accu
else
add_req
accu
q
.
descr
t
xs
in
let
accu
=
List
.
fold_left
aux
empty_reqs
(
collect_all
Derivation
.
collect_times
reqs
)
in
List
.
fold_left
aux2
accu
(
collect_all
Derivation
.
collect_constr
reqs
)
let
call_disp
reqs
f
=
if
PatList
.
Map
.
is_empty
reqs
then
Ignore
(
f
(
Types
.
any
,
0
,
[]
))
...
...
@@ -2067,6 +2124,7 @@ x=(1,2)
let
times_disp
r
=
let
t0
=
Types
.
cap
r
.
assumpt
Types
.
Product
.
any
in
if
Types
.
is_empty
t0
then
Impossible
else
let
reqs
=
opt_all
t0
r
.
reqs
in
let
reqs1
=
prod_all
pi1
fst
fst
reqs
in
let
second
(
t1
,
ar1
,
binds1
)
=
...
...
@@ -2078,19 +2136,29 @@ x=(1,2)
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
mk_res
t0
r
reqs
in
call_disp
reqs2
final
in
call_disp
reqs1
second
let
print_disp
ppf
r
=
match
r
.
actions
with
|
Some
_
->
()
|
None
->
print
ppf
r
;
let
basic
=
basic_disp
r
and
prod
=
times_disp
r
in
print_basic_disp
ppf
basic
;
print_prod
ppf
prod
;
r
.
actions
<-
Some
(
AKind
{
basic
=
basic
;
prod
=
prod
})
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
in
print
ppf
r
;
print_basic_disp
ppf
(
basic_disp
r
);
print_prod
ppf
(
times_disp
r
)
to_
print
r
;
(
try
while
true
do
print_disp
ppf
(
Queue
.
take
print_queue
)
done
;
with
Queue
.
Empty
->
()
)
end
...
...
@@ -2104,3 +2172,10 @@ let approx ((_,fv,_) as p) t =
let
demo
=
Compile2
.
Derivation
.
demo
let
demo_compile
=
Compile2
.
Request
.
demo
(* Failure:
debug compile [ Int* Char* ] [ (x::Int|y::_)* ];;
*)
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