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
52770e6a
Commit
52770e6a
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-11-24 20:44:12 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-24 20:44:13+00:00
parent
efb4646c
Changes
4
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
52770e6a
...
...
@@ -109,10 +109,7 @@ let debug ppf = function
Format
.
fprintf
ppf
"[DEBUG:compile]@
\n
"
;
let
t
=
Typer
.
typ
!
glb_env
t
and
pl
=
List
.
map
(
Typer
.
pat
!
glb_env
)
pl
in
let
pl
=
Array
.
of_list
(
List
.
map
(
fun
p
->
Patterns
.
Compile
.
normal
(
Patterns
.
descr
p
))
pl
)
in
Patterns
.
Compile
.
show
ppf
(
Types
.
descr
t
)
pl
Patterns
.
Compile
.
debug_compile
ppf
t
pl
|
`Normal_record
t
->
Format
.
fprintf
ppf
"[DEBUG:normal_record]@
\n
"
;
let
t
=
Types
.
descr
(
Typer
.
typ
!
glb_env
t
)
in
...
...
types/patterns.ml
View file @
52770e6a
...
...
@@ -684,7 +684,37 @@ let restrict ((a,fv,_) as p) t =
(* Normal forms for patterns and compilation *)
module
Normal
=
module
Normal
:
sig
type
'
a
sl
=
'
a
SortedList
.
t
type
(
'
a
,
'
b
)
sm
=
(
'
a
,
'
b
)
SortedMap
.
t
type
source
=
[
`Catch
|
`Const
of
Types
.
const
|
`Left
|
`Right
|
`Recompose
|
`Field
of
Types
.
label
]
type
result
=
(
capture
,
source
)
sm
type
nnf
=
node
sl
*
Types
.
descr
type
'
a
nline
=
(
result
*
'
a
)
list
type
record
=
[
`Success
|
`Fail
|
`Dispatch
of
(
nnf
*
record
)
list
|
`Label
of
Types
.
label
*
(
nnf
*
record
)
list
*
record
]
type
t
=
{
nfv
:
fv
;
ncatchv
:
fv
;
na
:
Types
.
descr
;
nbasic
:
Types
.
descr
nline
;
nprod
:
(
nnf
*
nnf
)
nline
;
nxml
:
(
nnf
*
nnf
)
nline
;
nrecord
:
record
nline
}
val
any_basic
:
Types
.
descr
val
normal
:
Types
.
descr
->
node
list
->
t
end
=
struct
type
'
a
sl
=
'
a
SortedList
.
t
type
(
'
a
,
'
b
)
sm
=
(
'
a
,
'
b
)
SortedMap
.
t
...
...
@@ -707,8 +737,9 @@ struct
record
:
((
Types
.
label
,
node
sl
)
sm
)
line
;
}
type
nnf
=
Types
.
descr
*
node
sl
type
'
a
nline
=
(
result
*
'
a
)
list
type
nnf
=
node
sl
*
Types
.
descr
(* pl,t; t <= \accept{pl} *)
type
'
a
nline
=
(
result
*
'
a
)
sl
type
record
=
[
`Success
|
`Fail
...
...
@@ -724,6 +755,72 @@ struct
nrecord
:
record
nline
}
let
nempty
=
{
nfv
=
[]
;
ncatchv
=
[]
;
na
=
Types
.
empty
;
nbasic
=
[]
;
nprod
=
[]
;
nxml
=
[]
;
nrecord
=
[]
}
let
ncup
nf1
nf2
=
(* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
(* assert (nf1.nfv = nf2.nfv); *)
{
nfv
=
nf1
.
nfv
;
ncatchv
=
SortedList
.
cap
nf1
.
ncatchv
nf2
.
ncatchv
;
na
=
Types
.
cup
nf1
.
na
nf2
.
na
;
nbasic
=
SortedList
.
cup
nf1
.
nbasic
nf2
.
nbasic
;
nprod
=
SortedList
.
cup
nf1
.
nprod
nf2
.
nprod
;
nxml
=
SortedList
.
cup
nf1
.
nxml
nf2
.
nxml
;
nrecord
=
SortedList
.
cup
nf1
.
nrecord
nf2
.
nrecord
;
}
let
fus
=
SortedMap
.
union_disj
let
slcup
=
SortedList
.
cup
let
double_fold
f
l1
l2
=
SortedList
.
from_list
(
List
.
fold_left
(
fun
accu
x1
->
List
.
fold_left
(
fun
accu
x2
->
f
accu
x1
x2
)
accu
l2
)
[]
l1
)
let
ncap
nf1
nf2
=
let
prod
accu
(
res1
,
((
pl1
,
t1
)
,
(
ql1
,
s1
)))
(
res2
,
((
pl2
,
t2
)
,
(
ql2
,
s2
)))
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
let
s
=
Types
.
cap
s1
s2
in
if
Types
.
is_empty
s
then
accu
else
(
fus
res1
res2
,
((
slcup
pl1
pl2
,
t
)
,
(
slcup
ql1
ql2
,
s
)))
::
accu
in
let
basic
accu
(
res1
,
t1
)
(
res2
,
t2
)
=
let
t
=
Types
.
cap
t1
t2
in
if
Types
.
is_empty
t
then
accu
else
(
fus
res1
res2
,
t
)
::
accu
in
{
nfv
=
SortedList
.
cup
nf1
.
nfv
nf2
.
nfv
;
ncatchv
=
SortedList
.
cup
nf1
.
ncatchv
nf2
.
ncatchv
;
na
=
Types
.
cap
nf1
.
na
nf2
.
na
;
nbasic
=
double_fold
basic
nf1
.
nbasic
nf2
.
nbasic
;
nprod
=
double_fold
prod
nf1
.
nprod
nf2
.
nprod
;
nxml
=
double_fold
prod
nf1
.
nxml
nf2
.
nxml
;
nrecord
=
[]
;
(* TODO ... *)
}
let
ntimes
acc
p
q
=
let
src_p
=
List
.
map
(
fun
v
->
(
v
,
`Left
))
p
.
fv
and
src_q
=
List
.
map
(
fun
v
->
(
v
,
`Right
))
q
.
fv
in
let
src
=
SortedMap
.
union
(
fun
_
_
->
`Recompose
)
src_p
src_q
in
let
rects
=
Types
.
Product
.
normal
acc
in
let
prod
=
List
.
map
(
fun
(
t1
,
t2
)
->
(
src
,
(([
p
]
,
t1
)
,
([
q
]
,
t2
))))
rects
in
{
nempty
with
nfv
=
SortedList
.
cup
p
.
fv
q
.
fv
;
na
=
acc
;
nprod
=
SortedList
.
from_list
prod
}
let
empty
=
{
v
=
[]
;
catchv
=
[]
;
a
=
Types
.
empty
;
basic
=
[]
;
prod
=
[]
;
xml
=
[]
;
record
=
[]
}
...
...
@@ -747,8 +844,6 @@ struct
record
=
filter
nf
.
record
;
}
let
fus
=
SortedMap
.
union_disj
let
slcup
=
SortedList
.
cup
let
cap
nf1
nf2
=
let
merge
f
lines1
lines2
=
...
...
@@ -870,15 +965,13 @@ struct
|
Constant
(
x
,
c
)
->
constant
x
c
|
Record
(
l
,
p
)
->
record
acc
l
p
let
bigcap
pl
=
pl
(* List.fold_left (fun a p -> cap a (nf (descr p))) any *)
let
normal
nf
=
let
basic
=
List
.
map
(
fun
((
res
,
()
)
,
acc
)
->
(
res
,
acc
))
and
prod
?
kind
l
=
let
line
accu
(((
res
,
(
pl
,
ql
))
,
acc
))
=
let
aux
accu
(
t1
,
t2
)
=
(
res
,
(
(
t1
,
pl
)
,
(
t2
,
ql
)
))
::
accu
in
let
aux
accu
(
t1
,
t2
)
=
(
res
,
(
(
pl
,
t1
)
,
(
ql
,
t2
)
))
::
accu
in
let
t
=
Types
.
Product
.
normal
?
kind
acc
in
List
.
fold_left
aux
accu
t
in
List
.
fold_left
line
[]
l
...
...
@@ -890,17 +983,17 @@ struct
|
(
`Success
,
[]
)
->
`Success
|
(
`Fail
,_
)
->
`Fail
|
(
`Success
,
(
l2
,
pl
)
::
fields
)
->
`Label
(
l2
,
[(
Types
.
any
,
pl
)
,
aux
nr
fields
]
,
`Fail
)
`Label
(
l2
,
[(
pl
,
Types
.
any
)
,
aux
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
_
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l2
<
l1
->
`Label
(
l2
,
[(
Types
.
any
,
pl
)
,
aux
nr
fields
]
,
`Fail
)
`Label
(
l2
,
[(
pl
,
Types
.
any
)
,
aux
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l1
=
l2
->
let
pr
=
List
.
map
(
fun
(
t
,
x
)
->
((
t
,
pl
)
,
aux
x
fields
))
pr
in
List
.
map
(
fun
(
t
,
x
)
->
((
(
pl
,
t
)
:
nnf
)
,
aux
x
fields
))
pr
in
`Label
(
l1
,
pr
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
ab
)
,_
)
->
let
aux_ab
=
aux
ab
fields
in
let
pr
=
List
.
map
(
fun
(
t
,
x
)
->
((
t
,
[]
)
,
List
.
map
(
fun
(
t
,
x
)
->
(([]
,
t
)
,
(* Types.Record.normal enforce physical equility
in case of a ? field *)
if
x
==
ab
then
aux_ab
else
...
...
@@ -927,6 +1020,9 @@ struct
nrecord
=
nlines
(
record
nf
.
record
);
}
let
normal
t
pl
=
normal
(
List
.
fold_left
(
fun
a
p
->
cap
a
(
nf
(
descr
p
)))
(
constr
t
)
pl
)
end
...
...
@@ -1195,14 +1291,8 @@ struct
let
unselect
=
Array
.
create
(
Array
.
length
pl
)
[]
in
let
aux
i
x
=
let
yes
,
no
=
f
x
in
List
.
iter
(
fun
(
(
ty
,
pl
)
,
info
)
->
let
p
=
List
.
fold_left
(
fun
a
p
->
Normal
.
cap
a
(
Normal
.
nf
(
descr
p
)))
(
Normal
.
constr
ty
)
pl
in
let
p
=
Normal
.
restrict
t
p
in
let
p
=
Normal
.
normal
p
in
List
.
iter
(
fun
(
(
pl
,
ty
)
,
info
)
->
let
p
=
Normal
.
normal
ty
pl
in
accu
:=
(
p
,
[
i
,
p
.
Normal
.
ncatchv
,
info
])
::
!
accu
;
)
yes
;
unselect
.
(
i
)
<-
no
@
unselect
.
(
i
)
in
...
...
@@ -1225,7 +1315,7 @@ struct
let
(
_
,
brs
)
=
List
.
fold_left
(
fun
(
t
,
brs
)
(
p
,
e
)
->
let
p'
=
(
t
,
[
p
])
in
let
p'
=
([
p
]
,
t
)
in
let
t'
=
Types
.
diff
t
(
Types
.
descr
(
accept
p
))
in
(
t'
,
(
p'
,
e
)
::
brs
)
)
(
t
,
[]
)
brs
in
...
...
@@ -1590,9 +1680,11 @@ struct
queue
disp
;
print_dispatchers
ppf
type
normal
=
Normal
.
t
let
normal
p
=
Normal
.
normal
(
Normal
.
nf
p
)
let
debug_compile
ppf
t
pl
=
let
pl
=
Array
.
of_list
(
List
.
map
(
fun
p
->
Normal
.
normal
Types
.
any
[
p
])
pl
)
in
let
t
=
Types
.
descr
t
in
show
ppf
t
pl
end
types/patterns.mli
View file @
52770e6a
...
...
@@ -46,11 +46,7 @@ end
(* Pattern matching: compilation *)
module
Compile
:
sig
type
normal
val
normal
:
descr
->
normal
type
dispatcher
val
dispatcher
:
Types
.
descr
->
normal
array
->
dispatcher
type
actions
=
[
`Ignore
of
result
...
...
@@ -81,9 +77,9 @@ module Compile: sig
val
actions
:
dispatcher
->
actions
val
show
:
Format
.
formatter
->
Types
.
descr
->
normal
array
->
unit
val
make_branches
:
Types
.
descr
->
(
node
*
'
a
)
list
->
dispatcher
*
((
capture
,
int
)
SortedMap
.
t
*
'
a
)
array
val
debug_compile
:
Format
.
formatter
->
Types
.
node
->
node
list
->
unit
end
types/types.ml
View file @
52770e6a
...
...
@@ -24,13 +24,13 @@ type pair_kind = [ `Normal | `XML ]
module
I
=
struct
type
'
a
t
=
{
ints
:
Intervals
.
t
;
atoms
:
atom
Atoms
.
t
;
ints
:
Intervals
.
t
;
chars
:
Chars
.
t
;
times
:
(
'
a
*
'
a
)
Boolean
.
t
;
xml
:
(
'
a
*
'
a
)
Boolean
.
t
;
arrow
:
(
'
a
*
'
a
)
Boolean
.
t
;
record
:
(
label
*
bool
*
'
a
)
Boolean
.
t
;
chars
:
Chars
.
t
;
}
let
empty
=
{
...
...
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