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
07489b93
Commit
07489b93
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-11-16 22:17:14 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-16 22:17:14+00:00
parent
34c2cc05
Changes
6
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
07489b93
...
...
@@ -89,6 +89,16 @@ 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
"
;
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
)
|
`Accept
p
->
Format
.
fprintf
ppf
"[DEBUG:accept]@
\n
"
;
let
p
=
Typer
.
pat
!
glb_env
p
in
...
...
driver/webiface.ml
View file @
07489b93
...
...
@@ -266,7 +266,7 @@ let main (cgi : Netcgi.std_activation) =
p
"<a href='http://ocamlnet.sourceforge.net/'>OCamlnet</a>, "
;
p
"<a href='http://www.ocaml-programming.de/programming/pxp.html'>PXP</a>, "
;
p
"<a href='http://www.eleves.ens.fr/home/frisch/soft#wlex'>wlex</a>."
;
p
"<
br
>"
;
p
"<
p
>"
;
p
"<a href='mailto:Alain.Frisch@ens.fr'>Webmaster</a>"
;
p
end_table
;
...
...
parser/ast.ml
View file @
07489b93
...
...
@@ -17,6 +17,7 @@ and debug_directive =
|
`Accept
of
ppat
|
`Compile
of
ppat
*
ppat
list
|
`Normal_record
of
ppat
|
`Restrict
of
ppat
*
ppat
]
...
...
parser/parser.ml
View file @
07489b93
...
...
@@ -75,6 +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
)
]
];
...
...
types/patterns.ml
View file @
07489b93
...
...
@@ -22,10 +22,15 @@ and node = {
fv
:
fv
}
and
descr
=
Types
.
descr
*
fv
*
d
let
id
x
=
x
.
id
let
descr
x
=
match
x
.
descr
with
Some
d
->
d
|
None
->
failwith
"Patterns.descr"
let
fv
x
=
x
.
fv
let
accept
x
=
Types
.
internalize
x
.
accept
let
printed
=
ref
[]
let
to_print
=
ref
[]
let
rec
print
ppf
(
_
,_,
d
)
=
let
rec
print
ppf
(
a
,_,
d
)
=
(* Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
match
d
with
|
Constr
t
->
Types
.
Print
.
print_descr
ppf
t
|
Cup
(
p1
,
p2
)
->
Format
.
fprintf
ppf
"(%a | %a)"
print
p1
print
p2
...
...
@@ -44,6 +49,19 @@ let rec print ppf (_,_,d) =
|
Constant
(
x
,
c
)
->
Format
.
fprintf
ppf
"(%s := %a)"
x
Types
.
Print
.
print_const
c
let
dump_print
ppf
=
while
!
to_print
<>
[]
do
let
p
=
List
.
hd
!
to_print
in
to_print
:=
List
.
tl
!
to_print
;
if
not
(
List
.
mem
p
.
id
!
printed
)
then
(
printed
:=
p
.
id
::
!
printed
;
Format
.
fprintf
ppf
"P%i:=%a
\n
"
p
.
id
print
(
descr
p
)
)
done
let
print
ppf
d
=
Format
.
fprintf
ppf
"%a@
\n
"
print
d
;
dump_print
ppf
let
counter
=
State
.
ref
"Patterns.counter"
0
...
...
@@ -91,10 +109,6 @@ let capture x = (Types.any, [x], Capture x)
let
constant
x
c
=
(
Types
.
any
,
[
x
]
,
Constant
(
x
,
c
))
let
id
x
=
x
.
id
let
descr
x
=
match
x
.
descr
with
Some
d
->
d
|
None
->
failwith
"Patterns.descr"
let
fv
x
=
x
.
fv
let
accept
x
=
Types
.
internalize
x
.
accept
(* Static semantics *)
...
...
@@ -162,19 +176,147 @@ let filter t p =
(* Returns a pattern q equivalent to p when applied to a
value of type t *)
type
pat
=
Types
.
descr
*
capture
SortedList
.
t
*
(
capture
,
Types
.
const
)
SortedMap
.
t
*
patd
and
patd
=
module
Compiler
=
struct
type
disp
=
{
did
:
int
;
results
:
(
int
*
(
capture
,
int
)
SortedMap
.
t
option
array
*
bool
array
)
array
}
module
DispMap
=
Map
.
Make
(
struct
type
t
=
(
node
*
Types
.
descr
)
array
*
(
Types
.
descr
*
Types
.
descr
)
array
let
compare
=
compare
end
)
let
dispatchers
=
ref
DispMap
.
empty
let
nb_disp
=
ref
0
let
dispatcher
pats
typs
:
disp
=
try
DispMap
.
find
(
pats
,
typs
)
!
dispatchers
with
Not_found
->
incr
nb_disp
;
let
d
=
{
did
=
!
nb_disp
;
results
=
[
|
|
]
}
in
dispatchers
:=
DispMap
.
add
(
pats
,
typs
)
d
!
dispatchers
;
d
let
sort_list
l
=
Array
.
of_list
(
SortedList
.
from_list
l
)
type
'
a
pat
=
|
One
|
Zero
|
Alt
of
pat
*
pat
|
And
of
pat
*
pat
|
Prod
of
node
*
node
|
XML
of
node
*
node
|
Rec
of
Types
.
label
*
node
|
Capt
of
capture
|
Const
of
capture
*
Types
.
const
|
Alt
of
'
a
pat
*
'
a
pat
|
And
of
'
a
pat
*
'
a
pat
|
Type
of
Types
.
descr
*
Types
.
descr
|
Atom
of
Types
.
descr
*
'
a
let
rec
print
f
ppf
=
function
|
One
->
Format
.
fprintf
ppf
"One"
|
Zero
->
Format
.
fprintf
ppf
"Zero"
|
Capt
x
->
Format
.
fprintf
ppf
"%s"
x
|
Const
(
x
,
c
)
->
Format
.
fprintf
ppf
"(%s := %a)"
x
Types
.
Print
.
print_const
c
|
Alt
(
p1
,
p2
)
->
Format
.
fprintf
ppf
"(%a | %a)"
(
print
f
)
p1
(
print
f
)
p2
|
And
(
p1
,
p2
)
->
Format
.
fprintf
ppf
"(%a & %a)"
(
print
f
)
p1
(
print
f
)
p2
|
Atom
(
d
,
a
)
->
Format
.
fprintf
ppf
"[%a]%a"
Types
.
Print
.
print_descr
d
f
a
|
Type
(
d
,
a
)
->
Format
.
fprintf
ppf
"[%a]%a"
Types
.
Print
.
print_descr
d
Types
.
Print
.
print_descr
a
let
alt
=
function
|
(
Zero
,
p
)
|
(
p
,
Zero
)
->
p
|
(
p1
,
p2
)
->
Alt
(
p1
,
p2
)
let
and_
=
function
|
(
Zero
,_
)
|
(
_
,
Zero
)
->
Zero
|
(
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
get
f
(
a
,_,
d
)
s
=
if
Types
.
is_empty
(
Types
.
cap
s
a
)
then
Zero
else
match
d
with
|
Constr
t
->
if
Types
.
subtype
s
t
then
One
else
Type
(
s
,
Types
.
cap
s
t
)
|
Cup
((
a1
,_,_
)
as
d1
,
d2
)
->
let
p1
=
get
f
d1
s
in
let
p2
=
get
f
d2
(
Types
.
diff
s
a1
)
in
alt
(
p1
,
p2
)
|
Cap
((
a1
,_,_
)
as
d1
,
d2
)
->
(* could swap the two to optimize ? ... *)
let
p1
=
get
f
d1
s
in
let
p2
=
get
f
d2
(
Types
.
cap
s
a1
)
in
and_
(
p1
,
p2
)
|
Capture
x
->
Capt
x
|
Constant
(
x
,
c
)
->
Const
(
x
,
c
)
|
d
->
(
match
f
d
with
None
->
Zero
|
Some
x
->
Atom
(
s
,
x
))
let
rec
collect
typ
f
(
a
,_,
d
)
s
=
if
Types
.
is_empty
(
Types
.
cap
s
a
)
then
()
else
match
d
with
|
Constr
t
->
if
not
(
Types
.
subtype
s
a
)
then
typ
s
(
Types
.
cap
s
t
)
|
Cup
((
a1
,_,_
)
as
d1
,
d2
)
->
collect
typ
f
d1
s
;
collect
typ
f
d2
(
Types
.
diff
s
a1
)
|
Cap
((
a1
,_,_
)
as
d1
,
d2
)
->
collect
typ
f
d1
s
;
collect
typ
f
d2
(
Types
.
cap
s
a1
)
|
Capture
_
|
Constant
(
_
,_
)
->
()
|
d
->
f
s
d
let
get_prod
=
get
(
function
Times
(
n1
,
n2
)
->
Some
n1
|
_
->
None
)
let
get_record
=
get
(
function
Record
(
l
,
n
)
->
Some
(
l
,
n
)
|
_
->
None
)
let
print_prod
=
print
(
fun
ppf
p1
->
Format
.
fprintf
ppf
"(P%i)"
p1
.
id
)
let
print_record
=
print
(
fun
ppf
(
l
,
p
)
->
Format
.
fprintf
ppf
"{ %s = P%i }"
(
Types
.
LabelPool
.
value
l
)
p
.
id
)
let
demo
ppf
p
t
=
collect
(
fun
w
t
->
Format
.
fprintf
ppf
"TYP1:%a // %a@
\n
"
Types
.
Print
.
print_descr
t
Types
.
Print
.
print_descr
w
;
let
n
=
Types
.
Product
.
normal
t
in
let
pi1
=
Types
.
Product
.
pi1
(
Types
.
Product
.
get
w
)
in
List
.
iter
(
fun
(
d1
,
d2
)
->
Format
.
fprintf
ppf
"=> %a // %a@
\n
"
Types
.
Print
.
print_descr
d1
Types
.
Print
.
print_descr
pi1
)
n
)
(
fun
w
->
function
|
Times
(
n1
,
n2
)
->
let
pi1
=
Types
.
Product
.
pi1
(
Types
.
Product
.
get
w
)
in
Format
.
fprintf
ppf
"PAT1:%i // %a@
\n
"
n1
.
id
Types
.
Print
.
print_descr
pi1
;
to_print
:=
n1
::
!
to_print
|
_
->
()
)
p
t
end
let
demo
ppf
p
t
=
(*
Compiler.demo ppf p t;
dump_print ppf
*)
Format
.
fprintf
ppf
"PROD:%a@
\n
"
Compiler
.
print_prod
(
Compiler
.
get_prod
p
(
Types
.
cap
Types
.
Product
.
any
t
));
Format
.
fprintf
ppf
"REC :%a@
\n
"
Compiler
.
print_record
(
Compiler
.
get_record
p
(
Types
.
cap
Types
.
Record
.
any
t
))
let
rec
restrict
((
a
,
fv
,
d
)
as
p
)
t
=
(* TODO OPT: Don't call cup,cap .... *)
...
...
@@ -195,11 +337,9 @@ let rec restrict ((a,fv,d) as p) t =
|
Some
p1
,
None
->
p1
|
None
,
Some
p2
->
p2
|
_
->
assert
false
)
|
Cap
((
_
,_,
Constr
s
)
,
p'
)
|
Cap
(
p'
,
(
_
,_,
Constr
s
))
when
Types
.
subtype
t
s
->
restrict
p'
t
|
Cap
(
p1
,
p2
)
->
cap
(
restrict
p1
t
)
(
restrict
p2
t
)
|
Capture
_
|
Constant
(
_
,_
)
->
p
|
_
->
(
Types
.
cap
a
t
,
fv
,
d
)
(*
| Capture _ | Constant (_,_) -> p
*)
|
_
->
p
(*
(Types.cap a t, fv, d)
*)
let
restrict
((
a
,
fv
,_
)
as
p
)
t
=
if
Types
.
is_empty
(
Types
.
cap
a
t
)
then
`Reject
...
...
types/patterns.mli
View file @
07489b93
...
...
@@ -26,6 +26,12 @@ val id: node -> int
val
descr
:
node
->
descr
val
fv
:
node
->
fv
(*
val print: Format.formatter -> descr -> unit
val restrict: descr -> Types.descr -> [ `Pat of descr | `Reject | `Accept ]
*)
val
demo
:
Format
.
formatter
->
descr
->
Types
.
descr
->
unit
(* Pattern matching: static semantics *)
val
accept
:
node
->
Types
.
node
...
...
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