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
48ac778a
Commit
48ac778a
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-03-06 18:26:47 by afrisch] Concatenation in types
Original author: afrisch Date: 2005-03-06 18:26:47+00:00
parent
9ed9051b
Changes
4
Hide whitespace changes
Inline
Side-by-side
CHANGES
View file @
48ac778a
...
...
@@ -26,6 +26,7 @@ Since 0.2.2
- the ";" between fields is optional even for records
(used to be optional only for attributes)
* Keywords are now allowed as type names
* Concatenatiom @ allowed in types
- Tools:
* A new tool cduce_mktop produces customized CDuce toplevels with embedded
...
...
parser/ast.ml
View file @
48ac778a
...
...
@@ -112,6 +112,7 @@ and ppat' =
|
Record
of
bool
*
(
label
*
(
ppat
*
ppat
option
))
list
|
Constant
of
U
.
t
*
pexpr
|
Regexp
of
regexp
|
Concat
of
ppat
*
ppat
and
regexp
=
|
Epsilon
...
...
parser/parser.ml
View file @
48ac778a
...
...
@@ -553,7 +553,8 @@ EXTEND
b
=
LIST1
[
(
la
,
a
)
=
located_ident
;
"="
;
y
=
pat
->
(
la
,
a
,
y
)
]
SEP
"and"
->
mk
loc
(
Recurs
(
x
,
b
))
]
|
RIGHTA
[
x
=
pat
;
"->"
;
y
=
pat
->
mk
loc
(
Arrow
(
x
,
y
))
]
|
RIGHTA
[
x
=
pat
;
"->"
;
y
=
pat
->
mk
loc
(
Arrow
(
x
,
y
))
|
x
=
pat
;
"@"
;
y
=
pat
->
mk
loc
(
Concat
(
x
,
y
))
]
|
"no_arrow"
[
x
=
pat
;
"|"
;
y
=
pat
->
mk
loc
(
Or
(
x
,
y
))
]
|
"simple"
[
x
=
pat
;
"&"
;
y
=
pat
->
mk
loc
(
And
(
x
,
y
))
|
x
=
pat
;
"
\\
"
;
y
=
pat
->
mk
loc
(
Diff
(
x
,
y
))
]
...
...
typing/typer.ml
View file @
48ac778a
...
...
@@ -281,6 +281,7 @@ module IType = struct
|
IRecord
of
bool
*
(
node
*
node
option
)
label_map
|
ICapture
of
id
|
IConstant
of
id
*
Types
.
const
|
IConcat
of
node
*
node
let
rec
node_temp
=
{
desc
=
ILink
node_temp
;
...
...
@@ -309,6 +310,7 @@ module IType = struct
257
*
(
LabelMap
.
hash
(
hash_field
f
)
r
)
|
ICapture
x
->
10
+
17
*
(
Id
.
hash
x
)
|
IConstant
(
x
,
c
)
->
11
+
17
*
(
Id
.
hash
x
)
+
257
*
(
Types
.
Const
.
hash
c
)
|
IConcat
(
p1
,
p2
)
->
assert
false
let
hash0
=
hash
(
fun
n
->
1
)
let
hash1
=
hash
hash0
...
...
@@ -524,6 +526,7 @@ module IType = struct
|
IRecord
(
o
,
r
)
->
Types
.
record'
(
o
,
LabelMap
.
map
compute_typ_field
r
)
|
ILink
_
->
assert
false
|
ICapture
_
|
IConstant
(
_
,_
)
->
assert
false
|
IConcat
_
->
assert
false
and
compute_typ_field
=
function
|
(
s
,
None
)
->
typ_node
s
|
(
s
,
Some
_
)
->
...
...
@@ -583,7 +586,7 @@ module IType = struct
|
IConstant
(
x
,
c
)
->
Patterns
.
constant
x
c
|
IArrow
_
->
raise
(
Patterns
.
Error
"Arrows are not allowed in patterns"
)
|
IType
_
|
ILink
_
->
assert
false
|
IType
_
|
ILink
_
|
IConcat
_
->
assert
false
and
pat_node
n
=
let
n
=
repr
n
in
...
...
@@ -606,6 +609,8 @@ module IType = struct
let
penv
tenv
=
{
penv_tenv
=
tenv
;
penv_derec
=
Env
.
empty
}
let
concats
=
ref
[]
let
mk
d
=
{
node_temp
with
desc
=
d
}
let
mk_delayed
()
=
{
node_temp
with
desc
=
ILink
node_temp
}
let
itype
t
=
mk
(
IType
(
t
,
Types
.
hash
t
))
...
...
@@ -760,17 +765,11 @@ module IType = struct
let
l
=
!
all_delayed
in
all_delayed
:=
[]
;
List
.
iter
check_one_delayed
l
let
rec
derecurs
env
p
=
match
p
.
descr
with
|
PatVar
(
cu
,
v
)
->
derecurs_var
env
p
.
loc
cu
v
(*
| SchemaVar (kind, schema_name, component_name) ->
let name = qname env.penv_tenv p.loc component_name in
itype (find_schema_descr env.penv_tenv kind schema_name name)
*)
|
Recurs
(
p
,
b
)
->
derecurs
(
derecurs_def
env
b
)
p
|
Recurs
(
p
,
b
)
->
derecurs
(
fst
(
derecurs_def
env
b
))
p
|
Internal
t
->
itype
t
|
NsT
ns
->
itype
(
Types
.
atom
(
Atoms
.
any_in_ns
(
parse_ns
env
.
penv_tenv
p
.
loc
ns
)))
...
...
@@ -792,6 +791,10 @@ module IType = struct
|
Regexp
r
->
let
r
,_
=
derecurs_regexp
IdSet
.
empty
false
IdSet
.
empty
true
env
r
in
rexp
r
|
Concat
(
p1
,
p2
)
->
let
n
=
mk
(
IConcat
(
derecurs
env
p1
,
derecurs
env
p2
))
in
concats
:=
n
::
!
concats
;
n
and
derecurs_regexp
vars
b
rvars
f
env
=
function
(* - vars: seq variables to be propagated top-down and added
...
...
@@ -869,10 +872,74 @@ module IType = struct
List
.
fold_left
(
fun
env
(
v
,
p
,
s
)
->
Env
.
add
v
s
env
)
env
.
penv_derec
b
in
let
env
=
{
env
with
penv_derec
=
n
}
in
List
.
iter
(
fun
(
v
,
p
,
s
)
->
s
.
desc
<-
ILink
(
derecurs
env
p
))
b
;
env
(
env
,
b
)
module
H
=
Hashtbl
.
Make
(
Types
)
let
rec
elim_concat
n
=
match
n
.
desc
with
|
IConcat
(
a
,
b
)
->
if
(
n
.
sid
>
0
)
then
raise
(
Patterns
.
Error
"Ill-formed concatenation loop"
);
n
.
sid
<-
1
;
n
.
desc
<-
ILink
(
elim_conc
a
b
)
|
_
->
()
and
elim_conc
n
q
=
let
mem
=
ref
[]
in
let
rec
aux
n
=
try
List
.
assq
n
!
mem
with
Not_found
->
let
r
=
mk_delayed
()
in
mem
:=
(
n
,
r
)
::
!
mem
;
let
rec
aux2
n
=
let
m
=
match
n
.
desc
with
|
ILink
n'
->
aux2
n'
|
IOr
(
a
,
b
)
->
ior
(
aux
a
)
(
aux
b
)
|
ITimes
(
a
,
b
)
->
mk
(
ITimes
(
a
,
aux
b
))
|
IConcat
(
a
,
b
)
->
elim_concat
n
;
aux2
n
|
IType
(
t
,_
)
->
elim_concat_type
t
q
|
_
->
assert
false
in
m
in
r
.
desc
<-
ILink
(
aux2
n
);
r
in
aux
n
and
elim_concat_type
t
q
=
if
not
(
Types
.
subtype
t
Sequence
.
any
)
then
raise
(
Patterns
.
Error
"Left argument of concatenation is not a sequence type"
);
(* TODO: check t <= [ Any* ] *)
let
mem
=
H
.
create
17
in
let
rec
aux
t
=
try
H
.
find
mem
t
with
Not_found
->
let
n
=
mk_delayed
()
in
H
.
add
mem
t
n
;
let
d
=
List
.
fold_left
(
fun
accu
(
t1
,
t2
)
->
ior
accu
(
mk
(
ITimes
(
itype
t1
,
aux
t2
))))
(
if
Types
.
Atom
.
has_atom
t
Sequence
.
nil_atom
then
q
else
iempty
)
(
Types
.
Product
.
get
t
)
in
n
.
desc
<-
d
.
desc
;
n
in
aux
t
let
elim_concats
()
=
try
List
.
iter
elim_concat
!
concats
;
List
.
iter
(
fun
n
->
n
.
sid
<-
0
)
!
concats
;
concats
:=
[]
with
exn
->
List
.
iter
(
fun
n
->
n
.
sid
<-
0
)
!
concats
;
concats
:=
[]
;
raise
exn
let
derec
penv
p
=
let
d
=
derecurs
penv
p
in
elim_concats
()
;
check_delayed
()
;
internalize
d
;
d
...
...
@@ -882,22 +949,24 @@ module IType = struct
module
Ids
=
Set
.
Make
(
Id
)
let
type_defs
env
b
=
let
penv
=
derecurs_def
(
penv
env
)
b
in
let
aux
t
=
let
d
=
derec
penv
t
in
check_no_fv
t
.
loc
d
;
let
_
,
b'
=
derecurs_def
(
penv
env
)
b
in
elim_concats
()
;
check_delayed
()
;
let
aux
loc
d
=
internalize
d
;
check_no_fv
loc
d
;
try
typ
d
with
Patterns
.
Error
s
->
raise_loc_generic
t
.
loc
s
with
Patterns
.
Error
s
->
raise_loc_generic
loc
s
in
let
b
=
List
.
map
(
fun
(
loc
,
v
,
p
)
->
let
t
=
aux
p
in
List
.
map
2
(
fun
(
loc
,
v
,
p
)
(
v'
,_,
d
)
->
let
t
=
aux
loc
d
in
if
(
loc
<>
noloc
)
&&
(
Types
.
is_empty
t
)
then
warning
loc
(
"This definition yields an empty type for "
^
(
U
.
to_string
v
));
let
v
=
ident
env
loc
v
in
(
v
,
t
))
b
in
(
v
'
,
t
))
b
b'
in
List
.
iter
(
fun
(
v
,
t
)
->
Types
.
Print
.
register_global
(
Types
.
CompUnit
.
get_current
()
)
(
Id
.
value
v
)
t
)
b
;
b
...
...
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