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
069fd5aa
Commit
069fd5aa
authored
Oct 30, 2007
by
Pietro Abate
Browse files
clean up
parent
ae22ade3
Changes
12
Hide whitespace changes
Inline
Side-by-side
CHANGES
View file @
069fd5aa
Since 0.5.6
* Allow reference to named OCaml types (by Pietro Abate)
0.5.0
* Port to OCaml 3.10, with the help of Nicolas Pouillard
...
...
ocamliface/.cvsignore
View file @
069fd5aa
...
...
@@ -4,5 +4,4 @@
*.cma
*.cmxa
cmi2ml
asttypes.ml
ocaml_files
asttypes.ml
\ No newline at end of file
ocamliface/mlstub.ml
View file @
069fd5aa
...
...
@@ -684,8 +684,6 @@ let to_cd_dyn = function
let
register
()
=
Typer
.
has_ocaml_unit
:=
(
fun
cu
->
Mltypes
.
has_cmi
(
U
.
get_str
cu
));
Typer
.
cduce_conv
:=
(
fun
v
->
typ_descr
(
Mltypes
.
find_type
v
)
.
def
);
Librarian
.
stub_ml
:=
stub_ml
;
Externals
.
register
:=
register
;
Externals
.
ext_info
:=
(
fun
()
->
Obj
.
magic
!
exts
);
...
...
ocamliface/mltypes.ml
View file @
069fd5aa
...
...
@@ -223,14 +223,6 @@ let unfold ty =
vars
:=
[]
;
(
t
,
n
)
let
unfold_type
p
=
vars
:=
[]
;
Hashtbl
.
clear
constr_table
;
let
t
=
unfold_constr
{
seen
=
IntSet
.
empty
;
constrs
=
StringSet
.
empty
;
vars
=
IntMap
.
empty
}
p
[]
in
assert
(
!
vars
=
[]
);
t
(* Reading .cmi *)
let
unsupported
s
=
...
...
@@ -241,7 +233,6 @@ let has_cmi name =
try
ignore
(
Misc
.
find_in_path_uncap
!
Config
.
load_path
(
name
^
".cmi"
));
true
with
Not_found
->
false
(* find the cduce type associated to an ocaml value *)
let
find_value
v
=
Config
.
load_path
:=
Config
.
standard_library
::
!
Loc
.
obj_path
;
let
li
=
Longident
.
parse
v
in
...
...
@@ -249,14 +240,6 @@ let find_value v =
let
(
_
,
vd
)
=
Env
.
lookup_value
li
Env
.
initial
in
unfold
vd
.
val_type
(* find the cduce type associated to an ocaml type *)
let
find_type
t
=
Config
.
load_path
:=
Config
.
standard_library
::
!
Loc
.
obj_path
;
let
li
=
Longident
.
parse
t
in
ocaml_env
:=
Env
.
initial
;
let
(
p
,_
)
=
Env
.
lookup_type
li
Env
.
initial
in
unfold_type
p
let
values_of_sig
name
sg
=
List
.
fold_left
(
fun
accu
v
->
match
v
with
...
...
ocamliface/mltypes.mli
View file @
069fd5aa
...
...
@@ -31,4 +31,4 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
val
find_value
:
string
->
t
*
int
val
find_type
:
string
->
t
runtime/print_xml.ml
View file @
069fd5aa
...
...
@@ -66,9 +66,13 @@ let false_literal = U.mk "false"
(* @raise exn_print_xml in case of failure. Rationale: schema printing is
* the last attempt to print a value, others have already failed *)
let
rec
schema_value
?
(
recurs
=
true
)
~
wds
v
=
match
v
with
|
Abstract
(
"float"
,
f
)
->
wds
(
U
.
mk
(
string_of_float
(
Obj
.
magic
f
:
float
)))
let
rec
schema_value
?
(
recurs
=
true
)
~
wds
~
wcs
v
=
match
v
with
|
Abstract
(
"float"
,
o
)
->
wds
(
U
.
mk
(
string_of_float
(
Obj
.
magic
o
:
float
)))
|
Abstract
(
"cdata"
,
o
)
->
wcs
(
U
.
mk
"<![CDATA["
);
wcs
(
U
.
mk
(
U
.
get_str
(
Obj
.
magic
o
:
U
.
t
)));
wcs
(
U
.
mk
"]]>"
)
|
Record
_
as
v
->
(
try
wds
(
Schema_builtin
.
string_of_time_type
(
Value
.
get_fields
v
))
...
...
@@ -76,18 +80,18 @@ let rec schema_value ?(recurs=true) ~wds v = match v with
|
Integer
i
->
wds
(
U
.
mk
(
Intervals
.
V
.
to_string
i
))
|
v
when
Value
.
equal
v
Value
.
vtrue
->
wds
true
_literal
|
v
when
Value
.
equal
v
Value
.
vfalse
->
wds
false
_literal
|
Pair
_
as
v
when
recurs
->
schema_values
~
wds
v
|
Pair
_
as
v
when
recurs
->
schema_values
~
wds
~
wcs
v
|
String_utf8
_
|
String_latin1
_
as
v
->
wds
(
fst
(
get_string_utf8
v
))
|
_
->
raise
exn_print_xml
and
schema_values
~
wds
v
=
and
schema_values
~
wds
~
wcs
v
=
match
v
with
|
Pair
(
hd
,
Atom
a
)
when
a
=
Sequence
.
nil_atom
->
schema_value
~
recurs
:
false
~
wds
hd
schema_value
~
recurs
:
false
~
wds
~
wcs
hd
|
Pair
(
hd
,
tl
)
->
schema_value
~
recurs
:
false
~
wds
hd
;
schema_value
~
recurs
:
false
~
wds
~
wcs
hd
;
wds
blank
;
schema_values
~
wds
tl
schema_values
~
wds
~
wcs
tl
|
_
->
raise
exn_print_xml
let
to_buf
~
utf8
buffer
ns_table
v
=
...
...
@@ -97,6 +101,7 @@ let to_buf ~utf8 buffer ns_table v =
let
wms
=
write_markup_string
~
to_enc
buffer
and
wds
s
=
write_data_string
~
to_enc
buffer
(
U
.
get_str
s
)
and
wcs
s
=
buffer
(
U
.
get_str
s
)
in
in
let
write_att
(
n
,
v
)
=
wms
(
" "
^
(
Ns
.
Printer
.
attr
printer
(
Label
.
value
n
))
^
"=
\"
"
);
wds
v
;
wms
"
\"
"
in
...
...
@@ -160,7 +165,7 @@ let to_buf ~utf8 buffer ns_table v =
end
else
begin
let
buf
=
Buffer
.
create
20
in
let
wds
s
=
Buffer
.
add_string
buf
(
U
.
get_str
s
)
in
schema_value
~
wds
v
;
schema_value
~
wds
~
wcs
:
wds
v
;
(
Label
.
from_int
n
,
U
.
mk
(
Buffer
.
contents
buf
))
end
)
attrs
in
...
...
@@ -177,7 +182,7 @@ let to_buf ~utf8 buffer ns_table v =
match
q
with
|
Pair
((
Xml
_
|
XmlNs
_
)
as
x
,
q
)
->
print_elt
[]
x
;
print_content
q
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
()
|
v
->
schema_value
~
wds
v
|
v
->
schema_value
~
wds
~
wcs
v
in
document_start
()
;
print_elt
(
Ns
.
Printer
.
prefixes
printer
)
v
...
...
runtime/value.ml
View file @
069fd5aa
...
...
@@ -284,6 +284,11 @@ let rec print ppf v =
Format
.
fprintf
ppf
"<concat:%a;%a>"
print
x
print
y
|
Abstract
(
"float"
,
o
)
->
Format
.
fprintf
ppf
"%f"
(
Obj
.
magic
o
:
float
)
|
Abstract
(
"cdata"
,
o
)
->
let
s
=
Utf8
.
get_str
(
Obj
.
magic
o
:
Utf8
.
t
)
in
Format
.
fprintf
ppf
"'%s'"
s
(* Format.fprintf ppf "%s" (Utf8.get_str (Obj.magic o :
* Encodings.Utf8.t)) *)
|
Abstract
(
s
,_
)
->
Format
.
fprintf
ppf
"<abstract=%s>"
s
|
Absent
->
...
...
@@ -417,8 +422,12 @@ let rec compare x y =
raise
(
CDuceExn
(
string_latin1
"comparing functional values"
))
|
Abstract
(
s1
,
v1
)
,
Abstract
(
s2
,
v2
)
->
let
c
=
Types
.
Abstract
.
T
.
compare
s1
s2
in
if
c
<>
0
then
c
else
Pervasives
.
compare
(
Obj
.
magic
v1
:
float
)
(
Obj
.
magic
v2
:
float
)
(* raise (CDuceExn (string_latin1 "comparing abstract values")) *)
else
begin
match
s1
with
|
"float"
->
Pervasives
.
compare
(
Obj
.
magic
v1
:
float
)
(
Obj
.
magic
v2
:
float
)
|
"cdata"
->
Pervasives
.
compare
(
Obj
.
magic
v1
:
Encodings
.
Utf8
.
t
)
(
Obj
.
magic
v2
:
Encodings
.
Utf8
.
t
)
|_
->
raise
(
CDuceExn
(
string_latin1
"comparing abstract values"
))
end
|
Absent
,_
|
_
,
Absent
->
Format
.
fprintf
Format
.
std_formatter
"ERR: Compare %a %a@."
print
x
print
y
;
...
...
@@ -713,6 +722,9 @@ let print_utf8 v =
let
float
n
=
Abstract
(
"float"
,
Obj
.
repr
n
)
let
cdata
n
=
Abstract
(
"cdata"
,
Obj
.
repr
n
)
let
cduce2ocaml_option
f
v
=
match
normalize
v
with
|
Pair
(
x
,
y
)
->
Some
(
f
x
)
...
...
runtime/value.mli
View file @
069fd5aa
...
...
@@ -83,6 +83,7 @@ val flatten : t -> t
val
append
:
t
->
t
->
t
val
float
:
float
->
t
val
cdata
:
string
->
t
val
get_string_latin1
:
t
->
string
val
get_string_utf8
:
t
->
U
.
t
*
t
...
...
types/builtin.ml
View file @
069fd5aa
...
...
@@ -116,6 +116,12 @@ let exn_namespaces = lazy (
Value
.
string_latin1
"namespaces"
))
)
let
exn_cdata_of
=
lazy
(
Value
.
CDuceExn
(
Value
.
Pair
(
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
"Invalid_argument"
)
,
Value
.
string_latin1
"cdata_of"
))
)
let
eval_load_file
~
utf8
e
=
Cduce_loc
.
protect_op
"load_file"
;
...
...
@@ -439,3 +445,11 @@ register_fun "float_of" string float
let
(
s
,_
)
=
Value
.
get_string_utf8
v
in
try
Value
.
float
(
float_of_string
(
U
.
get_str
s
))
with
Failure
_
->
raise
(
Lazy
.
force
exn_float_of
));;
(* cdata *)
register_fun
"cdata_of"
string
string
(
fun
v
->
let
(
s
,_
)
=
Value
.
get_string_utf8
v
in
try
Value
.
cdata
(
U
.
get_str
s
)
with
Failure
_
->
raise
(
Lazy
.
force
exn_cdata_of
));;
typing/typer.ml
View file @
069fd5aa
...
...
@@ -131,12 +131,7 @@ let find_id env0 env loc head x =
with
Not_found
when
head
->
try
ECDuce
(
!
load_comp_unit
x
)
with
Not_found
->
if
((
match
(
U
.
get_str
x
)
.
[
0
]
with
'
A'
..
'
Z'
->
true
|
_
->
false
)
&&
!
has_ocaml_unit
x
)
then
EOCaml
(
U
.
get_str
x
)
else
error
loc
(
"Cannot resolve this identifier "
^
(
Ns
.
QName
.
to_string
id
))
error
loc
"Cannot resolve this identifier"
let
find_id_comp
env0
env
loc
x
=
if
((
match
(
U
.
get_str
x
)
.
[
0
]
with
'
A'
..
'
Z'
->
true
|
_
->
false
)
...
...
@@ -246,16 +241,11 @@ let type_ns env loc p ns =
ns
=
Ns
.
add_prefix
p
ns
env
.
ns
;
ids
=
Env
.
add
(
Ns
.
empty
,
p
)
(
ENamespace
ns
)
env
.
ids
}
let
cduce_conv
=
ref
(
fun
_
->
failwith
"cduce conv not initialized"
)
let
find_global_type
env
loc
ids
=
match
find_global
env
loc
ids
with
|
Type
t
|
ESchemaComponent
(
t
,_
)
->
t
|
EOCamlComponent
s
->
let
t
=
!
cduce_conv
s
in
let
v
=
ident
env
loc
(
U
.
mk
s
)
in
Types
.
Print
.
register_global
""
v
t
;
t
|
_
->
error
loc
"This path does not refer to a type"
let
find_global_schema_component
env
loc
ids
=
...
...
typing/typer.mli
View file @
069fd5aa
...
...
@@ -69,4 +69,3 @@ val has_static_external: (string -> bool) ref
val
load_schema
:
(
string
->
string
->
Ns
.
Uri
.
t
*
(
Types
.
t
*
Schema_validator
.
t
)
Ident
.
Env
.
t
)
ref
val
cduce_conv
:
(
string
->
Types
.
t
)
ref
web/contacts.xml
View file @
069fd5aa
...
...
@@ -43,27 +43,57 @@ project.
Do you want to see
<local
href=
"img"
>
what we look like
</local>
?
</p>
<section
title=
"CDuce @ Gallium (INRIA Rocquencourt)"
>
<p>
Research group:
<a
href=
"http://cristal.inria.fr"
>
Gallium project
</a>
.
</p>
<ul>
<li>
<a
href=
"http://
alain.
frisch
.fr
/"
>
<a
href=
"http://
www.eleves.ens.fr/home/
frisch/"
>
Alain Frisch
</a>
(now at
<a
href=
"http://www.lexifi.com"
>
LexiFi
</a>
):
<i>
project
leader, main developer
</i>
.
</a>
(Research associate):
<i>
project leader, main developer
</i>
.
</li>
</ul>
</section>
<section
title=
"CDuce @ ENS (Paris)"
>
<p>
Research group:
<a
href=
"http://www.di.ens.fr/~castagna/EQUIPE/"
>
Language group
</a>
.
</p>
<ul>
<li>
<a
href=
"http://www.di.ens.fr/~castagna/"
>
Giuseppe Castagna
</a>
(CNRS researcher, PPS laboratory):
<i>
project leader
</i>
.
</a>
(CNRS researcher):
<i>
project leader
</i>
.
</li>
<li>
<a
href=
"http://www.di.ens.fr/~gesbert"
>
Nils Gesbert
</a>
(Post Doc):
<i>
concurrency for CDuce
</i>
.
</li>
</ul>
</section>
<section
title=
"CDuce @ LRI (Orsay)"
>
<p>
Research group:
<a
href=
"http://www.lri.fr/bd/introduction.en.shtml"
>
Database group
</a>
.
</p>
<ul>
<li>
<a
href=
"http://www.lri.fr/~benzaken/"
>
Vronique Benzaken
</a>
(Prof. Univ. Paris 11):
<i>
project leader
</i>
.
</li>
<li>
<a
href=
"http://www.di.ens.fr/~gesbert"
>
Nils Gesbert
</a>
(Post Doc):
<i>
concurrency for CDuce
</i>
.
</li>
<li>
<a
href=
"http://www.lri.fr/~burelle/"
>
Marwan Burelle
...
...
@@ -84,24 +114,7 @@ Do you want to see <local href="img">what we look like</local> ?
</li>
</ul>
<p>
Our work on CDuce was supported by the following research
groups:
</p>
<ul>
<li>
<a
href=
"http://www.di.ens.fr/~castagna/EQUIPE/"
>
Language group
</a>
,
ENS Paris.
</li>
<li>
<a
href=
"http://www.lri.fr/bd/introduction.en.shtml"
>
Database
group
</a>
, Paris-Sud 11 University.
</li>
<li><a
href=
"http://gallium.inria.fr"
>
Gallium project
</a>
, INRIA Rocquencourt.
</li>
<li><a
href=
"http://www.pps.jussieu.fr/"
>
PPS laboratory
</a>
, Paris 7 University.
</li>
</ul>
</section>
<section
title=
"Former interns and students"
>
<ul>
...
...
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