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
0f6bf435
Commit
0f6bf435
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-11-24 17:25:48 by cvscast] Empty log message
Original author: cvscast Date: 2002-11-24 17:25:48+00:00
parent
5afe3e5f
Changes
3
Hide whitespace changes
Inline
Side-by-side
types/patterns.ml
View file @
0f6bf435
...
...
@@ -707,20 +707,20 @@ struct
record
:
((
Types
.
label
,
node
sl
)
sm
)
line
;
}
type
nnf
=
Types
.
descr
*
node
sl
type
'
a
nline
=
(
result
*
'
a
)
list
type
record
=
[
`Success
|
`Fail
|
`Dispatch
of
(
nf
*
record
)
list
|
`Label
of
Types
.
label
*
(
nf
*
record
)
list
*
record
]
|
`Dispatch
of
(
n
nf
*
record
)
list
|
`Label
of
Types
.
label
*
(
n
nf
*
record
)
list
*
record
]
type
t
=
{
nfv
:
fv
;
ncatchv
:
fv
;
na
:
Types
.
descr
;
nbasic
:
Types
.
descr
nline
;
nprod
:
(
nf
*
nf
)
nline
;
nxml
:
(
nf
*
nf
)
nline
;
nprod
:
(
n
nf
*
n
nf
)
nline
;
nxml
:
(
n
nf
*
n
nf
)
nline
;
nrecord
:
record
nline
}
...
...
@@ -870,7 +870,7 @@ struct
|
Constant
(
x
,
c
)
->
constant
x
c
|
Record
(
l
,
p
)
->
record
acc
l
p
let
bigcap
=
List
.
fold_left
(
fun
a
p
->
cap
a
(
nf
(
descr
p
)))
any
let
bigcap
pl
=
pl
(*
List.fold_left (fun a p -> cap a (nf (descr p))) any
*)
let
normal
nf
=
let
basic
=
...
...
@@ -878,8 +878,7 @@ struct
and
prod
?
kind
l
=
let
line
accu
(((
res
,
(
pl
,
ql
))
,
acc
))
=
let
p
=
bigcap
pl
and
q
=
bigcap
ql
in
let
aux
accu
(
t1
,
t2
)
=
(
res
,
(
restrict
t1
p
,
restrict
t2
q
))
::
accu
in
let
aux
accu
(
t1
,
t2
)
=
(
res
,
(
(
t1
,
pl
)
,
(
t2
,
ql
)
))
::
accu
in
let
t
=
Types
.
Product
.
normal
?
kind
acc
in
List
.
fold_left
aux
accu
t
in
List
.
fold_left
line
[]
l
...
...
@@ -891,18 +890,17 @@ struct
|
(
`Success
,
[]
)
->
`Success
|
(
`Fail
,_
)
->
`Fail
|
(
`Success
,
(
l2
,
pl
)
::
fields
)
->
`Label
(
l2
,
[
bigcap
pl
,
aux
nr
fields
]
,
`Fail
)
`Label
(
l2
,
[
(
Types
.
any
,
pl
)
,
aux
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
_
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l2
<
l1
->
`Label
(
l2
,
[
bigcap
pl
,
aux
nr
fields
]
,
`Fail
)
`Label
(
l2
,
[
(
Types
.
any
,
pl
)
,
aux
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l1
=
l2
->
let
p
=
bigcap
pl
in
let
pr
=
List
.
map
(
fun
(
t
,
x
)
->
(
restrict
t
p
,
aux
x
fields
))
pr
in
List
.
map
(
fun
(
t
,
x
)
->
(
(
t
,
pl
)
,
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
)
->
(
constr
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
...
...
@@ -1197,10 +1195,15 @@ struct
let
unselect
=
Array
.
create
(
Array
.
length
pl
)
[]
in
let
aux
i
x
=
let
yes
,
no
=
f
x
in
List
.
iter
(
fun
(
p
,
info
)
->
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
accu
:=
(
p
,
[
i
,
info
])
::
!
accu
;
accu
:=
(
p
,
[
i
,
p
.
Normal
.
ncatchv
,
info
])
::
!
accu
;
)
yes
;
unselect
.
(
i
)
<-
no
@
unselect
.
(
i
)
in
Array
.
iteri
(
fun
i
->
List
.
iter
(
aux
i
))
pl
;
...
...
@@ -1210,7 +1213,7 @@ struct
let
disp
=
dispatcher
t
(
Array
.
map
fst
sorted
)
in
let
result
(
t
,_,
m
)
=
let
selected
=
Array
.
create
(
Array
.
length
pl
)
[]
in
let
add
r
(
i
,
inf
)
=
selected
.
(
i
)
<-
(
r
,
inf
)
::
selected
.
(
i
)
in
let
add
r
(
i
,
ncv
,
inf
)
=
selected
.
(
i
)
<-
(
r
,
ncv
,
inf
)
::
selected
.
(
i
)
in
List
.
iter
(
fun
(
j
,
r
)
->
List
.
iter
(
add
r
)
infos
.
(
j
))
m
;
d
t
selected
unselect
in
...
...
@@ -1222,9 +1225,9 @@ struct
let
(
_
,
brs
)
=
List
.
fold_left
(
fun
(
t
,
brs
)
(
p
,
e
)
->
let
p
=
Normal
.
restrict
t
(
Normal
.
nf
p
)
in
let
t
=
Types
.
diff
t
(
p
.
Normal
.
a
)
in
(
t
,
(
p
,
(
p
.
Normal
.
catchv
,
e
)
)
::
brs
)
let
p
'
=
(
t
,
[
p
]
)
in
let
t
'
=
Types
.
diff
t
(
Types
.
descr
(
accept
p
)
)
in
(
t
'
,
(
p
'
,
e
)
::
brs
)
)
(
t
,
[]
)
brs
in
let
pl
=
Array
.
map
(
fun
x
->
[
x
])
(
Array
.
of_list
brs
)
in
...
...
@@ -1235,7 +1238,7 @@ struct
(
fun
_
pl
_
->
let
r
=
ref
None
in
let
aux
=
function
|
[(
res
,
(
catchv
,
e
)
)
]
->
assert
(
!
r
=
None
);
|
[(
res
,
catchv
,
e
)]
->
assert
(
!
r
=
None
);
let
catchv
=
List
.
map
(
fun
v
->
(
v
,-
1
))
catchv
in
r
:=
Some
(
SortedMap
.
union_disj
catchv
res
,
e
)
|
[]
->
()
|
_
->
assert
false
in
...
...
@@ -1261,12 +1264,12 @@ struct
and
dispatch_prod1
disp
t
t1
pl
_
=
let
t
=
Types
.
Product
.
restrict_1
t
t1
in
get_tests
pl
(
fun
(
ret1
,
(
res
,
q
))
->
[
q
,
(
ret1
,
res
)]
,
[]
)
(
fun
(
ret1
,
ncatchv
,
(
res
,
q
))
->
[
q
,
(
ret1
,
res
)]
,
[]
)
(
Types
.
Product
.
pi2
t
)
(
dispatch_prod2
disp
t
)
(
fun
x
->
detect_right_tail_call
(
combine
x
))
and
dispatch_prod2
disp
t
t2
pl
_
=
let
aux_final
(
ret2
,
(
ret1
,
res
))
=
let
aux_final
(
ret2
,
ncatchv
,
(
ret1
,
res
))
=
List
.
map
(
conv_source_prod
ret1
ret2
)
res
in
return
disp
pl
aux_final
...
...
@@ -1386,7 +1389,7 @@ struct
combine_record
l
present
absent
and
dispatch_record_field
l
disp
t
plabs
tfield
pl
others
=
let
t
=
Types
.
Record
.
restrict_field
t
l
tfield
in
let
aux
(
ret
,
(
res
,
catch
,
rem
))
=
let
aux
(
ret
,
ncatchv
,
(
res
,
catch
,
rem
))
=
let
catch
=
if
ret
=
[]
then
catch
else
(
l
,
ret
)
::
catch
in
(
res
,
catch
,
rem
)
in
let
pl
=
Array
.
map
(
List
.
map
aux
)
pl
in
...
...
types/patterns.mli
View file @
0f6bf435
...
...
@@ -84,6 +84,6 @@ module Compile: sig
val
show
:
Format
.
formatter
->
Types
.
descr
->
normal
array
->
unit
val
make_branches
:
Types
.
descr
->
(
de
scr
*
'
a
)
list
->
Types
.
descr
->
(
no
de
*
'
a
)
list
->
dispatcher
*
((
capture
,
int
)
SortedMap
.
t
*
'
a
)
array
end
typing/typed.ml
View file @
0f6bf435
...
...
@@ -75,7 +75,7 @@ let dispatcher brs =
match
brs
.
br_compiled
with
|
Some
d
->
d
|
None
->
let
aux
b
=
Patterns
.
descr
b
.
br_pat
,
b
.
br_body
in
let
aux
b
=
b
.
br_pat
,
b
.
br_body
in
let
x
=
Patterns
.
Compile
.
make_branches
brs
.
br_typ
(
List
.
map
aux
brs
.
br_branches
)
in
...
...
@@ -88,7 +88,7 @@ let dispatcher_let_decl l =
|
None
->
let
comp
=
Patterns
.
Compile
.
make_branches
(
Types
.
descr
(
Patterns
.
accept
l
.
let_pat
))
[
Patterns
.
descr
l
.
let_pat
,
()
]
in
[
l
.
let_pat
,
()
]
in
let
x
=
match
comp
with
|
(
disp
,
[
|
l
,
()
|
])
->
(
disp
,
l
)
|
_
->
assert
false
...
...
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