Skip to content

GitLab

Commit 28897209 authored by Pietro Abate's avatar 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
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/pretty.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/pool.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/pretty.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/pool.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/encodings.cmi runtime/value.cmi
driver/cduce.cmi: misc/ns.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 *)