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
286b3b8b
Commit
286b3b8b
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2002-12-05 15:47:05 by cvscast] Empty log message
Original author: cvscast Date: 2002-12-05 15:48:13+00:00
parent
535f1839
Changes
11
Expand all
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
286b3b8b
...
...
@@ -102,6 +102,7 @@ clean:
rm
-f
cduce cduce.opt ocamlprof.dump
rm
-f
dtd2cduce pool webiface
rm
-Rf
prepro
rm
-f
web/index.html
.SUFFIXES
:
.ml .mli .cmo .cmi .cmx
...
...
@@ -145,6 +146,8 @@ include depend
driver/examples.ml
:
cduce tests/web.cd tests/examples.xml
./cduce
-quiet
tests/web.cd
web/index.html
:
cduce
(
cd
web
;
../cduce
-quiet
macros.cd
)
# Site-specific installation
build_web
:
...
...
@@ -153,3 +156,7 @@ install_web:
ssh cduce@iris
"cp ~frisch/IMPLEM/CDUCE/webiface cgi-bin/cduce2; cp ~frisch/IMPLEM/CDUCE/memento.html public_html/; chmod +s cgi-bin/cduce2"
install_web_local
:
ssh root@localhost
"cp ~beppe/IMPLEM/CDUCE/webiface /var/www/cgi-bin/cduce; cp ~beppe/IMPLEM/CDUCE/memento.html /var/www/html/; chmod +s /var/www/cgi-bin/cduce"
build_website
:
rsh cedre
". .env; cd IMPLEM/CDUCE; make web/index.html"
scp web/index.html cduce@iris:public_html/
runtime/load_xml.ml
View file @
286b3b8b
...
...
@@ -36,10 +36,12 @@ let run s =
|
Some
x
->
curr
:=
x
|
None
->
()
in
let
txt
=
Buffer
.
create
1024
in
let
rec
parse_elt
name
att
=
let
att
=
List
.
map
(
fun
(
l
,
v
)
->
Types
.
LabelPool
.
mk
l
,
string
v
nil
)
att
in
let
att
=
SortedMap
.
from_list
(
fun
_
_
->
assert
false
)
att
in
let
child
=
parse_seq
true
in
let
child
=
parse_seq
()
in
let
elt
=
Xml
(
Atom
(
Types
.
AtomPool
.
mk
name
)
,
...
...
@@ -50,21 +52,27 @@ let run s =
|
_
->
failwith
"Expect end_tag"
);
elt
and
dump_txt
q
=
let
data
=
Buffer
.
contents
txt
in
Buffer
.
clear
txt
;
if
(
is_ws
data
)
then
q
()
else
string
data
(
q
()
)
and
parse_seq
dropws
=
and
parse_seq
()
=
match
!
curr
with
|
E_start_tag
(
name
,
att
,_
)
->
|
E_start_tag
(
name
,
att
,_
)
->
get
()
;
let
e1
=
parse_elt
name
att
in
let
rest
=
parse_seq
true
in
Pair
(
e1
,
rest
)
dump_txt
(
fun
()
->
let
e1
=
parse_elt
name
att
in
let
rest
=
parse_seq
()
in
Pair
(
e1
,
rest
)
)
|
E_char_data
data
->
get
()
;
if
dropws
&&
(
is_ws
data
)
then
parse_seq
true
else
string
data
(
parse_seq
false
)
get
()
;
Buffer
.
add_string
txt
data
;
parse_seq
()
|
E_end_tag
(
_
,_
)
->
nil
dump_txt
(
fun
()
->
nil
)
|
_
->
failwith
"Expect start_tag, char_data, or end_tag"
and
parse_doc
()
=
...
...
runtime/print_xml.ml
View file @
286b3b8b
...
...
@@ -30,6 +30,8 @@ let string_of_xml v=
and
write_att
(
n
,
v
)
=
wms
(
" "
^
n
^
"=
\"
"
);
wds
v
;
wms
"
\"
"
in
let
element_start
name
attrs
=
wms
(
"<"
^
name
);
List
.
iter
write_att
attrs
;
wms
"
\n
>"
and
empty_element
name
attrs
=
wms
(
"<"
^
name
);
List
.
iter
write_att
attrs
;
wms
"/>"
and
element_end
name
=
wms
(
"</"
^
name
^
"
\n
>"
)
and
document_start
()
=
(* wms ("<?xml version='1.0' encoding='" ^
...
...
@@ -41,12 +43,15 @@ let string_of_xml v=
let
rec
print_elt
=
function
|
Xml
(
Atom
tag
,
Pair
(
Record
attrs
,
content
))
->
let
tag
=
Types
.
AtomPool
.
value
tag
in
element_start
tag
(
List
.
map
(
fun
(
n
,
v
)
->
let
attrs
=
List
.
map
(
fun
(
n
,
v
)
->
if
not
(
is_str
v
)
then
raise
exn_print_xml
;
(
Types
.
LabelPool
.
value
n
,
get_string
v
))
attrs
);
print_content
content
;
element_end
tag
(
Types
.
LabelPool
.
value
n
,
get_string
v
))
attrs
in
(
match
content
with
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
empty_element
tag
attrs
|
_
->
element_start
tag
attrs
;
print_content
content
;
element_end
tag
)
|
Char
x
->
wds
(
String
.
make
1
(
Chars
.
Unichar
.
to_char
x
));
(* TODO: opt *)
|
_
->
raise
exn_print_xml
...
...
runtime/run_dispatch.ml
View file @
286b3b8b
...
...
@@ -3,16 +3,16 @@
(* TODO: remove `Absent and clean .... *)
open
Value
open
Patterns
.
Compile
let
make_result_prod
v1
r1
v2
r2
v
(
code
,
r
)
=
let
ret
=
Array
.
map
(
function
|
`
Catch
->
v
|
`
Const
c
->
const
c
|
`
Left
i
->
if
(
i
<
0
)
then
v1
else
r1
.
(
i
)
|
`
Right
j
->
if
(
j
<
0
)
then
v2
else
r2
.
(
j
)
|
`
Recompose
(
i
,
j
)
->
|
Catch
->
v
|
Const
c
->
const
c
|
Left
i
->
if
(
i
<
0
)
then
v1
else
r1
.
(
i
)
|
Right
j
->
if
(
j
<
0
)
then
v2
else
r2
.
(
j
)
|
Recompose
(
i
,
j
)
->
Pair
((
if
(
i
<
0
)
then
v1
else
r1
.
(
i
))
,
(
if
(
j
<
0
)
then
v2
else
r2
.
(
j
)))
|
_
->
assert
false
...
...
@@ -22,9 +22,9 @@ let make_result_prod v1 r1 v2 r2 v (code,r) =
let
make_result_record
fields
v
bindings
(
code
,
r
)
=
let
ret
=
Array
.
map
(
function
|
`
Catch
->
v
|
`
Const
c
->
const
c
|
`
Field
(
l
,
i
)
->
|
Catch
->
v
|
Const
c
->
const
c
|
Field
(
l
,
i
)
->
if
(
i
<
0
)
then
List
.
assoc
l
fields
else
(
List
.
assoc
l
bindings
)
.
(
i
)
|
_
->
assert
false
...
...
@@ -34,8 +34,8 @@ let make_result_record fields v bindings (code,r) =
let
make_result_basic
v
(
code
,
r
)
=
let
ret
=
Array
.
map
(
function
|
`
Catch
->
v
|
`
Const
c
->
const
c
|
Catch
->
v
|
Const
c
->
const
c
|
_
->
assert
false
)
r
in
(
code
,
ret
)
...
...
@@ -43,28 +43,24 @@ let make_result_basic v (code,r) =
let
dummy_r
=
[
||
]
let
rec
run_dispatcher
d
v
=
let
actions
=
Patterns
.
Compile
.
actions
d
in
match
actions
with
|
`Ignore
r
->
make_result_basic
v
r
|
`Kind
k
->
run_disp_kind
k
v
match
actions
d
with
|
AIgnore
r
->
make_result_basic
v
r
|
AKind
k
->
run_disp_kind
k
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
false
actions
.
Patterns
.
Compile
.
record
|
Pair
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
prod
|
Xml
(
v1
,
v2
)
->
run_disp_prod
v
v1
v2
actions
.
xml
|
Record
r
->
run_disp_record
r
v
[]
r
false
actions
.
record
|
Atom
a
->
run_disp_basic
v
(
fun
t
->
Types
.
Atom
.
has_atom
t
a
)
actions
.
Patterns
.
Compile
.
basic
run_disp_basic
v
(
fun
t
->
Types
.
Atom
.
has_atom
t
a
)
actions
.
basic
|
Char
c
->
run_disp_basic
v
(
fun
t
->
Types
.
Char
.
has_char
t
c
)
actions
.
Patterns
.
Compile
.
basic
run_disp_basic
v
(
fun
t
->
Types
.
Char
.
has_char
t
c
)
actions
.
basic
|
Integer
i
->
run_disp_basic
v
(
fun
t
->
Types
.
Int
.
has_int
t
i
)
actions
.
Patterns
.
Compile
.
basic
run_disp_basic
v
(
fun
t
->
Types
.
Int
.
has_int
t
i
)
actions
.
basic
|
Abstraction
(
iface
,_
)
->
run_disp_basic
v
(
fun
t
->
Types
.
Arrow
.
check_iface
iface
t
)
actions
.
Patterns
.
Compile
.
basic
actions
.
basic
|
v
->
run_disp_kind
actions
(
normalize
v
)
...
...
@@ -78,19 +74,19 @@ and run_disp_basic v f x =
and
run_disp_prod
v
v1
v2
x
=
match
x
with
|
`Non
e
->
assert
false
|
`
TailCall
d1
->
run_dispatcher
d1
v1
|
`
Ignore
d2
->
run_disp_prod2
v1
dummy_r
v
v2
d2
|
`
Dispatch
(
d1
,
b1
)
->
|
Impossibl
e
->
assert
false
|
TailCall
d1
->
run_dispatcher
d1
v1
|
Ignore
d2
->
run_disp_prod2
v1
dummy_r
v
v2
d2
|
Dispatch
(
d1
,
b1
)
->
let
(
code1
,
r1
)
=
run_dispatcher
d1
v1
in
run_disp_prod2
v1
r1
v
v2
b1
.
(
code1
)
and
run_disp_prod2
v1
r1
v
v2
x
=
match
x
with
|
`Non
e
->
assert
false
|
`
Ignore
r
->
make_result_prod
v1
r1
v2
dummy_r
v
r
|
`
TailCall
d2
->
run_dispatcher
d2
v2
|
`
Dispatch
(
d2
,
b2
)
->
|
Impossibl
e
->
assert
false
|
Ignore
r
->
make_result_prod
v1
r1
v2
dummy_r
v
r
|
TailCall
d2
->
run_dispatcher
d2
v2
|
Dispatch
(
d2
,
b2
)
->
let
(
code2
,
r2
)
=
run_dispatcher
d2
v2
in
make_result_prod
v1
r1
v2
r2
v
b2
.
(
code2
)
...
...
@@ -114,9 +110,9 @@ and run_disp_record' f v bindings fields other = function
aux
other
fields
and
run_disp_field
f
v
bindings
fields
other
l
vl
=
function
|
`Non
e
->
assert
false
|
`
Ignore
r
->
run_disp_record'
f
v
bindings
fields
other
r
|
`
TailCall
d
->
run_dispatcher
d
vl
|
`
Dispatch
(
dl
,
bl
)
->
|
Impossibl
e
->
assert
false
|
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
)
fields
other
bl
.
(
codel
)
tests/memento.cd
View file @
286b3b8b
...
...
@@ -74,7 +74,7 @@ let fun summary (Content' -> [Block*])
c ->
let s = transform c with
<section
no=
i
>
[
<title>
t; _] ->
[
<li>
[
<a
href=
"#"
@
string_of
i
>
t]] in
match s with lis -> box [
<ul>
lis];;
match s with
[] -> [] |
lis -> box [
<ul>
lis];;
let (fname, title, content) =
...
...
tests/overloading.cd
View file @
286b3b8b
...
...
@@ -73,3 +73,5 @@ name (sort base);;
transform [ base base ] with
<person>[ n <children>[Person]; _] -> [n]
| _ -> [];;
debug compile Any Any;;
types/patterns.ml
View file @
286b3b8b
This diff is collapsed.
Click to expand it.
types/patterns.mli
View file @
286b3b8b
...
...
@@ -49,8 +49,8 @@ module Compile: sig
type
dispatcher
type
actions
=
[
`
Ignore
of
result
|
`
Kind
of
actions_kind
]
|
A
Ignore
of
result
|
A
Kind
of
actions_kind
and
actions_kind
=
{
basic
:
(
Types
.
descr
*
result
)
list
;
prod
:
result
dispatch
dispatch
;
...
...
@@ -63,17 +63,16 @@ module Compile: sig
|
`Result_other
of
Types
.
label
list
*
result
*
result
]
and
'
a
dispatch
=
[
`
Dispatch
of
dispatcher
*
'
a
array
|
`
TailCall
of
dispatcher
|
`
Ignore
of
'
a
|
`None
]
|
Dispatch
of
dispatcher
*
'
a
array
|
TailCall
of
dispatcher
|
Ignore
of
'
a
|
Impossible
and
result
=
int
*
source
array
and
source
=
[
`Catch
|
`Const
of
Types
.
const
|
`Left
of
int
|
`Right
of
int
|
`Recompose
of
int
*
int
|
`Field
of
Types
.
label
*
int
]
|
Catch
|
Const
of
Types
.
const
|
Left
of
int
|
Right
of
int
|
Recompose
of
int
*
int
|
Field
of
Types
.
label
*
int
val
actions
:
dispatcher
->
actions
...
...
typing/typer.ml
View file @
286b3b8b
...
...
@@ -30,18 +30,17 @@ type ti = {
mutable
pat_node
:
Patterns
.
node
option
}
and
descr
=
[
`Alias
of
string
*
ti
|
`Type
of
Types
.
descr
|
`Or
of
ti
*
ti
|
`And
of
ti
*
ti
|
`Diff
of
ti
*
ti
|
`Times
of
ti
*
ti
|
`Xml
of
ti
*
ti
|
`Arrow
of
ti
*
ti
|
`Record
of
bool
*
(
Types
.
label
*
bool
*
ti
)
list
|
`Capture
of
Patterns
.
capture
|
`Constant
of
Patterns
.
capture
*
Types
.
const
]
|
IAlias
of
string
*
ti
|
IType
of
Types
.
descr
|
IOr
of
ti
*
ti
|
IAnd
of
ti
*
ti
|
IDiff
of
ti
*
ti
|
ITimes
of
ti
*
ti
|
IXml
of
ti
*
ti
|
IArrow
of
ti
*
ti
|
IRecord
of
bool
*
(
Types
.
label
*
bool
*
ti
)
list
|
ICapture
of
Patterns
.
capture
|
IConstant
of
Patterns
.
capture
*
Types
.
const
type
glb
=
ti
StringMap
.
t
...
...
@@ -55,7 +54,7 @@ let mk' =
seen
=
false
;
loc'
=
loc
;
fv
=
None
;
descr'
=
`
Alias
(
"__dummy__"
,
x
);
descr'
=
I
Alias
(
"__dummy__"
,
x
);
type_node
=
None
;
pat_node
=
None
}
in
...
...
@@ -91,32 +90,33 @@ module Regexp = struct
let
uniq_id
=
let
r
=
ref
0
in
fun
()
->
incr
r
;
!
r
type
flat
=
[
`Epsilon
|
`Elem
of
int
*
Ast
.
ppat
(* the int arg is used
type
flat
=
|
REpsilon
|
RElem
of
int
*
Ast
.
ppat
(* the int arg is used
to stop generic comparison *)
|
`
Seq
of
flat
*
flat
|
`
Alt
of
flat
*
flat
|
`
Star
of
flat
|
`
WeakStar
of
flat
]
|
R
Seq
of
flat
*
flat
|
R
Alt
of
flat
*
flat
|
R
Star
of
flat
|
R
WeakStar
of
flat
let
re_loc
=
ref
noloc
let
rec
propagate
vars
:
regexp
->
flat
=
function
|
Epsilon
->
`
Epsilon
|
Elem
x
->
let
p
=
vars
x
in
`
Elem
(
uniq_id
()
,
p
)
|
Seq
(
r1
,
r2
)
->
`
Seq
(
propagate
vars
r1
,
propagate
vars
r2
)
|
Alt
(
r1
,
r2
)
->
`
Alt
(
propagate
vars
r1
,
propagate
vars
r2
)
|
Star
r
->
`
Star
(
propagate
vars
r
)
|
WeakStar
r
->
`
WeakStar
(
propagate
vars
r
)
|
Epsilon
->
R
Epsilon
|
Elem
x
->
let
p
=
vars
x
in
R
Elem
(
uniq_id
()
,
p
)
|
Seq
(
r1
,
r2
)
->
R
Seq
(
propagate
vars
r1
,
propagate
vars
r2
)
|
Alt
(
r1
,
r2
)
->
R
Alt
(
propagate
vars
r1
,
propagate
vars
r2
)
|
Star
r
->
R
Star
(
propagate
vars
r
)
|
WeakStar
r
->
R
WeakStar
(
propagate
vars
r
)
|
SeqCapture
(
v
,
x
)
->
let
v
=
mk
!
re_loc
(
Capture
v
)
in
propagate
(
fun
p
->
mk
!
re_loc
(
And
(
vars
p
,
v
)))
x
let
cup
r1
r2
=
match
(
r1
,
r2
)
with
|
(
_
,
`Empty
)
->
r1
|
(
`Empty
,
_
)
->
r2
|
(
`Res
t1
,
`Res
t2
)
->
`Res
(
mk
!
re_loc
(
Or
(
t
1
,
t2
)
))
let
dummy_pat
=
mk
noloc
(
PatVar
"DUMMY"
)
let
cup
r1
r2
=
if
r1
==
dummy_pat
then
r2
else
if
r2
==
dummy_pat
then
r1
else
mk
!
re_loc
(
Or
(
r
1
,
r2
))
(*TODO: review this compilation schema to avoid explosion when
coding (Optional x) by (Or(Epsilon,x)); memoization ... *)
...
...
@@ -126,24 +126,24 @@ module Regexp = struct
let
memo
=
ref
Memo
.
empty
let
rec
compile
fin
e
seq
:
[
`Res
of
Ast
.
ppat
|
`Empty
]
=
if
Coind
.
mem
seq
!
e
then
`Empty
let
rec
compile
fin
e
seq
:
Ast
.
ppat
=
if
Coind
.
mem
seq
!
e
then
dummy_pat
else
(
e
:=
Coind
.
add
seq
!
e
;
match
seq
with
|
[]
->
`Res
fin
|
`
Epsilon
::
rest
->
fin
|
R
Epsilon
::
rest
->
compile
fin
e
rest
|
`
Elem
(
_
,
p
)
::
rest
->
`Res
(
mk
!
re_loc
(
Prod
(
p
,
guard_compile
fin
rest
))
)
|
`
Seq
(
r1
,
r2
)
::
rest
->
|
R
Elem
(
_
,
p
)
::
rest
->
mk
!
re_loc
(
Prod
(
p
,
guard_compile
fin
rest
))
|
R
Seq
(
r1
,
r2
)
::
rest
->
compile
fin
e
(
r1
::
r2
::
rest
)
|
`
Alt
(
r1
,
r2
)
::
rest
->
|
R
Alt
(
r1
,
r2
)
::
rest
->
cup
(
compile
fin
e
(
r1
::
rest
))
(
compile
fin
e
(
r2
::
rest
))
|
`
Star
r
::
rest
->
|
R
Star
r
::
rest
->
cup
(
compile
fin
e
(
r
::
seq
))
(
compile
fin
e
rest
)
|
`
WeakStar
r
::
rest
->
|
R
WeakStar
r
::
rest
->
cup
(
compile
fin
e
rest
)
(
compile
fin
e
(
r
::
seq
))
)
and
guard_compile
fin
seq
=
...
...
@@ -154,9 +154,8 @@ module Regexp = struct
let
v
=
mk
!
re_loc
(
PatVar
n
)
in
memo
:=
Memo
.
add
seq
v
!
memo
;
let
d
=
compile
fin
(
ref
Coind
.
empty
)
seq
in
(
match
d
with
|
`Empty
->
assert
false
|
`Res
d
->
defs
:=
(
n
,
d
)
::
!
defs
);
assert
(
d
!=
dummy_pat
);
defs
:=
(
n
,
d
)
::
!
defs
;
v
(*
...
...
@@ -254,23 +253,23 @@ let rec compile env { loc = loc; descr = d } : ti =
)
|
Recurs
(
t
,
b
)
->
compile
(
compile_many
env
b
)
t
|
Regexp
(
r
,
q
)
->
compile
env
(
Regexp
.
compile
loc
r
q
)
|
Internal
t
->
cons
loc
(
`
Type
t
)
|
Or
(
t1
,
t2
)
->
cons
loc
(
`
Or
(
compile
env
t1
,
compile
env
t2
))
|
And
(
t1
,
t2
)
->
cons
loc
(
`
And
(
compile
env
t1
,
compile
env
t2
))
|
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
))
|
Internal
t
->
cons
loc
(
I
Type
t
)
|
Or
(
t1
,
t2
)
->
cons
loc
(
I
Or
(
compile
env
t1
,
compile
env
t2
))
|
And
(
t1
,
t2
)
->
cons
loc
(
I
And
(
compile
env
t1
,
compile
env
t2
))
|
Diff
(
t1
,
t2
)
->
cons
loc
(
I
Diff
(
compile
env
t1
,
compile
env
t2
))
|
Prod
(
t1
,
t2
)
->
cons
loc
(
I
Times
(
compile
env
t1
,
compile
env
t2
))
|
XmlT
(
t1
,
t2
)
->
cons
loc
(
I
Xml
(
compile
env
t1
,
compile
env
t2
))
|
Arrow
(
t1
,
t2
)
->
cons
loc
(
I
Arrow
(
compile
env
t1
,
compile
env
t2
))
|
Record
(
o
,
r
)
->
cons
loc
(
`
Record
(
o
,
List
.
map
(
fun
(
l
,
o
,
t
)
->
l
,
o
,
compile
env
t
)
r
))
|
Constant
(
x
,
v
)
->
cons
loc
(
`
Constant
(
x
,
v
))
|
Capture
x
->
cons
loc
(
`
Capture
x
)
cons
loc
(
I
Record
(
o
,
List
.
map
(
fun
(
l
,
o
,
t
)
->
l
,
o
,
compile
env
t
)
r
))
|
Constant
(
x
,
v
)
->
cons
loc
(
I
Constant
(
x
,
v
))
|
Capture
x
->
cons
loc
(
I
Capture
x
)
and
compile_many
env
b
=
let
b
=
List
.
map
(
fun
(
v
,
t
)
->
(
v
,
t
,
mk'
t
.
loc
))
b
in
let
env
=
List
.
fold_left
(
fun
env
(
v
,
t
,
x
)
->
StringMap
.
add
v
x
env
)
env
b
in
List
.
iter
(
fun
(
v
,
t
,
x
)
->
x
.
descr'
<-
`
Alias
(
v
,
compile
env
t
))
b
;
List
.
iter
(
fun
(
v
,
t
,
x
)
->
x
.
descr'
<-
I
Alias
(
v
,
compile
env
t
))
b
;
env
module
IntSet
=
...
...
@@ -283,23 +282,23 @@ let rec comp_fv s =
|
Some
fv
->
comp_fv_res
:=
StringSet
.
union
fv
!
comp_fv_res
|
None
->
(
match
s
.
descr'
with
|
`
Alias
(
_
,
x
)
->
|
I
Alias
(
_
,
x
)
->
if
x
.
seen
then
()
else
(
x
.
seen
<-
true
;
comp_fv_seen
:=
x
::
!
comp_fv_seen
;
comp_fv
x
)
|
`
Or
(
s1
,
s2
)
|
`
And
(
s1
,
s2
)
|
`
Diff
(
s1
,
s2
)
|
`
Times
(
s1
,
s2
)
|
`
Xml
(
s1
,
s2
)
|
`
Arrow
(
s1
,
s2
)
->
comp_fv
s1
;
comp_fv
s2
|
`
Record
(
_
,
r
)
->
List
.
iter
(
fun
(
l
,
opt
,
s
)
->
comp_fv
s
)
r
|
`
Type
_
->
()
|
`
Capture
x
|
`
Constant
(
x
,_
)
->
comp_fv_res
:=
StringSet
.
add
x
!
comp_fv_res
)
|
I
Or
(
s1
,
s2
)
|
I
And
(
s1
,
s2
)
|
I
Diff
(
s1
,
s2
)
|
I
Times
(
s1
,
s2
)
|
I
Xml
(
s1
,
s2
)
|
I
Arrow
(
s1
,
s2
)
->
comp_fv
s1
;
comp_fv
s2
|
I
Record
(
_
,
r
)
->
List
.
iter
(
fun
(
l
,
opt
,
s
)
->
comp_fv
s
)
r
|
I
Type
_
->
()
|
I
Capture
x
|
I
Constant
(
x
,_
)
->
comp_fv_res
:=
StringSet
.
add
x
!
comp_fv_res
)
let
fv
s
=
...
...
@@ -316,22 +315,22 @@ let fv s =
let
rec
typ
seen
s
:
Types
.
descr
=
match
s
.
descr'
with
|
`
Alias
(
v
,
x
)
->
|
I
Alias
(
v
,
x
)
->
if
IntSet
.
mem
s
.
id
seen
then
raise_loc_generic
s
.
loc'
(
"Unguarded recursion on variable "
^
v
^
" in this type"
)
else
typ
(
IntSet
.
add
s
.
id
seen
)
x
|
`
Type
t
->
t
|
`
Or
(
s1
,
s2
)
->
Types
.
cup
(
typ
seen
s1
)
(
typ
seen
s2
)
|
`
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
(
o
,
r
)
->
|
I
Type
t
->
t
|
I
Or
(
s1
,
s2
)
->
Types
.
cup
(
typ
seen
s1
)
(
typ
seen
s2
)
|
I
And
(
s1
,
s2
)
->
Types
.
cap
(
typ
seen
s1
)
(
typ
seen
s2
)
|
I
Diff
(
s1
,
s2
)
->
Types
.
diff
(
typ
seen
s1
)
(
typ
seen
s2
)
|
I
Times
(
s1
,
s2
)
->
Types
.
times
(
typ_node
s1
)
(
typ_node
s2
)
|
I
Xml
(
s1
,
s2
)
->
Types
.
xml
(
typ_node
s1
)
(
typ_node
s2
)
|
I
Arrow
(
s1
,
s2
)
->
Types
.
arrow
(
typ_node
s1
)
(
typ_node
s2
)
|
I
Record
(
o
,
r
)
->
Types
.
record'
(
o
,
List
.
map
(
fun
(
l
,
o
,
s
)
->
(
l
,
(
o
,
typ_node
s
)))
r
)
|
`
Capture
x
|
`
Constant
(
x
,_
)
->
assert
false
|
I
Capture
x
|
I
Constant
(
x
,_
)
->
assert
false
and
typ_node
s
:
Types
.
node
=
match
s
.
type_node
with
...
...
@@ -359,22 +358,22 @@ let rec pat seen s : Patterns.descr =
and
pat_aux
seen
s
=
match
s
.
descr'
with
|
`
Alias
(
v
,
x
)
->
|
I
Alias
(
v
,
x
)
->
if
IntSet
.
mem
s
.
id
seen
then
raise
(
Patterns
.
Error
(
"Unguarded recursion on variable "
^
v
^
" in this pattern"
));
pat
(
IntSet
.
add
s
.
id
seen
)
x
|
`
Or
(
s1
,
s2
)
->
Patterns
.
cup
(
pat
seen
s1
)
(
pat
seen
s2
)
|
`
And
(
s1
,
s2
)
->
Patterns
.
cap
(
pat
seen
s1
)
(
pat
seen
s2
)
|
`
Diff
(
s1
,
s2
)
when
StringSet
.
is_empty
(
fv
s2
)
->
|
I
Or
(
s1
,
s2
)
->
Patterns
.
cup
(
pat
seen
s1
)
(
pat
seen
s2
)
|
I
And
(
s1
,
s2
)
->
Patterns
.
cap
(
pat
seen
s1
)
(
pat
seen
s2
)
|
I
Diff
(
s1
,
s2
)
when
StringSet
.
is_empty
(
fv
s2
)
->
let
s2
=
Types
.
neg
(
Types
.
descr
(
type_node
s2
))
in
Patterns
.
cap
(
pat
seen
s1
)
(
Patterns
.
constr
s2
)
|
`
Diff
_
->
|
I
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
(
o
,
r
)
->
|
I
Times
(
s1
,
s2
)
->
Patterns
.
times
(
pat_node
s1
)
(
pat_node
s2
)
|
I
Xml
(
s1
,
s2
)
->
Patterns
.
xml
(
pat_node
s1
)
(
pat_node
s2
)
|
I
Record
(
o
,
r
)
->
let
pats
=
ref
[]
in
let
aux
(
l
,
o
,
s
)
=
if
StringSet
.
is_empty
(
fv
s
)
then
(
l
,
(
o
,
type_node
s
))
...
...
@@ -390,11 +389,11 @@ and pat_aux seen s = match s.descr' with
let
constr
=
Types
.
record'
(
o
,
List
.
map
aux
r
)
in
List
.
fold_left
Patterns
.
cap
(
Patterns
.
constr
constr
)
!
pats
(* TODO: can avoid constr when o=true, and all fields have fv *)
|
`
Capture
x
->
Patterns
.
capture
x
|
`
Constant
(
x
,
c
)
->
Patterns
.
constant
x
c
|
`
Arrow
_
->
|
I
Capture
x
->
Patterns
.
capture
x
|
I
Constant
(
x
,
c
)
->
Patterns
.
constant
x
c
|
I
Arrow
_
->
raise
(
Patterns
.
Error
"Arrow not allowed in patterns"
)
|
`
Type
_
->
assert
false
|
I
Type
_
->
assert
false
and
pat_node
s
:
Patterns
.
node
=
match
s
.
pat_node
with
...
...
web/index.xml
0 → 100644
View file @
286b3b8b
<?xml version="1.0" standalone="yes" encoding="iso8859-1"?>
<html>
<head>
<meta
http-equiv=
"Content-Type"
content=
"text/html; charset=iso-8859-1"
/>
<title>
CDuce
</title>
</head>
<body
bgcolor=
"#BBDDFF"
>
<banner
title=
"CDuce"
subtitle=
"Page last modified on 2002-12-05"
/>
<p/>
<box
title=
""
>
<ul>
<li><a
href=
"#proto"
>
Give it a try !
</a></li>
<li><a
href=
"#papers"
>
Papers
</a></li>
<li><a
href=
"#slides"
>
Slides
</a></li>
<li><a
href=
"#links"
>
Related links
</a></li>
</ul>
</box>
<