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
9f9826f5
Commit
9f9826f5
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2002-11-10 22:26:37 by cvscast] Passage au type XML
Original author: cvscast Date: 2002-11-10 22:26:39+00:00
parent
6085e08a
Changes
19
Expand all
Hide whitespace changes
Inline
Side-by-side
driver/cduce.ml
View file @
9f9826f5
...
...
@@ -6,7 +6,7 @@ let eval_env = Eval.global_env
let
print_norm
ppf
d
=
Location
.
protect
ppf
(
fun
ppf
->
Types
.
Print
.
print_descr
ppf
(
(
*
Types
.
normalize
*
)
d
))
(
fun
ppf
->
Types
.
Print
.
print_descr
ppf
(
Types
.
normalize
d
))
let
print_value
ppf
v
=
Location
.
protect
ppf
(
fun
ppf
->
Value
.
print
ppf
v
)
...
...
driver/webiface.ml
View file @
9f9826f5
...
...
@@ -170,7 +170,6 @@ let main (cgi : Netcgi.std_activation) =
Location
.
set_source
(
`String
src
);
Load_xml
.
set_auth
false
;
load_state
()
;
let
ok
=
Cduce
.
run
ppf
input
in
if
ok
then
Format
.
fprintf
ppf
"@
\n
Ok.@
\n
"
;
let
res
=
Format
.
flush_str_formatter
()
in
...
...
@@ -180,8 +179,6 @@ let main (cgi : Netcgi.std_activation) =
let
dump
src
=
let
ppf
=
Format
.
str_formatter
in
load_state
()
;
store_state
()
;
(* Just touch the file ... *)
Format
.
fprintf
ppf
"<b>Environment</b>:@."
;
Cduce
.
dump_env
ppf
;
...
...
@@ -192,6 +189,8 @@ let main (cgi : Netcgi.std_activation) =
in
Location
.
set_viewport
`Html
;
load_state
()
;
store_state
()
;
(* Just touch the file ... *)
html_header
p
;
let
prog
=
cgi
#
argument_value
"prog"
in
(
match
cmd
with
...
...
parser/ast.ml
View file @
9f9826f5
...
...
@@ -31,6 +31,7 @@ and pexpr' =
(* Data constructors *)
|
Cst
of
Types
.
const
|
Pair
of
pexpr
*
pexpr
|
Xml
of
pexpr
*
pexpr
|
RecordLitt
of
(
Types
.
label
*
pexpr
)
list
(* Data destructors *)
...
...
@@ -61,6 +62,7 @@ and ppat' =
|
And
of
ppat
*
ppat
*
bool
|
Diff
of
ppat
*
ppat
|
Prod
of
ppat
*
ppat
|
XmlT
of
ppat
*
ppat
|
Arrow
of
ppat
*
ppat
|
Record
of
Types
.
label
*
bool
*
ppat
|
Capture
of
Patterns
.
capture
...
...
parser/parser.ml
View file @
9f9826f5
...
...
@@ -137,11 +137,10 @@ EXTEND
mk
loc
(
Cst
(
Types
.
Atom
(
Types
.
AtomPool
.
mk
a
)))
|
"<"
;
e
=
expr
LEVEL
"no_appl"
->
e
];
a
=
expr_attrib_spec
;
">"
;
c
=
expr
->
tuple
loc
[
t
;
a
;
c
]
mk
loc
(
Xml
(
t
,
mk
loc
(
Pair
(
a
,
c
))))
|
"{"
;
r
=
[
expr_record_spec
|
->
mk
loc
(
RecordLitt
[]
)
];
"}"
->
r
|
s
=
STRING2
->
tuple
loc
(
char_list
loc
s
@
[
cst_nil
])
(* | "!"; t = pat -> mk loc (DebugTyper t) *)
|
a
=
LIDENT
->
mk
loc
(
Var
a
)
]
...
...
@@ -281,7 +280,7 @@ EXTEND
|
[
"<"
;
t
=
pat
->
t
]
];
a
=
attrib_spec
;
">"
;
c
=
pat
->
multi_prod
loc
[
t
;
a
;
c
]
mk
loc
(
XmlT
(
t
,
multi_prod
loc
[
a
;
c
]
))
|
s
=
STRING2
->
let
s
=
seq_of_string
loc
s
in
let
s
=
List
.
map
...
...
runtime/eval.ml
View file @
9f9826f5
...
...
@@ -47,6 +47,7 @@ let rec eval env e0 =
*)
|
Typed
.
RecordLitt
r
->
Record
(
List
.
map
(
fun
(
l
,
e
)
->
(
l
,
eval
env
e
))
r
)
|
Typed
.
Pair
(
e1
,
e2
)
->
Pair
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Xml
(
e1
,
e2
)
->
Xml
(
eval
env
e1
,
eval
env
e2
)
|
Typed
.
Cst
c
->
const
c
|
Typed
.
Match
(
arg
,
brs
)
->
eval_branches
env
brs
(
eval
env
arg
)
|
Typed
.
Map
(
arg
,
brs
)
->
eval_map
env
brs
(
eval
env
arg
)
...
...
runtime/load_xml.ml
View file @
9f9826f5
...
...
@@ -40,7 +40,7 @@ let run s =
let
att
=
SortedMap
.
from_list
(
fun
_
_
->
assert
false
)
att
in
let
child
=
parse_seq
()
in
let
elt
=
Pair
let
elt
=
Xml
(
Atom
(
Types
.
AtomPool
.
mk
name
)
,
Pair
(
Record
att
,
child
)
)
in
...
...
runtime/run_dispatch.ml
View file @
9f9826f5
...
...
@@ -49,6 +49,7 @@ let rec run_dispatcher d v =
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
|
Atom
a
->
run_disp_basic
v
(
fun
t
->
Types
.
Atom
.
has_atom
t
a
)
...
...
runtime/value.ml
View file @
9f9826f5
type
t
=
|
Pair
of
t
*
t
|
Xml
of
t
*
t
|
Record
of
(
Types
.
label
,
t
)
SortedMap
.
t
|
Atom
of
Types
.
atom
|
Integer
of
Big_int
.
big_int
...
...
@@ -48,10 +49,10 @@ let rec is_str = function
let
rec
print
ppf
v
=
if
is_str
v
then
Format
.
fprintf
ppf
"
\"
%a
\"
"
print_quoted_str
v
else
if
is_xml
v
then
print_xml
ppf
v
else
if
is_seq
v
then
Format
.
fprintf
ppf
"[ %a]"
print_seq
v
else
match
v
with
|
Pair
(
x
,
y
)
->
Format
.
fprintf
ppf
"(%a,%a)"
print
x
print
y
|
Xml
(
x
,
y
)
->
print_xml
ppf
(
x
,
y
)
|
Record
l
->
Format
.
fprintf
ppf
"{%a }"
print_record
l
|
Atom
a
->
Format
.
fprintf
ppf
"`%s"
(
Types
.
AtomPool
.
value
a
)
|
Integer
i
->
Format
.
fprintf
ppf
"%s"
(
Big_int
.
string_of_big_int
i
)
...
...
@@ -87,7 +88,7 @@ and print_str ppf = function
print_seq
ppf
v
and
print_xml
ppf
=
function
|
Pair
(
Atom
tag
,
Pair
(
Record
attr
,
content
))
->
|
(
Atom
tag
,
Pair
(
Record
attr
,
content
))
->
Format
.
fprintf
ppf
"@[<hv2><%s%a>[@ %a@]]"
(
Types
.
AtomPool
.
value
tag
)
print_record
attr
...
...
runtime/value.mli
View file @
9f9826f5
type
t
=
(* Canonical representation *)
|
Pair
of
t
*
t
|
Xml
of
t
*
t
|
Record
of
(
Types
.
label
,
t
)
SortedMap
.
t
|
Atom
of
Types
.
atom
|
Integer
of
Big_int
.
big_int
...
...
tests/biblio.cd
View file @
9f9826f5
...
...
@@ -18,14 +18,14 @@ type Mix = <h1>[Mix*]
let fun do_authors ([Author+] -> [Mix*])
| [
<author>
a ] -> a
| [
<author>
a
<author>
b ] -> a " and, " b
| [
<author>
a; x] -> a ", " (do_authors x);;
| [
<author>
a
<author>
b ] -> a
@
" and, "
@
b
| [
<author>
a; x] -> a
@
", "
@
(do_authors x);;
let fun do_paper (Paper ->
<li>
[Mix*])
<paper>
[ x::(_* )
<title>
t
<conference>
c
<file>
f ] ->
(* Here, type inference says: x : [Author+] ... *)
let authors = do_authors x in
<li>
([
<a
href=
f
>
t ] authors "; in " [
<em>
c ] "." );;
<li>
([
<a
href=
f
>
t ]
@
authors
@
"; in "
@
[
<em>
c ]
@
"." );;
let fun do_biblio (Biblio -> Html)
<bibliography>
[
<heading>
h; p ] ->
...
...
tests/overloading.cd
View file @
9f9826f5
...
...
@@ -26,4 +26,4 @@ let base : Person =
]
]
]
in sort
3
;;
in sort
base
;;
types/atoms.ml
View file @
9f9826f5
...
...
@@ -33,6 +33,10 @@ let contains x = function
let
is_empty
=
function
|
Finite
[]
->
true
|
_
->
false
let
is_atom
=
function
|
Finite
[
a
]
->
Some
a
|
_
->
None
let
sample
except
=
function
|
Finite
(
x
::
_
)
->
x
...
...
types/atoms.mli
View file @
9f9826f5
...
...
@@ -10,6 +10,7 @@ val atom : 'a -> 'a t
val
contains
:
'
a
->
'
a
t
->
bool
val
is_empty
:
'
a
t
->
bool
val
is_atom
:
'
a
t
->
'
a
option
val
sample
:
(
'
a
list
->
'
a
)
->
'
a
t
->
'
a
val
print
:
string
->
(
Format
.
formatter
->
'
a
->
unit
)
->
'
a
t
->
...
...
types/patterns.ml
View file @
9f9826f5
let
wrap
s
f
x
=
Printf
.
eprintf
"%s start
\n
"
s
;
flush
stderr
;
let
r
=
f
x
in
Printf
.
eprintf
"%s stop
\n
"
s
;
flush
stderr
;
r
type
capture
=
string
type
fv
=
capture
SortedList
.
t
...
...
@@ -17,6 +11,7 @@ type d =
|
Cup
of
descr
*
descr
|
Cap
of
descr
*
descr
*
bool
|
Times
of
node
*
node
|
Xml
of
node
*
node
|
Record
of
Types
.
label
*
node
|
Capture
of
capture
|
Constant
of
capture
*
Types
.
const
...
...
@@ -64,6 +59,8 @@ let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) e =
(
Types
.
cap
acc1
acc2
,
SortedList
.
cup
fv1
fv2
,
Cap
(
x1
,
x2
,
e
))
let
times
x
y
=
(
Types
.
times
x
.
accept
y
.
accept
,
SortedList
.
cup
x
.
fv
y
.
fv
,
Times
(
x
,
y
))
let
xml
x
y
=
(
Types
.
xml
x
.
accept
y
.
accept
,
SortedList
.
cup
x
.
fv
y
.
fv
,
Xml
(
x
,
y
))
let
record
l
x
=
(
Types
.
record
l
false
x
.
accept
,
x
.
fv
,
Record
(
l
,
x
))
let
capture
x
=
(
Types
.
any
,
[
x
]
,
Capture
x
)
...
...
@@ -101,18 +98,8 @@ let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
SortedMap
.
union
cup_res
(
filter_descr
t
d1
)
(
filter_descr
t
d2
)
|
Cap
((
a1
,_,_
)
as
d1
,
((
a2
,_,_
)
as
d2
)
,
false
)
->
SortedMap
.
union
cup_res
(
filter_descr
a2
d1
)
(
filter_descr
a1
d2
)
|
Times
(
p1
,
p2
)
->
List
.
fold_left
(
fun
accu
(
d1
,
d2
)
->
let
term
=
SortedMap
.
union
times_res
(
filter_node
d1
p1
)
(
filter_node
d2
p2
)
in
SortedMap
.
union
cup_res
accu
term
)
(
empty_res
fv
)
(
Types
.
Product
.
normal
t
)
|
Times
(
p1
,
p2
)
->
filter_prod
fv
p1
p2
t
|
Xml
(
p1
,
p2
)
->
filter_prod
~
kind
:
`XML
fv
p1
p2
t
|
Record
(
l
,
p
)
->
filter_node
(
Types
.
Record
.
project
t
l
)
p
|
Capture
c
->
...
...
@@ -120,6 +107,18 @@ let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
|
Constant
(
c
,
cst
)
->
[(
c
,
Types
.
Positive
.
ty
(
Types
.
constant
cst
))]
and
filter_prod
?
kind
fv
p1
p2
t
=
List
.
fold_left
(
fun
accu
(
d1
,
d2
)
->
let
term
=
SortedMap
.
union
times_res
(
filter_node
d1
p1
)
(
filter_node
d2
p2
)
in
SortedMap
.
union
cup_res
accu
term
)
(
empty_res
fv
)
(
Types
.
Product
.
normal
?
kind
t
)
and
filter_node
t
p
:
(
capture
,
Types
.
Positive
.
v
)
SortedMap
.
t
=
try
MemoFilter
.
find
(
t
,
p
)
!
memo_filter
with
Not_found
->
...
...
@@ -158,7 +157,9 @@ struct
a
:
Types
.
descr
;
basic
:
unit
line
;
prod
:
(
node
sl
*
node
sl
)
line
;
record
:
((
Types
.
label
,
node
sl
)
sm
)
line
xml
:
(
node
sl
*
node
sl
)
line
;
record
:
((
Types
.
label
,
node
sl
)
sm
)
line
;
}
type
'
a
nline
=
(
result
*
'
a
)
list
...
...
@@ -173,15 +174,17 @@ struct
na
:
Types
.
descr
;
nbasic
:
Types
.
descr
nline
;
nprod
:
(
nf
*
nf
)
nline
;
nxml
:
(
nf
*
nf
)
nline
;
nrecord
:
record
nline
}
let
empty
=
{
v
=
[]
;
catchv
=
[]
;
a
=
Types
.
empty
;
basic
=
[]
;
prod
=
[]
;
record
=
[]
}
let
any_basic
=
Types
.
neg
(
Types
.
cup
Types
.
Product
.
any
Types
.
Record
.
any
)
basic
=
[]
;
prod
=
[]
;
xml
=
[]
;
record
=
[]
}
let
any_basic
=
Types
.
neg
(
List
.
fold_left
Types
.
cup
Types
.
empty
[
Types
.
Product
.
any_xml
;
Types
.
Product
.
any
;
Types
.
Record
.
any
])
let
restrict
t
nf
=
let
rec
filter
=
function
|
(
key
,
acc
)
::
rem
->
...
...
@@ -194,6 +197,7 @@ struct
a
=
Types
.
cap
t
nf
.
a
;
basic
=
filter
nf
.
basic
;
prod
=
filter
nf
.
prod
;
xml
=
filter
nf
.
xml
;
record
=
filter
nf
.
record
;
}
...
...
@@ -222,6 +226,7 @@ struct
a
=
Types
.
cap
nf1
.
a
nf2
.
a
;
basic
=
merge
merge_basic
nf1
.
basic
nf2
.
basic
;
prod
=
merge
merge_prod
nf1
.
prod
nf2
.
prod
;
xml
=
merge
merge_prod
nf1
.
xml
nf2
.
xml
;
record
=
merge
merge_record
nf1
.
record
nf2
.
record
;
}
...
...
@@ -234,6 +239,7 @@ struct
a
=
Types
.
cup
nf1
.
a
nf2
.
a
;
basic
=
SortedMap
.
union
Types
.
cup
nf1
.
basic
nf2
.
basic
;
prod
=
SortedMap
.
union
Types
.
cup
nf1
.
prod
nf2
.
prod
;
xml
=
SortedMap
.
union
Types
.
cup
nf1
.
xml
nf2
.
xml
;
record
=
SortedMap
.
union
Types
.
cup
nf1
.
record
nf2
.
record
;
}
...
...
@@ -246,6 +252,15 @@ struct
a
=
acc
;
prod
=
[
(
src
,
([
p
]
,
[
q
]))
,
acc
]
}
let
xml
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
{
empty
with
v
=
SortedList
.
cup
p
.
fv
q
.
fv
;
a
=
acc
;
xml
=
[
(
src
,
([
p
]
,
[
q
]))
,
acc
]
}
let
record
acc
l
p
=
let
src
=
List
.
map
(
fun
v
->
(
v
,
`Field
l
))
p
.
fv
in
{
empty
with
...
...
@@ -259,6 +274,7 @@ struct
a
=
Types
.
any
;
basic
=
[
([]
,
()
)
,
any_basic
];
prod
=
[
([]
,
([]
,
[]
))
,
Types
.
Product
.
any
];
xml
=
[
([]
,
([]
,
[]
))
,
Types
.
Product
.
any_xml
];
record
=
[
([]
,
[]
)
,
Types
.
Record
.
any
];
}
...
...
@@ -269,6 +285,7 @@ struct
a
=
Types
.
any
;
basic
=
[
(
l
,
()
)
,
any_basic
];
prod
=
[
(
l
,
([]
,
[]
))
,
Types
.
Product
.
any
];
xml
=
[
(
l
,
([]
,
[]
))
,
Types
.
Product
.
any_xml
];
record
=
[
(
l
,
[]
)
,
Types
.
Record
.
any
];
}
...
...
@@ -279,6 +296,7 @@ struct
a
=
Types
.
any
;
basic
=
[
(
l
,
()
)
,
any_basic
];
prod
=
[
(
l
,
([]
,
[]
))
,
Types
.
Product
.
any
];
xml
=
[
(
l
,
([]
,
[]
))
,
Types
.
Product
.
any_xml
];
record
=
[
(
l
,
[]
)
,
Types
.
Record
.
any
];
}
...
...
@@ -288,6 +306,7 @@ struct
a
=
t
;
basic
=
[
([]
,
()
)
,
Types
.
cap
t
any_basic
];
prod
=
[
([]
,
([]
,
[]
))
,
Types
.
cap
t
Types
.
Product
.
any
];
xml
=
[
([]
,
([]
,
[]
))
,
Types
.
cap
t
Types
.
Product
.
any_xml
];
record
=
[
([]
,
[]
)
,
Types
.
cap
t
Types
.
Record
.
any
];
}
...
...
@@ -300,6 +319,7 @@ struct
|
Cap
(
p
,
q
,_
)
->
cap
(
nf
p
)
(
nf
q
)
|
Cup
((
acc1
,_,_
)
as
p
,
q
)
->
cup
acc1
(
nf
p
)
(
nf
q
)
|
Times
(
p
,
q
)
->
times
acc
p
q
|
Xml
(
p
,
q
)
->
xml
acc
p
q
|
Capture
x
->
capture
x
|
Constant
(
x
,
c
)
->
constant
x
c
|
Record
(
l
,
p
)
->
record
acc
l
p
...
...
@@ -310,13 +330,13 @@ struct
let
basic
=
List
.
map
(
fun
((
res
,
()
)
,
acc
)
->
(
res
,
acc
))
and
prod
=
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
t
=
Types
.
Product
.
normal
acc
in
let
t
=
Types
.
Product
.
normal
?
kind
acc
in
List
.
fold_left
aux
accu
t
in
List
.
fold_left
line
[]
List
.
fold_left
line
[]
l
and
record
=
...
...
@@ -359,6 +379,7 @@ struct
na
=
nf
.
a
;
nbasic
=
nlines
(
basic
nf
.
basic
);
nprod
=
nlines
(
prod
nf
.
prod
);
nxml
=
nlines
(
prod
~
kind
:
`XML
nf
.
xml
);
nrecord
=
nlines
(
record
nf
.
record
);
}
...
...
@@ -373,6 +394,7 @@ struct
and
actions_kind
=
{
basic
:
(
Types
.
descr
*
result
)
list
;
prod
:
result
dispatch
dispatch
;
xml
:
result
dispatch
dispatch
;
record
:
record
option
;
}
and
record
=
...
...
@@ -425,7 +447,7 @@ struct
in
aux
f
a
0
let
combine_kind
basic
prod
record
=
let
combine_kind
basic
prod
xml
record
=
try
(
let
rs
=
[]
in
let
rs
=
match
basic
with
...
...
@@ -436,6 +458,10 @@ struct
|
`None
->
rs
|
`Ignore
(
`Ignore
r
)
->
r
::
rs
|
_
->
raise
Exit
in
let
rs
=
match
xml
with
|
`None
->
rs
|
`Ignore
(
`Ignore
r
)
->
r
::
rs
|
_
->
raise
Exit
in
let
rs
=
match
record
with
|
None
->
rs
|
Some
(
`Result
r
)
->
r
::
rs
...
...
@@ -448,7 +474,7 @@ struct
->
`Ignore
r
|
_
->
raise
Exit
)
with
Exit
->
`Kind
{
basic
=
basic
;
prod
=
prod
;
record
=
record
}
with
Exit
->
`Kind
{
basic
=
basic
;
prod
=
prod
;
xml
=
xml
;
record
=
record
}
let
combine
(
disp
,
act
)
=
if
Array
.
length
act
=
0
then
`None
...
...
@@ -550,7 +576,8 @@ struct
|
`None
->
()
|
`Switch
(
pos
,
yes
,
no
)
->
aux
(
i
+
1
)
((
i
,
pos
)
::
accu
)
yes
;
aux
(
i
+
1
)
accu
no
|
`Result
(
code
,
t
,
arity
)
->
codes
.
(
code
)
<-
(
t
,
arity
,
accu
)
|
`Result
(
code
,
t
,
arity
)
->
codes
.
(
code
)
<-
(
t
,
arity
,
accu
)
in
aux
0
[]
iface
;
let
res
=
{
id
=
!
cur_id
;
...
...
@@ -576,7 +603,8 @@ struct
let
find_code
d
a
=
let
rec
aux
i
=
function
|
`Result
(
code
,_,_
)
->
code
|
`None
->
assert
false
|
`None
->
assert
false
|
`Switch
(
_
,
yes
,
no
)
->
match
a
.
(
i
)
with
Some
_
->
aux
(
i
+
1
)
yes
|
None
->
aux
(
i
+
1
)
no
in
...
...
@@ -698,9 +726,13 @@ struct
(
fun
x
->
x
)
let
rec
dispatch_prod
disp
=
let
pl
=
Array
.
map
(
fun
p
->
p
.
Normal
.
nprod
)
disp
.
pl
in
let
t
=
Types
.
Product
.
get
disp
.
t
in
let
rec
dispatch_prod
?
(
kind
=
`Normal
)
disp
=
let
pl
=
match
kind
with
|
`Normal
->
Array
.
map
(
fun
p
->
p
.
Normal
.
nprod
)
disp
.
pl
|
`XML
->
Array
.
map
(
fun
p
->
p
.
Normal
.
nxml
)
disp
.
pl
in
let
t
=
Types
.
Product
.
get
~
kind
disp
.
t
in
get_tests
pl
(
fun
(
res
,
(
p
,
q
))
->
[
p
,
(
res
,
q
)]
,
[]
)
(
Types
.
Product
.
pi1
t
)
...
...
@@ -852,6 +884,7 @@ struct
let
a
=
combine_kind
(
dispatch_basic
disp
)
(
dispatch_prod
disp
)
(
dispatch_prod
~
kind
:
`XML
disp
)
(
dispatch_record
disp
)
in
disp
.
actions
<-
Some
a
;
...
...
@@ -925,18 +958,18 @@ struct
)
branches
in
let
print_prod
=
function
let
print_prod
prefix
=
function
|
`None
->
()
|
`Ignore
d2
->
Format
.
fprintf
ppf
" | (v1,v2) -> @
\n
"
;
Format
.
fprintf
ppf
" |
%s
(v1,v2) -> @
\n
"
prefix
;
print_prod2
d2
|
`TailCall
d
->
queue
d
;
Format
.
fprintf
ppf
" | (v1,v2) -> @
\n
"
;
Format
.
fprintf
ppf
" |
%s
(v1,v2) -> @
\n
"
prefix
;
Format
.
fprintf
ppf
" disp_%i v1@
\n
"
d
.
id
|
`Dispatch
(
d
,
branches
)
->
queue
d
;
Format
.
fprintf
ppf
" | (v1,v2) -> @
\n
"
;
Format
.
fprintf
ppf
" |
%s
(v1,v2) -> @
\n
"
prefix
;
Format
.
fprintf
ppf
" match v1 with disp_%i@
\n
"
d
.
id
;
Array
.
iteri
(
fun
code
d2
->
...
...
@@ -984,7 +1017,8 @@ struct
in
List
.
iter
print_basic
actions
.
basic
;
print_prod
actions
.
prod
;
print_prod
""
actions
.
prod
;
print_prod
"XML"
actions
.
xml
;
print_record_opt
ppf
actions
.
record
let
print_actions
ppf
=
function
...
...
types/patterns.mli
View file @
9f9826f5
...
...
@@ -16,6 +16,7 @@ val cup : descr -> descr -> descr
val
cap
:
descr
->
descr
->
bool
->
descr
val
times
:
node
->
node
->
descr
val
xml
:
node
->
node
->
descr
val
record
:
Types
.
label
->
node
->
descr
val
capture
:
capture
->
descr
...
...
@@ -45,6 +46,7 @@ module Compile: sig
and
actions_kind
=
{
basic
:
(
Types
.
descr
*
result
)
list
;
prod
:
result
dispatch
dispatch
;
xml
:
result
dispatch
dispatch
;
record
:
record
option
;
}
and
record
=
...
...
types/types.ml
View file @
9f9826f5
This diff is collapsed.
Click to expand it.
types/types.mli
View file @
9f9826f5
...
...
@@ -39,9 +39,12 @@ val any : descr
(** Constructors **)
type
pair_kind
=
[
`Normal
|
`XML
]
val
interval
:
Intervals
.
t
->
descr
val
atom
:
atom
Atoms
.
t
->
descr
val
times
:
node
->
node
->
descr
val
xml
:
node
->
node
->
descr
val
arrow
:
node
->
node
->
descr
val
record
:
label
->
bool
->
node
->
descr
val
char
:
Chars
.
t
->
descr
...
...
@@ -65,13 +68,14 @@ end
module
Product
:
sig
val
any
:
descr
val
other
:
descr
->
descr
val
is_product
:
descr
->
bool
val
any_xml
:
descr
val
other
:
?
kind
:
pair_kind
->
descr
->
descr
val
is_product
:
?
kind
:
pair_kind
->
descr
->
bool
(* List of non-empty rectangles *)
type
t
=
(
descr
*
descr
)
list
val
is_empty
:
t
->
bool
val
get
:
descr
->
t
val
get
:
?
kind
:
pair_kind
->
descr
->
t
val
pi1
:
t
->
descr
val
pi2
:
t
->
descr
...
...
@@ -81,7 +85,7 @@ module Product : sig
(* List of non-empty rectangles whose first projection
are pair-wise disjunct *)
type
normal
=
t
val
normal
:
descr
->
normal
val
normal
:
?
kind
:
pair_kind
->
descr
->
normal
val
need_second
:
t
->
bool
(* Is there more than a single rectangle ? *)
...
...
@@ -177,7 +181,8 @@ sig
|
Int
of
Big_int
.
big_int
|
Atom
of
atom
|
Char
of
Chars
.
Unichar
.
t
|
Pair
of
t
*
t
|
Pair
of
(
t
*
t
)
|
Xml
of
(
t
*
t
)
|
Record
of
(
label
*
t
)
list
|
Fun
of
(
node
*
node
)
list
...
...
typing/typed.ml
View file @
9f9826f5
...
...
@@ -28,6 +28,7 @@ and texpr' =
(* Data constructors *)
|
Cst
of
Types
.
const
|
Pair
of
texpr
*
texpr
|
Xml
of
texpr
*
texpr
|
RecordLitt
of
(
Types
.
label
,
texpr
)
SortedMap
.
t
(* Data destructors *)
...
...
typing/typer.ml
View file @
9f9826f5
...
...
@@ -31,6 +31,7 @@ and descr =
|
`And
of
ti
*
ti
*
bool
|
`Diff
of
ti
*
ti
|
`Times
of
ti
*
ti
|
`Xml
of
ti
*
ti
|
`Arrow
of
ti
*
ti
|
`Record
of
Types
.
label
*
bool
*
ti
|
`Capture
of
Patterns
.
capture
...
...
@@ -190,6 +191,7 @@ let rec compile env { loc = loc; descr = d } : ti =
|
And
(
t1
,
t2
,
e
)
->
cons
loc
(
`And
(
compile
env
t1
,
compile
env
t2
,
e
))
|
Diff
(
t1
,
t2
)
->
cons
loc
(
`Diff
(
compile
env
t1
,
compile
env
t2
))
|
Prod
(
t1
,
t2
)
->
cons
loc
(
`Times
(
compile
env
t1
,
compile
env
t2
))
|
XmlT
(
t1
,
t2
)
->
cons
loc
(
`Xml
(
compile
env
t1
,
compile
env
t2
))
|
Arrow
(
t1
,
t2
)
->
cons
loc
(
`Arrow
(
compile
env
t1
,
compile
env
t2
))
|
Record
(
l
,
o
,
t
)
->
cons
loc
(
`Record
(
l
,
o
,
compile
env
t
))
|
Constant
(
x
,
v
)
->
cons
loc
(
`Constant
(
x
,
v
))
...
...
@@ -213,7 +215,7 @@ let rec comp_fv s =
|
`Or
(
s1
,
s2
)
|
`And
(
s1
,
s2
,_
)
|
`Diff
(
s1
,
s2
)
|
`Times
(
s1
,
s2
)
|
`Times
(
s1
,
s2
)
|
`Xml
(
s1
,
s2
)
|
`Arrow
(
s1
,
s2
)
->
comp_fv
s1
;
comp_fv
s2
|
`Record
(
l
,
opt
,
s
)
->
comp_fv
s
|
`Type
_
->
()
...
...
@@ -248,6 +250,7 @@ let rec typ seen s : Types.descr =
|
`And
(
s1
,
s2
,_
)
->
Types
.
cap
(
typ
seen
s1
)
(
typ
seen
s2
)
|
`Diff
(
s1
,
s2
)
->
Types
.
diff
(
typ
seen
s1
)
(
typ
seen
s2
)
|
`Times
(
s1
,
s2
)
->
Types
.
times
(
typ_node
s1
)
(
typ_node
s2
)
|
`Xml
(
s1
,
s2
)
->
Types
.
xml
(
typ_node
s1
)
(
typ_node
s2
)
|
`Arrow
(
s1
,
s2
)
->
Types
.
arrow
(
typ_node
s1
)
(
typ_node
s2
)
|
`Record
(
l
,
o
,
s
)
->
Types
.
record
l
o
(
typ_node
s
)
|
`Capture
_
|
`Constant
_
->
assert
false
...
...
@@ -290,6 +293,7 @@ and pat_aux seen s = match s.descr' with
|
`Diff
_
->
raise
(
Patterns
.
Error
"Difference not allowed in patterns"
)
|
`Times
(
s1
,
s2
)
->
Patterns
.
times
(
pat_node
s1
)
(
pat_node
s2
)
|
`Xml
(
s1
,
s2
)
->
Patterns
.
xml
(
pat_node
s1
)
(
pat_node
s2
)
|
`Record
(
l
,
false
,
s
)
->
Patterns
.
record
l
(
pat_node
s
)