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
4776d728
Commit
4776d728
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2004-06-28 00:23:45 by afrisch] Types abstraits, unit, Any
Original author: afrisch Date: 2004-06-28 00:23:46+00:00
parent
b2b41826
Changes
9
Hide whitespace changes
Inline
Side-by-side
ocamliface/mlstub.ml
View file @
4776d728
...
...
@@ -49,8 +49,11 @@ and typ_descr = function
|
Abstract
"int"
->
Builtin_defs
.
caml_int
|
Abstract
"char"
->
Builtin_defs
.
char_latin1
|
Abstract
"string"
->
Builtin_defs
.
string_latin1
|
Abstract
s
->
Types
.
abstract
(
Types
.
Abstract
.
atom
s
)
|
Builtin
(
"list"
,
[
t
])
->
Types
.
descr
(
Sequence
.
star_node
(
typ
t
))
|
Builtin
(
"Pervasives.ref"
,
[
t
])
->
Builtin_defs
.
ref_type
(
typ
t
)
|
Builtin
(
"CDuce_all.Value.t"
,
[]
)
->
Types
.
any
|
Builtin
(
"unit"
,
[]
)
->
Sequence
.
nil_type
|
_
->
assert
false
and
pvariant
=
function
...
...
@@ -174,11 +177,14 @@ and to_cd_descr e = function
|
Abstract
"int"
->
<:
expr
<
ocaml2cduce_int
$
e
$
>>
|
Abstract
"char"
->
<:
expr
<
ocaml2cduce_char
$
e
$
>>
|
Abstract
"string"
->
<:
expr
<
ocaml2cduce_string
$
e
$
>>
|
Abstract
s
->
<:
expr
<
Value
.
abstract
$
str
:
String
.
escaped
s
$
$
e
$
>>
|
Builtin
(
"list"
,
[
t
])
->
(* Value.sequence_rev (List.rev_map fun_t <...>) *)
<:
expr
<
Value
.
sequence_rev
(
List
.
rev_map
$
lid
:
to_cd_fun
t
$
$
e
$
)
>>
|
Builtin
(
"Pervasives.ref"
,
[
t
])
->
failwith
"to_cd: Reference. TODO"
|
Builtin
(
"CDuce_all.Value.t"
,
[]
)
->
e
|
Builtin
(
"unit"
,
[]
)
->
<:
expr
<
do
{
$
e
$;
Value
.
nil
}
>>
|
_
->
assert
false
and
tuple_to_cd
tl
vars
=
List
.
map2
(
fun
t
id
->
to_cd
<:
expr
<
$
lid
:
id
$
>>
t
)
tl
vars
...
...
@@ -275,6 +281,7 @@ and to_ml_descr e = function
|
Abstract
"int"
->
<:
expr
<
cduce2ocaml_int
$
e
$
>>
|
Abstract
"char"
->
<:
expr
<
cduce2ocaml_char
$
e
$
>>
|
Abstract
"string"
->
<:
expr
<
cduce2ocaml_string
$
e
$
>>
|
Abstract
s
->
<:
expr
<
Value
.
get_abstract
$
e
$
>>
|
Builtin
(
"list"
,
[
t
])
->
(* List.rev_map fun_t (Value.get_sequence_rev <...> *)
<:
expr
<
List
.
rev_map
$
lid
:
to_ml_fun
t
$
(
Value
.
get_sequence_rev
$
e
$
)
>>
...
...
@@ -283,6 +290,8 @@ and to_ml_descr e = function
let
e
=
<:
expr
<
Value
.
get_field
$
e
$
$
label_ascii
"get"
$
>>
in
let
e
=
<:
expr
<
Eval
.
eval_apply
$
e
$
Value
.
nil
>>
in
<:
expr
<
Pervasives
.
ref
$
to_ml
e
t
$
>>
|
Builtin
(
"CDuce_all.Value.t"
,
[]
)
->
e
|
Builtin
(
"unit"
,
[]
)
->
<:
expr
<
ignore
$
e
$
>>
|
_
->
assert
false
and
tuple_to_ml
tl
vars
=
List
.
map2
(
fun
t
id
->
to_ml
<:
expr
<
$
lid
:
id
$
>>
t
)
tl
vars
...
...
ocamliface/mltypes.ml
View file @
4776d728
...
...
@@ -78,7 +78,7 @@ let new_slot () =
let
builtins
=
List
.
fold_left
(
fun
m
x
->
StringMap
.
add
x
()
m
)
StringMap
.
empty
[
"list"
;
"Pervasives.ref"
]
[
"list"
;
"Pervasives.ref"
;
"CDuce_all.Value.t"
;
"unit"
]
let
rec
unfold
seen
constrs
ty
=
try
...
...
@@ -141,8 +141,8 @@ let rec unfold seen constrs ty =
Link
(
loop
t
)
|
Type_abstract
,
None
->
(
match
args
with
|
[]
->
Abstract
(
Path
.
name
p
)
|
_
->
failwith
"Polymorphic abstract type
"
)))
|
[]
->
Abstract
pn
|
_
->
failwith
(
"Polymorphic abstract type
: "
^
pn
)
)))
|
_
->
failwith
"Unsupported feature"
);
slot
...
...
parser/parser.ml
View file @
4776d728
...
...
@@ -518,6 +518,8 @@ EXTEND
|
schema
=
IDENT
;
"#"
;
typ
=
[
IDENT
|
keyword
];
kind
=
OPT
[
"as"
;
k
=
schema_kind
->
k
]
->
mk
loc
(
SchemaVar
(
kind
,
U
.
mk
schema
,
U
.
mk
typ
))
|
"!"
;
a
=
IDENT
->
mk
loc
(
Internal
(
Types
.
abstract
(
Types
.
Abstract
.
atom
a
)))
|
a
=
IDENT
->
mk
loc
(
PatVar
(
U
.
mk
a
))
|
i
=
INT
;
"--"
;
j
=
INT
->
...
...
runtime/value.ml
View file @
4776d728
...
...
@@ -256,10 +256,8 @@ let rec print ppf v =
(
Utf8
.
get_idx
i
)
(
Utf8
.
get_idx
j
)
(
Utf8
.
get_str
s
)
print
q
|
Concat
(
x
,
y
)
->
Format
.
fprintf
ppf
"<concat:%a;%a>"
print
x
print
y
|
Abstract
((
cu
,
id
)
,_
)
->
Format
.
fprintf
ppf
"<abstract=%a:%a>"
Utf8
.
print
(
Types
.
CompUnit
.
value
cu
)
Utf8
.
print
(
Id
.
value
id
)
|
Abstract
(
s
,_
)
->
Format
.
fprintf
ppf
"<abstract=%s>"
s
|
Absent
->
Format
.
fprintf
ppf
"<[absent]>"
|
Delayed
x
->
...
...
@@ -353,10 +351,8 @@ let dump_xml ppf v =
|
Abstraction2
_
->
Format
.
fprintf
ppf
"@[<hv1>"
;
Format
.
fprintf
ppf
"<abstraction2 />@]"
|
Abstract
((
cu
,
id
)
,_
)
->
Format
.
fprintf
ppf
"<abstract><unit>%a</unit><type>%a</type></abstract>"
Utf8
.
print
(
Types
.
CompUnit
.
value
cu
)
Utf8
.
print
(
Id
.
value
id
)
|
Abstract
(
s
,_
)
->
Format
.
fprintf
ppf
"<abstract>%s</abstract>"
s
|
String_latin1
(
_
,
_
,
s
,
v
)
->
Format
.
fprintf
ppf
"@[<hv1>"
;
Format
.
fprintf
ppf
"<string_latin1>@,%s@,</string_latin1>@,"
s
;
...
...
@@ -397,14 +393,12 @@ let rec compare x y =
|
Integer
x
,
Integer
y
->
Intervals
.
V
.
compare
x
y
|
Char
x
,
Char
y
->
Chars
.
V
.
compare
x
y
|
Abstraction
(
_
,_
)
,
_
|
_
,
Abstraction
(
_
,_
)
->
raise
(
CDuceExn
(
string_latin1
"comparing functional values"
))
|
_
,
Abstraction
(
_
,_
)
|
Abstraction2
(
_
,_,_
)
,
_
|
_
,
Abstraction2
(
_
,_,_
)
->
raise
(
CDuceExn
(
string_latin1
"comparing functional values"
))
|
Abstract
((
cu1
,
id1
)
,
v1
)
,
Abstract
((
cu2
,
id2
)
,
v2
)
->
let
c
=
Types
.
CompUnit
.
compare
cu1
cu2
in
if
c
<>
0
then
c
else
let
c
=
Id
.
compare
id1
id2
in
if
c
<>
0
then
c
|
Abstract
(
s1
,
v1
)
,
Abstract
(
s2
,
v2
)
->
let
c
=
Types
.
Abstract
.
T
.
compare
s1
s2
in
if
c
<>
0
then
c
else
raise
(
CDuceExn
(
string_latin1
"comparing abstract values"
))
|
Absent
,_
|
_
,
Absent
|
Delayed
_
,
_
|
_
,
Delayed
_
->
assert
false
...
...
@@ -575,3 +569,10 @@ let get_field v l =
|
Record
fields
->
LabelMap
.
assoc
l
fields
|
_
->
raise
Not_found
let
abstract
a
v
=
Abstract
(
a
,
Obj
.
repr
v
)
let
get_abstract
=
function
|
Abstract
(
_
,
v
)
->
Obj
.
magic
v
|
_
->
assert
false
runtime/value.mli
View file @
4776d728
...
...
@@ -61,6 +61,9 @@ val get_field : t -> label -> t
val
get_variant
:
t
->
string
*
t
option
val
abstract
:
Types
.
Abstract
.
abs
->
'
a
->
t
val
get_abstract
:
t
->
'
a
(* iterator on the content of an Xml value. First callback is invoked on Utf8
character children; second callback is invoked on other children values *)
val
iter_xml
:
(
U
.
t
->
unit
)
->
(
t
->
unit
)
->
t
->
unit
...
...
types/builtin_defs.ml
View file @
4776d728
...
...
@@ -63,7 +63,7 @@ let ref_type t =
Types
.
record'
(
false
,
mk_ref
~
get
~
set
)
let
float_abs
=
Types
.
CompUnit
.
pervasives
,
Ident
.
Id
.
mk
(
Encodings
.
Utf8
.
mk
"float"
)
"float"
let
float
=
Types
.
abstract
(
Types
.
Abstract
.
atom
float_abs
)
types/sample.ml
View file @
4776d728
...
...
@@ -33,7 +33,10 @@ let rec get memo t =
let
r
=
List
.
sort
(
fun
(
_
,_,
n1
)
(
_
,_,
n2
)
->
-
(
compare
n1
n2
))
r
in
try_seq
record
r
with
Not_found
->
try
Types
.
Arrow
.
sample
t
with
Not_found
->
t
(*
raise Not_found
*)
let
get
=
get
D
.
empty
...
...
types/types.ml
View file @
4776d728
...
...
@@ -172,7 +172,7 @@ end
module
Abstract
=
struct
module
T
=
Custom
.
Pair
(
CompUnit
)(
Id
)
module
T
=
Custom
.
String
type
abs
=
T
.
t
module
V
=
...
...
@@ -185,7 +185,8 @@ struct
let
print
=
function
|
Finite
[]
->
[
]
|
Cofinite
[]
->
[
fun
ppf
->
Format
.
fprintf
ppf
"Abstract"
]
|
_
->
failwith
"Types.Abstract.print"
|
Finite
l
->
List
.
map
(
fun
x
ppf
->
Format
.
fprintf
ppf
"!%s"
x
)
l
|
Cofinite
_
->
assert
false
end
...
...
types/types.mli
View file @
4776d728
...
...
@@ -29,10 +29,12 @@ module CompUnit : sig
end
module
Abstract
:
sig
type
abs
=
CompUnit
.
t
*
Ident
.
id
module
T
:
Custom
.
T
with
type
t
=
string
type
abs
=
T
.
t
type
t
val
any
:
t
val
atom
:
abs
->
t
val
compare
:
t
->
t
->
int
module
V
:
sig
type
t
=
abs
*
Obj
.
t
...
...
@@ -253,3 +255,4 @@ sig
val
print
:
Format
.
formatter
->
t
->
unit
end
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