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
3a5f2694
Commit
3a5f2694
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-11-20 23:20:10 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-20 23:20:11+00:00
parent
1a96118d
Changes
7
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
3a5f2694
...
...
@@ -89,16 +89,14 @@ let debug ppf = function
List
.
iter
(
fun
(
x
,
t
)
->
Format
.
fprintf
ppf
" %s:%a@
\n
"
x
print_norm
(
Types
.
descr
t
))
f
|
`
Restrict
(
p
,
t
)
->
Format
.
fprintf
ppf
"[DEBUG:
restrict
]@
\n
"
;
|
`
Compile2
(
t
,
pl
)
->
Format
.
fprintf
ppf
"[DEBUG:
compile2
]@
\n
"
;
let
t
=
Typer
.
typ
!
glb_env
t
and
p
=
Typer
.
pat
!
glb_env
p
in
(* let f = Patterns.restrict (Patterns.descr p) (Types.descr t) in
(match f with
| `Pat q -> Format.fprintf ppf "Pat: %a@\n" Patterns.print q
| `Accept -> Format.fprintf ppf "Accept@\n"
| `Reject -> Format.fprintf ppf "Reject@\n") *)
Patterns
.
demo
ppf
(
Patterns
.
descr
p
)
(
Types
.
descr
t
)
and
pl
=
List
.
map
(
fun
p
->
(
`Pat
(
Typer
.
pat
!
glb_env
p
)
,
Types
.
any
))
pl
in
let
d
=
Patterns
.
Compiler
.
make_dispatcher
(
Types
.
descr
t
)
pl
in
Patterns
.
Compiler
.
print_disp
ppf
d
|
`Accept
p
->
Format
.
fprintf
ppf
"[DEBUG:accept]@
\n
"
;
let
p
=
Typer
.
pat
!
glb_env
p
in
...
...
parser/ast.ml
View file @
3a5f2694
...
...
@@ -17,7 +17,7 @@ and debug_directive =
|
`Accept
of
ppat
|
`Compile
of
ppat
*
ppat
list
|
`Normal_record
of
ppat
|
`
Restrict
of
ppat
*
ppat
|
`
Compile2
of
ppat
*
ppat
list
]
...
...
parser/parser.ml
View file @
3a5f2694
...
...
@@ -75,7 +75,7 @@ EXTEND
|
LIDENT
"accept"
;
p
=
pat
->
`Accept
p
|
LIDENT
"compile"
;
t
=
pat
;
p
=
LIST1
pat
->
`Compile
(
t
,
p
)
|
LIDENT
"normal_record"
;
t
=
pat
->
`Normal_record
t
|
LIDENT
"
restrict
"
;
p
=
pat
;
t
=
pat
->
`
Restrict
(
p
,
t
)
|
LIDENT
"
compile2
"
;
t
=
pat
;
p
=
LIST1
pat
->
`
Compile2
(
t
,
p
)
]
];
...
...
types/patterns.ml
View file @
3a5f2694
...
...
@@ -178,16 +178,32 @@ let filter t p =
module
Compiler
=
struct
type
p
=
[
`Pat
of
node
|
`Typ
of
Types
.
descr
]
type
disp
=
{
did
:
int
;
type
disp
atcher
=
{
did
:
int
;
nb_codes
:
int
;
results
:
res
;
results
:
res
;
t
:
Types
.
descr
;
pats
:
(
p
,
Types
.
descr
)
SortedMap
.
t
;
mutable
actions
:
actions
option
;
}
and
bind
=
(
capture
,
int
)
SortedMap
.
t
and
res
=
[
`Return
of
int
|
`Fail
|
`Branch
of
(
bind
*
res
*
res
)
]
and
res
=
[
`Return
of
Types
.
descr
*
int
|
`Fail
|
`Branch
of
(
bind
*
res
*
res
)
]
and
'
a
dispatch
=
dispatcher
*
'
a
array
and
actions
=
{
act_basic
:
basic_actions
;
act_prod
:
prod_actions
}
and
prod_actions
=
(
int
*
prod_src
list
)
dispatch
dispatch
and
basic_actions
=
(
Types
.
descr
*
(
int
*
basic_src
list
))
SortedList
.
t
and
prod_src
=
[
`Capture
|
`Const
of
Types
.
const
|
`Combine
of
int
*
int
|
`Left
of
int
|
`Right
of
int
]
and
basic_src
=
[
`Capture
|
`Const
of
Types
.
const
]
type
p
=
[
`Pat
of
node
|
`Typ
of
Types
.
descr
]
module
DispMap
=
Map
.
Make
(
struct
...
...
@@ -202,7 +218,8 @@ struct
let
rec
make_res
codes
pos
t
l
=
if
Types
.
is_empty
t
then
`Fail
else
match
l
with
|
[]
->
incr
codes
;
`Return
(
!
codes
-
1
)
|
[]
->
incr
codes
;
`Return
(
t
,
!
codes
-
1
)
|
(
p
,
restr
)
::
rem
->
let
(
pos
,
bind
,
a
)
=
match
p
with
|
`Pat
p
->
...
...
@@ -212,23 +229,40 @@ struct
|
`Typ
a
->
(
pos
,
[]
,
a
)
in
let
oth
=
Types
.
diff
t
restr
in
(* Format.fprintf Format.std_formatter
"<<<%a>>>@\n" Types.Print.print_descr (Types.cap t a);
*)
(* assert (Types.subtype restr t);*)
let
yes
=
make_res
codes
pos
(
Types
.
cup
(
Types
.
cap
t
a
)
oth
)
rem
and
no
=
make_res
codes
pos
(
Types
.
cup
(
Types
.
diff
t
a
)
oth
)
rem
in
`Branch
(
bind
,
yes
,
no
)
let
make_dispatcher
t
pats
:
disp
=
let
make_dispatcher
t
pats
=
try
DispMap
.
find
(
t
,
pats
)
!
dispatchers
with
Not_found
->
incr
nb_disp
;
let
nbc
=
ref
0
in
let
res
=
make_res
nbc
0
t
pats
in
let
d
=
{
did
=
!
nb_disp
;
results
=
res
;
nb_codes
=
!
nbc
}
in
let
d
=
{
did
=
!
nb_disp
;
pats
=
pats
;
t
=
t
;
results
=
res
;
nb_codes
=
!
nbc
;
actions
=
None
}
in
dispatchers
:=
DispMap
.
add
(
t
,
pats
)
d
!
dispatchers
;
d
let
rec
find_code
accu
=
function
|
(
`Return
(
_
,
c
)
,
[]
)
->
(
c
,
List
.
rev
accu
)
|
(
`Branch
(
_
,_,
no
)
,
None
::
rem
)
->
find_code
accu
(
no
,
rem
)
|
(
`Branch
(
_
,
yes
,_
)
,
Some
x
::
rem
)
->
find_code
(
List
.
rev_append
x
accu
)
(
yes
,
rem
)
|
_
->
assert
false
let
dispatcher
t
(
args
:
(
p
*
Types
.
descr
*
bind
option
ref
)
list
)
f
=
let
args
=
List
.
map
...
...
@@ -242,7 +276,7 @@ struct
let
res
=
Array
.
create
d
.
nb_codes
(
Obj
.
magic
0
)
in
let
rec
aux
=
function
|
(
`Fail
,_
)
->
()
|
(
`Return
c
,
[]
)
->
res
.
(
c
)
<-
f
()
|
(
`Return
(
t
,
c
)
,
[]
)
->
res
.
(
c
)
<-
f
t
|
(
`Branch
(
bind
,
yes
,
no
)
,
(
_
,
(
_
,
fl
))
::
rem
)
->
List
.
iter
(
fun
r
->
r
:=
Some
bind
)
fl
;
aux
(
yes
,
rem
);
List
.
iter
(
fun
r
->
r
:=
None
)
fl
;
aux
(
no
,
rem
)
...
...
@@ -283,18 +317,20 @@ struct
|
(
One
,
p
)
|
(
p
,
One
)
->
p
|
(
p1
,
p2
)
->
And
(
p1
,
p2
)
(*
let atom s a p =
if Types.is_empty (Types.cap s a) then Zero else
Atom (s, p)
*)
let
rec
map
f
=
function
|
One
->
One
|
Zero
->
Zero
|
Capt
x
->
Capt
x
|
Const
(
x
,
c
)
->
Const
(
x
,
c
)
|
Alt
(
p1
,
p2
)
->
A
lt
(
map
f
p1
,
map
f
p2
)
|
And
(
p1
,
p2
)
->
A
nd
(
map
f
p1
,
map
f
p2
)
|
Atom
a
->
Atom
(
f
a
)
|
Alt
(
p1
,
p2
)
->
a
lt
(
map
f
p1
,
map
f
p2
)
|
And
(
p1
,
p2
)
->
a
nd
_
(
map
f
p1
,
map
f
p2
)
|
Atom
a
->
f
a
let
rec
get
f
(
a
,_,
d
)
s
=
if
Types
.
is_empty
(
Types
.
cap
s
a
)
then
Zero
...
...
@@ -315,49 +351,239 @@ struct
Const
(
x
,
c
)
|
d
->
f
d
s
let
prepare_prod
=
let
rec
get_final
f
=
function
|
Atom
x
->
f
x
|
One
->
Some
[]
|
Zero
->
None
|
Capt
x
->
Some
[
x
,
`Capture
]
|
Const
(
x
,
c
)
->
Some
[
x
,
`Const
c
]
|
Alt
(
p1
,
p2
)
->
(
match
get_final
f
p1
with
|
Some
_
as
x
->
x
|
None
->
get_final
f
p2
)
|
And
(
p1
,
p2
)
->
(
match
get_final
f
p1
with
|
Some
x
->
(
match
get_final
f
p2
with
|
Some
y
->
Some
(
SortedMap
.
union_disj
x
y
)
|
None
->
None
)
|
None
->
None
)
let
get_final
f
p
=
match
get_final
f
p
with
|
None
->
None
|
Some
l
->
Some
(
List
.
map
snd
l
)
let
map_list
f
=
List
.
map
(
map
f
)
let
pi1
d
=
Types
.
Product
.
pi1
(
Types
.
Product
.
get
d
)
let
pi2
d
d1
=
Types
.
Product
.
pi2
(
Types
.
Product
.
restrict_1
(
Types
.
Product
.
get
d
)
d1
)
let
prepare_prod'
=
get
(
fun
d
r
->
match
d
with
|
Times
(
n1
,
n2
)
->
let
r
=
Types
.
Product
.
normal
r
in
Atom
(
`Pat
(
n1
,
n2
,
r
))
|
Constr
t
->
Atom
(
`Typ
(
t
,
r
))
Atom
(
`Typ
(
Types
.
cap
t
r
,
r
))
|
_
->
Zero
)
let
dispatch_record
t
pats
=
let
pats
=
List
.
map
(
fun
(
p
,
restr
)
->
match
p
with
|
`Pat
p
->
prepare_prod
(
descr
p
)
restr
|
`Typ
s
->
Atom
(
`Typ
(
s
,
restr
))
(* TODO: special case here ... restr<=t...*)
)
pats
in
(* Make dispatcher on first component *)
let
prepare_prod
(
p
,
restr
)
=
match
p
with
|
`Pat
p
->
prepare_prod'
(
descr
p
)
restr
|
`Typ
s
->
Atom
(
`Typ
(
s
,
restr
))
(* TODO: special case here ... restr<=t...*)
let
map_prod1
collect
=
function
|
`Pat
(
n1
,
n2
,
r
)
->
let
fl
=
ref
None
in
collect
:=
(
`Pat
n1
,
pi1
r
,
fl
)
::
!
collect
;
Atom
(
`Pat
(
fl
,
n2
,
r
))
|
`Typ
(
s
,
r
)
->
let
r1
=
pi1
r
in
let
l
=
List
.
map
(
fun
(
s1
,
s2
)
->
let
fl
=
ref
None
in
collect
:=
(
`Typ
s1
,
r1
,
fl
)
::
!
collect
;
(
fl
,
s2
)
)
(
Types
.
Product
.
normal
s
)
in
(* would be ok with Types.Product.get ... *)
Atom
(
`Typ
(
l
,
r
))
let
map_prod2
t1
collect
=
function
|
`Pat
(
fl1
,
n2
,
r
)
->
(
match
!
fl1
with
|
None
->
Zero
|
Some
bind
->
let
fl2
=
ref
None
in
collect
:=
(
`Pat
n2
,
pi2
r
t1
,
fl2
)
::
!
collect
;
Atom
(
`Pat
(
bind
,
fl2
))
)
|
`Typ
(
l
,
r
)
->
let
r2
=
pi2
r
t1
in
let
l
=
List
.
fold_left
(
fun
accu
(
fl1
,
s2
)
->
match
!
fl1
with
|
None
->
accu
|
Some
bind
->
assert
(
bind
=
[]
);
let
fl2
=
ref
None
in
collect
:=
(
`Typ
s2
,
r2
,
fl2
)
::
!
collect
;
fl2
::
accu
)
[]
l
in
Atom
(
`Typ
l
)
let
prod_final
=
get_final
(
function
|
`Pat
(
bind1
,
{
contents
=
Some
bind2
})
->
let
x
=
SortedMap
.
combine
(
fun
x
->
`Left
x
)
(
fun
x
->
`Right
x
)
(
fun
x
y
->
`Combine
(
x
,
y
))
bind1
bind2
in
Some
x
|
`Typ
l
when
List
.
exists
(
fun
fl
->
!
fl
<>
None
)
l
->
Some
[]
|
_
->
None
)
let
dispatch_prod
(
res
:
res
)
t
(
pats
:
(
p
*
Types
.
descr
)
list
)
:
prod_actions
=
let
pats
=
List
.
map
prepare_prod
pats
in
let
lefts
=
ref
[]
in
let
pats
=
List
.
map
(
map
(
function
|
`Pat
(
n1
,
n2
,
r
)
->
let
pat
=
List
.
map
(
fun
(
r1
,
r2
)
->
let
fl
=
ref
None
in
lefts
:=
(
`Pat
n1
,
r1
,
fl
)
::
!
lefts
;
(
fl
,
n2
,
r2
)
)
r
in
`Pat
pat
|
`Typ
(
s
,
r
)
->
(*...*)
assert
false
))
pats
in
let
(
disp1
,
f1
)
=
dispatcher
(
Types
.
Product
.
pi1
(
Types
.
Product
.
get
t
))
!
lefts
(
fun
()
->
0
)
let
pats
=
map_list
(
map_prod1
lefts
)
pats
in
dispatcher
(
pi1
t
)
!
lefts
(
fun
t1
->
let
rights
=
ref
[]
in
let
pats
=
map_list
(
map_prod2
t1
rights
)
pats
in
dispatcher
(
pi2
t
t1
)
!
rights
(
fun
t2
->
let
pats
=
List
.
map
prod_final
pats
in
find_code
[]
(
res
,
pats
)
)
)
let
any_basic
=
Types
.
neg
(
List
.
fold_left
Types
.
cup
Types
.
empty
[
Types
.
Product
.
any_xml
;
Types
.
Product
.
any
;
Types
.
Record
.
any
])
let
prepare_basic'
=
get
(
fun
d
r
->
match
d
with
|
Constr
t
->
Atom
t
|
_
->
Zero
)
let
prepare_basic
(
p
,
restr
)
=
match
p
with
|
`Pat
p
->
prepare_basic'
(
descr
p
)
restr
|
`Typ
s
->
Atom
s
let
basic_final
t
=
get_final
(
fun
s
->
if
Types
.
subtype
t
s
then
Some
[]
else
(
assert
(
Types
.
is_empty
(
Types
.
cap
t
s
));
None
)
)
let
dispatch_basic
res
t
pats
:
basic_actions
=
let
types
=
ref
[]
in
let
rec
aux
=
function
|
`Fail
->
()
|
`Branch
(
bind
,
yes
,
no
)
->
aux
yes
;
aux
no
|
`Return
(
t
,_
)
->
let
t
=
Types
.
cap
t
any_basic
in
if
not
(
Types
.
is_empty
t
)
then
types
:=
t
::
!
types
in
aux
res
;
let
pats
=
List
.
map
prepare_basic
pats
in
List
.
map
(
fun
t
->
let
pats
=
List
.
map
(
basic_final
t
)
pats
in
(
t
,
find_code
[]
(
res
,
pats
))
)
!
types
let
get_actions
disp
=
match
disp
.
actions
with
|
Some
a
->
a
|
None
->
let
a
=
{
act_basic
=
dispatch_basic
disp
.
results
disp
.
t
disp
.
pats
;
act_prod
=
dispatch_prod
disp
.
results
disp
.
t
disp
.
pats
}
in
disp
.
actions
<-
Some
a
;
a
let
to_print
=
ref
([]
:
dispatcher
list
)
let
printed
=
ref
([]
:
dispatcher
list
)
let
print_act_basic
ppf
b
=
List
.
iter
(
fun
(
d
,
(
code
,
bind
))
->
Format
.
fprintf
ppf
"| %a -> %i( "
Types
.
Print
.
print_descr
d
code
;
List
.
iter
(
function
|
`Capture
->
Format
.
fprintf
ppf
"v "
|
`Const
c
->
Format
.
fprintf
ppf
"%a "
Types
.
Print
.
print_const
c
)
bind
;
Format
.
fprintf
ppf
")@
\n
"
)
b
let
print_act_prod
ppf
(
disp1
,
b1
)
=
Format
.
fprintf
ppf
"| (v1,v2) -> match v1 with disp%i@
\n
"
disp1
.
did
;
to_print
:=
disp1
::
!
to_print
;
for
i
=
0
to
Array
.
length
b1
-
1
do
let
(
disp2
,
b2
)
=
b1
.
(
i
)
in
to_print
:=
disp2
::
!
to_print
;
Format
.
fprintf
ppf
" | %i(l) -> match v2 with disp%i@
\n
"
i
disp2
.
did
;
for
j
=
0
to
Array
.
length
b2
-
1
do
let
(
code
,
bind
)
=
b2
.
(
j
)
in
Format
.
fprintf
ppf
" | %i(r) -> %i("
j
code
;
List
.
iter
(
function
|
`Capture
->
Format
.
fprintf
ppf
"v "
|
`Const
c
->
Format
.
fprintf
ppf
"%a "
Types
.
Print
.
print_const
c
|
`Left
x
->
Format
.
fprintf
ppf
"l%i "
x
|
`Right
x
->
Format
.
fprintf
ppf
"r%i "
x
|
`Combine
(
x
,
y
)
->
Format
.
fprintf
ppf
"(l%i,r%i) "
x
y
)
bind
;
Format
.
fprintf
ppf
")@
\n
"
done
;
done
let
rec
print_disp
ppf
disp
=
Format
.
fprintf
ppf
"Dispatcher [%i]: 0..%i@
\n
"
disp
.
did
(
disp
.
nb_codes
-
1
);
let
a
=
get_actions
disp
in
print_act_basic
ppf
a
.
act_basic
;
print_act_prod
ppf
a
.
act_prod
;
let
rec
loop
()
=
match
!
to_print
with
|
[]
->
()
|
d
::
q
->
to_print
:=
q
;
if
List
.
memq
d
!
printed
then
loop
()
else
(
printed
:=
d
::
!
printed
;
print_disp
ppf
d
)
in
()
loop
()
(*
let rec collect typ f (a,_,d) s =
...
...
types/patterns.mli
View file @
3a5f2694
...
...
@@ -37,6 +37,14 @@ val demo: Format.formatter -> descr -> Types.descr -> unit
val
accept
:
node
->
Types
.
node
val
filter
:
Types
.
descr
->
node
->
(
capture
,
Types
.
node
)
SortedMap
.
t
module
Compiler
:
sig
type
p
=
[
`Pat
of
node
|
`Typ
of
Types
.
descr
]
type
dispatcher
val
make_dispatcher
:
Types
.
descr
->
(
p
,
Types
.
descr
)
SortedMap
.
t
->
dispatcher
val
print_disp
:
Format
.
formatter
->
dispatcher
->
unit
end
(* Pattern matching: compilation *)
module
Compile
:
sig
...
...
types/sortedMap.ml
View file @
3a5f2694
...
...
@@ -30,6 +30,15 @@ let rec union_disj l1 l2 =
|
([]
,
l2
)
->
l2
|
(
l1
,
[]
)
->
l1
let
rec
combine
f1
f2
f12
l1
l2
=
match
(
l1
,
l2
)
with
|
(
x1
,
y1
)
::
q1
,
(
x2
,
y2
)
::
q2
->
let
c
=
compare
x1
x2
in
if
c
=
0
then
(
x1
,
(
f12
y1
y2
))
::
(
combine
f1
f2
f12
q1
q2
)
else
if
c
<
0
then
(
x1
,
f1
y1
)
::
(
combine
f1
f2
f12
q1
l2
)
else
(
x2
,
f2
y2
)
::
(
combine
f1
f2
f12
l1
q2
)
|
([]
,
q2
)
->
List
.
map
(
fun
(
x2
,
y2
)
->
(
x2
,
f2
y2
))
l2
|
(
l1
,
[]
)
->
List
.
map
(
fun
(
x1
,
y1
)
->
(
x1
,
f1
y1
))
l1
let
rec
map
f
=
function
|
[]
->
[]
...
...
types/sortedMap.mli
View file @
3a5f2694
...
...
@@ -3,6 +3,9 @@ val union: ('b -> 'b -> 'b) -> ('a,'b) t -> ('a,'b) t -> ('a,'b) t
val
unioni
:
(
'
a
->
'
b
->
'
b
->
'
b
)
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
b
)
t
val
union_disj
:
(
'
a
,
'
b
)
t
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
b
)
t
val
combine
:
(
'
b
->
'
d
)
->
(
'
c
->
'
d
)
->
(
'
b
->
'
c
->
'
d
)
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
c
)
t
->
(
'
a
,
'
d
)
t
val
map
:
(
'
b
->
'
c
)
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
c
)
t
val
add
:
(
'
b
->
'
b
->
'
b
)
->
'
a
->
'
b
->
(
'
a
,
'
b
)
t
->
(
'
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