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
8d7ec92c
Commit
8d7ec92c
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-12-02 23:05:47 by cvscast] Empty log message
Original author: cvscast Date: 2002-12-02 23:05:47+00:00
parent
46e329bb
Changes
3
Hide whitespace changes
Inline
Side-by-side
runtime/run_dispatch.ml
View file @
8d7ec92c
(* Running dispatchers *)
(* TODO: remove `Absent and clean .... *)
open
Value
...
...
@@ -94,28 +96,27 @@ and run_disp_prod2 v1 r1 v v2 x =
and
run_disp_record
f
v
bindings
fields
other
=
function
|
None
->
assert
false
|
Some
record
->
run_disp_record'
f
v
bindings
None
fields
other
record
|
Some
record
->
run_disp_record'
f
v
bindings
fields
other
record
and
run_disp_record'
f
v
bindings
abs
fields
other
=
function
and
run_disp_record'
f
v
bindings
fields
other
=
function
|
`Result
r
->
make_result_record
f
v
bindings
r
|
`Result_other
(
r1
,
r2
)
->
|
`Result_other
(
_
,
r1
,
r2
)
->
let
other
=
other
||
fields
<>
[]
in
make_result_record
f
v
bindings
(
if
other
then
r1
else
r2
)
|
`Absent
->
run_disp_record
f
v
bindings
fields
other
abs
|
`Label
(
l
,
present
,
absent
)
->
let
rec
aux
other
=
function
|
(
l1
,_
)
::
rem
when
l1
<
l
->
aux
true
rem
|
(
l1
,
vl
)
::
rem
when
l1
=
l
->
run_disp_field
f
v
bindings
abs
rem
other
l
vl
present
run_disp_field
f
v
bindings
rem
other
l
vl
present
|
_
->
run_disp_record
f
v
bindings
fields
other
absent
in
aux
other
fields
and
run_disp_field
f
v
bindings
abs
fields
other
l
vl
=
function
and
run_disp_field
f
v
bindings
fields
other
l
vl
=
function
|
`None
->
assert
false
|
`Ignore
r
->
run_disp_record'
f
v
bindings
abs
fields
other
r
|
`Ignore
r
->
run_disp_record'
f
v
bindings
fields
other
r
|
`TailCall
d
->
run_dispatcher
d
vl
|
`Dispatch
(
dl
,
bl
)
->
let
(
codel
,
rl
)
=
run_dispatcher
dl
vl
in
run_disp_record'
f
v
((
l
,
rl
)
::
bindings
)
abs
fields
other
bl
.
(
codel
)
run_disp_record'
f
v
((
l
,
rl
)
::
bindings
)
fields
other
bl
.
(
codel
)
types/patterns.ml
View file @
8d7ec92c
...
...
@@ -1046,8 +1046,7 @@ struct
and
record
=
[
`Label
of
Types
.
label
*
record
dispatch
*
record
option
|
`Result
of
result
|
`Result_other
of
result
*
result
|
`Absent
]
|
`Result_other
of
Types
.
label
list
*
result
*
result
]
and
'
a
dispatch
=
[
`Dispatch
of
dispatcher
*
'
a
array
...
...
@@ -1135,8 +1134,8 @@ struct
let
combine_record
l
present
absent
=
match
(
present
,
absent
)
with
|
(
`Ignore
r1
,
Some
r2
)
when
r1
=
r2
->
r1
|
(
`Ignore
`Absent
,
Some
r
)
->
r
|
(
`
Ignore
r
,
None
)
->
r
|
(
`Ignore
r
,
None
)
->
r
|
(
`
None
,
Some
r
)
->
r
|
_
->
`Label
(
l
,
present
,
absent
)
let
detect_right_tail_call
=
function
...
...
@@ -1231,13 +1230,8 @@ struct
aux
0
d
.
interface
let
create_result
pl
=
Array
.
of_list
(
Array
.
fold_right
(
fun
x
accu
->
match
x
with
|
Some
b
->
b
@
accu
|
None
->
accu
)
pl
[]
)
let
aux
x
accu
=
match
x
with
Some
b
->
b
@
accu
|
None
->
accu
in
Array
.
of_list
(
Array
.
fold_right
aux
pl
[]
)
let
return
disp
pl
f
=
let
aux
=
function
[
x
]
->
Some
(
f
x
)
|
[]
->
None
|
_
->
assert
false
in
...
...
@@ -1441,12 +1435,12 @@ struct
let
prep
p
=
List
.
map
(
fun
(
res
,
r
)
->
(
res
,
[]
,
r
))
p
.
Normal
.
nrecord
in
let
pl0
=
Array
.
map
prep
disp
.
pl
in
let
t
=
Types
.
Record
.
get
disp
.
t
in
let
r
=
dispatch_record_opt
disp
t
pl0
in
let
r
=
dispatch_record_opt
disp
t
pl0
[]
in
(* memo_dispatch_record := []; *)
r
and
dispatch_record_opt
disp
t
pl
=
and
dispatch_record_opt
disp
t
pl
labs
=
if
Types
.
Record
.
is_empty
t
then
None
else
Some
(
dispatch_record_label
disp
t
pl
)
else
Some
(
dispatch_record_label
disp
t
pl
labs
)
(* and dispatch_record_label disp t pl =
try List.assoc (t,pl) !memo_dispatch_record
with Not_found ->
...
...
@@ -1458,7 +1452,7 @@ struct
let r = !memo_dr_count, r in
memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
r *)
and
dispatch_record_label
disp
t
pl
=
and
dispatch_record_label
disp
t
pl
labs
=
match
collect_first_label
pl
with
|
None
->
let
aux_final
(
res
,
catch
,
x
)
=
...
...
@@ -1479,36 +1473,32 @@ struct
in
(
match
(
somefield
,
nofield
)
with
|
Some
r1
,
Some
r2
->
if
r1
=
r2
then
`Result
r1
else
`Result_other
(
r1
,
r2
)
if
r1
=
r2
then
`Result
r1
else
`Result_other
(
labs
,
r1
,
r2
)
|
Some
r1
,
None
->
`Result
r1
|
None
,
Some
r2
->
`Result
r2
|
_
->
assert
false
)
|
Some
l
->
let
labs
=
l
::
labs
in
let
(
plabs
,
absent
)
=
let
pl
=
label_not_found
l
pl
in
let
t
=
Types
.
Record
.
restrict_label_absent
t
l
in
pl
,
dispatch_record_opt
disp
t
pl
pl
,
dispatch_record_opt
disp
t
pl
labs
in
let
present
=
let
pl
=
label_found
l
pl
in
let
t
=
Types
.
Record
.
restrict_label_present
t
l
in
if
Types
.
Record
.
is_empty
t
then
None
else
Some
(
get_tests
pl
(
function
|
(
res
,
catch
,
`Dispatch
d
)
->
List
.
map
(
fun
(
p
,
r
)
->
p
,
(
res
,
catch
,
r
))
d
,
[]
|
x
->
[]
,
[
x
])
(
Types
.
Record
.
project_field
t
l
)
(
dispatch_record_field
l
disp
t
plabs
)
(
fun
x
->
combine
x
)
)
if
Types
.
Record
.
is_empty
t
then
`None
else
get_tests
pl
(
function
|
(
res
,
catch
,
`Dispatch
d
)
->
List
.
map
(
fun
(
p
,
r
)
->
p
,
(
res
,
catch
,
r
))
d
,
[]
|
x
->
[]
,
[
x
])
(
Types
.
Record
.
project_field
t
l
)
(
dispatch_record_field
l
disp
t
plabs
labs
)
(
fun
x
->
combine
x
)
in
(
match
(
present
,
absent
)
with
|
(
Some
present
,
absent
)
->
combine_record
l
present
absent
|
(
None
,
Some
absent
)
->
absent
|
_
->
assert
false
)
and
dispatch_record_field
l
disp
t
plabs
tfield
pl
others
=
combine_record
l
present
absent
and
dispatch_record_field
l
disp
t
plabs
labs
tfield
pl
others
=
let
t
=
Types
.
Record
.
restrict_field
t
l
tfield
in
let
aux
(
ret
,
ncatchv
,
(
res
,
catch
,
rem
))
=
let
catch
=
if
ret
=
[]
then
catch
else
(
l
,
ret
)
::
catch
in
...
...
@@ -1526,7 +1516,7 @@ struct
Need to investigate ....
*)
dispatch_record_label
disp
t
pl
dispatch_record_label
disp
t
pl
labs
let
actions
disp
=
...
...
@@ -1638,9 +1628,8 @@ struct
Format
.
fprintf
ppf
" @[%a@]@
\n
"
print_record
r
and
print_record
ppf
=
function
|
`Result
r
->
Format
.
fprintf
ppf
"%a"
print_ret
r
|
`Result_other
(
r1
,
r2
)
->
Format
.
fprintf
ppf
"SomeField:%a;NoField:%a"
|
`Result_other
(
_
,
r1
,
r2
)
->
Format
.
fprintf
ppf
"SomeField:%a;NoField:%a"
print_ret
r1
print_ret
r2
|
`Absent
->
Format
.
fprintf
ppf
"Jump to Absent"
|
`Label
(
l
,
present
,
absent
)
->
let
l
=
Types
.
LabelPool
.
value
l
in
Format
.
fprintf
ppf
"check label %s:@
\n
"
l
;
...
...
types/patterns.mli
View file @
8d7ec92c
...
...
@@ -60,8 +60,7 @@ module Compile: sig
and
record
=
[
`Label
of
Types
.
label
*
record
dispatch
*
record
option
|
`Result
of
result
|
`Result_other
of
result
*
result
|
`Absent
]
|
`Result_other
of
Types
.
label
list
*
result
*
result
]
and
'
a
dispatch
=
[
`Dispatch
of
dispatcher
*
'
a
array
...
...
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