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
27c6e232
Commit
27c6e232
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-12-02 22:22:04 by cvscast] Empty log message
Original author: cvscast Date: 2002-12-02 22:22:04+00:00
parent
c04b18d8
Changes
8
Hide whitespace changes
Inline
Side-by-side
depend
View file @
27c6e232
...
...
@@ -44,8 +44,6 @@ types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi misc/state.cmi \
types/types.cmi types/patterns.cmi
types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx misc/state.cmx \
types/types.cmx types/patterns.cmi
types/record.cmo: types/boolean.cmi types/sortedList.cmi
types/record.cmx: types/boolean.cmx types/sortedList.cmx
types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi
types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx
types/recursive_share.cmo: types/recursive.cmo misc/state.cmi
...
...
@@ -59,11 +57,11 @@ types/sortedMap.cmx: types/sortedMap.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi misc/pool.cmi types/recursive.cmo \
types/intervals.cmi
types/normal.cmi
misc/pool.cmi types/recursive.cmo \
types/recursive_noshare.cmo types/sortedList.cmi types/sortedMap.cmi \
misc/state.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx misc/pool.cmx types/recursive.cmx \
types/intervals.cmx
types/normal.cmx
misc/pool.cmx types/recursive.cmx \
types/recursive_noshare.cmx types/sortedList.cmx types/sortedMap.cmx \
misc/state.cmx types/types.cmi
runtime/eval.cmo: runtime/load_xml.cmi parser/location.cmi \
...
...
@@ -112,8 +110,8 @@ types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/sequence.cmi: types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/
boolean
.cmi types/
char
s.cmi \
types/intervals.cmi misc/pool
.cmi
types/types.cmi: types/atoms.cmi types/
chars
.cmi types/
interval
s.cmi \
misc/pool.cmi types/sortedMap
.cmi
runtime/eval.cmi: typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
...
...
runtime/run_dispatch.ml
View file @
27c6e232
...
...
@@ -50,7 +50,7 @@ and run_disp_kind actions v =
match
v
with
|
Pair
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
Patterns
.
Compile
.
prod
|
Xml
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
Patterns
.
Compile
.
xml
|
Record
r
->
run_disp_record
r
v
[]
r
actions
.
Patterns
.
Compile
.
record
|
Record
r
->
run_disp_record
r
v
[]
r
false
actions
.
Patterns
.
Compile
.
record
|
Atom
a
->
run_disp_basic
v
(
fun
t
->
Types
.
Atom
.
has_atom
t
a
)
actions
.
Patterns
.
Compile
.
basic
...
...
@@ -92,26 +92,30 @@ and run_disp_prod2 v1 r1 v v2 x =
let
(
code2
,
r2
)
=
run_dispatcher
d2
v2
in
make_result_prod
v1
r1
v2
r2
v
b2
.
(
code2
)
and
run_disp_record
f
v
bindings
fields
=
function
and
run_disp_record
f
v
bindings
fields
other
=
function
|
None
->
assert
false
|
Some
record
->
run_disp_record'
f
v
bindings
None
fields
record
|
Some
record
->
run_disp_record'
f
v
bindings
None
fields
other
record
and
run_disp_record'
f
v
bindings
abs
fields
=
function
|
`Result
r
->
make_result_record
f
v
bindings
r
|
`Absent
->
run_disp_record
f
v
bindings
fields
abs
and
run_disp_record'
f
v
bindings
abs
fields
other
=
function
|
`Result
r
->
make_result_record
f
v
bindings
r
|
`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
=
function
|
(
l1
,_
)
::
rem
when
l1
<
l
->
aux
rem
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
l
vl
present
|
_
->
run_disp_record
f
v
bindings
fields
absent
run_disp_field
f
v
bindings
abs
rem
other
l
vl
present
|
_
->
run_disp_record
f
v
bindings
fields
other
absent
in
aux
fields
aux
other
fields
and
run_disp_field
f
v
bindings
abs
fields
l
vl
=
function
and
run_disp_field
f
v
bindings
abs
fields
other
l
vl
=
function
|
`None
->
assert
false
|
`Ignore
r
->
run_disp_record'
f
v
bindings
abs
fields
r
|
`Ignore
r
->
run_disp_record'
f
v
bindings
abs
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
bl
.
(
codel
)
run_disp_record'
f
v
((
l
,
rl
)
::
bindings
)
abs
fields
other
bl
.
(
codel
)
types/patterns.ml
View file @
27c6e232
...
...
@@ -699,6 +699,8 @@ module Normal : sig
type
'
a
nline
=
(
result
*
'
a
)
list
type
record
=
[
`Success
|
`SomeField
|
`NoField
|
`Fail
|
`Dispatch
of
(
nnf
*
record
)
list
|
`Label
of
Types
.
label
*
(
nnf
*
record
)
list
*
record
]
...
...
@@ -742,6 +744,8 @@ struct
type
'
a
nline
=
(
result
*
'
a
)
sl
type
record
=
[
`Success
|
`SomeField
|
`NoField
|
`Fail
|
`Dispatch
of
(
nnf
*
record
)
list
|
`Label
of
Types
.
label
*
(
nnf
*
record
)
list
*
record
]
...
...
@@ -755,6 +759,9 @@ struct
nrecord
:
record
nline
}
let
fus
=
SortedMap
.
union_disj
let
slcup
=
SortedList
.
cup
(*
let nempty = { nfv = []; ncatchv = []; na = Types.empty;
nbasic = []; nprod = []; nxml = []; nrecord = [] }
...
...
@@ -771,9 +778,6 @@ struct
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
...
...
@@ -818,7 +822,7 @@ struct
na = acc;
nprod = SortedList.from_list prod
}
*)
let
empty
=
{
v
=
[]
;
catchv
=
[]
;
...
...
@@ -981,9 +985,11 @@ struct
let
rec
aux
nr
fields
=
match
(
nr
,
fields
)
with
|
(
`Success
,
[]
)
->
`Success
|
(
`Fail
,_
)
->
`Fail
|
(
`Success
,
(
l2
,
pl
)
::
fields
)
->
`Label
(
l2
,
[(
pl
,
Types
.
any
)
,
aux
nr
fields
]
,
`Fail
)
|
(
`SomeField
,
[]
)
->
`SomeField
|
(
`NoField
,
[]
)
->
`NoField
|
(
`Fail
,_
)
|
(
`NoField
,_::_
)
->
`Fail
|
((
`Success
|
`SomeField
)
,
(
l2
,
pl
)
::
fields
)
->
`Label
(
l2
,
[(
pl
,
Types
.
any
)
,
aux
`Success
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
_
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l2
<
l1
->
`Label
(
l2
,
[(
pl
,
Types
.
any
)
,
aux
nr
fields
]
,
`Fail
)
|
(
`Label
(
l1
,
pr
,
_
)
,
(
l2
,
pl
)
::
fields
)
when
l1
=
l2
->
...
...
@@ -999,9 +1005,6 @@ struct
if
x
==
ab
then
aux_ab
else
aux
x
fields
))
pr
in
`Label
(
l1
,
pr
,
aux_ab
)
(* TODO:!!!*)
|
((
`NoField
|
`SomeField
)
,_
)
->
aux
`Success
fields
in
let
line
accu
((
res
,
fields
)
,
acc
)
=
...
...
@@ -1043,6 +1046,7 @@ struct
and
record
=
[
`Label
of
Types
.
label
*
record
dispatch
*
record
option
|
`Result
of
result
|
`Result_other
of
result
*
result
|
`Absent
]
and
'
a
dispatch
=
...
...
@@ -1380,20 +1384,20 @@ struct
let
map_record
f
=
let
rec
aux
=
function
|
[]
->
[]
|
h
::
t
->
(
match
f
h
with
(
_
,_,
`Fail
)
->
aux
t
|
x
->
x
::
(
aux
t
))
in
|
(
res
,
catch
,
h
)
::
t
->
(
match
f
h
with
`Fail
->
aux
t
|
x
->
(
res
,
catch
,
x
)
::
(
aux
t
))
in
Array
.
map
aux
let
label_found
l
=
map_record
(
function
|
(
res
,
catch
,
`Label
(
l1
,
pr
,
_
))
when
l1
=
l
->
(
res
,
catch
,
`Dispatch
pr
)
|
`Label
(
l1
,
pr
,
_
)
when
l1
=
l
->
`Dispatch
pr
|
x
->
x
)
let
label_not_found
l
=
map_record
(
function
|
(
res
,
catch
,
`Label
(
l1
,
_
,
ab
)
)
when
l1
=
l
->
(
res
,
catch
,
ab
)
|
`Label
(
l1
,
_
,
ab
)
when
l1
=
l
->
ab
|
x
->
x
)
(*
...
...
@@ -1458,9 +1462,27 @@ struct
match
collect_first_label
pl
with
|
None
->
let
aux_final
(
res
,
catch
,
x
)
=
assert
(
x
=
`Success
);
List
.
map
(
conv_source_record
catch
)
res
in
`Result
(
return
disp
pl
aux_final
)
assert
(
x
=
`Success
);
List
.
map
(
conv_source_record
catch
)
res
in
let
somefield
=
if
Types
.
Record
.
somefield_possible
t
then
let
aux
=
function
`Success
|
`SomeField
->
`Success
|
_
->
`Fail
in
Some
(
return
disp
(
map_record
aux
pl
)
aux_final
)
else
None
in
let
nofield
=
if
Types
.
Record
.
nofield_possible
t
then
let
aux
=
function
`Success
|
`NoField
->
`Success
|
_
->
`Fail
in
Some
(
return
disp
(
map_record
aux
pl
)
aux_final
)
else
None
in
(
match
(
somefield
,
nofield
)
with
|
Some
r1
,
Some
r2
->
if
r1
=
r2
then
`Result
r1
else
`Result_other
(
r1
,
r2
)
|
Some
r1
,
None
->
`Result
r1
|
None
,
Some
r2
->
`Result
r2
|
_
->
assert
false
)
|
Some
l
->
let
(
plabs
,
absent
)
=
let
pl
=
label_not_found
l
pl
in
...
...
@@ -1470,16 +1492,22 @@ struct
let
present
=
let
pl
=
label_found
l
pl
in
let
t
=
Types
.
Record
.
restrict_label_present
t
l
in
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
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
)
)
in
combine_record
l
present
absent
(
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
=
let
t
=
Types
.
Record
.
restrict_field
t
l
tfield
in
let
aux
(
ret
,
ncatchv
,
(
res
,
catch
,
rem
))
=
...
...
@@ -1609,7 +1637,9 @@ struct
Format
.
fprintf
ppf
" | Record -> @
\n
"
;
Format
.
fprintf
ppf
" @[%a@]@
\n
"
print_record
r
and
print_record
ppf
=
function
|
`Result
r
->
print_ret
ppf
r
|
`Result
r
->
Format
.
fprintf
ppf
"%a"
print_ret
r
|
`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
...
...
@@ -1621,7 +1651,9 @@ struct
print_record
r
|
None
->
()
and
print_present
l
ppf
=
function
|
`None
->
assert
false
|
`None
->
Format
.
fprintf
ppf
"(cannot happen)"
(* assert false *)
|
`TailCall
d
->
queue
d
;
Format
.
fprintf
ppf
"disp_%i@
\n
"
d
.
id
...
...
types/patterns.mli
View file @
27c6e232
...
...
@@ -59,7 +59,8 @@ module Compile: sig
}
and
record
=
[
`Label
of
Types
.
label
*
record
dispatch
*
record
option
|
`Result
of
result
|
`Result
of
result
|
`Result_other
of
result
*
result
|
`Absent
]
and
'
a
dispatch
=
...
...
types/sortedMap.ml
View file @
27c6e232
...
...
@@ -50,6 +50,11 @@ let add f x y m =
let
change
x
f
=
add
(
fun
_
->
f
)
x
let
rec
change_exists
x1
f
=
function
|
[]
->
raise
Not_found
|
(
x
,
y
)
::
q
when
x
=
x1
->
(
x
,
f
y
)
::
q
|
h
::
q
->
h
::
(
change_exists
x1
f
q
)
let
rec
diff
l1
l2
=
match
(
l1
,
l2
)
with
|
(((
x1
,
y1
)
as
t1
)
::
q1
,
x2
::
q2
)
->
...
...
types/sortedMap.mli
View file @
27c6e232
...
...
@@ -11,6 +11,8 @@ val map: ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
val
add
:
(
'
b
->
'
b
->
'
b
)
->
'
a
->
'
b
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
b
)
t
val
change
:
'
a
->
(
'
b
->
'
b
)
->
'
b
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
b
)
t
val
change_exists
:
'
a
->
(
'
b
->
'
b
)
->
(
'
a
,
'
b
)
t
->
(
'
a
,
'
b
)
t
val
diff
:
(
'
a
,
'
b
)
t
->
'
a
SortedList
.
t
->
(
'
a
,
'
b
)
t
val
iter
:
(
'
a
->
'
b
->
unit
)
->
(
'
a
,
'
b
)
t
->
unit
...
...
types/types.ml
View file @
27c6e232
...
...
@@ -194,6 +194,8 @@ let any = descr any_node
let
neg
x
=
diff
any
x
let
any_node
=
cons
any
(*
let get_record r =
let add = SortedMap.add (fun (o1,t1) (o2,t2) -> (o1&&o2, cap t1 t2)) in
...
...
@@ -981,6 +983,12 @@ struct
|
(
true
,
[]
)
->
Boolean
.
full
|
(
o
,
l
)
->
Boolean
.
atom
(
o
,
l
)
let
somefield_possible
t
=
not
(
R
.
empty
(
R
.
diff
t
(
Boolean
.
atom
(
false
,
[]
))))
let
nofield_possible
t
=
not
(
R
.
empty
(
R
.
cap
t
(
Boolean
.
atom
(
false
,
[]
))))
let
restrict_label_absent
t
l
=
Boolean
.
compute_bool
(
fun
(
o
,
r
)
as
x
->
...
...
@@ -1023,11 +1031,16 @@ struct
TR
.
boolean
x
let
restrict_label_present
t
l
=
t
(*
let r = label_present t l in
List.fold_left (fun accu (_,t) -> Boolean.cup accu t) Boolean.empty r
*)
Boolean
.
compute_bool
(
fun
(
o
,
r
)
as
x
->
try
Boolean
.
atom
(
o
,
SortedMap
.
change_exists
l
(
fun
(
_
,
lt
)
->
(
false
,
lt
))
r
)
with
Not_found
->
if
o
then
Boolean
.
atom
(
true
,
SortedMap
.
union_disj
[
l
,
(
false
,
any_node
)]
r
)
else
Boolean
.
empty
)
t
let
project_field
t
l
=
let
r
=
label_present
t
l
in
...
...
types/types.mli
View file @
27c6e232
...
...
@@ -101,6 +101,8 @@ module Record : sig
val
restrict_label_absent
:
t
->
label
->
t
val
restrict_label_present
:
t
->
label
->
t
val
label_present
:
t
->
label
->
(
descr
*
t
)
list
val
somefield_possible
:
t
->
bool
val
nofield_possible
:
t
->
bool
val
any
:
descr
val
project_field
:
t
->
label
->
descr
val
project
:
descr
->
label
->
descr
...
...
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