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
f775a5cf
Commit
f775a5cf
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2007-06-12 15:13:49 by afrisch] ocaml/cduce iface for OCaml 3.10
Original author: afrisch Date: 2007-06-12 15:13:49+00:00
parent
5dd9400e
Changes
7
Hide whitespace changes
Inline
Side-by-side
META.in
View file @
f775a5cf
version="%VER%"
requires="%REQ%
camlp4.gramlib
"
requires="%REQ%"
description="Runtime support for CDuce"
archive(byte)="+camlp4/camlp4
.cma +camlp4/pr_o
.cm
o
cduce_lib.cma"
archive(native)="+camlp4/camlp4
.cmxa +camlp4/pr_o
.cmx cduce_lib.cmxa"
archive(byte)="+camlp4/camlp4
lib
.cm
a
cduce_lib.cma"
archive(native)="+camlp4/camlp4
lib
.cmx
a
cduce_lib.cmxa"
depend
View file @
f775a5cf
...
...
@@ -268,14 +268,28 @@ query/query_aggregates.cmo: runtime/value.cmi types/sequence.cmi \
compile/operators.cmi types/intervals.cmi types/builtin_defs.cmi
query/query_aggregates.cmx: runtime/value.cmx types/sequence.cmx \
compile/operators.cmx types/intervals.cmx types/builtin_defs.cmx
ocamliface/mltypes.cmo: types/ident.cmo ocamliface/config.cmo \
parser/cduce_loc.cmi ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: types/ident.cmx ocamliface/config.cmx \
parser/cduce_loc.cmx ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/types.cmi typing/typer.cmi types/sequence.cmi \
misc/ns.cmi ocamliface/mltypes.cmi driver/librarian.cmi types/ident.cmo \
types/externals.cmi ocamliface/config.cmo compile/compile.cmi \
parser/cduce_loc.cmi types/builtin_defs.cmi types/atoms.cmi \
parser/ast.cmo ocamliface/mlstub.cmi
ocamliface/mlstub.cmx: types/types.cmx typing/typer.cmx types/sequence.cmx \
misc/ns.cmx ocamliface/mltypes.cmx driver/librarian.cmx types/ident.cmx \
types/externals.cmx ocamliface/config.cmx compile/compile.cmx \
parser/cduce_loc.cmx types/builtin_defs.cmx types/atoms.cmx \
parser/ast.cmx ocamliface/mlstub.cmi
parser/cduce_netclient.cmo: runtime/value.cmi parser/url.cmi \
ocamliface/
config.cm
o
driver/cduce_
config.cm
i
parser/cduce_netclient.cmx: runtime/value.cmx parser/url.cmx \
ocamlifa
ce
/
config.cmx
driver/cdu
ce
_
config.cmx
runtime/cduce_pxp.cmo: runtime/value.cmi parser/url.cmi schema/schema_xml.cmi \
runtime/load_xml.cmi
ocamliface/
config.cm
o
runtime/cduce_pxp.cmi
runtime/load_xml.cmi
driver/cduce_
config.cm
i
runtime/cduce_pxp.cmi
runtime/cduce_pxp.cmx: runtime/value.cmx parser/url.cmx schema/schema_xml.cmx \
runtime/load_xml.cmx
ocamlifa
ce
/
config.cmx runtime/cduce_pxp.cmi
runtime/load_xml.cmx
driver/cdu
ce
_
config.cmx runtime/cduce_pxp.cmi
driver/run.cmo: runtime/value.cmi parser/ulexer.cmi misc/stats.cmi \
driver/librarian.cmi types/ident.cmo misc/html.cmi parser/cduce_loc.cmi \
driver/cduce_config.cmi driver/cduce.cmi types/builtin.cmi
...
...
@@ -296,36 +310,38 @@ tools/validate.cmo: schema/schema_types.cmi schema/schema_parser.cmi \
schema/schema_common.cmi
tools/validate.cmx: schema/schema_types.cmx schema/schema_parser.cmx \
schema/schema_common.cmx
ocamliface/mltypes.cmo:
ocamliface/location.cmo types/ident
.cmo \
ocamliface/config
.cm
o
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx:
ocamliface/location.cmx types/ident
.cmx \
ocamliface/config
.cmx ocamliface/mltypes.cmi
ocamliface/mltypes.cmo:
types/ident.cmo ocamliface/config
.cmo \
parser/cduce_loc
.cm
i
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx:
types/ident.cmx ocamliface/config
.cmx \
parser/cduce_loc
.cmx ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/types.cmi typing/typer.cmi types/sequence.cmi \
misc/ns.cmi ocamliface/mltypes.cmi
ocamliface/location
.cmo \
driver/librarian.cmi types/ident.cmo types/externals
.cmi \
ocamliface/config.cmo compile/compile
.cmi types/builtin_defs.cmi \
types/atoms.cmi
parser/ast.cmo ocamliface/mlstub.cmi
misc/ns.cmi ocamliface/mltypes.cmi
driver/librarian.cmi types/ident
.cmo \
types/externals.cmi ocamliface/config.cmo compile/compile
.cmi \
parser/cduce_loc
.cmi types/builtin_defs.cmi
types/atoms.cmi
\
parser/ast.cmo ocamliface/mlstub.cmi
ocamliface/mlstub.cmx: types/types.cmx typing/typer.cmx types/sequence.cmx \
misc/ns.cmx ocamliface/mltypes.cmx ocamliface/location.cmx \
driver/librarian.cmx types/ident.cmx types/externals.cmx \
ocamliface/config.cmx compile/compile.cmx types/builtin_defs.cmx \
types/atoms.cmx parser/ast.cmx ocamliface/mlstub.cmi
parser/cduce_curl.cmo: runtime/value.cmi parser/url.cmi ocamliface/config.cmo
parser/cduce_curl.cmx: runtime/value.cmx parser/url.cmx ocamliface/config.cmx
misc/ns.cmx ocamliface/mltypes.cmx driver/librarian.cmx types/ident.cmx \
types/externals.cmx ocamliface/config.cmx compile/compile.cmx \
parser/cduce_loc.cmx types/builtin_defs.cmx types/atoms.cmx \
parser/ast.cmx ocamliface/mlstub.cmi
parser/cduce_curl.cmo: runtime/value.cmi parser/url.cmi \
driver/cduce_config.cmi
parser/cduce_curl.cmx: runtime/value.cmx parser/url.cmx \
driver/cduce_config.cmx
parser/cduce_netclient.cmo: runtime/value.cmi parser/url.cmi \
ocamliface/
config.cm
o
driver/cduce_
config.cm
i
parser/cduce_netclient.cmx: runtime/value.cmx parser/url.cmx \
ocamlifa
ce
/
config.cmx
driver/cdu
ce
_
config.cmx
runtime/cduce_expat.cmo: runtime/value.cmi parser/url.cmi \
schema/schema_xml.cmi runtime/load_xml.cmi
ocamliface/
config.cm
o
\
schema/schema_xml.cmi runtime/load_xml.cmi
driver/cduce_
config.cm
i
\
runtime/cduce_expat.cmi
runtime/cduce_expat.cmx: runtime/value.cmx parser/url.cmx \
schema/schema_xml.cmx runtime/load_xml.cmx
ocamlifa
ce
/
config.cmx \
schema/schema_xml.cmx runtime/load_xml.cmx
driver/cdu
ce
_
config.cmx \
runtime/cduce_expat.cmi
runtime/cduce_pxp.cmo: runtime/value.cmi parser/url.cmi schema/schema_xml.cmi \
runtime/load_xml.cmi
ocamliface/
config.cm
o
runtime/cduce_pxp.cmi
runtime/load_xml.cmi
driver/cduce_
config.cm
i
runtime/cduce_pxp.cmi
runtime/cduce_pxp.cmx: runtime/value.cmx parser/url.cmx schema/schema_xml.cmx \
runtime/load_xml.cmx
ocamlifa
ce
/
config.cmx runtime/cduce_pxp.cmi
runtime/load_xml.cmx
driver/cdu
ce
_
config.cmx runtime/cduce_pxp.cmi
misc/encodings.cmi: misc/custom.cmo
misc/upool.cmi: misc/custom.cmo
misc/ns.cmi: misc/upool.cmi misc/encodings.cmi misc/custom.cmo
...
...
@@ -386,5 +402,8 @@ driver/librarian.cmi: runtime/value.cmi types/types.cmi typing/typer.cmi \
types/sample.cmi: types/types.cmi
driver/cduce.cmi: runtime/value.cmi types/atoms.cmi
ocamliface/mltypes.cmi: types/types.cmi
ocamliface/mlstub.cmi: parser/ast.cmo
ocamliface/mltypes.cmi: types/types.cmi
ocamliface/mlstub.cmi: parser/ast.cmo
schema/schema_types.cmi: runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
types/atoms.cmi
ocamliface/Makefile
View file @
f775a5cf
...
...
@@ -19,14 +19,15 @@ endif
ocaml_files
:
mkdir
ocaml_files
$(HIDE)
cp
$(
patsubst
%,
$(OCAML_SRC)
/%,
$(COPY_FILES)
)
ocaml_files/
cp
location.ml ocaml_files
mv
ocaml_files/asttypes.mli ocaml_files/asttypes.ml
cp
location.ml ocaml_files
/location.ml
cp
ocaml_files/asttypes.mli ocaml_files/asttypes.ml
sed
s
=
STDLIB
=
$(STDLIB)
=
config.ml
>
ocaml_files/config.ml
grep
cmi_magic
$(OCAML_SRC)
/utils/config.mlp
>>
ocaml_files/config.ml
caml_cduce.cmo
:
ocaml_files
@
echo
"Build
$@
"
(
cd
ocaml_files
;
ocamlc
$(FORPACKOPT1)
-c
$(COMPILE_FILES)
;
\
(
cd
ocaml_files
;
\
ocamlc
$(FORPACKOPT1)
-c
$(COMPILE_FILES)
;
\
ocamlc
$(FORPACKOPT2)
-pack
-o
$@
$(OBJECTS)
;
\
cp
caml_cduce.cmo caml_cduce.cmi ..
)
...
...
@@ -42,7 +43,9 @@ clean:
COPY_FILES
=
\
utils/misc.ml utils/tbl.ml
\
utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.ml
\
parsing/asttypes.mli parsing/longident.ml
\
parsing/asttypes.mli parsing/location.mli
\
parsing/longident.ml
\
typing/outcometree.mli
\
typing/ident.ml typing/path.ml
\
typing/primitive.ml typing/types.ml
\
typing/btype.ml typing/oprint.ml
\
...
...
@@ -51,9 +54,10 @@ COPY_FILES=\
typing/ctype.ml typing/ctype.mli typing/printtyp.ml
COMPILE_FILES
=
\
asttypes.mli outcometree.mli asttypes.ml
\
config.ml misc.ml tbl.ml
\
clflags.ml consistbl.ml warnings.ml terminfo.ml
\
location.ml
asttypes
.ml longident.ml
\
location.ml
i location
.ml longident.ml
\
ident.ml path.ml
\
primitive.ml types.ml
\
btype.ml oprint.ml
\
...
...
ocamliface/location.ml
View file @
f775a5cf
(* An implementation of the OCaml's Location signature (to cut dependencies
to other OCaml modules *)
open
Lexing
type
t
=
{
loc_start
:
position
;
loc_end
:
position
;
loc_ghost
:
bool
}
let
none
=
{
loc_start
=
dummy_pos
;
loc_end
=
dummy_pos
;
loc_ghost
=
true
}
let
dummy
x
=
assert
false
let
in_file
=
dummy
let
init
=
dummy
let
curr
=
dummy
let
symbol_rloc
=
dummy
let
symbol_gloc
=
dummy
let
rhs_loc
=
dummy
let
input_name
=
ref
""
let
input_lexbuf
=
ref
None
let
get_pos_info
=
dummy
let
print
=
dummy
let
print_warning
=
dummy
let
prerr_warning
=
dummy
let
echo_eof
=
dummy
let
reset
=
dummy
let
highlight_locations
=
dummy
ocamliface/mlstub.ml
View file @
f775a5cf
#
load
"q_MLast.cmo"
;;
(* TODO:
- optimizations: generate labels and atoms only once.
- translate record to open record on positive occurence
*)
open
Mltypes
open
Ident
open
Camlp4
.
PreCast
let
_loc
=
Loc
.
ghost
module
IntMap
=
Map
.
Make
(
struct
type
t
=
int
let
compare
:
t
->
t
->
int
=
compare
end
)
...
...
@@ -25,6 +26,17 @@ let atom lab = Types.atom (Atoms.atom (Atoms.V.mk_ascii lab))
let
label
lab
=
Label
.
mk
(
Ns
.
empty
,
U
.
mk
lab
)
let
bigcup
f
l
=
List
.
fold_left
(
fun
accu
x
->
Types
.
cup
accu
(
f
x
))
Types
.
empty
l
let
id
s
=
let
rec
aux
i
:
Ast
.
ident
=
try
let
j
=
String
.
index_from
s
i
'.'
in
<:
ident
<
$
uid
:
String
.
sub
s
i
(
j
-
i
)
$.$
aux
(
j
+
1
)
$
>>
with
Not_found
->
<:
ident
<
$
lid
:
String
.
sub
s
i
(
String
.
length
s
-
i
)
$
>>
in
(* Printf.eprintf "*** %S\n" s; *)
aux
0
let
rec
typ
t
=
try
IntHash
.
find
memo_typ
t
.
uid
with
Not_found
->
...
...
@@ -77,11 +89,6 @@ let mk_var _ =
let
mk_vars
=
List
.
map
mk_var
let
_loc
=
(
Lexing
.
dummy_pos
,
Lexing
.
dummy_pos
)
let
let_in
p
e
body
=
<:
expr
<
let
$
list
:
[
p
,
e
]
$
in
$
body
$
>>
let
atom_ascii
lab
=
<:
expr
<
Value
.
atom_ascii
$
str
:
String
.
escaped
lab
$
>>
...
...
@@ -91,16 +98,15 @@ let label_ascii lab =
let
pair
e1
e2
=
<:
expr
<
Value
.
Pair
(
$
e1
$,$
e2
$
)
>>
let
pmatch
e
l
=
let
l
=
List
.
map
(
fun
(
p
,
e
)
->
p
,
None
,
e
)
l
in
<:
expr
<
match
$
e
$
with
[
$
list
:
l
$
]
>>
let
rec
matches
ine
oute
=
function
|
[
v1
;
v2
]
->
let_in
<:
patt
<
(
$
lid
:
v1
$,$
lid
:
v2
$
)
>>
<:
expr
<
Value
.
get_pair
$
ine
$
>>
oute
<:
expr
<
let
(
$
lid
:
v1
$,$
lid
:
v2
$
)
=
Value
.
get_pair
$
ine
$
in
$
oute
$
>>
|
v
::
vl
->
let
r
=
mk_var
()
in
let
oute
=
matches
<:
expr
<
$
lid
:
r
$
>>
oute
vl
in
let_in
<:
patt
<
(
$
lid
:
v
$,$
lid
:
r
$
)
>>
<:
expr
<
Value
.
get_pair
$
ine
$
>>
oute
<:
expr
<
let
(
$
lid
:
v
$,$
lid
:
r
$
)
=
Value
.
get_pair
$
ine
$
in
$
oute
$
>>
|
[]
->
assert
false
let
list_lit
el
=
...
...
@@ -169,7 +175,7 @@ let rec tuple = function
let
pat_tuple
vars
=
let
pl
=
List
.
map
(
fun
id
->
<:
patt
<
$
lid
:
id
$
>>
)
vars
in
<:
patt
<
(
$
list
:
pl
$
)
>>
<:
patt
<
(
$
Ast
.
paCom_of_
list
pl
$
)
>>
let
call_lab
f
l
x
=
...
...
@@ -196,7 +202,7 @@ let rec to_cd e t =
(* Format.fprintf Format.err_formatter "to_cd %a [uid=%i; recurs=%i]@."
Mltypes.print t t.uid t.recurs; *)
if
t
.
recurs
>
0
then
<:
expr
<
$
lid
:
to_cd_fun
t
$
$
e
$
>>
else
to_cd_descr
e
t
.
def
else
to_cd_descr
e
t
.
def
and
to_cd_descr
e
=
function
|
Link
t
->
to_cd
e
t
...
...
@@ -219,7 +225,7 @@ and to_cd_descr e = function
|
Tuple
tl
->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
let
vars
=
mk_vars
tl
in
let_in
(
pat_tuple
vars
)
e
(
tuple
(
tuple_to_cd
tl
vars
)
)
<:
expr
<
let
$
pat_tuple
vars
$
=
$
e
$
in
$
tuple
(
tuple_to_cd
tl
vars
)
$
>>
|
PVariant
l
->
(* match <...> with
| `A -> Value.atom_ascii "A"
...
...
@@ -228,10 +234,9 @@ and to_cd_descr e = function
let
cases
=
List
.
map
(
function
|
(
lab
,
None
)
->
<:
patt
<
`
$
lid
:
lab
$
>>,
atom_ascii
lab
|
(
lab
,
Some
t
)
->
<:
patt
<
`
$
lid
:
lab
$
x
>>,
pair
(
atom_ascii
lab
)
(
to_cd
<:
expr
<
x
>>
t
)
|
(
lab
,
None
)
->
<:
match_case
<
`
$
lid
:
lab
$
->
$
atom_ascii
lab
$
>>
|
(
lab
,
Some
t
)
->
<:
match_case
<
`
$
lid
:
lab
$
x
->
$
pair
(
atom_ascii
lab
)
(
to_cd
<:
expr
<
x
>>
t
)
$
>>
)
l
in
pmatch
e
cases
|
Variant
(
p
,
l
,_
)
->
...
...
@@ -246,13 +251,13 @@ and to_cd_descr e = function
let
pat
=
match
lab
with
(* Stupid Camlp4 *)
|
"true"
->
<:
patt
<
True
>>
|
"false"
->
<:
patt
<
False
>>
|
lab
->
<:
patt
<
$
l
id
:
p
^
lab
$
>>
|
lab
->
<:
patt
<
$
id
:
id
(
p
^
lab
)
$
>>
in
pat
,
atom_ascii
lab
<:
match_case
<
$
pat
$
->
$
atom_ascii
lab
$
>>
|
(
lab
,
tl
)
->
let
vars
=
mk_vars
tl
in
<:
p
at
t
<
$
l
id
:
p
^
lab
$
$
pat_tuple
vars
$
>
>,
tuple
(
atom_ascii
lab
::
tuple_to_cd
tl
vars
)
<:
m
at
ch_case
<
$
id
:
id
(
p
^
lab
)
$
$
pat_tuple
vars
$
-
>
$
tuple
(
atom_ascii
lab
::
tuple_to_cd
tl
vars
)
$
>>
)
l
in
pmatch
e
cases
|
Record
(
p
,
l
,_
)
->
...
...
@@ -262,7 +267,7 @@ and to_cd_descr e = function
let
l
=
List
.
map
(
fun
(
lab
,
t
)
->
let
e
=
to_cd
<:
expr
<$
x
$.$
l
id
:
p
^
lab
$>>
t
in
let
e
=
to_cd
<:
expr
<$
x
$.$
id
:
id
(
p
^
lab
)
$>>
t
in
<:
expr
<
(
$
label_ascii
lab
$,
$
e
$
)
>>
)
l
in
...
...
@@ -314,7 +319,7 @@ and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl
and
to_ml
e
t
=
and
to_ml
(
e
:
Ast
.
expr
)
(
t
:
Mltypes
.
t
)
=
(* Format.fprintf Format.err_formatter "to_ml %a@."
Mltypes.print t; *)
if
t
.
recurs
>
0
then
<:
expr
<
$
lid
:
to_ml_fun
t
$
$
e
$
>>
...
...
@@ -340,8 +345,7 @@ and to_ml_descr e = function
(t1(x1),...,tn(xn)) *)
let
vars
=
mk_vars
tl
in
let
el
=
tuple_to_ml
tl
vars
in
matches
e
<:
expr
<
(
$
list
:
el
$
)
>>
vars
matches
e
<:
expr
<
$
tuple_to_ml
tl
vars
$
>>
vars
|
PVariant
l
->
(* match Value.get_variant <...> with
| "A",None -> `A
...
...
@@ -352,15 +356,16 @@ and to_ml_descr e = function
List
.
map
(
function
|
(
lab
,
None
)
->
<:
p
at
t
<
(
$
str
:
String
.
escaped
lab
$,
None
)
>>,
<:
expr
<
`
$
lid
:
lab
$
>>
<:
m
at
ch_case
<
(
$
str
:
String
.
escaped
lab
$,
None
)
->
`
$
lid
:
lab
$
>>
|
(
lab
,
Some
t
)
->
let
x
=
mk_var
()
in
let
ex
=
<:
expr
<
$
lid
:
x
$
>>
in
<:
patt
<
(
$
str
:
String
.
escaped
lab
$,
Some
$
lid
:
x
$
)
>>,
<:
expr
<
`
$
lid
:
lab
$
$
to_ml
ex
t
$
>>
<:
match_case
<
(
$
str
:
String
.
escaped
lab
$,
Some
$
lid
:
x
$
)
->
`
$
lid
:
lab
$
$
to_ml
ex
t
$
>>
)
l
in
let
cases
=
cases
@
[
<:
p
at
t
<
_
>>,
<:
expr
<
assert
False
>>
]
in
let
cases
=
cases
@
[
<:
m
at
ch_case
<
_
->
assert
False
>>
]
in
pmatch
<:
expr
<
Value
.
get_variant
$
e
$
>>
cases
|
Variant
(
_
,
l
,
false
)
->
failwith
"Private Sum type"
...
...
@@ -373,25 +378,26 @@ and to_ml_descr e = function
List
.
map
(
function
|
(
lab
,
[]
)
->
<:
patt
<
(
$
str
:
String
.
escaped
lab
$,
None
)
>>
,
(
match
lab
with
(* Stupid Camlp4 *)
let
pa
=
<:
patt
<
(
$
str
:
String
.
escaped
lab
$,
None
)
>>
and
e
=
match
lab
with
(* Stupid Camlp4 *)
|
"true"
->
<:
expr
<
True
>>
|
"false"
->
<:
expr
<
False
>>
|
lab
->
<:
expr
<
$
lid
:
p
^
lab
$
>>
)
|
lab
->
<:
expr
<
$
id
:
id
(
p
^
lab
)
$
>>
in
<:
match_case
<
$
pa
$
->
$
e
$
>>
|
(
lab
,
[
t
])
->
let
x
=
mk_var
()
in
let
ex
=
<:
expr
<
$
lid
:
x
$
>>
in
<:
p
at
t
<
(
$
str
:
String
.
escaped
lab
$,
Some
$
lid
:
x
$
)
>
>,
<:
expr
<
$
l
id
:
p
^
lab
$
$
to_ml
ex
t
$
>>
<:
m
at
ch_case
<
(
$
str
:
String
.
escaped
lab
$,
Some
$
lid
:
x
$
)
-
>
$
id
:
id
(
p
^
lab
)
$
$
to_ml
ex
t
$
>>
|
(
lab
,
tl
)
->
let
vars
=
mk_vars
tl
in
let
el
=
tuple_to_ml
tl
vars
in
let
x
=
mk_var
()
in
<:
patt
<
(
$
str
:
String
.
escaped
lab
$,
Some
$
lid
:
x
$
)
>>,
matches
<:
expr
<
$
lid
:
x
$
>>
<:
expr
<
$
lid
:
p
^
lab
$
(
$
list
:
el
$
)
>>
vars
<:
match_case
<
(
$
str
:
String
.
escaped
lab
$,
Some
$
lid
:
x
$
)
->
$
matches
<:
expr
<
$
lid
:
x
$
>>
<:
expr
<
$
id
:
id
(
p
^
lab
)
$
$
tuple_to_ml
tl
vars
$
>>
vars
$
>>
)
l
in
let
cases
=
cases
@
[
<:
p
at
t
<
_
>>,
<:
expr
<
assert
False
>>
]
in
let
cases
=
cases
@
[
<:
m
at
ch_case
<
_
->
assert
False
>>
]
in
pmatch
<:
expr
<
Value
.
get_variant
$
e
$
>>
cases
|
Record
(
_
,
l
,
false
)
->
failwith
"Private Record type"
...
...
@@ -403,9 +409,9 @@ and to_ml_descr e = function
let
l
=
List
.
map
(
fun
(
lab
,
t
)
->
(
<:
patt
<
$
lid
:
p
^
lab
$>>,
to_ml
<:
expr
<
Value
.
get_field
$
x
$
$
label_ascii
lab
$
>>
t
)
)
l
in
let
e
=
to_ml
<:
expr
<
Value
.
get_field
$
x
$
$
label_ascii
lab
$
>>
t
in
<:
rec_binding
<
$
id
:
id
(
p
^
lab
)
$
=
$
e
$
>>
)
l
in
<:
expr
<
{
$
list
:
l
$
}
>>
)
|
Abstract
"int"
->
<:
expr
<
Value
.
cduce2ocaml_int
$
e
$
>>
...
...
@@ -436,7 +442,9 @@ and to_ml_descr e = function
|
Var
_
->
e
|
_
->
assert
false
and
tuple_to_ml
tl
vars
=
List
.
map2
(
fun
t
id
->
to_ml
<:
expr
<
$
lid
:
id
$
>>
t
)
tl
vars
and
tuple_to_ml
tl
vars
=
Ast
.
exCom_of_list
(
List
.
map2
(
fun
t
id
->
to_ml
<:
expr
<
$
lid
:
id
$
>>
t
)
tl
vars
)
let
to_ml_done
=
IntHash
.
create
13
...
...
@@ -450,7 +458,7 @@ let global_transl () =
IntHash
.
add
don
hd
.
uid
()
;
let
p
=
<:
patt
<
$
lid
:
fun_name
hd
$
>>
in
let
e
=
<:
expr
<
fun
x
->
$
to_descr
<:
expr
<
x
>>
hd
.
def
$
>>
in
defs
:=
(
p
,
e
)
::
!
defs
defs
:=
<:
binding
<
$
p
$
=
$
e
$
>>
::
!
defs
);
loop
()
and
loop
()
=
match
!
to_cd_gen
,!
to_ml_gen
with
...
...
@@ -500,13 +508,25 @@ let check_value ty_env c_env (s,caml_t,t) =
let
x
=
mk_var
()
in
let
slot
=
Compile
.
find_slot
id
c_env
in
let
e
=
to_ml
<:
expr
<
slots
.
(
$
int
:
string_of_int
slot
$
)
>>
t
in
<:
patt
<
$
uid
:
s
$
>>,
<:
expr
<
C
.
$
uid
:
x
$
>>,
(
<:
patt
<
$
uid
:
x
$
>>,
e
)
<:
patt
<
$
lid
:
s
$
>>,
<:
expr
<
C
.
$
lid
:
x
$
>>,
<:
binding
<
$
lid
:
x
$
=
$
e
$
>>
module
Cleaner
=
Camlp4
.
Struct
.
CleanAst
.
Make
(
Ast
)
let
cleaner
=
object
inherit
Cleaner
.
clean_ast
as
super
method
str_item
st
=
match
super
#
str_item
st
with
|
<:
str_item
<
value
$
rec
:_$
$
<:
binding
<
>>
$
>>
->
<:
str_item
<
>>
|
x
->
x
end
let
stub
ty_env
c_env
exts
values
mk
prolog
=
gen_types
:=
false
;
let
items
=
List
.
map
(
check_value
ty_env
c_env
)
values
in
let
exts
=
List
.
rev_map
(
fun
(
s
,
t
)
->
to_cd
<:
expr
<
$
l
id
:
s
$
>>
t
)
exts
in
let
exts
=
List
.
rev_map
(
fun
(
s
,
t
)
->
to_cd
<:
expr
<
$
id
:
id
s
$
>>
t
)
exts
in
let
g
=
global_transl
()
in
let
types
=
get_registered_types
()
in
...
...
@@ -518,20 +538,21 @@ let stub ty_env c_env exts values mk prolog =
let
str_items
=
<:
str_item
<
value
(
$
paCom_of_list
items_pat
$
)
=
value
$
tup
:
Ast
.
paCom_of_list
items_pat
$
=
let
module
C
=
struct
open
Cduce_lib
;
Cduce_config
.
init_all
()
;
value
(
types
,
set_externals
,
slots
,
run
)
=
Librarian
.
ocaml_stub
$
str
:
String
.
escaped
raw
$;
value
rec
$
biAnd_of_list
g
$;
set_externals
[
|$
exSem_of_list
exts
$|
];
value
rec
$
Ast
.
biAnd_of_list
g
$;
set_externals
[
|$
Ast
.
exSem_of_list
exts
$|
];
run
()
;
value
$
biAnd_of_list
items_def
$;
end
in
(
$
exCom_of_list
items_expr
$
)
>>
in
value
$
Ast
.
biAnd_of_list
items_def
$;
end
in
$
tup
:
Ast
.
exCom_of_list
items_expr
$
>>
in
print_endline
prolog
;
!
Pcaml
.
print_implem
str_items
try
Printers
.
OCaml
.
print_implem
(
cleaner
#
str_item
str_items
)
with
exn
->
Format
.
printf
"@."
;
raise
exn
(* let exe = Filename.concat (Filename.dirname Sys.argv.(0)) "cdo2ml" in
let oc = Unix.open_process_out exe in
Marshal.to_channel oc str_items [];
...
...
@@ -552,7 +573,7 @@ let stub_ml name ty_env c_env exts mk =
try
Mltypes
.
read_cmi
name
with
Not_found
->
(
""
,
[]
)
in
stub
ty_env
c_env
exts
values
mk
prolog
with
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
with
Mltypes
.
Error
s
->
raise
(
Cduce_loc
.
Generic
s
)
let
register
b
s
args
=
...
...
@@ -560,7 +581,7 @@ let register b s args =
let
(
t
,
n
)
=
Mltypes
.
find_value
s
in
let
m
=
List
.
length
args
in
if
n
<>
m
then
Location
.
raise_generic
Cduce_loc
.
raise_generic
(
Printf
.
sprintf
"Wrong arity for external symbol %s (real arity = %i; given = %i)"
s
n
m
);
let
i
=
if
b
then
...
...
@@ -575,7 +596,7 @@ let register b s args =
vars
:=
[
|
|
];
i
,
cdt
with
Not_found
->
Location
.
raise_generic
Cduce_loc
.
raise_generic
(
Printf
.
sprintf
"Cannot resolve ocaml external %s"
s
)
(* Generation of wrappers *)
...
...
@@ -593,8 +614,8 @@ let wrapper values =
<:
str_item
<
open
Cduce_lib
;
Cduce_config
.
init_all
()
;
value
rec
$
biAnd_of_list
g
$;
$
stSem_of_list
exts
$;
value
rec
$
Ast
.
biAnd_of_list
g
$;
$
Ast
.
stSem_of_list
exts
$;
>>
let
gen_wrapper
vals
=
...
...
@@ -612,7 +633,7 @@ let gen_wrapper vals =
)
[]
vals
in
wrapper
values
with
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
with
Mltypes
.
Error
s
->
raise
(
Cduce_loc
.
Generic
s
)
let
make_wrapper
fn
=
let
ic
=
open_in
fn
in
...
...
@@ -627,9 +648,9 @@ let make_wrapper fn =
done
with
End_of_file
->
()
);
let
s
=
gen_wrapper
!
v
in
!
Pc
aml
.
print_implem
[
s
,_
loc
]
;
print_endline
"let () =
Location
.obj_path := ["
;
List
.
iter
(
fun
s
->
Printf
.
printf
" %S;
\n
"
s
)
!
Location
.
obj_path
;
Printers
.
OC
aml
.
print_implem
s
;
print_endline
"let () =
Cduce_loc
.obj_path := ["
;
List
.
iter
(
fun
s
->
Printf
.
printf
" %S;
\n
"
s
)
!
Cduce_loc
.
obj_path
;
print_endline
" ];;"
;
print_endline
"let () = Run.main ();;"
...
...
@@ -669,7 +690,7 @@ let register () =
Librarian
.
make_wrapper
:=
make_wrapper
let
()
=
Config
.
register
C
duce_c
onfig
.
register
"ocaml"
"OCaml interface"
register
ocamliface/mlstub.mli
View file @
f775a5cf
val
gen_wrapper
:
string
list
->
MLast
.
str_item
open
Camlp4
.
PreCast
val
gen_wrapper
:
string
list
->
Ast
.
str_item
ocamliface/mltypes.ml
View file @
f775a5cf
exception
Error
of
string
module
Loc
=
Location
module
Loc
=
Cduce_loc
open
Caml_cduce
open
Caml_cduce
.
Types
...
...
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