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
28897209
Commit
28897209
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-03-04 12:11:52 by afrisch] cduce_mktop
Original author: afrisch Date: 2005-03-04 12:11:54+00:00
parent
1d59613c
Changes
32
Hide whitespace changes
Inline
Side-by-side
META.in
0 → 100644
View file @
28897209
version="%VER%"
requires="%REQ% camlp4.gramlib"
description="Runtime support for CDuce"
archive(byte)="cduce_lib.cma"
archive(native)="cduce_lib.cmxa"
Makefile.distrib
View file @
28897209
include
Makefile.conf
VERSION
=
0.2.3b1
all
:
cduce dtd2cduce validate cdo2ml cduce_lib.cma
all
:
cduce dtd2cduce
cduce_
validate cdo2ml
mlcduce_wrapper
cduce_lib.cma
ifeq
($(NATIVE),true)
all
:
cduce_lib.cmxa
endif
...
...
@@ -87,16 +87,14 @@ install_bin:
@
echo
"Install binaries"
$(HIDE)
mkdir
-p
$(BINDIR)
$(HIDE)$(INSTALL)
-m755
cduce
$(EXE)
dtd2cduce
$(EXE)
\
validate
$(EXE)
cdo2ml
$(EXE)
$(BINDIR)
/
cduce_validate
$(EXE)
cdo2ml
$(EXE)
\
mlcduce_wrapper
$(EXE)
\
cduce_mktop
$(BINDIR)
/
install_lib
:
@
echo
"Build META"
$(HIDE)
echo
'version="
$(VERSION)
"'
>
META
$(HIDE)
echo
'requires="
$(PACKAGES)
camlp4.gramlib"'
>>
META
$(HIDE)
echo
'description="Runtime support for CDuce"'
>>
META
$(HIDE)
echo
'archive(byte)="cduce_lib.cma"'
>>
META
$(HIDE)
echo
'archive(native)="cduce_lib.cmxa"'
>>
META
$(HIDE)
(
sed
"s/%REQ%/
$(PACKAGES)
/"
< META.in |
sed
"s/%VER%/
$(VERSION)
/"
>
META
)
$(HIDE)
-
$(OCAMLFIND)
remove cduce
$(HIDE)
-
$(OCAMLFIND)
install
cduce META
\
cduce_lib.cmi
$(
wildcard
*
.cma
)
$(
wildcard
*
.cmxa
)
$(
wildcard
*
.a
)
\
...
...
@@ -104,9 +102,10 @@ install_lib:
uninstall
:
rm
-f
$(BINDIR)
/cduce
$(EXE)
$(BINDIR)
/dtd2cduce
$(EXE)
\
$(BINDIR)
/validate
$(EXE)
$(BINDIR)
/cdo2ml
$(EXE)
$(BINDIR)
/cduce_validate
$(EXE)
$(BINDIR)
/cdo2ml
$(EXE)
\
$(BINDIR)
/mlcduce_wrapper
$(EXE)
$(BINDIR)
/cduce_mktop
rm
-f
$(MANDIR)
/man1/cduce.1
$(MANDIR)
/man1/dtd2cduce.1
\
$(MANDIR)
/man1/validate.1
$(MANDIR)
/man1/cdo2ml.1
$(MANDIR)
/man1/
cduce_
validate.1
$(MANDIR)
/man1/cdo2ml.1
rm
-Rf
$(DOCDIR)
ocamlfind remove cduce
...
...
@@ -114,7 +113,7 @@ help:
@
echo
"GOALS"
@
echo
" cduce : compiles the CDuce command line interpreter"
@
echo
" dtd2cduce : compiles the dtd2cduce tools"
@
echo
" validate : compiles the schema validation tool"
@
echo
"
cduce_
validate : compiles the schema validation tool"
@
echo
" doc : build the documentation"
@
echo
" all : build binaries and libraries"
@
echo
" install : install binaries, man pages, documentation"
...
...
@@ -212,7 +211,8 @@ OBJECTS += $(CQL_OBJECTS)
VALIDATE_OBJECTS
:=
$(
shell
for
o
in
$(OBJECTS)
;
do
echo
$$
o
;
if
[
"
$$
o"
=
"schema/schema_parser.cmo"
]
;
then
exit
0
;
fi
;
done
)
# all objects until schema_parser.cmo
CDUCE
=
$(OBJECTS)
$(CQL_OBJECTS_RUN)
driver/run.cmo
OBJECTS
+=
$(CQL_OBJECTS_RUN)
driver/run.cmo
CDUCE
=
$(OBJECTS)
driver/start.cmo
DTD2CDUCE
=
tools/dtd2cduce.cmo
ALL_OBJECTS
=
$(OBJECTS)
$(NEW_SCHEMA_OBJS)
\
...
...
@@ -255,10 +255,14 @@ dtd2cduce: $(DTD2CDUCE:.cmo=.$(EXTENSION))
@
echo
"Build
$@
"
$(HIDE)$(LINK)
$(INCLUDES)
-o
$@
$^
validate
:
$(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
cduce_
validate
:
$(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
@
echo
"Build
$@
"
$(HIDE)$(LINK)
$(INCLUDES)
-o
$@
$^
mlcduce_wrapper
:
$(OBJECTS:.cmo=.$(EXTENSION)) ocamliface/mlcduce_wrapper.ml
@
echo
"Build
$@
"
$(HIDE)$(LINK)
$(INCLUDES)
-o
$@
odyl.cma camlp4.cma pr_o.cmo
$^
$(EXTRA_LINK_OPTS)
cdo2ml
:
ocamliface/cdo2ml.ml
@
echo
"Build
$@
"
$(HIDE)
ocamlc
-o
$@
-pp
camlp4o
-I
+camlp4 odyl.cma camlp4.cma pr_o.cmo
$^
...
...
@@ -277,7 +281,7 @@ clean:
rm
-f
`
find
.
-name
"*~"
`
rm
-f
*
.cmi
*
.cmo
*
.cma
*
.cmx
*
.a
*
.cmxa
*
.o
*
~ META
rm
-f
cduce
$(EXE)
ocamlprof.dump
rm
-f
dtd2cduce
$(EXE)
webiface
$(EXE)
validate
$(EXE)
cdo2ml
$(EXE)
evaluator
$(EXE)
rm
-f
dtd2cduce
$(EXE)
webiface
$(EXE)
cduce_
validate
$(EXE)
cdo2ml
$(EXE)
evaluator
$(EXE)
rm
-Rf
prepro package
rm
-f
web/www/
*
.html web/
*
~
rm
-f
web/
*
.cdo
...
...
cduce_mktop
0 → 100755
View file @
28897209
#!/bin/sh
TARG
=
$1
PRIMS
=
$2
if
[
"
${
TARG
}
"
=
""
]
||
[
"
${
PRIMS
}
"
=
""
]
;
then
echo
"Usage: cduce_mktop <target> <primitive file>"
exit
2
fi
exec
ocamlfind ocamlc
-package
cduce
-o
$TARG
-linkpkg
-pp
mlcduce_wrapper
-impl
$PRIMS
compile/compile.ml
View file @
28897209
...
...
@@ -83,10 +83,12 @@ and compile_aux env tail = function
|
Typed
.
Dot
(
e
,
l
)
->
Dot
(
compile
env
tail
e
,
l
)
|
Typed
.
Try
(
e
,
brs
)
->
Try
(
compile
env
false
e
,
compile_branches
env
tail
brs
)
|
Typed
.
Ref
(
e
,
t
)
->
Ref
(
compile
env
tail
e
,
t
)
|
Typed
.
External
(
t
,
i
)
->
|
Typed
.
External
(
t
,
`Ext
i
)
->
(
match
env
.
cu
with
|
Some
cu
->
Var
(
External
(
cu
,
i
))
|
None
->
failwith
"Cannot compile externals in the toplevel"
)
|
Typed
.
External
(
t
,
`Builtin
s
)
->
Var
(
Builtin
s
)
|
Typed
.
Op
(
op
,_,
args
)
->
let
rec
aux
=
function
|
[
arg
]
->
[
compile
env
tail
arg
]
...
...
@@ -110,7 +112,7 @@ and compile_abstr env a =
p
::
slots
,
succ
nb_slots
,
Env
.
add
x
(
Env
nb_slots
)
fun_env
;
|
Global
_
|
Ext
_
|
External
_
as
p
->
|
Global
_
|
Ext
_
|
External
_
|
Builtin
_
as
p
->
slots
,
nb_slots
,
Env
.
add
x
p
fun_env
...
...
compile/lambda.ml
View file @
28897209
...
...
@@ -6,6 +6,7 @@ type var_loc =
|
Ext
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
External
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
Builtin
of
string
|
Global
of
int
(* Only for the toplevel *)
|
Dummy
...
...
@@ -14,6 +15,7 @@ let print_var_loc ppf = function
|
Env
i
->
Format
.
fprintf
ppf
"Env %i"
i
|
Ext
(
cu
,
i
)
->
Format
.
fprintf
ppf
"Ext (_,%i)"
i
|
External
(
cu
,
i
)
->
Format
.
fprintf
ppf
"External (_,%i)"
i
|
Builtin
s
->
Format
.
fprintf
ppf
"Builtin (%s,_)"
s
|
Global
i
->
Format
.
fprintf
ppf
"Global %i"
i
|
Dummy
->
Format
.
fprintf
ppf
"Dummy"
...
...
@@ -123,14 +125,18 @@ module Put = struct
Types
.
CompUnit
.
serialize
s
cu
;
int
s
i
|
External
(
cu
,
i
)
->
assert
(
i
>=
0
);
bits
3
s
2
;
Types
.
CompUnit
.
serialize
s
cu
;
int
s
i
|
Env
i
->
|
Builtin
b
->
bits
3
s
3
;
Serialize
.
Put
.
string
s
b
|
Env
i
->
bits
3
s
4
;
int
s
i
|
Dummy
->
bits
3
s
4
bits
3
s
5
|
Global
_
->
assert
false
let
rec
expr
s
=
function
...
...
@@ -258,8 +264,11 @@ module Get = struct
let
cu
=
Types
.
CompUnit
.
deserialize
s
in
let
pos
=
int
s
in
External
(
cu
,
pos
)
|
3
->
Env
(
int
s
)
|
4
->
Dummy
|
3
->
let
s
=
Serialize
.
Get
.
string
s
in
Builtin
s
|
4
->
Env
(
int
s
)
|
5
->
Dummy
|
_
->
assert
false
let
rec
expr
s
=
...
...
compile/lambda.mli
View file @
28897209
...
...
@@ -6,6 +6,7 @@ type var_loc =
|
Ext
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
External
of
Types
.
CompUnit
.
t
*
int
(* If pos < 0, the first arg is the value *)
|
Builtin
of
string
|
Global
of
int
(* Only for the toplevel *)
|
Dummy
...
...
compile/operators.ml
View file @
28897209
...
...
@@ -46,7 +46,7 @@ let register_cst op t v =
let
register_fun
op
dom
codom
eval
=
register_cst
op
(
Types
.
arrow
(
Types
.
cons
dom
)
(
Types
.
cons
codom
))
(
Value
.
Abstraction
([(
dom
,
codom
)]
,
eval
))
(
Value
.
Abstraction
(
Some
[(
dom
,
codom
)]
,
eval
))
let
register_op
op
?
(
expect
=
Types
.
any
)
typ
eval
=
register_unary
op
...
...
depend
View file @
28897209
...
...
@@ -48,14 +48,14 @@ types/normal.cmo: types/normal.cmi
types/normal.cmx: types/normal.cmi
types/types.cmo: types/atoms.cmi misc/bool.cmi types/chars.cmi \
misc/custom.cmo misc/encodings.cmi types/ident.cmo types/intervals.cmi \
misc/inttbl.cmi types/normal.cmi misc/
pool
.cmi misc/p
retty
.cmi \
misc/serialize.cmi types/sortedList.cmi misc/state.cmi
misc/stats.cmi
\
types/types.cmi
misc/inttbl.cmi types/normal.cmi misc/
ns
.cmi misc/p
ool
.cmi \
misc/pretty.cmi
misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
misc/stats.cmi
types/types.cmi
types/types.cmx: types/atoms.cmx misc/bool.cmx types/chars.cmx \
misc/custom.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \
misc/inttbl.cmx types/normal.cmx misc/
pool
.cmx misc/p
retty
.cmx \
misc/serialize.cmx types/sortedList.cmx misc/state.cmx
misc/stats.cmx
\
types/types.cmi
misc/inttbl.cmx types/normal.cmx misc/
ns
.cmx misc/p
ool
.cmx \
misc/pretty.cmx
misc/serialize.cmx types/sortedList.cmx misc/state.cmx \
misc/stats.cmx
types/types.cmi
types/sample.cmo: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi types/types.cmi types/sample.cmi
types/sample.cmx: types/atoms.cmx types/chars.cmx types/ident.cmx \
...
...
@@ -100,11 +100,11 @@ schema/schema_xml.cmo: misc/encodings.cmi parser/location.cmi misc/ns.cmi \
schema/schema_pcre.cmi parser/url.cmi schema/schema_xml.cmi
schema/schema_xml.cmx: misc/encodings.cmx parser/location.cmx misc/ns.cmx \
schema/schema_pcre.cmx parser/url.cmx schema/schema_xml.cmi
schema/schema_common.cmo: types/atoms.cmi misc/encodings.cmi \
schema/schema_common.cmo: types/atoms.cmi misc/encodings.cmi
types/ident.cmo
\
types/intervals.cmi misc/ns.cmi schema/schema_pcre.cmi \
schema/schema_types.cmi schema/schema_xml.cmi types/types.cmi \
runtime/value.cmi schema/schema_common.cmi
schema/schema_common.cmx: types/atoms.cmx misc/encodings.cmx \
schema/schema_common.cmx: types/atoms.cmx misc/encodings.cmx
types/ident.cmx
\
types/intervals.cmx misc/ns.cmx schema/schema_pcre.cmx \
schema/schema_types.cmx schema/schema_xml.cmx types/types.cmx \
runtime/value.cmx schema/schema_common.cmi
...
...
@@ -135,11 +135,11 @@ schema/schema_parser.cmx: types/atoms.cmx misc/encodings.cmx misc/ns.cmx \
parser/ulexer.cmo: parser/ulexer.cmi
parser/ulexer.cmx: parser/ulexer.cmi
parser/ast.cmo: types/builtin_defs.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi parser/location.cmi misc/ns.cmi \
schema/schema_types.cmi types/sequence.cmi
types/types.cmi
types/intervals.cmi parser/location.cmi misc/ns.cmi
types/sequence.cmi
\
types/types.cmi
parser/ast.cmx: types/builtin_defs.cmx types/chars.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx misc/ns.cmx \
schema/schema_types.cmx types/sequence.cmx
types/types.cmx
types/intervals.cmx parser/location.cmx misc/ns.cmx
types/sequence.cmx
\
types/types.cmx
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi \
parser/location.cmi misc/ns.cmi types/sequence.cmi types/types.cmi \
...
...
@@ -151,23 +151,25 @@ parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/externals.cmo: parser/location.cmi types/externals.cmi
types/externals.cmx: parser/location.cmx types/externals.cmi
typing/typed.cmo: types/ident.cmo parser/location.cmi misc/ns.cmi \
types/patterns.cmi
schema/schema_types.cmi
types/types.cmi
types/patterns.cmi types/types.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx
schema/schema_types.cmx
types/types.cmx
types/patterns.cmx types/types.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi misc/encodings.cmi types/externals.cmi misc/html.cmi \
types/ident.cmo parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_builtin.cmi schema/schema_common.cmi \
schema/schema_parser.cmi schema/schema_types.cmi schema/schema_xml.cmi \
types/sequence.cmi misc/serialize.cmi misc/state.cmi typing/typed.cmo \
types/types.cmi runtime/value.cmi typing/typer.cmi
types/ident.cmo driver/librarian.cmi parser/location.cmi misc/ns.cmi \
types/patterns.cmi schema/schema_builtin.cmi schema/schema_common.cmi \
schema/schema_parser.cmi schema/schema_types.cmi \
schema/schema_validator.cmi schema/schema_xml.cmi types/sequence.cmi \
misc/serialize.cmi typing/typed.cmo types/types.cmi runtime/value.cmi \
typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx misc/encodings.cmx types/externals.cmx misc/html.cmx \
types/ident.cmx parser/location.cmx misc/ns.cmx types/patterns.cmx \
schema/schema_builtin.cmx schema/schema_common.cmx \
schema/schema_parser.cmx schema/schema_types.cmx schema/schema_xml.cmx \
types/sequence.cmx misc/serialize.cmx misc/state.cmx typing/typed.cmx \
types/types.cmx runtime/value.cmx typing/typer.cmi
types/ident.cmx driver/librarian.cmx parser/location.cmx misc/ns.cmx \
types/patterns.cmx schema/schema_builtin.cmx schema/schema_common.cmx \
schema/schema_parser.cmx schema/schema_types.cmx \
schema/schema_validator.cmx schema/schema_xml.cmx types/sequence.cmx \
misc/serialize.cmx typing/typed.cmx types/types.cmx runtime/value.cmx \
typing/typer.cmi
runtime/load_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi misc/ns.cmi parser/url.cmi runtime/value.cmi \
runtime/load_xml.cmi
...
...
@@ -196,13 +198,11 @@ runtime/print_xml.cmx: types/atoms.cmx misc/encodings.cmx types/ident.cmx \
runtime/print_xml.cmi
runtime/eval.cmo: runtime/explain.cmi types/ident.cmo compile/lambda.cmi \
misc/ns.cmi types/patterns.cmi runtime/run_dispatch.cmi \
schema/schema_common.cmi schema/schema_types.cmi \
schema/schema_validator.cmi typing/typer.cmi types/types.cmi \
schema/schema_common.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: runtime/explain.cmx types/ident.cmx compile/lambda.cmx \
misc/ns.cmx types/patterns.cmx runtime/run_dispatch.cmx \
schema/schema_common.cmx schema/schema_types.cmx \
schema/schema_validator.cmx typing/typer.cmx types/types.cmx \
schema/schema_common.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx runtime/eval.cmi
compile/compile.cmo: parser/ast.cmo runtime/eval.cmi types/ident.cmo \
compile/lambda.cmi parser/location.cmi types/patterns.cmi \
...
...
@@ -240,16 +240,14 @@ driver/cduce.cmo: parser/ast.cmo types/builtin.cmi types/builtin_defs.cmi \
compile/compile.cmi misc/encodings.cmi runtime/eval.cmi \
runtime/explain.cmi types/ident.cmo driver/librarian.cmi \
parser/location.cmi misc/ns.cmi compile/operators.cmi parser/parser.cmi \
types/patterns.cmi types/sample.cmi schema/schema_common.cmi \
misc/state.cmi typing/typer.cmi types/types.cmi parser/ulexer.cmi \
runtime/value.cmi driver/cduce.cmi
types/patterns.cmi types/sample.cmi misc/state.cmi typing/typer.cmi \
types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx types/builtin_defs.cmx \
compile/compile.cmx misc/encodings.cmx runtime/eval.cmx \
runtime/explain.cmx types/ident.cmx driver/librarian.cmx \
parser/location.cmx misc/ns.cmx compile/operators.cmx parser/parser.cmx \
types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
types/patterns.cmx types/sample.cmx misc/state.cmx typing/typer.cmx \
types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi
runtime/system.cmo: types/atoms.cmi types/builtin.cmi types/builtin_defs.cmi \
types/ident.cmo parser/location.cmi compile/operators.cmi \
types/sequence.cmi types/types.cmi runtime/value.cmi
...
...
@@ -286,10 +284,10 @@ query/query_aggregates.cmx: types/builtin_defs.cmx types/intervals.cmx \
compile/operators.cmx types/sequence.cmx runtime/value.cmx
query/query.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/ident.cmo types/intervals.cmi parser/location.cmi \
parser/parser.cmi types/types.cmi query/query.cmi
misc/ns.cmi
parser/parser.cmi types/types.cmi query/query.cmi
query/query.cmx: parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/ident.cmx types/intervals.cmx parser/location.cmx \
parser/parser.cmx types/types.cmx query/query.cmi
misc/ns.cmx
parser/parser.cmx types/types.cmx query/query.cmi
query/query_parse.cmo: parser/ast.cmo types/atoms.cmi types/ident.cmo \
parser/location.cmi parser/parser.cmi query/query.cmi types/sequence.cmi \
types/types.cmi
...
...
@@ -376,7 +374,7 @@ schema/schema_pcre.cmi: misc/encodings.cmi
schema/schema_types.cmi: types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi
schema/schema_xml.cmi: misc/encodings.cmi misc/ns.cmi
schema/schema_common.cmi: types/atoms.cmi misc/encodings.cmi \
schema/schema_common.cmi: types/atoms.cmi misc/encodings.cmi
types/ident.cmo
\
types/intervals.cmi misc/ns.cmi schema/schema_types.cmi types/types.cmi \
runtime/value.cmi
schema/schema_builtin.cmi: misc/encodings.cmi misc/ns.cmi \
...
...
@@ -387,8 +385,8 @@ schema/schema_parser.cmi: schema/schema_types.cmi
parser/parser.cmi: parser/ast.cmo
types/externals.cmi: types/types.cmi
typing/typer.cmi: parser/ast.cmo misc/custom.cmo types/ident.cmo \
parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_types.cmi typing/typed.cmo types/types
.cmi
parser/location.cmi misc/ns.cmi types/patterns.cmi
typing/typed.cmo
\
types/types.cmi runtime/value
.cmi
runtime/load_xml.cmi: parser/url.cmi runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/explain.cmi: types/types.cmi runtime/value.cmi
...
...
@@ -402,7 +400,7 @@ compile/operators.cmi: parser/location.cmi types/types.cmi runtime/value.cmi
types/builtin.cmi: typing/typer.cmi runtime/value.cmi
driver/librarian.cmi: compile/compile.cmi types/ident.cmo typing/typer.cmi \
types/types.cmi runtime/value.cmi
driver/cduce.cmi: misc/
encoding
s.cmi runtime/value.cmi
driver/cduce.cmi: misc/
n
s.cmi runtime/value.cmi
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
query/query.cmi: parser/ast.cmo
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
...
...
driver/librarian.ml
View file @
28897209
...
...
@@ -182,7 +182,7 @@ let rec compile verbose name id src =
p
in
let
stub
,
types
=
!
stub_ml
name
ty_env
c_env
in
let
ext
=
Externals
.
nb
()
>
0
in
let
ext
=
Externals
.
has
()
in
let
cu
=
mk
(
cu
,
types
,
ext
)
in
cu
.
stub
<-
stub
;
C
.
Tbl
.
add
tbl
id
cu
;
...
...
@@ -279,16 +279,30 @@ let import_check id chk = ignore (load_check id chk)
let
import_and_run
id
=
import
id
;
run
id
let
import_from_string
id
str
dig
dep
=
ignore
(
load_from_string
id
str
dig
dep
)
let
static_externals
=
Hashtbl
.
create
17
let
register_static_external
n
v
=
print_endline
(
"Builtin "
^
n
);
Hashtbl
.
add
static_externals
n
v
let
()
=
Typer
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
typing
);
Typer
.
has_comp_unit
:=
has_obj
;
Typer
.
has_static_external
:=
Hashtbl
.
mem
static_externals
;
Compile
.
from_comp_unit
:=
(
fun
cu
->
(
load
cu
)
.
compile
);
Eval
.
get_global
:=
(
fun
cu
i
->
import_and_run
cu
;
(
load
cu
)
.
vals
.
(
i
));
Eval
.
set_global
:=
(
fun
cu
i
v
->
import
cu
;
(
load
cu
)
.
vals
.
(
i
)
<-
v
);
Eval
.
get_external
:=
(
fun
cu
i
->
(
load
cu
)
.
exts
.
(
i
))
Eval
.
get_external
:=
(
fun
cu
i
->
(
load
cu
)
.
exts
.
(
i
));
Eval
.
get_builtin
:=
Hashtbl
.
find
static_externals
let
set_externals
cu
a
=
(
load
cu
)
.
exts
<-
a
let
registered_types
cu
=
(
load
cu
)
.
types
let
pack_types
typs
=
Serialize
.
Put
.
run
(
Serialize
.
Put
.
array
Types
.
serialize
)
typs
let
unpack_types
typs
=
Serialize
.
Get
.
run
(
Serialize
.
Get
.
array
Types
.
deserialize
)
typs
driver/librarian.mli
View file @
28897209
...
...
@@ -27,3 +27,9 @@ val set_externals: Types.CompUnit.t -> Value.t array -> unit
type
stub_ml
val
stub_ml
:
(
string
->
Typer
.
t
->
Compile
.
env
->
stub_ml
option
*
Types
.
t
array
)
ref
val
pack_types
:
Types
.
t
array
->
string
val
unpack_types
:
string
->
Types
.
t
array
val
register_static_external
:
string
->
Value
.
t
->
unit
driver/run.ml
View file @
28897209
...
...
@@ -181,10 +181,11 @@ let save () =
|
None
->
()
let
main
()
=
at_exit
(
fun
()
->
Stats
.
dump
Format
.
std_formatter
);
Location
.
set_viewport
(
Html
.
create
false
);
match
mode
()
with
|
`Toplevel
args
->
Config
.
inhibit
"ocaml"
;
(*
Config.inhibit "ocaml";
*)
Config
.
init_all
()
;
Builtin
.
argv
:=
argv
args
;
restore
()
;
...
...
@@ -202,6 +203,4 @@ let main () =
Builtin
.
argv
:=
argv
args
;
Cduce
.
run
f
let
()
=
at_exit
(
fun
()
->
Stats
.
dump
Format
.
std_formatter
);
main
()
ocamliface/mlcduce_wrapper.ml
0 → 100644
View file @
28897209
let
loc
=
(
Lexing
.
dummy_pos
,
Lexing
.
dummy_pos
)
let
usage
=
"Usage: mlcduce_wrapper <primitive file>
"
let
err
s
=
prerr_endline
s
;
prerr_endline
usage
;
exit
1
let
()
=
if
Array
.
length
Sys
.
argv
!=
2
then
err
""
;
let
fn
=
Sys
.
argv
.
(
1
)
in
let
ic
=
try
open_in
fn
with
Sys_error
s
->
err
s
in
let
v
=
ref
[]
in
(
try
while
true
do
let
s
=
input_line
ic
in
if
s
=
""
then
raise
End_of_file
;
match
s
.
[
0
]
with
|
'
A'
..
'
Z'
->
v
:=
s
::
!
v
|
_
->
err
"Names must start with a capitalized letter"
done
with
End_of_file
->
()
);
let
s
=
Mlstub
.
gen_wrapper
!
v
in
!
Pcaml
.
print_implem
[
s
,
loc
]
ocamliface/mlstub.ml
View file @
28897209
...
...
@@ -113,11 +113,14 @@ let protect e f =
(* Registered types *)
let
gen_types
=
ref
true
module
HashTypes
=
Hashtbl
.
Make
(
Types
)
let
registered_types
=
HashTypes
.
create
13
let
nb_registered_types
=
ref
0
let
register_type
t
=
assert
(
!
gen_types
);
let
n
=
try
HashTypes
.
find
registered_types
t
with
Not_found
->
...
...
@@ -200,9 +203,13 @@ and to_cd_descr e = function
let
arg
=
to_ml
<:
expr
<
$
lid
:
x
$
>>
t
in
let
res
=
to_cd
(
call_lab
y
l
arg
)
s
in
let
abs
=
<:
expr
<
fun
$
lid
:
x
$
->
$
res
$
>>
in
let
tt
=
register_type
(
Types
.
descr
(
typ
t
))
in
let
ss
=
register_type
(
Types
.
descr
(
typ
s
))
in
<:
expr
<
Value
.
Abstraction
([(
$
tt
$,$
ss
$
)]
,$
abs
$
)
>>
let
iface
=
if
!
gen_types
then
let
tt
=
register_type
(
Types
.
descr
(
typ
t
))
in
let
ss
=
register_type
(
Types
.
descr
(
typ
s
))
in
<:
expr
<
Some
[(
$
tt
$,$
ss
$
)]
>>
else
<:
expr
<
None
>>
in
<:
expr
<
Value
.
Abstraction
(
$
iface
$,$
abs
$
)
>>
)
|
Tuple
tl
->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
...
...
@@ -230,7 +237,13 @@ and to_cd_descr e = function
let
cases
=
List
.
map
(
function
|
(
lab
,
[]
)
->
<:
patt
<
$
lid
:
p
^
lab
$
>>,
atom_ascii
lab
|
(
lab
,
[]
)
->
let
pat
=
match
lab
with
(* Stupid Camlp4 *)
|
"true"
->
<:
patt
<
True
>>
|
"false"
->
<:
patt
<
False
>>
|
lab
->
<:
patt
<
$
lid
:
p
^
lab
$
>>
in
pat
,
atom_ascii
lab
|
(
lab
,
tl
)
->
let
vars
=
mk_vars
tl
in
<:
patt
<
$
lid
:
p
^
lab
$
$
pat_tuple
vars
$
>>,
...
...
@@ -249,7 +262,7 @@ and to_cd_descr e = function
l
in
<:
expr
<
Value
.
record
$
list_lit
l
$
>>
)
|
Abstract
"int"
->
<:
expr
<
Value
.
ocaml2cduce_int
$
e
$
>>
|
Abstract
"char"
->
<:
expr
<
Value
.
ocaml2cduce_char
$
e
$
>>
|
Abstract
"string"
->
<:
expr
<
Value
.
ocaml2cduce_string
$
e
$
>>
...
...
@@ -265,7 +278,11 @@ and to_cd_descr e = function
protect
e
(
fun
e
->
let
y
=
mk_var
()
in
let
tt
=
register_type
(
Types
.
descr
(
typ
t
))
in
let
tt
=
if
!
gen_types
then
let
t
=
register_type
(
Types
.
descr
(
typ
t
))
in
<:
expr
<
Some
$
t
$
>>
else
<:
expr
<
None
>>
in
let
get_x
=
<:
expr
<
$
e
$.
val
>>
in
let
get
=
<:
expr
<
fun
()
->
$
to_cd
get_x
t
$
>>
in
let
tr_y
=
to_ml
<:
expr
<
$
lid
:
y
$
>>
t
in
...
...
@@ -475,6 +492,7 @@ let check_value ty_env c_env (s,caml_t,t) =
<:
patt
<
$
uid
:
s
$
>>,
<:
expr
<
C
.
$
uid
:
x
$
>>,
(
<:
patt
<
$
uid
:
x
$
>>,
e
)
let
stub
name
ty_env
c_env
values
=
gen_types
:=
true
;
let
items
=
List
.
map
(
check_value
ty_env
c_env
)
values
in
let
exts
=
List
.
rev_map
(
fun
(
s
,
t
)
->
to_cd
<:
expr
<
$
lid
:
s
$
>>
t
)
!
exts
in
...
...
@@ -502,8 +520,7 @@ let stub name ty_env c_env values =
[
<:
str_item
<
open
Cduce_lib
>>;
<:
str_item
<
Config
.
init_all
()
>>;
<:
str_item
<
value
types
=
Librarian
.
registered_types
cu
>>
]
@
(
if
g
=
[]
then
[]
else
[
<:
str_item
<
value
rec
$
list
:
g
$
>>
])
@
[
<:
str_item
<
Librarian
.
set_externals
cu
[
|$
list
:
exts
$|
]
>>;
(
if
g
=
[]
then
[]
else
[
<:
str_item
<
value
rec
$
list
:
g
$
>>
])
@
[
<:
str_item
<
Librarian
.
set_externals
cu
[
|$
list
:
exts
$|
]
>>;
<:
str_item
<
Librarian
.
run
cu
>>
]
@
(
if
items
=
[]
then
[]
else
[
<:
str_item
<
value
$
list
:
items_def
$
>>
])
in
...
...
@@ -514,44 +531,110 @@ let stub name ty_env c_env values =
<:
patt
<
(
$
list
:
items_pat
$
)
>>,
m
,
items_expr
let
stub_ml
cu
ty_env
c_env
=
try
let
name
=
String
.
capitalize
cu
in
let
(
prolog
,
values
)
=
try
Mltypes
.
read_cmi
name
with
Not_found
->
(
""
,
[]
)
in
let
code
=
stub
cu
ty_env
c_env
values
in
Some
(
Obj
.
magic
(
prolog
,
code
))
,
get_registered_types
()
with
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
let
register
b
s
args
=
try
let
(
t
,
n
)
=
Mltypes
.
find_value
s
in
let
m
=
List
.
length
args
in
if
n
<>
m
then
Location
.
raise_generic
(
Printf
.
sprintf
"Wrong arity for external symbol %s (real arity = %i; given = %i)"
s
n
m
);
let
i
=
if
b
then
let
i
=
List
.
length
!
exts
in
exts
:=
(
s
,
t
)
::
!
exts
;
i
else
0
in
vars
:=
Array
.
of_list
args
;
let
cdt
=
Types
.
descr
(
typ
t
)
in
vars
:=
[
|
|
];
i
,
cdt
with
Not_found
->
Location
.
raise_generic
(
Printf
.
sprintf
"Cannot resolve ocaml external %s"
s
)
(* Generation of wrappers *)
let
wrapper
values
=
gen_types
:=
false
;
let
exts
=
List
.
rev_map
(
fun
(
s
,
t
)
->
let
v
=
to_cd
<:
expr
<
$
lid
:
s
$
>>
t
in
<:
str_item
<
Librarian
.
register_static_external
$
str
:
String
.
escaped
s
$
$
v
$
>>
)
values
in
let
g
=
global_transl
()
in
let
m
=
if
g
=
[]
then
exts
else
<:
str_item
<
value
rec
$
list
:
g
$
>>::
exts
in
let
m
=
[
<:
str_item
<
open
Cduce_lib
>>;
<:
str_item
<
Config
.
init_all
()
>>
]
@
m
@
[
<:
str_item
<
Run
.
main
()
>>
]
in
<:
str_item
<
declare
$
list
:
m
$
end
>>
let
gen_wrapper
vals
=
try
let
values
=
List
.
fold_left
(
fun
accu
s
->
try
(
s
,
fst
(
Mltypes
.
find_value
s
))
::
accu
with
Not_found
->
let
vals
=
try
Mltypes
.
load_cmi
s
with
Not_found
->
failwith
(
"Cannot resolve "
^
s
)
in
vals
@
accu
)
[]
vals
in
wrapper
values
with
Mltypes
.
Error
s
->
raise
(
Location
.
Generic
s
)
(* Dynamic coercions *)
<