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
4460caed
Commit
4460caed
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-03-29 15:15:50 by afrisch] Pb with ocamlopt -pack
Original author: afrisch Date: 2005-03-29 15:15:50+00:00
parent
3a7566f0
Changes
8
Hide whitespace changes
Inline
Side-by-side
ocamliface/mlstub.ml
View file @
4460caed
...
...
@@ -41,7 +41,7 @@ and typ_descr = function
|
Variant
(
_
,
l
,_
)
->
bigcup
variant
l
|
Record
(
_
,
l
,_
)
->
let
l
=
List
.
map
(
fun
(
lab
,
t
)
->
label
lab
,
typ
t
)
l
in
Types
.
record
'
(
false
,
(
LabelMap
.
from_list_disj
l
))
Types
.
record
_fields
(
false
,
(
LabelMap
.
from_list_disj
l
))
|
Abstract
"int"
->
Builtin_defs
.
caml_int
|
Abstract
"char"
->
Builtin_defs
.
char_latin1
|
Abstract
"string"
->
Builtin_defs
.
string_latin1
...
...
runtime/system.ml
View file @
4460caed
...
...
@@ -13,7 +13,7 @@ let variant_type_ascii l =
l
let
record_type_ascii
l
=
Types
.
record
'
(
false
,
Types
.
record
_fields
(
false
,
(
LabelMap
.
from_list_disj
(
List
.
map
(
fun
(
l
,
t
)
->
Value
.
label_ascii
l
,
Types
.
cons
t
)
l
)))
...
...
schema/schema_converter.ml
View file @
4460caed
...
...
@@ -44,7 +44,7 @@ let mk_seq_derecurs base facets =
let
xsi_nil_type
=
let
m
=
LabelMap
.
singleton
xsi_nil_label
(
Types
.
cons
Builtin_defs
.
true_type
)
in
Types
.
record
'
(
false
,
m
)
Types
.
record
_fields
(
false
,
m
)
...
...
types/builtin_defs.ml
View file @
4460caed
...
...
@@ -63,7 +63,7 @@ let mk_ref ~get ~set =
let
ref_type
t
=
let
get
=
Types
.
cons
(
Types
.
arrow
Sequence
.
nil_node
t
)
and
set
=
Types
.
cons
(
Types
.
arrow
t
Sequence
.
nil_node
)
in
Types
.
record
'
(
false
,
mk_ref
~
get
~
set
)
Types
.
record
_fields
(
false
,
mk_ref
~
get
~
set
)
let
float_abs
=
"float"
...
...
@@ -71,7 +71,7 @@ let float_abs =
let
float
=
Types
.
abstract
(
Types
.
Abstract
.
atom
float_abs
)
let
any_attr_node
=
Types
.
cons
(
Types
.
record
'
(
true
,
LabelMap
.
empty
))
let
any_attr_node
=
Types
.
cons
(
Types
.
record
_fields
(
true
,
LabelMap
.
empty
))
let
any_xml
,
any_xml_seq
,
any_xml_content
=
let
elt
=
Types
.
make
()
in
let
seq
=
Types
.
make
()
in
...
...
types/sample.ml
View file @
4460caed
...
...
@@ -21,7 +21,7 @@ let rec get memo t =
|
(
false
,
t
)
->
cons
t
in
let
record
(
r
,
some
,
none
)
=
let
r
=
LabelMap
.
filter
(
fun
l
(
o
,
t
)
->
not
o
)
r
in
Types
.
record
'
(
not
none
,
LabelMap
.
map
fields
r
)
in
Types
.
record
_fields
(
not
none
,
LabelMap
.
map
fields
r
)
in
let
typ
u
=
let
u
=
Types
.
cap
t
u
in
if
Types
.
is_empty
u
then
raise
Not_found
else
u
in
...
...
types/types.ml
View file @
4460caed
...
...
@@ -542,7 +542,7 @@ let arrow x y = { empty with hash = 0; arrow = BoolPair.atom (x,y) }
let
record
label
t
=
{
empty
with
hash
=
0
;
record
=
BoolRec
.
atom
(
true
,
LabelMap
.
singleton
label
t
)
}
let
record
'
(
x
:
bool
*
node
Ident
.
label_map
)
=
let
record
_fields
(
x
:
bool
*
node
Ident
.
label_map
)
=
{
empty
with
hash
=
0
;
record
=
BoolRec
.
atom
x
}
let
atom
a
=
{
empty
with
hash
=
0
;
atoms
=
a
}
let
char
c
=
{
empty
with
hash
=
0
;
chars
=
c
}
...
...
@@ -620,7 +620,7 @@ let rec constant = function
|
Char
c
->
char
(
Chars
.
atom
c
)
|
Pair
(
x
,
y
)
->
times
(
const_node
x
)
(
const_node
y
)
|
Xml
(
x
,
y
)
->
xml
(
const_node
x
)
(
const_node
y
)
|
Record
x
->
record
'
(
false
,
LabelMap
.
map
const_node
x
)
|
Record
x
->
record
_fields
(
false
,
LabelMap
.
map
const_node
x
)
|
String
(
i
,
j
,
s
,
c
)
->
if
U
.
equal_index
i
j
then
constant
c
else
...
...
@@ -1304,7 +1304,7 @@ struct
let
none
=
none1
&&
none2
and
some
=
some1
||
some2
in
let
accu
=
LabelMap
.
from_list
(
fun
_
_
->
assert
false
)
accu
in
(* approx for the case (some && not none) ... *)
res
:=
cup
!
res
(
record
'
(
some
,
accu
))
res
:=
cup
!
res
(
record
_fields
(
some
,
accu
))
else
let
l1
=
split
d1
l
and
l2
=
split
d2
l
in
let
loop
(
t1
,
d1
)
(
t2
,
d2
)
=
...
...
@@ -1944,7 +1944,7 @@ let rec_of_list o l =
cons
(
if
opt
then
Record
.
or_absent
typ
else
typ
))
l
)
in
record
'
(
o
,
map
)
record
_fields
(
o
,
map
)
let
empty_closed_record
=
rec_of_list
false
[]
let
empty_open_record
=
rec_of_list
true
[]
...
...
types/types.mli
View file @
4460caed
...
...
@@ -89,7 +89,7 @@ val xml : Node.t -> Node.t -> t
val
arrow
:
Node
.
t
->
Node
.
t
->
t
val
record
:
label
->
Node
.
t
->
t
(* bool = true -> open record; bool = false -> closed record *)
val
record
'
:
bool
*
Node
.
t
label_map
->
t
val
record
_fields
:
bool
*
Node
.
t
label_map
->
t
val
char
:
Chars
.
t
->
t
val
constant
:
const
->
t
val
abstract
:
Abstract
.
t
->
t
...
...
typing/typer.ml
View file @
4460caed
...
...
@@ -519,7 +519,7 @@ module IType = struct
|
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
compute_typ_field
r
)
|
IRecord
(
o
,
r
)
->
Types
.
record
_fields
(
o
,
LabelMap
.
map
compute_typ_field
r
)
|
ILink
_
->
assert
false
|
ICapture
_
|
IConstant
(
_
,_
)
->
assert
false
|
IConcat
_
|
IMerge
_
->
assert
false
...
...
@@ -575,7 +575,7 @@ module IType = struct
(
pat
e
)
::
!
pats
;
Types
.
Record
.
any_or_absent_node
)
in
let
constr
=
Types
.
record
'
(
o
,
LabelMap
.
mapi
aux
r
)
in
let
constr
=
Types
.
record
_fields
(
o
,
LabelMap
.
mapi
aux
r
)
in
List
.
fold_left
Patterns
.
cap
(
Patterns
.
constr
constr
)
!
pats
(* TODO: can avoid constr when o=true, and all fields have fv *)
|
ICapture
x
->
Patterns
.
capture
x
...
...
@@ -1643,7 +1643,7 @@ and type_record loc env r constr precise =
if
not
(
Types
.
Record
.
has_empty_record
rconstr
)
then
should_have
loc
constr
"More fields should be present"
;
let
t
=
Types
.
record
'
(
false
,
LabelMap
.
from_list
(
fun
_
_
->
assert
false
)
res
)
Types
.
record
_fields
(
false
,
LabelMap
.
from_list
(
fun
_
_
->
assert
false
)
res
)
in
verify
loc
t
constr
...
...
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