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
203537de
Commit
203537de
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2004-12-25 20:39:15 by afrisch] Default values for record fields
Original author: afrisch Date: 2004-12-25 20:39:15+00:00
parent
75975fa4
Changes
5
Hide whitespace changes
Inline
Side-by-side
parser/ast.ml
View file @
203537de
...
...
@@ -106,7 +106,7 @@ and ppat' =
|
XmlT
of
ppat
*
ppat
|
Arrow
of
ppat
*
ppat
|
Optional
of
ppat
|
Record
of
bool
*
(
label
*
ppat
)
list
|
Record
of
bool
*
(
label
*
(
ppat
*
ppat
option
)
)
list
|
Constant
of
id
*
pexpr
|
Regexp
of
regexp
*
ppat
(* regular expression, continuation: [ re ; cont ], e.g: [ re ; nil ] *)
...
...
parser/parser.ml
View file @
203537de
...
...
@@ -506,8 +506,9 @@ EXTEND
|
"{|"
;
r
=
record_spec
;
"|}"
->
mk
loc
(
Record
(
false
,
r
))
|
"ref"
;
p
=
pat
->
let
get_fun
=
mk
loc
(
Arrow
(
pat_nil
,
p
))
and
set_fun
=
mk
loc
(
Arrow
(
p
,
pat_nil
))
in
let
fields
=
[
label
"get"
,
get_fun
;
label
"set"
,
set_fun
]
in
and
set_fun
=
mk
loc
(
Arrow
(
p
,
pat_nil
))
in
let
fields
=
[
label
"get"
,
(
get_fun
,
None
);
label
"set"
,
(
set_fun
,
None
)
]
in
mk
loc
(
Record
(
false
,
fields
))
|
IDENT
"_"
->
mk
loc
(
Internal
Types
.
any
)
|
"("
;
a
=
IDENT
;
":="
;
c
=
expr
;
")"
->
...
...
@@ -562,12 +563,14 @@ EXTEND
];
or_else
:
[
[
OPT
[
"else"
;
y
=
pat
->
y
]
]
];
record_spec
:
[
[
r
=
LIST0
[
l
=
[
IDENT
|
keyword
];
"="
;
o
=
[
"?"
->
true
|
->
false
];
x
=
pat
->
x
=
pat
;
y
=
or_else
->
let
x
=
if
o
then
mk
loc
(
Optional
x
)
else
x
in
(
label
l
,
x
)
(
label
l
,
(
x
,
y
)
)
]
SEP
";"
->
r
]
];
...
...
@@ -581,9 +584,9 @@ EXTEND
attrib_spec
:
[
[
r
=
LIST0
[
l
=
[
IDENT
|
keyword
];
"="
;
o
=
[
"?"
->
true
|
->
false
];
x
=
pat
;
OPT
";"
->
x
=
pat
;
y
=
or_else
;
OPT
";"
->
let
x
=
if
o
then
mk
loc
(
Optional
x
)
else
x
in
(
label
l
,
x
)
(
label
l
,
(
x
,
y
)
)
]
->
mk
loc
(
Record
(
true
,
r
))
|
"("
;
t
=
pat
;
")"
->
t
...
...
query/query.ml
View file @
203537de
...
...
@@ -111,10 +111,14 @@ let rec var_of_ppat x =
|
XmlT
(
p1
,
p2
)
->
var_of_ppat
p1
@
var_of_ppat
p2
|
Arrow
(
p1
,
p2
)
->
var_of_ppat
p1
@
var_of_ppat
p2
|
Optional
(
p1
)
->
var_of_ppat
p1
|
Record
(
b
,
lm
)
->
let
rec
listing
l
=
(
match
l
with
[]
->
[]
|
(
s
,
ppat
)
::
r
->
var_of_ppat
(
ppat
)
@
listing
r
)
in
listing
(
lm
)
|
Record
(
b
,
lm
)
->
let
rec
aux
accu
(
_
,
(
ppat
,
e
))
=
let
accu
=
var_of_ppat
ppat
@
accu
in
match
e
with
|
None
->
accu
|
Some
ppat
->
var_of_ppat
ppat
@
accu
in
List
.
fold_left
aux
[]
lm
|
Constant
(
i
,
t
)
->
[
i
]
|
Regexp
(
rg
,
p
)
->
var_of_rg
rg
@
var_of_ppat
p
...
...
query/query_parse.ml
View file @
203537de
...
...
@@ -55,7 +55,8 @@ EXTEND
a
=
[
IDENT
|
keyword
]
->
(* projection sur 1 attribut *)
let
tag
=
mk
loc
(
Internal
(
Types
.
atom
Atoms
.
any
))
in
let
any
=
mk
loc
(
Internal
(
Types
.
any
))
in
let
att
=
mk
loc
(
Record
(
true
,
[(
label
a
,
mk
loc
(
PatVar
(
U
.
mk
"$$$"
)))]))
in
let
att
=
mk
loc
(
Record
(
true
,
[(
label
a
,
(
mk
loc
(
PatVar
(
U
.
mk
"$$$"
))
,
None
))]))
in
(*let ct= mk loc (Regexp(Elem any , any)) in *)
let
p
=
mk
loc
(
XmlT
(
tag
,
multi_prod
loc
[
att
;
any
]))
in
let
t
=
(
p
,
Pair
(
Var
(
Id
.
value
id_dummy
)
,
cst_nil
))
...
...
typing/typer.ml
View file @
203537de
...
...
@@ -285,7 +285,7 @@ type derecurs_slot = {
|
PXml
of
derecurs
*
derecurs
|
PArrow
of
derecurs
*
derecurs
|
POptional
of
derecurs
|
PRecord
of
bool
*
derecurs
label_map
|
PRecord
of
bool
*
(
derecurs
*
derecurs
option
)
label_map
|
PCapture
of
id
|
PConstant
of
id
*
Types
.
const
|
PRegexp
of
derecurs_regexp
*
derecurs
...
...
@@ -311,7 +311,7 @@ type descr =
|
IXml
of
slot
*
slot
|
IArrow
of
slot
*
slot
|
IOptional
of
descr
|
IRecord
of
bool
*
slot
label_map
|
IRecord
of
bool
*
(
slot
*
descr
option
)
label_map
|
ICapture
of
id
|
IConstant
of
id
*
Types
.
const
and
slot
=
{
...
...
@@ -361,13 +361,16 @@ let rec hash_derecurs = function
|
POptional
p
->
8
+
17
*
(
hash_derecurs
p
)
|
PRecord
(
o
,
r
)
->
(
if
o
then
9
else
10
)
+
17
*
(
LabelMap
.
hash
hash_derecurs
r
)
(
if
o
then
9
else
10
)
+
17
*
(
LabelMap
.
hash
hash_derecurs
_field
r
)
|
PCapture
x
->
11
+
17
*
(
Id
.
hash
x
)
|
PConstant
(
x
,
c
)
->
12
+
17
*
(
Id
.
hash
x
)
+
257
*
(
Types
.
Const
.
hash
c
)
|
PRegexp
(
p
,
q
)
->
13
+
17
*
(
hash_derecurs_regexp
p
)
+
257
*
(
hash_derecurs
q
)
and
hash_derecurs_field
=
function
|
(
p
,
Some
e
)
->
1
+
17
*
hash_derecurs
p
+
257
*
hash_derecurs
e
|
(
p
,
None
)
->
2
+
17
*
hash_derecurs
p
and
hash_derecurs_regexp
=
function
|
PEpsilon
->
1
...
...
@@ -399,7 +402,7 @@ let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
|
POptional
p1
,
POptional
p2
->
equal_derecurs
p1
p2
|
PRecord
(
o1
,
r1
)
,
PRecord
(
o2
,
r2
)
->
(
o1
==
o2
)
&&
(
LabelMap
.
equal
equal_derecurs
r1
r2
)
(
o1
==
o2
)
&&
(
LabelMap
.
equal
equal_derecurs
_field
r1
r2
)
|
PCapture
x1
,
PCapture
x2
->
Id
.
equal
x1
x2
|
PConstant
(
x1
,
c1
)
,
PConstant
(
x2
,
c2
)
->
...
...
@@ -407,6 +410,10 @@ let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
|
PRegexp
(
p1
,
q1
)
,
PRegexp
(
p2
,
q2
)
->
(
equal_derecurs_regexp
p1
p2
)
&&
(
equal_derecurs
q1
q2
)
|
_
->
false
and
equal_derecurs_field
r1
r2
=
match
(
r1
,
r2
)
with
|
(
p1
,
None
)
,
(
p2
,
None
)
->
equal_derecurs
p1
p2
|
(
p1
,
Some
e1
)
,
(
p2
,
Some
e2
)
->
equal_derecurs
p1
p2
&&
equal_derecurs
e1
e2
|
_
->
false
and
equal_derecurs_regexp
r1
r2
=
match
r1
,
r2
with
|
PEpsilon
,
PEpsilon
->
true
...
...
@@ -453,9 +460,12 @@ let rec hash_descr = function
|
ITimes
(
s1
,
s2
)
->
5
+
17
*
(
hash_slot
s1
)
+
257
*
(
hash_slot
s2
)
|
IXml
(
s1
,
s2
)
->
6
+
17
*
(
hash_slot
s1
)
+
257
*
(
hash_slot
s2
)
|
IArrow
(
s1
,
s2
)
->
7
+
17
*
(
hash_slot
s1
)
+
257
*
(
hash_slot
s2
)
|
IRecord
(
o
,
r
)
->
(
if
o
then
8
else
9
)
+
17
*
(
LabelMap
.
hash
hash_
slot
r
)
|
IRecord
(
o
,
r
)
->
(
if
o
then
8
else
9
)
+
17
*
(
LabelMap
.
hash
hash_
descr_field
r
)
|
ICapture
x
->
10
+
17
*
(
Id
.
hash
x
)
|
IConstant
(
x
,
y
)
->
11
+
17
*
(
Id
.
hash
x
)
+
257
*
(
Types
.
Const
.
hash
y
)
and
hash_descr_field
=
function
|
(
d
,
Some
e
)
->
1
+
17
*
hash_slot
d
+
257
*
hash_descr
e
|
(
d
,
None
)
->
2
+
17
*
hash_slot
d
and
hash_slot
s
=
if
s
.
gen1
=
!
gen
then
13
*
s
.
rank1
else
(
...
...
@@ -475,11 +485,15 @@ let rec equal_descr d1 d2 =
|
IXml
(
x1
,
y1
)
,
IXml
(
x2
,
y2
)
|
IArrow
(
x1
,
y1
)
,
IArrow
(
x2
,
y2
)
->
(
equal_slot
x1
x2
)
&&
(
equal_slot
y1
y2
)
|
IRecord
(
o1
,
r1
)
,
IRecord
(
o2
,
r2
)
->
(
o1
=
o2
)
&&
(
LabelMap
.
equal
equal_
slot
r1
r2
)
(
o1
=
o2
)
&&
(
LabelMap
.
equal
equal_
descr_field
r1
r2
)
|
ICapture
x1
,
ICapture
x2
->
Id
.
equal
x1
x2
|
IConstant
(
x1
,
y1
)
,
IConstant
(
x2
,
y2
)
->
(
Id
.
equal
x1
x2
)
&&
(
Types
.
Const
.
equal
y1
y2
)
|
_
->
false
and
equal_descr_field
d1
d2
=
match
(
d1
,
d2
)
with
|
(
d1
,
None
)
,
(
d2
,
None
)
->
equal_slot
d1
d2
|
(
d1
,
Some
e1
)
,
(
d2
,
Some
e2
)
->
equal_slot
d1
d2
&&
equal_descr
e1
e2
|
_
->
false
and
equal_slot
s1
s2
=
((
s1
.
gen1
=
!
gen
)
&&
(
s2
.
gen2
=
!
gen
)
&&
(
s1
.
rank1
=
s2
.
rank2
))
||
...
...
@@ -584,7 +598,11 @@ let rec derecurs env p = match p.descr with
|
XmlT
(
p1
,
p2
)
->
PXml
(
derecurs
env
p1
,
derecurs
env
p2
)
|
Arrow
(
p1
,
p2
)
->
PArrow
(
derecurs
env
p1
,
derecurs
env
p2
)
|
Optional
p
->
POptional
(
derecurs
env
p
)
|
Record
(
o
,
r
)
->
PRecord
(
o
,
parse_record
env
.
penv_tenv
p
.
loc
(
derecurs
env
)
r
)
|
Record
(
o
,
r
)
->
let
aux
=
function
|
(
p
,
Some
e
)
->
(
derecurs
env
p
,
Some
(
derecurs
env
e
))
|
(
p
,
None
)
->
derecurs
env
p
,
None
in
PRecord
(
o
,
parse_record
env
.
penv_tenv
p
.
loc
aux
r
)
|
Constant
(
x
,
c
)
->
PConstant
(
x
,
const
env
.
penv_tenv
p
.
loc
c
)
|
Cst
c
->
PType
(
Types
.
constant
(
const
env
.
penv_tenv
p
.
loc
c
))
|
Regexp
(
r
,
q
)
->
...
...
@@ -657,8 +675,12 @@ and fv_descr = function
|
IXml
(
s1
,
s2
)
|
IArrow
(
s1
,
s2
)
->
IdSet
.
cup
(
fv_slot
s1
)
(
fv_slot
s2
)
|
IRecord
(
o
,
r
)
->
List
.
fold_left
IdSet
.
cup
IdSet
.
empty
(
LabelMap
.
map_to_list
fv_
slot
r
)
List
.
fold_left
IdSet
.
cup
IdSet
.
empty
(
LabelMap
.
map_to_list
fv_
field
r
)
|
ICapture
x
|
IConstant
(
x
,_
)
->
IdSet
.
singleton
x
and
fv_field
=
function
|
(
d
,
Some
e
)
->
IdSet
.
cup
(
fv_slot
d
)
(
fv_descr
e
)
|
(
d
,
None
)
->
fv_slot
d
let
compute_fv
s
=
match
s
.
fv
with
...
...
@@ -703,11 +725,15 @@ and real_compile = function
|
PXml
(
t1
,
t2
)
->
IXml
(
compile_slot
t1
,
compile_slot
t2
)
|
PArrow
(
t1
,
t2
)
->
IArrow
(
compile_slot
t1
,
compile_slot
t2
)
|
POptional
t
->
IOptional
(
compile
t
)
|
PRecord
(
o
,
r
)
->
IRecord
(
o
,
LabelMap
.
map
compile_
slot
r
)
|
PRecord
(
o
,
r
)
->
IRecord
(
o
,
LabelMap
.
map
compile_
field
r
)
|
PConstant
(
x
,
v
)
->
IConstant
(
x
,
v
)
|
PCapture
x
->
ICapture
x
|
PRegexp
(
r
,
q
)
->
compile
(
remove_regexp
r
q
)
and
compile_field
=
function
|
(
p
,
Some
e
)
->
(
compile_slot
p
,
Some
(
compile
e
))
|
(
p
,
None
)
->
(
compile_slot
p
,
None
)
and
compile_slot
p
=
try
DerecursTable
.
find
compile_slot_hash
p
with
Not_found
->
...
...
@@ -743,9 +769,14 @@ let rec typ = function
|
IXml
(
s1
,
s2
)
->
Types
.
xml
(
typ_node
s1
)
(
typ_node
s2
)
|
IArrow
(
s1
,
s2
)
->
Types
.
arrow
(
typ_node
s1
)
(
typ_node
s2
)
|
IOptional
s
->
Types
.
Record
.
or_absent
(
typ
s
)
|
IRecord
(
o
,
r
)
->
Types
.
record'
(
o
,
LabelMap
.
map
typ_
node
r
)
|
IRecord
(
o
,
r
)
->
Types
.
record'
(
o
,
LabelMap
.
map
typ_
field
r
)
|
IDummy
|
ICapture
_
|
IConstant
(
_
,_
)
->
assert
false
and
typ_field
=
function
|
(
s
,
None
)
->
typ_node
s
|
(
s
,
Some
_
)
->
raise
(
Patterns
.
Error
"Or-else clauses are not allowed in types"
)
and
typ_node
s
:
Types
.
Node
.
t
=
try
SlotTable
.
find
typ_nodes
s
with
Not_found
->
...
...
@@ -774,11 +805,20 @@ and pat_aux = function
raise
(
Patterns
.
Error
"Optional fields are not allowed in record patterns"
)
|
IRecord
(
o
,
r
)
->
let
pats
=
ref
[]
in
let
aux
l
s
=
if
IdSet
.
is_empty
(
fv_slot
s
)
then
typ_node
s
else
(
pats
:=
Patterns
.
record
l
(
pat_node
s
)
::
!
pats
;
Types
.
any_node
)
let
aux
l
=
function
|
(
s
,
None
)
->
if
IdSet
.
is_empty
(
fv_slot
s
)
then
typ_node
s
else
(
pats
:=
Patterns
.
record
l
(
pat_node
s
)
::
!
pats
;
Types
.
any_node
)
|
(
s
,
Some
e
)
->
if
IdSet
.
is_empty
(
fv_slot
s
)
then
raise
(
Patterns
.
Error
"Or-else clauses are not allowed in types"
)
else
(
pats
:=
Patterns
.
cup
(
Patterns
.
record
l
(
pat_node
s
))
(
pat
e
)
::
!
pats
;
Types
.
Record
.
any_or_absent_node
)
in
let
constr
=
Types
.
record'
(
o
,
LabelMap
.
mapi
aux
r
)
in
List
.
fold_left
Patterns
.
cap
(
Patterns
.
constr
constr
)
!
pats
...
...
@@ -1612,7 +1652,7 @@ module Schema_converter =
|
_
->
cd_type_of_simple_type
~
schema
at
.
attr_decl
.
attr_typdef
in
let
r
=
if
at
.
attr_required
then
r
else
POptional
r
in
(
LabelPool
.
mk
(
Ns
.
empty
,
at
.
attr_decl
.
attr_name
)
,
r
))
(
LabelPool
.
mk
(
Ns
.
empty
,
at
.
attr_decl
.
attr_name
)
,
(
r
,
None
)
))
attr_uses
in
PRecord
(
false
,
LabelMap
.
from_list_disj
fields
)
...
...
@@ -1620,7 +1660,7 @@ module Schema_converter =
let
r
=
cd_type_of_simple_type
~
schema
att
.
attr_typdef
in
PRecord
(
false
,
LabelMap
.
from_list_disj
[(
LabelPool
.
mk
(
schema
.
targetNamespace
,
att
.
attr_name
)
,
r
)])
[(
LabelPool
.
mk
(
schema
.
targetNamespace
,
att
.
attr_name
)
,
(
r
,
None
)
)])
and
cd_type_of_elt_decl
~
schema
elt
=
let
atom_type
=
...
...
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