[cduce/f21] Import upstream patches which might fix build on OCaml 4.02.
Richard W.M. Jones
rjones at fedoraproject.org
Mon Nov 3 12:44:11 UTC 2014
commit a610e281f9047dbe0975a4f7d65ea5d02ab1ab26
Author: Richard W.M. Jones <rjones at redhat.com>
Date: Sun Aug 3 17:34:53 2014 +0100
Import upstream patches which might fix build on OCaml 4.02.
(cherry picked from commit fd4fc6890110a81a9d0352b0ef7a11d4ab7c011e)
...default-inlining-from-10000-to-100-OCaml-.patch | 34 +
...-on-a-load-directive-at-the-top-of-parser.patch | 39 +
0003-Fix-the-compilation-of-ocaml-bindings.patch | 57 +
...l-version-used-for-the-ocaml-bridge-in-th.patch | 227 +
...sible-compile-the-ocaml-cduce-interface-a.patch | 6081 ++++++++++++++++++++
cduce.spec | 18 +-
cduce_ocaml_4.02.0.patch | 37 -
7 files changed, 6453 insertions(+), 40 deletions(-)
---
diff --git a/0001-Change-the-default-inlining-from-10000-to-100-OCaml-.patch b/0001-Change-the-default-inlining-from-10000-to-100-OCaml-.patch
new file mode 100644
index 0000000..594036b
--- /dev/null
+++ b/0001-Change-the-default-inlining-from-10000-to-100-OCaml-.patch
@@ -0,0 +1,34 @@
+From c45bc2d7200c13ac5c53c788912f52574fa52e41 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Kim=20Nguy=E1=BB=85n?= <kn at lri.fr>
+Date: Sat, 2 Aug 2014 15:01:53 +0200
+Subject: [PATCH 1/5] Change the default inlining from 10000 to 100 (OCaml
+ 4.02.0 generates too large binaries with -inline 10000).
+
+---
+ Makefile.distrib | 4 ++--
+ 1 file changed, 2 insertions(+), 2 deletions(-)
+
+diff --git a/Makefile.distrib b/Makefile.distrib
+index 3d92d59..ace8008 100644
+--- a/Makefile.distrib
++++ b/Makefile.distrib
+@@ -41,14 +41,14 @@ SYNTAX_PARSER = -syntax camlp4o $(SYNTAX:%=-ppopt %)
+ CAMLC_P = ocamlc -g
+ DEPEND_OCAMLDEP = misc/q_symbol.cmo
+ ifeq ($(PROFILE), true)
+- CAMLOPT_P = ocamlopt -p -inline 10000
++ CAMLOPT_P = ocamlopt -p -inline 100
+ ifeq ($(NATIVE), false)
+ CAMLC_P = ocamlcp -p a
+ SYNTAX_PARSER =
+ DEPEND_OCAMLDEP =
+ endif
+ else
+- CAMLOPT_P = ocamlopt -inline 10000
++ CAMLOPT_P = ocamlopt -inline 100
+ endif
+
+ OPT = -warn-error FPSXY
+--
+1.9.3
+
diff --git a/0002-Do-not-rely-on-a-load-directive-at-the-top-of-parser.patch b/0002-Do-not-rely-on-a-load-directive-at-the-top-of-parser.patch
new file mode 100644
index 0000000..718795c
--- /dev/null
+++ b/0002-Do-not-rely-on-a-load-directive-at-the-top-of-parser.patch
@@ -0,0 +1,39 @@
+From cd2d3363bad49884e384f7a01753c19de7af89a8 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Kim=20Nguy=E1=BB=85n?= <kn at lri.fr>
+Date: Sat, 2 Aug 2014 15:13:24 +0200
+Subject: [PATCH 2/5] Do not rely on a #load directive at the top of
+ parser/parser.ml to load a camlp4 extension.
+
+---
+ Makefile.distrib | 4 ++++
+ parser/parser.ml | 2 --
+ 2 files changed, 4 insertions(+), 2 deletions(-)
+
+diff --git a/Makefile.distrib b/Makefile.distrib
+index ace8008..152f228 100644
+--- a/Makefile.distrib
++++ b/Makefile.distrib
+@@ -309,6 +309,10 @@ misc/q_symbol.cmo: misc/q_symbol.ml
+ @echo "Build $@"
+ $(HIDE)$(CAMLC) -c -pp camlp4orf $<
+
++parser/parser.cmo: PACKAGES += camlp4.extend
++parser/parser.cmx: PACKAGES += camlp4.extend
++
++
+ .ml.cmo:
+ @echo "Build $@"
+ $(HIDE)$(CAMLC) -c $(INCLUDES) $(SYNTAX_PARSER) $<
+diff --git a/parser/parser.ml b/parser/parser.ml
+index 8f805da..2a2763a 100644
+--- a/parser/parser.ml
++++ b/parser/parser.ml
+@@ -1,5 +1,3 @@
+-#load "pa_extend.cmo";;
+-
+ open Cduce_loc
+ (* let raise = Pervasives.raise *)
+ open Ast
+--
+1.9.3
+
diff --git a/0003-Fix-the-compilation-of-ocaml-bindings.patch b/0003-Fix-the-compilation-of-ocaml-bindings.patch
new file mode 100644
index 0000000..b398654
--- /dev/null
+++ b/0003-Fix-the-compilation-of-ocaml-bindings.patch
@@ -0,0 +1,57 @@
+From 6ab40218b625f6b337f553af1be8e7ae3cb4b397 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Kim=20Nguy=E1=BB=85n?= <kn at lri.fr>
+Date: Sat, 2 Aug 2014 17:39:12 +0200
+Subject: [PATCH 3/5] Fix the compilation of ocaml bindings: - add clflags.mli
+ to the list of files imported from the ocaml source tree - remove another use
+ of #load for syntax extension loading.
+
+---
+ Makefile.distrib | 2 ++
+ ocamliface/Makefile | 4 +++-
+ ocamliface/mlstub.ml | 1 -
+ 3 files changed, 5 insertions(+), 2 deletions(-)
+
+diff --git a/Makefile.distrib b/Makefile.distrib
+index 152f228..16039e2 100644
+--- a/Makefile.distrib
++++ b/Makefile.distrib
+@@ -362,3 +362,5 @@ ocamliface/caml_cduce.cmx:
+ @cd ocamliface; \
+ $(MAKE) caml_cduce.cmx
+
++ocamliface/mlstub.cmo: SYNTAX += q_MLast.cmo
++ocamliface/mlstub.cmx: SYNTAX += q_MLast.cmo
+diff --git a/ocamliface/Makefile b/ocamliface/Makefile
+index 838fcc6..0d2e59f 100644
+--- a/ocamliface/Makefile
++++ b/ocamliface/Makefile
+@@ -43,7 +43,8 @@ clean:
+ COPY_FILES=\
+ typing/annot.mli \
+ utils/misc.ml utils/tbl.ml \
+- utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.ml \
++ utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.mli \
++ utils/clflags.ml \
+ parsing/asttypes.mli parsing/location.mli \
+ parsing/longident.ml \
+ typing/outcometree.mli \
+@@ -57,6 +58,7 @@ COPY_FILES=\
+ COMPILE_FILES=\
+ warnings.ml location.mli asttypes.mli outcometree.mli annot.mli asttypes.ml \
+ config.ml misc.ml tbl.ml \
++ clflags.mli \
+ clflags.ml consistbl.ml terminfo.ml \
+ location.ml longident.ml \
+ ident.ml path.ml \
+diff --git a/ocamliface/mlstub.ml b/ocamliface/mlstub.ml
+index 5730857..54c5a84 100644
+--- a/ocamliface/mlstub.ml
++++ b/ocamliface/mlstub.ml
+@@ -1,4 +1,3 @@
+-#load "q_MLast.cmo";;
+ (* TODO:
+ - optimizations: generate labels and atoms only once.
+ - translate record to open record on positive occurence
+--
+1.9.3
+
diff --git a/0004-Detect-OCaml-version-used-for-the-ocaml-bridge-in-th.patch b/0004-Detect-OCaml-version-used-for-the-ocaml-bridge-in-th.patch
new file mode 100644
index 0000000..6c1a0ab
--- /dev/null
+++ b/0004-Detect-OCaml-version-used-for-the-ocaml-bridge-in-th.patch
@@ -0,0 +1,227 @@
+From 07fef81c576b3c94d13acd1880538b8140767a19 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Kim=20Nguy=E1=BB=85n?= <kn at lri.fr>
+Date: Sat, 2 Aug 2014 23:02:56 +0200
+Subject: [PATCH 4/5] Detect OCaml version used for the ocaml bridge in the
+ configure script.
+
+---
+ configure.ml | 84 ++++++++++++++++++++++++++++++++++--------------------------
+ 1 file changed, 48 insertions(+), 36 deletions(-)
+
+diff --git a/configure.ml b/configure.ml
+index 3e60372..4860dfe 100644
+--- a/configure.ml
++++ b/configure.ml
+@@ -29,7 +29,7 @@ Optional features:
+ expat support for the expat XML parser
+ curl support for the libcurl library
+ netclient support for the netclient library
+- cgi support for the cgi library
++ cgi support for the cgi library
+
+ OCaml/CDuce interface:
+ --mliface=DIR build the interface with the OCaml sources in DIR
+@@ -44,11 +44,11 @@ if not_distrib then print_string "
+ --wprefix=WPREFIX root directory of the web-server [/var/www]
+ --cgidir=DIR install the cgi-bin interpreter in DIR [WPREFIX/cgi-bin]
+ --htmldir=DIR install the website in DIR [WPREFIX/html]
+- --sessiondir=DIR store the open sessions of the cgi-bin in DIR
++ --sessiondir=DIR store the open sessions of the cgi-bin in DIR
+ [/tmp/cduce_sessions]
+ "
+
+-let features =
++let features =
+ [ "ocamlopt", ref `auto;
+ "mliface", ref `auto;
+ "pxp", ref `auto;
+@@ -57,8 +57,8 @@ let features =
+ "netclient", ref `auto;
+ "cgi", ref `auto;
+ "pxp_wlex", ref `no ]
+-
+-let vars =
++
++let vars =
+ [ "prefix", ref "/usr/local";
+ "bindir", ref "";
+ "mandir", ref "";
+@@ -74,7 +74,7 @@ let vars =
+
+
+ let src_dirs = ["/usr/src"; "/usr/local/src"; "/tmp"]
+-
++
+ let fatal s = printf "*** Fatal error: %s\n" s; exit 1
+ let warning s = printf "* Warning: %s\n" s
+
+@@ -93,7 +93,7 @@ let start_with s p =
+ let ls = String.length s and lp = String.length p in
+ if (ls >= lp) && (String.sub s 0 lp = p)
+ then Some (String.sub s lp (ls - lp)) else None
+-
++
+ let parse_arg s =
+ if s = "--help" then (usage (); exit 0)
+ else
+@@ -121,20 +121,20 @@ let print s = print_string s; flush stdout
+ let check_feature f p =
+ printf "%s: " f;
+ match !(List.assoc f features) with
+- | `no ->
++ | `no ->
+ print "disabled\n"; false
+- | `yes ->
++ | `yes ->
+ print "checking... ";
+- if p ()
+- then (print "ok\n"; true)
++ if p ()
++ then (print "ok\n"; true)
+ else (print "failed !\n"; fatal "Required feature is not available")
+- | `auto ->
++ | `auto ->
+ print "autodetecting... ";
+- if p ()
++ if p ()
+ then (print "enabled\n"; true)
+ else (print "disabled\n"; false)
+
+-let native =
++let native =
+ check_feature "ocamlopt" (fun () -> command "ocamlfind ocamlopt")
+
+ let check_pkg p () =
+@@ -142,8 +142,8 @@ let check_pkg p () =
+ (* ignore (Findlib.package_property
+ [ (if native then "native" else "bytecode") ]
+ p "archive"); *)
+- command
+- (sprintf
++ command
++ (sprintf
+ "ocamlfind ocaml%s -package %s -linkpkg -o configure.try && rm -f configure.try"
+ (if native then "opt" else "c")
+ p)
+@@ -151,32 +151,42 @@ let check_pkg p () =
+
+ let need_pkg p =
+ printf "Checking for package %s... " p; flush stdout;
+- if not (check_pkg p ())
++ if not (check_pkg p ())
+ then (print "failed !\n"; fatal "Required package is not available")
+ else (print "ok\n")
+
+-let dir ?def d =
++let dir ?def d =
+ let s = !(List.assoc d vars) in
+ if s <> "" then s
+- else match def with
+- | Some x -> x
++ else match def with
++ | Some x -> x
+ | None -> fatal (sprintf "%s cannot be empty" d)
+
+
+-let exe = match Sys.os_type with
++let exe = match Sys.os_type with
+ | "Win32" ->
+- print "Win32 detected... executable will have .exe extension\n"; ".exe"
++ print "Win32 detected... executable will have .exe extension\n"; ".exe"
+ | "Cygwin" ->
+- print "Cygwin detected... executable will have .exe extension\n"; ".exe"
++ print "Cygwin detected... executable will have .exe extension\n"; ".exe"
+ | _ -> ""
+
+-let add_icon = match Sys.os_type with
++let add_icon = match Sys.os_type with
+ | "Win32" | "Cygwin" -> true
+ | _ -> false
+
+ let check_mliface dir =
+ (* Sys.file_exists (Filename.concat dir "typing/types.ml") *)
+- Sys.file_exists (Filename.concat dir "typing/types.ml")
++ List.for_all (fun f ->
++ Sys.file_exists (Filename.concat dir f))
++ [ "typing/types.ml"; "VERSION" ]
++
++let mliface_version dir =
++ let ic = open_in (Filename.concat dir "VERSION") in
++ let s = input_line ic in
++ close_in ic;
++ if s < "4" then "3.x"
++ else if s < "4.02" then "4.01"
++ else "4.02"
+
+ let ocaml_stdlib () =
+ if (Sys.command "ocamlc -where > ocaml_stdlib" <> 0) then
+@@ -188,25 +198,27 @@ let ocaml_stdlib () =
+ s
+
+ let make_absolute dir =
+- if Filename.is_relative dir
++ if Filename.is_relative dir
+ then Filename.concat (Sys.getcwd ()) dir
+ else dir
+
+-let ml_interface =
++let ml_interface, mliface_version =
+ let dir1 = !(List.assoc "mliface" vars) in
+ let dirs = if dir1 = "" then [] else [ make_absolute dir1 ] in
+ print "ocaml sources... ";
+ let rec loop = function
+- | [] ->
++ | [] ->
+ print "not found (the interface will not be built)\n";
+- None
++ None, ""
+ | d::dirs ->
+ if check_mliface d then
+- (print ("found: " ^ d ^ "\n"); Some d)
++ let version = mliface_version d in
++ (print ("found: " ^ d ^ ", version " ^ version ^ "\n");
++ Some d, version)
+ else loop dirs
+ in
+ loop dirs
+-
++
+ let pxp = check_feature "pxp" (check_pkg "pxp")
+ let expat = check_feature "expat" (check_pkg "expat")
+ let curl = check_feature "curl" (check_pkg "curl")
+@@ -222,9 +234,9 @@ let cgidir = dir ~def:(wprefix^"/cgi-bin") "cgidir"
+ let htmldir = dir ~def:(wprefix^"/html") "htmldir"
+ let sessiondir = dir "sessiondir"
+
+-let curl,netclient =
++let curl,netclient =
+ match curl,netclient with
+- | true,true ->
++ | true,true ->
+ warning "Both netclient and curl are available. Will use curl.";
+ true,false
+ | false,false ->
+@@ -232,9 +244,9 @@ let curl,netclient =
+ false,false
+ | c,n -> c,n
+
+-let pxp,expat =
++let pxp,expat =
+ match pxp,expat with
+- | true,true ->
++ | true,true ->
+ warning "Both PXP and expat are available. Will build both and use expat by default.";
+ true,true
+ | false,false ->
+@@ -282,7 +294,7 @@ let () =
+ fprintf out "# This file has been generated by the configure script\n";
+ fprintf out "NATIVE=%b\n" native;
+ (match ml_interface with
+- | Some d -> fprintf out "ML_INTERFACE=true\nOCAML_SRC=%s\n" d
++ | Some d -> fprintf out "ML_INTERFACE=true\nOCAML_SRC=%s\nML_INTERFACE_VERSION=%s\n" d mliface_version
+ | None -> fprintf out "ML_INTERFACE=false\n");
+ fprintf out "PXP=%b\n" pxp;
+ fprintf out "EXPAT=%b\n" expat;
+--
+1.9.3
+
diff --git a/0005-Make-it-possible-compile-the-ocaml-cduce-interface-a.patch b/0005-Make-it-possible-compile-the-ocaml-cduce-interface-a.patch
new file mode 100644
index 0000000..17f32a2
--- /dev/null
+++ b/0005-Make-it-possible-compile-the-ocaml-cduce-interface-a.patch
@@ -0,0 +1,6081 @@
+From 059c0c26e0643e0bab7d590e94f4665566918655 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Kim=20Nguy=E1=BB=85n?= <kn at lri.fr>
+Date: Sun, 3 Aug 2014 01:05:05 +0200
+Subject: [PATCH 5/5] Make it possible compile the ocaml/cduce interface
+ against OCaml 3.1[12]/4.0[01]/4.02.
+
+---
+ Makefile.distrib | 72 ++--
+ depend | 658 ++++++++++++++++++++-----------------
+ ocamliface/3.x/Makefile | 70 ++++
+ ocamliface/3.x/config.ml | 4 +
+ ocamliface/3.x/location.ml | 25 ++
+ ocamliface/3.x/mlstub.ml | 717 ++++++++++++++++++++++++++++++++++++++++
+ ocamliface/3.x/mlstub.mli | 8 +
+ ocamliface/3.x/mltypes.ml | 332 +++++++++++++++++++
+ ocamliface/3.x/mltypes.mli | 40 +++
+ ocamliface/4.01/Makefile | 72 ++++
+ ocamliface/4.01/config.ml | 4 +
+ ocamliface/4.01/location.ml | 32 ++
+ ocamliface/4.01/mlstub.ml | 746 ++++++++++++++++++++++++++++++++++++++++++
+ ocamliface/4.01/mlstub.mli | 2 +
+ ocamliface/4.01/mltypes.ml | 332 +++++++++++++++++++
+ ocamliface/4.01/mltypes.mli | 33 ++
+ ocamliface/4.02/Makefile | 76 +++++
+ ocamliface/4.02/ast_mapper.ml | 5 +
+ ocamliface/4.02/config.ml | 4 +
+ ocamliface/4.02/location.ml | 49 +++
+ ocamliface/4.02/mlstub.ml | 746 ++++++++++++++++++++++++++++++++++++++++++
+ ocamliface/4.02/mlstub.mli | 2 +
+ ocamliface/4.02/mltypes.ml | 337 +++++++++++++++++++
+ ocamliface/4.02/mltypes.mli | 33 ++
+ ocamliface/4.02/parsetree.ml | 3 +
+ ocamliface/Makefile | 72 ----
+ ocamliface/config.ml | 4 -
+ ocamliface/location.ml | 32 --
+ ocamliface/mlstub.ml | 746 ------------------------------------------
+ ocamliface/mlstub.mli | 2 -
+ ocamliface/mltypes.ml | 332 -------------------
+ ocamliface/mltypes.mli | 33 --
+ 32 files changed, 4070 insertions(+), 1553 deletions(-)
+ create mode 100644 ocamliface/3.x/Makefile
+ create mode 100644 ocamliface/3.x/config.ml
+ create mode 100644 ocamliface/3.x/location.ml
+ create mode 100644 ocamliface/3.x/mlstub.ml
+ create mode 100644 ocamliface/3.x/mlstub.mli
+ create mode 100644 ocamliface/3.x/mltypes.ml
+ create mode 100644 ocamliface/3.x/mltypes.mli
+ create mode 100644 ocamliface/4.01/Makefile
+ create mode 100644 ocamliface/4.01/config.ml
+ create mode 100644 ocamliface/4.01/location.ml
+ create mode 100644 ocamliface/4.01/mlstub.ml
+ create mode 100644 ocamliface/4.01/mlstub.mli
+ create mode 100644 ocamliface/4.01/mltypes.ml
+ create mode 100644 ocamliface/4.01/mltypes.mli
+ create mode 100644 ocamliface/4.02/Makefile
+ create mode 100644 ocamliface/4.02/ast_mapper.ml
+ create mode 100644 ocamliface/4.02/config.ml
+ create mode 100644 ocamliface/4.02/location.ml
+ create mode 100644 ocamliface/4.02/mlstub.ml
+ create mode 100644 ocamliface/4.02/mlstub.mli
+ create mode 100644 ocamliface/4.02/mltypes.ml
+ create mode 100644 ocamliface/4.02/mltypes.mli
+ create mode 100644 ocamliface/4.02/parsetree.ml
+ delete mode 100644 ocamliface/Makefile
+ delete mode 100644 ocamliface/config.ml
+ delete mode 100644 ocamliface/location.ml
+ delete mode 100644 ocamliface/mlstub.ml
+ delete mode 100644 ocamliface/mlstub.mli
+ delete mode 100644 ocamliface/mltypes.ml
+ delete mode 100644 ocamliface/mltypes.mli
+
+diff --git a/Makefile.distrib b/Makefile.distrib
+index 16039e2..6378aac 100644
+--- a/Makefile.distrib
++++ b/Makefile.distrib
+@@ -3,6 +3,7 @@ default: cduce
+ include Makefile.conf
+ include VERSION
+
++OCAMLIFACE=ocamliface/$(ML_INTERFACE_VERSION)
+
+ ALL_TARGET=cduce cduce_lib.cma
+ INSTALL_BINARIES=cduce$(EXE)
+@@ -17,7 +18,8 @@ ifeq ($(NATIVE),true)
+ all: cduce_lib.cmxa
+ endif
+
+-PACKAGES = dynlink camlp4 ulex pcre num netstring
++PACKAGES = dynlink camlp4 ulex pcre num netstring
++ALL_ML_IFACE = 3.x 4.01 4.02
+
+ # Call make with VERBOSE=true to get a trace of commands
+
+@@ -42,9 +44,9 @@ CAMLC_P = ocamlc -g
+ DEPEND_OCAMLDEP = misc/q_symbol.cmo
+ ifeq ($(PROFILE), true)
+ CAMLOPT_P = ocamlopt -p -inline 100
+- ifeq ($(NATIVE), false)
++ ifeq ($(NATIVE), false)
+ CAMLC_P = ocamlcp -p a
+- SYNTAX_PARSER =
++ SYNTAX_PARSER =
+ DEPEND_OCAMLDEP =
+ endif
+ else
+@@ -134,9 +136,10 @@ help:
+ @echo " clean : back to the starting point"
+ @echo " uninstall : remove installed files"
+
+-# Source directories
++# Source directories
+
+-DIRS = misc parser schema typing types compile runtime driver query ocamliface win32
++DIRS_DEPEND = misc parser schema typing types compile runtime driver query win32
++DIRS := $(DIRS_DEPEND) $(OCAMLIFACE)
+ CLEAN_DIRS = $(DIRS) tools tests
+
+ # Objects to build
+@@ -182,14 +185,6 @@ compile/auto_pat.ml: compile/auto_pat.mli
+ compile/lambda.ml: compile/lambda.mli
+ cp $^ $@
+
+-ML_INTERFACE_OBJS = \
+- ocamliface/caml_cduce.cmo \
+- ocamliface/mltypes.cmo ocamliface/mlstub.cmo
+-
+-ifneq ($(ML_INTERFACE), false)
+- OBJECTS += $(ML_INTERFACE_OBJS)
+-endif
+-
+ ifneq ($(CURL), false)
+ OBJECTS += parser/cduce_curl.cmo
+ PACKAGES += curl
+@@ -229,21 +224,37 @@ endif
+ all: $(ALL_TARGET)
+
+ OBJECTS += driver/run.cmo
+-CDUCE = $(OBJECTS) driver/start.cmo
+
+-ALL_OBJECTS = $(OBJECTS) \
++ML_INTERFACE_BASE_OBJS = caml_cduce.cmo mltypes.cmo mlstub.cmo
++ML_INTERFACE_BASE_SRC = $(ML_INTERFACE_BASE_OBJS:.cmo=.ml) $(ML_INTERFACE_BASE_OBJS:.cmo=.mli)
++ML_INTERFACE_OBJS = \
++ $(ML_INTERFACE_BASE_OBJS:%=$(OCAMLIFACE)/%)
++
++OBJECTS_NO_MLIFACE := $(OBJECTS)
++
++ifneq ($(ML_INTERFACE), false)
++ OBJECTS += $(ML_INTERFACE_OBJS)
++endif
++
++
++
++CDUCE = $(OBJECTS) driver/start.cmo
++
++ALL_OBJECTS = $(OBJECTS_NO_MLIFACE) \
+ driver/start.cmo driver/examples.cmo \
+ driver/webiface.cmo driver/evaluator.cmo \
+ tools/validate.cmo \
+- $(ML_INTERFACE_OBJS) parser/cduce_curl.cmo \
++ parser/cduce_curl.cmo \
+ parser/cduce_netclient.cmo \
+ runtime/cduce_expat.cmo runtime/cduce_pxp.cmo
+
+-ALL_INTERFACES = schema/schema_types.mli
++ALL_INTERFACES = schema/schema_types.mli
+
+ DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)
+
+ INCLUDES = $(DIRS:%=-I %)
++INCLUDES_DEPEND = $(DIRS_DEPEND:%=-I %)
++
+ # -I +camlp4
+
+ cduce: $(CDUCE:.cmo=.$(EXTENSION))
+@@ -270,15 +281,22 @@ dtd2cduce: tools/dtd2cduce.ml
+ $(HIDE)$(OCAMLFIND) $(CAML) -o $@ -package "$(PXP_PACK) netcgi1" -linkpkg $^
+
+ .PHONY: compute_depend
++
+ compute_depend: $(DEPEND_OCAMLDEP)
+ @echo "Computing dependencies ..."
+ ocamlfind ocamldep -package "$(PACKAGES)" \
+- $(INCLUDES) $(SYNTAX_PARSER) $(DEPEND) > depend
++ $(INCLUDES_DEPEND) $(SYNTAX_PARSER) -ppopt pa_extend.cmo -ppopt q_MLast.cmo $(DEPEND) > depend
++ for i in $(ALL_ML_IFACE); do \
++ ocamlfind ocamldep -package "$(PACKAGES)" \
++ $(INCLUDES_DEPEND) -I ocamliface/$$i $(SYNTAX_PARSER) -ppopt pa_extend.cmo -ppopt q_MLast.cmo \
++ $(ML_INTERFACE_BASE_SRC:%=ocamliface/$$i/%) >> depend;\
++ done
++
+ clean:
+ for i in $(CLEAN_DIRS); do \
+ (cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *~); \
+ done
+- (cd ocamliface; $(MAKE) clean)
++ (cd $(OCAMLIFACE); $(MAKE) clean)
+ rm -f `find . -name "*~"`
+ rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~ META
+ rm -f cduce$(EXE) ocamlprof.dump
+@@ -298,7 +316,7 @@ clean:
+ distclean: clean
+ rm -f Makefile.conf
+
+-ocamliface/mltypes.$(EXTENSION): ocamliface/caml_cduce.$(EXTENSION)
++$(OCAMLIFACE)/mltypes.$(EXTENSION): $(OCAMLIFACE)/caml_cduce.$(EXTENSION)
+
+ $(ALL_OBJECTS:.cmo=.$(EXTENSION)): misc/q_symbol.cmo
+ $(ALL_INTERFACES): misc/q_symbol.cmo
+@@ -306,7 +324,7 @@ $(ALL_INTERFACES): misc/q_symbol.cmo
+ .SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+ misc/q_symbol.cmo: misc/q_symbol.ml
+- @echo "Build $@"
++ @echo "Build $@"
+ $(HIDE)$(CAMLC) -c -pp camlp4orf $<
+
+ parser/parser.cmo: PACKAGES += camlp4.extend
+@@ -354,13 +372,13 @@ install_doc: doc
+ ### Pack OCaml modules for the CDuce/OCaml interface
+
+
+-ocamliface/caml_cduce.cmo:
+- @cd ocamliface; \
++$(OCAMLIFACE)/caml_cduce.cmo:
++ @cd $(OCAMLIFACE); \
+ $(MAKE) caml_cduce.cmo
+
+-ocamliface/caml_cduce.cmx:
+- @cd ocamliface; \
++$(OCAMLIFACE)/caml_cduce.cmx:
++ @cd $(OCAMLIFACE); \
+ $(MAKE) caml_cduce.cmx
+
+-ocamliface/mlstub.cmo: SYNTAX += q_MLast.cmo
+-ocamliface/mlstub.cmx: SYNTAX += q_MLast.cmo
++$(OCAMLIFACE)/mlstub.cmo: SYNTAX += q_MLast.cmo
++$(OCAMLIFACE)/mlstub.cmx: SYNTAX += q_MLast.cmo
+diff --git a/depend b/depend
+index 3b7a234..83f8bd8 100644
+--- a/depend
++++ b/depend
+@@ -1,409 +1,457 @@
+-driver/cduce_config.cmo: driver/cduce_config.cmi
+-driver/cduce_config.cmx: driver/cduce_config.cmi
+-misc/stats.cmo: misc/stats.cmi
+-misc/stats.cmx: misc/stats.cmi
+-misc/encodings.cmo: misc/custom.cmo misc/encodings.cmi
+-misc/encodings.cmx: misc/custom.cmx misc/encodings.cmi
+-misc/upool.cmo: misc/custom.cmo misc/upool.cmi
+-misc/upool.cmx: misc/custom.cmx misc/upool.cmi
+-misc/pretty.cmo: misc/pretty.cmi
+-misc/pretty.cmx: misc/pretty.cmi
+-misc/ns.cmo: misc/upool.cmi misc/encodings.cmi misc/custom.cmo misc/ns.cmi
+-misc/ns.cmx: misc/upool.cmx misc/encodings.cmx misc/custom.cmx misc/ns.cmi
+-misc/imap.cmo: misc/imap.cmi
+-misc/imap.cmx: misc/imap.cmi
+-misc/html.cmo: misc/html.cmi
+-misc/html.cmx: misc/html.cmi
+-types/compunit.cmo: types/compunit.cmi
+-types/compunit.cmx: types/compunit.cmi
+-types/sortedList.cmo: misc/custom.cmo types/sortedList.cmi
+-types/sortedList.cmx: misc/custom.cmx types/sortedList.cmi
+-misc/bool.cmo: misc/custom.cmo misc/bool.cmi
+-misc/bool.cmx: misc/custom.cmx misc/bool.cmi
+-types/ident.cmo: types/sortedList.cmi misc/ns.cmi misc/encodings.cmi
+-types/ident.cmx: types/sortedList.cmx misc/ns.cmx misc/encodings.cmx
+-types/intervals.cmo: types/intervals.cmi
+-types/intervals.cmx: types/intervals.cmi
+-types/chars.cmo: misc/custom.cmo types/chars.cmi
+-types/chars.cmx: misc/custom.cmx types/chars.cmi
+-types/atoms.cmo: misc/upool.cmi types/sortedList.cmi misc/ns.cmi \
+- misc/imap.cmi misc/encodings.cmi types/atoms.cmi
+-types/atoms.cmx: misc/upool.cmx types/sortedList.cmx misc/ns.cmx \
+- misc/imap.cmx misc/encodings.cmx types/atoms.cmi
+-types/normal.cmo: types/normal.cmi
+-types/normal.cmx: types/normal.cmi
+-types/types.cmo: misc/stats.cmi types/sortedList.cmi misc/pretty.cmi \
++driver/cduce_config.cmo : driver/cduce_config.cmi
++driver/cduce_config.cmx : driver/cduce_config.cmi
++misc/stats.cmo : misc/stats.cmi
++misc/stats.cmx : misc/stats.cmi
++misc/custom.cmo :
++misc/custom.cmx :
++misc/encodings.cmo : misc/custom.cmo misc/encodings.cmi
++misc/encodings.cmx : misc/custom.cmx misc/encodings.cmi
++misc/upool.cmo : misc/custom.cmo misc/upool.cmi
++misc/upool.cmx : misc/custom.cmx misc/upool.cmi
++misc/pretty.cmo : misc/pretty.cmi
++misc/pretty.cmx : misc/pretty.cmi
++misc/ns.cmo : misc/upool.cmi misc/encodings.cmi misc/custom.cmo misc/ns.cmi
++misc/ns.cmx : misc/upool.cmx misc/encodings.cmx misc/custom.cmx misc/ns.cmi
++misc/imap.cmo : misc/imap.cmi
++misc/imap.cmx : misc/imap.cmi
++misc/html.cmo : misc/html.cmi
++misc/html.cmx : misc/html.cmi
++types/compunit.cmo : types/compunit.cmi
++types/compunit.cmx : types/compunit.cmi
++types/sortedList.cmo : misc/custom.cmo types/sortedList.cmi
++types/sortedList.cmx : misc/custom.cmx types/sortedList.cmi
++misc/bool.cmo : misc/custom.cmo misc/bool.cmi
++misc/bool.cmx : misc/custom.cmx misc/bool.cmi
++types/ident.cmo : types/sortedList.cmi misc/ns.cmi misc/encodings.cmi
++types/ident.cmx : types/sortedList.cmx misc/ns.cmx misc/encodings.cmx
++types/intervals.cmo : types/intervals.cmi
++types/intervals.cmx : types/intervals.cmi
++types/chars.cmo : misc/custom.cmo types/chars.cmi
++types/chars.cmx : misc/custom.cmx types/chars.cmi
++types/atoms.cmo : misc/upool.cmi types/sortedList.cmi misc/ns.cmi \
++ misc/imap.cmi misc/encodings.cmi types/atoms.cmi
++types/atoms.cmx : misc/upool.cmx types/sortedList.cmx misc/ns.cmx \
++ misc/imap.cmx misc/encodings.cmx types/atoms.cmi
++types/normal.cmo : types/normal.cmi
++types/normal.cmx : types/normal.cmi
++types/types.cmo : misc/stats.cmi types/sortedList.cmi misc/pretty.cmi \
+ misc/ns.cmi types/normal.cmi types/intervals.cmi types/ident.cmo \
+ misc/encodings.cmi misc/custom.cmo types/compunit.cmi types/chars.cmi \
+- misc/bool.cmi types/atoms.cmi types/types.cmi
+-types/types.cmx: misc/stats.cmx types/sortedList.cmx misc/pretty.cmx \
++ misc/bool.cmi types/atoms.cmi types/types.cmi
++types/types.cmx : misc/stats.cmx types/sortedList.cmx misc/pretty.cmx \
+ misc/ns.cmx types/normal.cmx types/intervals.cmx types/ident.cmx \
+ misc/encodings.cmx misc/custom.cmx types/compunit.cmx types/chars.cmx \
+- misc/bool.cmx types/atoms.cmx types/types.cmi
+-compile/auto_pat.cmo: types/types.cmi types/ident.cmo types/chars.cmi \
+- types/atoms.cmi compile/auto_pat.cmi
+-compile/auto_pat.cmx: types/types.cmx types/ident.cmx types/chars.cmx \
+- types/atoms.cmx compile/auto_pat.cmi
+-types/sequence.cmo: types/types.cmi misc/custom.cmo types/chars.cmi \
+- types/atoms.cmi types/sequence.cmi
+-types/sequence.cmx: types/types.cmx misc/custom.cmx types/chars.cmx \
+- types/atoms.cmx types/sequence.cmi
+-types/builtin_defs.cmo: types/types.cmi types/sequence.cmi \
++ misc/bool.cmx types/atoms.cmx types/types.cmi
++compile/auto_pat.cmo : types/types.cmi types/ident.cmo types/chars.cmi \
++ types/atoms.cmi compile/auto_pat.cmi
++compile/auto_pat.cmx : types/types.cmx types/ident.cmx types/chars.cmx \
++ types/atoms.cmx compile/auto_pat.cmi
++types/sequence.cmo : types/types.cmi misc/custom.cmo types/chars.cmi \
++ types/atoms.cmi types/sequence.cmi
++types/sequence.cmx : types/types.cmx misc/custom.cmx types/chars.cmx \
++ types/atoms.cmx types/sequence.cmi
++types/builtin_defs.cmo : types/types.cmi types/sequence.cmi \
+ types/intervals.cmi types/ident.cmo misc/encodings.cmi types/chars.cmi \
+- types/atoms.cmi types/builtin_defs.cmi
+-types/builtin_defs.cmx: types/types.cmx types/sequence.cmx \
++ types/atoms.cmi types/builtin_defs.cmi
++types/builtin_defs.cmx : types/types.cmx types/sequence.cmx \
+ types/intervals.cmx types/ident.cmx misc/encodings.cmx types/chars.cmx \
+- types/atoms.cmx types/builtin_defs.cmi
+-runtime/value.cmo: misc/upool.cmi types/types.cmi types/sequence.cmi \
++ types/atoms.cmx types/builtin_defs.cmi
++runtime/value.cmo : misc/upool.cmi types/types.cmi types/sequence.cmi \
+ misc/ns.cmi types/intervals.cmi misc/imap.cmi types/ident.cmo \
+- misc/encodings.cmi types/chars.cmi types/atoms.cmi runtime/value.cmi
+-runtime/value.cmx: misc/upool.cmx types/types.cmx types/sequence.cmx \
++ misc/encodings.cmi types/chars.cmi types/atoms.cmi runtime/value.cmi
++runtime/value.cmx : misc/upool.cmx types/types.cmx types/sequence.cmx \
+ misc/ns.cmx types/intervals.cmx misc/imap.cmx types/ident.cmx \
+- misc/encodings.cmx types/chars.cmx types/atoms.cmx runtime/value.cmi
+-schema/schema_pcre.cmo: misc/encodings.cmi schema/schema_pcre.cmi
+-schema/schema_pcre.cmx: misc/encodings.cmx schema/schema_pcre.cmi
+-schema/schema_types.cmo: runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
+- types/atoms.cmi schema/schema_types.cmi
+-schema/schema_types.cmx: runtime/value.cmx misc/ns.cmx misc/encodings.cmx \
+- types/atoms.cmx schema/schema_types.cmi
+-schema/schema_xml.cmo: schema/schema_pcre.cmi misc/ns.cmi misc/encodings.cmi \
+- schema/schema_xml.cmi
+-schema/schema_xml.cmx: schema/schema_pcre.cmx misc/ns.cmx misc/encodings.cmx \
+- schema/schema_xml.cmi
+-schema/schema_common.cmo: runtime/value.cmi types/types.cmi \
++ misc/encodings.cmx types/chars.cmx types/atoms.cmx runtime/value.cmi
++schema/schema_pcre.cmo : misc/encodings.cmi schema/schema_pcre.cmi
++schema/schema_pcre.cmx : misc/encodings.cmx schema/schema_pcre.cmi
++schema/schema_types.cmo : runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
++ types/atoms.cmi schema/schema_types.cmi
++schema/schema_types.cmx : runtime/value.cmx misc/ns.cmx misc/encodings.cmx \
++ types/atoms.cmx schema/schema_types.cmi
++schema/schema_xml.cmo : schema/schema_pcre.cmi misc/ns.cmi \
++ misc/encodings.cmi schema/schema_xml.cmi
++schema/schema_xml.cmx : schema/schema_pcre.cmx misc/ns.cmx \
++ misc/encodings.cmx schema/schema_xml.cmi
++schema/schema_common.cmo : runtime/value.cmi types/types.cmi \
+ schema/schema_xml.cmi schema/schema_types.cmi schema/schema_pcre.cmi \
+- misc/ns.cmi misc/encodings.cmi types/atoms.cmi schema/schema_common.cmi
+-schema/schema_common.cmx: runtime/value.cmx types/types.cmx \
++ misc/ns.cmi misc/encodings.cmi types/atoms.cmi schema/schema_common.cmi
++schema/schema_common.cmx : runtime/value.cmx types/types.cmx \
+ schema/schema_xml.cmx schema/schema_types.cmx schema/schema_pcre.cmx \
+- misc/ns.cmx misc/encodings.cmx types/atoms.cmx schema/schema_common.cmi
+-schema/schema_builtin.cmo: runtime/value.cmi types/types.cmi \
++ misc/ns.cmx misc/encodings.cmx types/atoms.cmx schema/schema_common.cmi
++schema/schema_builtin.cmo : runtime/value.cmi types/types.cmi \
+ types/sequence.cmi schema/schema_xml.cmi schema/schema_types.cmi \
+ schema/schema_pcre.cmi schema/schema_common.cmi misc/ns.cmi \
+ types/intervals.cmi misc/encodings.cmi types/builtin_defs.cmi \
+- types/atoms.cmi schema/schema_builtin.cmi
+-schema/schema_builtin.cmx: runtime/value.cmx types/types.cmx \
++ types/atoms.cmi schema/schema_builtin.cmi
++schema/schema_builtin.cmx : runtime/value.cmx types/types.cmx \
+ types/sequence.cmx schema/schema_xml.cmx schema/schema_types.cmx \
+ schema/schema_pcre.cmx schema/schema_common.cmx misc/ns.cmx \
+ types/intervals.cmx misc/encodings.cmx types/builtin_defs.cmx \
+- types/atoms.cmx schema/schema_builtin.cmi
+-schema/schema_validator.cmo: runtime/value.cmi schema/schema_types.cmi \
++ types/atoms.cmx schema/schema_builtin.cmi
++schema/schema_validator.cmo : runtime/value.cmi schema/schema_types.cmi \
+ schema/schema_pcre.cmi schema/schema_common.cmi schema/schema_builtin.cmi \
+ misc/ns.cmi misc/encodings.cmi types/atoms.cmi \
+- schema/schema_validator.cmi
+-schema/schema_validator.cmx: runtime/value.cmx schema/schema_types.cmx \
++ schema/schema_validator.cmi
++schema/schema_validator.cmx : runtime/value.cmx schema/schema_types.cmx \
+ schema/schema_pcre.cmx schema/schema_common.cmx schema/schema_builtin.cmx \
+ misc/ns.cmx misc/encodings.cmx types/atoms.cmx \
+- schema/schema_validator.cmi
+-types/patterns.cmo: types/types.cmi types/sortedList.cmi types/sequence.cmi \
++ schema/schema_validator.cmi
++types/patterns.cmo : types/types.cmi types/sortedList.cmi types/sequence.cmi \
+ types/ident.cmo misc/custom.cmo types/chars.cmi compile/auto_pat.cmi \
+- types/atoms.cmi types/patterns.cmi
+-types/patterns.cmx: types/types.cmx types/sortedList.cmx types/sequence.cmx \
++ types/atoms.cmi types/patterns.cmi
++types/patterns.cmx : types/types.cmx types/sortedList.cmx types/sequence.cmx \
+ types/ident.cmx misc/custom.cmx types/chars.cmx compile/auto_pat.cmx \
+- types/atoms.cmx types/patterns.cmi
+-compile/print_auto.cmo: types/types.cmi types/ident.cmo compile/auto_pat.cmi \
+- compile/print_auto.cmi
+-compile/print_auto.cmx: types/types.cmx types/ident.cmx compile/auto_pat.cmx \
+- compile/print_auto.cmi
+-compile/lambda.cmo: runtime/value.cmi types/types.cmi \
++ types/atoms.cmx types/patterns.cmi
++compile/print_auto.cmo : types/types.cmi types/ident.cmo \
++ compile/auto_pat.cmi compile/print_auto.cmi
++compile/print_auto.cmx : types/types.cmx types/ident.cmx \
++ compile/auto_pat.cmx compile/print_auto.cmi
++compile/lambda.cmo : runtime/value.cmi types/types.cmi \
+ schema/schema_validator.cmi misc/ns.cmi misc/imap.cmi types/ident.cmo \
+- types/compunit.cmi compile/auto_pat.cmi compile/lambda.cmi
+-compile/lambda.cmx: runtime/value.cmx types/types.cmx \
++ types/compunit.cmi compile/auto_pat.cmi compile/lambda.cmi
++compile/lambda.cmx : runtime/value.cmx types/types.cmx \
+ schema/schema_validator.cmx misc/ns.cmx misc/imap.cmx types/ident.cmx \
+- types/compunit.cmx compile/auto_pat.cmx compile/lambda.cmi
+-runtime/run_dispatch.cmo: runtime/value.cmi misc/upool.cmi types/types.cmi \
++ types/compunit.cmx compile/auto_pat.cmx compile/lambda.cmi
++runtime/run_dispatch.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
+ misc/imap.cmi types/ident.cmo misc/encodings.cmi types/chars.cmi \
+- compile/auto_pat.cmi types/atoms.cmi runtime/run_dispatch.cmi
+-runtime/run_dispatch.cmx: runtime/value.cmx misc/upool.cmx types/types.cmx \
++ compile/auto_pat.cmi types/atoms.cmi runtime/run_dispatch.cmi
++runtime/run_dispatch.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
+ misc/imap.cmx types/ident.cmx misc/encodings.cmx types/chars.cmx \
+- compile/auto_pat.cmx types/atoms.cmx runtime/run_dispatch.cmi
+-runtime/explain.cmo: runtime/value.cmi misc/upool.cmi types/types.cmi \
++ compile/auto_pat.cmx types/atoms.cmx runtime/run_dispatch.cmi
++runtime/explain.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
+ runtime/run_dispatch.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
+- types/chars.cmi compile/auto_pat.cmi types/atoms.cmi runtime/explain.cmi
+-runtime/explain.cmx: runtime/value.cmx misc/upool.cmx types/types.cmx \
++ types/chars.cmi compile/auto_pat.cmi types/atoms.cmi runtime/explain.cmi
++runtime/explain.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
+ runtime/run_dispatch.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
+- types/chars.cmx compile/auto_pat.cmx types/atoms.cmx runtime/explain.cmi
+-runtime/eval.cmo: runtime/value.cmi misc/upool.cmi types/types.cmi \
++ types/chars.cmx compile/auto_pat.cmx types/atoms.cmx runtime/explain.cmi
++runtime/eval.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
+ schema/schema_validator.cmi schema/schema_common.cmi \
+ runtime/run_dispatch.cmi misc/ns.cmi compile/lambda.cmi misc/imap.cmi \
+- types/ident.cmo runtime/explain.cmi compile/auto_pat.cmi runtime/eval.cmi
+-runtime/eval.cmx: runtime/value.cmx misc/upool.cmx types/types.cmx \
++ types/ident.cmo runtime/explain.cmi compile/auto_pat.cmi runtime/eval.cmi
++runtime/eval.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
+ schema/schema_validator.cmx schema/schema_common.cmx \
+ runtime/run_dispatch.cmx misc/ns.cmx compile/lambda.cmx misc/imap.cmx \
+- types/ident.cmx runtime/explain.cmx compile/auto_pat.cmx runtime/eval.cmi
+-parser/cduce_loc.cmo: misc/html.cmi parser/cduce_loc.cmi
+-parser/cduce_loc.cmx: misc/html.cmx parser/cduce_loc.cmi
+-parser/url.cmo: runtime/value.cmi parser/cduce_loc.cmi parser/url.cmi
+-parser/url.cmx: runtime/value.cmx parser/cduce_loc.cmx parser/url.cmi
+-parser/ulexer.cmo: parser/ulexer.cmi
+-parser/ulexer.cmx: parser/ulexer.cmi
+-parser/ast.cmo: types/types.cmi types/sequence.cmi misc/ns.cmi \
++ types/ident.cmx runtime/explain.cmx compile/auto_pat.cmx runtime/eval.cmi
++parser/cduce_loc.cmo : misc/html.cmi parser/cduce_loc.cmi
++parser/cduce_loc.cmx : misc/html.cmx parser/cduce_loc.cmi
++parser/url.cmo : runtime/value.cmi parser/cduce_loc.cmi parser/url.cmi
++parser/url.cmx : runtime/value.cmx parser/cduce_loc.cmx parser/url.cmi
++parser/ulexer.cmo : parser/ulexer.cmi
++parser/ulexer.cmx : parser/ulexer.cmi
++parser/ast.cmo : types/types.cmi types/sequence.cmi misc/ns.cmi \
+ types/intervals.cmi types/ident.cmo types/chars.cmi parser/cduce_loc.cmi \
+- types/builtin_defs.cmi
+-parser/ast.cmx: types/types.cmx types/sequence.cmx misc/ns.cmx \
++ types/builtin_defs.cmi
++parser/ast.cmx : types/types.cmx types/sequence.cmx misc/ns.cmx \
+ types/intervals.cmx types/ident.cmx types/chars.cmx parser/cduce_loc.cmx \
+- types/builtin_defs.cmx
+-parser/parser.cmo: parser/ulexer.cmi types/types.cmi types/sequence.cmi \
++ types/builtin_defs.cmx
++parser/parser.cmo : parser/ulexer.cmi types/types.cmi types/sequence.cmi \
+ misc/ns.cmi types/intervals.cmi types/ident.cmo misc/encodings.cmi \
+ types/chars.cmi parser/cduce_loc.cmi types/atoms.cmi parser/ast.cmo \
+- parser/parser.cmi
+-parser/parser.cmx: parser/ulexer.cmx types/types.cmx types/sequence.cmx \
++ parser/parser.cmi
++parser/parser.cmx : parser/ulexer.cmx types/types.cmx types/sequence.cmx \
+ misc/ns.cmx types/intervals.cmx types/ident.cmx misc/encodings.cmx \
+ types/chars.cmx parser/cduce_loc.cmx types/atoms.cmx parser/ast.cmx \
+- parser/parser.cmi
+-typing/typed.cmo: types/types.cmi schema/schema_validator.cmi \
++ parser/parser.cmi
++typing/typed.cmo : types/types.cmi schema/schema_validator.cmi \
+ types/patterns.cmi misc/ns.cmi types/ident.cmo types/compunit.cmi \
+- parser/cduce_loc.cmi
+-typing/typed.cmx: types/types.cmx schema/schema_validator.cmx \
++ parser/cduce_loc.cmi
++typing/typed.cmx : types/types.cmx schema/schema_validator.cmx \
+ types/patterns.cmx misc/ns.cmx types/ident.cmx types/compunit.cmx \
+- parser/cduce_loc.cmx
+-typing/typepat.cmo: types/types.cmi types/sequence.cmi types/patterns.cmi \
+- types/ident.cmo misc/encodings.cmi types/chars.cmi typing/typepat.cmi
+-typing/typepat.cmx: types/types.cmx types/sequence.cmx types/patterns.cmx \
+- types/ident.cmx misc/encodings.cmx types/chars.cmx typing/typepat.cmi
+-types/externals.cmo: parser/cduce_loc.cmi types/externals.cmi
+-types/externals.cmx: parser/cduce_loc.cmx types/externals.cmi
+-typing/typer.cmo: types/types.cmi typing/typepat.cmi typing/typed.cmo \
++ parser/cduce_loc.cmx
++typing/typepat.cmo : types/types.cmi types/sequence.cmi types/patterns.cmi \
++ types/ident.cmo misc/encodings.cmi types/chars.cmi typing/typepat.cmi
++typing/typepat.cmx : types/types.cmx types/sequence.cmx types/patterns.cmx \
++ types/ident.cmx misc/encodings.cmx types/chars.cmx typing/typepat.cmi
++types/externals.cmo : parser/cduce_loc.cmi types/externals.cmi
++types/externals.cmx : parser/cduce_loc.cmx types/externals.cmi
++typing/typer.cmo : types/types.cmi typing/typepat.cmi typing/typed.cmo \
+ types/sequence.cmi schema/schema_validator.cmi types/patterns.cmi \
+ misc/ns.cmi types/ident.cmo misc/html.cmi types/externals.cmi \
+ types/compunit.cmi types/chars.cmi parser/cduce_loc.cmi \
+- types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo typing/typer.cmi
+-typing/typer.cmx: types/types.cmx typing/typepat.cmx typing/typed.cmx \
++ types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo typing/typer.cmi
++typing/typer.cmx : types/types.cmx typing/typepat.cmx typing/typed.cmx \
+ types/sequence.cmx schema/schema_validator.cmx types/patterns.cmx \
+ misc/ns.cmx types/ident.cmx misc/html.cmx types/externals.cmx \
+ types/compunit.cmx types/chars.cmx parser/cduce_loc.cmx \
+- types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx typing/typer.cmi
+-compile/compile.cmo: runtime/value.cmi misc/upool.cmi types/types.cmi \
++ types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx typing/typer.cmi
++compile/compile.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
+ typing/typer.cmi typing/typed.cmo types/patterns.cmi compile/lambda.cmi \
+ misc/imap.cmi types/ident.cmo runtime/eval.cmi types/compunit.cmi \
+ parser/cduce_loc.cmi compile/auto_pat.cmi parser/ast.cmo \
+- compile/compile.cmi
+-compile/compile.cmx: runtime/value.cmx misc/upool.cmx types/types.cmx \
++ compile/compile.cmi
++compile/compile.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
+ typing/typer.cmx typing/typed.cmx types/patterns.cmx compile/lambda.cmx \
+ misc/imap.cmx types/ident.cmx runtime/eval.cmx types/compunit.cmx \
+ parser/cduce_loc.cmx compile/auto_pat.cmx parser/ast.cmx \
+- compile/compile.cmi
+-schema/schema_parser.cmo: parser/url.cmi schema/schema_xml.cmi \
++ compile/compile.cmi
++schema/schema_parser.cmo : parser/url.cmi schema/schema_xml.cmi \
+ schema/schema_validator.cmi schema/schema_types.cmi \
+ schema/schema_pcre.cmi schema/schema_common.cmi schema/schema_builtin.cmi \
+- misc/ns.cmi misc/encodings.cmi types/atoms.cmi schema/schema_parser.cmi
+-schema/schema_parser.cmx: parser/url.cmx schema/schema_xml.cmx \
++ misc/ns.cmi misc/encodings.cmi types/atoms.cmi schema/schema_parser.cmi
++schema/schema_parser.cmx : parser/url.cmx schema/schema_xml.cmx \
+ schema/schema_validator.cmx schema/schema_types.cmx \
+ schema/schema_pcre.cmx schema/schema_common.cmx schema/schema_builtin.cmx \
+- misc/ns.cmx misc/encodings.cmx types/atoms.cmx schema/schema_parser.cmi
+-schema/schema_converter.cmo: runtime/value.cmi types/types.cmi \
++ misc/ns.cmx misc/encodings.cmx types/atoms.cmx schema/schema_parser.cmi
++schema/schema_converter.cmo : runtime/value.cmi types/types.cmi \
+ typing/typer.cmi typing/typepat.cmi types/sequence.cmi \
+ schema/schema_xml.cmi schema/schema_validator.cmi schema/schema_types.cmi \
+ schema/schema_parser.cmi schema/schema_common.cmi \
+ schema/schema_builtin.cmi misc/ns.cmi types/ident.cmo misc/encodings.cmi \
+- types/builtin_defs.cmi types/atoms.cmi
+-schema/schema_converter.cmx: runtime/value.cmx types/types.cmx \
++ types/builtin_defs.cmi types/atoms.cmi
++schema/schema_converter.cmx : runtime/value.cmx types/types.cmx \
+ typing/typer.cmx typing/typepat.cmx types/sequence.cmx \
+ schema/schema_xml.cmx schema/schema_validator.cmx schema/schema_types.cmx \
+ schema/schema_parser.cmx schema/schema_common.cmx \
+ schema/schema_builtin.cmx misc/ns.cmx types/ident.cmx misc/encodings.cmx \
+- types/builtin_defs.cmx types/atoms.cmx
+-runtime/load_xml.cmo: runtime/value.cmi parser/url.cmi misc/upool.cmi \
++ types/builtin_defs.cmx types/atoms.cmx
++runtime/load_xml.cmo : runtime/value.cmi parser/url.cmi misc/upool.cmi \
+ misc/ns.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
+- parser/cduce_loc.cmi types/atoms.cmi runtime/load_xml.cmi
+-runtime/load_xml.cmx: runtime/value.cmx parser/url.cmx misc/upool.cmx \
++ parser/cduce_loc.cmi types/atoms.cmi runtime/load_xml.cmi
++runtime/load_xml.cmx : runtime/value.cmx parser/url.cmx misc/upool.cmx \
+ misc/ns.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
+- parser/cduce_loc.cmx types/atoms.cmx runtime/load_xml.cmi
+-runtime/print_xml.cmo: runtime/value.cmi types/sequence.cmi \
++ parser/cduce_loc.cmx types/atoms.cmx runtime/load_xml.cmi
++runtime/print_xml.cmo : runtime/value.cmi types/sequence.cmi \
+ schema/schema_builtin.cmi misc/ns.cmi types/intervals.cmi misc/imap.cmi \
+- types/ident.cmo misc/encodings.cmi types/atoms.cmi runtime/print_xml.cmi
+-runtime/print_xml.cmx: runtime/value.cmx types/sequence.cmx \
++ types/ident.cmo misc/encodings.cmi types/atoms.cmi runtime/print_xml.cmi
++runtime/print_xml.cmx : runtime/value.cmx types/sequence.cmx \
+ schema/schema_builtin.cmx misc/ns.cmx types/intervals.cmx misc/imap.cmx \
+- types/ident.cmx misc/encodings.cmx types/atoms.cmx runtime/print_xml.cmi
+-compile/operators.cmo: runtime/value.cmi types/types.cmi typing/typer.cmi \
+- runtime/eval.cmi parser/cduce_loc.cmi compile/operators.cmi
+-compile/operators.cmx: runtime/value.cmx types/types.cmx typing/typer.cmx \
+- runtime/eval.cmx parser/cduce_loc.cmx compile/operators.cmi
+-types/builtin.cmo: runtime/value.cmi parser/url.cmi types/types.cmi \
++ types/ident.cmx misc/encodings.cmx types/atoms.cmx runtime/print_xml.cmi
++compile/operators.cmo : runtime/value.cmi types/types.cmi typing/typer.cmi \
++ runtime/eval.cmi parser/cduce_loc.cmi compile/operators.cmi
++compile/operators.cmx : runtime/value.cmx types/types.cmx typing/typer.cmx \
++ runtime/eval.cmx parser/cduce_loc.cmx compile/operators.cmi
++types/builtin.cmo : runtime/value.cmi parser/url.cmi types/types.cmi \
+ typing/typer.cmi types/sequence.cmi runtime/print_xml.cmi \
+ compile/operators.cmi misc/ns.cmi runtime/load_xml.cmi \
+ types/intervals.cmi types/ident.cmo runtime/eval.cmi types/chars.cmi \
+ parser/cduce_loc.cmi types/builtin_defs.cmi types/atoms.cmi \
+- types/builtin.cmi
+-types/builtin.cmx: runtime/value.cmx parser/url.cmx types/types.cmx \
++ types/builtin.cmi
++types/builtin.cmx : runtime/value.cmx parser/url.cmx types/types.cmx \
+ typing/typer.cmx types/sequence.cmx runtime/print_xml.cmx \
+ compile/operators.cmx misc/ns.cmx runtime/load_xml.cmx \
+ types/intervals.cmx types/ident.cmx runtime/eval.cmx types/chars.cmx \
+ parser/cduce_loc.cmx types/builtin_defs.cmx types/atoms.cmx \
+- types/builtin.cmi
+-driver/librarian.cmo: runtime/value.cmi parser/ulexer.cmi types/types.cmi \
++ types/builtin.cmi
++driver/librarian.cmo : runtime/value.cmi parser/ulexer.cmi types/types.cmi \
+ typing/typer.cmi parser/parser.cmi compile/lambda.cmi types/ident.cmo \
+ types/externals.cmi runtime/eval.cmi types/compunit.cmi \
+ compile/compile.cmi parser/cduce_loc.cmi types/builtin.cmi \
+- driver/librarian.cmi
+-driver/librarian.cmx: runtime/value.cmx parser/ulexer.cmx types/types.cmx \
++ driver/librarian.cmi
++driver/librarian.cmx : runtime/value.cmx parser/ulexer.cmx types/types.cmx \
+ typing/typer.cmx parser/parser.cmx compile/lambda.cmx types/ident.cmx \
+ types/externals.cmx runtime/eval.cmx types/compunit.cmx \
+ compile/compile.cmx parser/cduce_loc.cmx types/builtin.cmx \
+- driver/librarian.cmi
+-types/sample.cmo: types/types.cmi types/intervals.cmi types/ident.cmo \
+- types/chars.cmi types/atoms.cmi types/sample.cmi
+-types/sample.cmx: types/types.cmx types/intervals.cmx types/ident.cmx \
+- types/chars.cmx types/atoms.cmx types/sample.cmi
+-driver/cduce.cmo: runtime/value.cmi parser/ulexer.cmi types/types.cmi \
++ driver/librarian.cmi
++types/sample.cmo : types/types.cmi types/intervals.cmi types/ident.cmo \
++ types/chars.cmi types/atoms.cmi types/sample.cmi
++types/sample.cmx : types/types.cmx types/intervals.cmx types/ident.cmx \
++ types/chars.cmx types/atoms.cmx types/sample.cmi
++driver/cduce.cmo : runtime/value.cmi parser/ulexer.cmi types/types.cmi \
+ typing/typer.cmi misc/stats.cmi types/sequence.cmi types/sample.cmi \
+ compile/print_auto.cmi types/patterns.cmi parser/parser.cmi \
+ compile/operators.cmi misc/ns.cmi driver/librarian.cmi types/ident.cmo \
+ runtime/eval.cmi compile/compile.cmi parser/cduce_loc.cmi \
+ types/builtin_defs.cmi types/builtin.cmi compile/auto_pat.cmi \
+- types/atoms.cmi parser/ast.cmo driver/cduce.cmi
+-driver/cduce.cmx: runtime/value.cmx parser/ulexer.cmx types/types.cmx \
++ types/atoms.cmi parser/ast.cmo driver/cduce.cmi
++driver/cduce.cmx : runtime/value.cmx parser/ulexer.cmx types/types.cmx \
+ typing/typer.cmx misc/stats.cmx types/sequence.cmx types/sample.cmx \
+ compile/print_auto.cmx types/patterns.cmx parser/parser.cmx \
+ compile/operators.cmx misc/ns.cmx driver/librarian.cmx types/ident.cmx \
+ runtime/eval.cmx compile/compile.cmx parser/cduce_loc.cmx \
+ types/builtin_defs.cmx types/builtin.cmx compile/auto_pat.cmx \
+- types/atoms.cmx parser/ast.cmx driver/cduce.cmi
+-runtime/system.cmo: runtime/value.cmi types/types.cmi types/sequence.cmi \
++ types/atoms.cmx parser/ast.cmx driver/cduce.cmi
++runtime/system.cmo : runtime/value.cmi types/types.cmi types/sequence.cmi \
+ compile/operators.cmi types/ident.cmo parser/cduce_loc.cmi \
+- types/builtin_defs.cmi types/builtin.cmi types/atoms.cmi
+-runtime/system.cmx: runtime/value.cmx types/types.cmx types/sequence.cmx \
++ types/builtin_defs.cmi types/builtin.cmi types/atoms.cmi
++runtime/system.cmx : runtime/value.cmx types/types.cmx types/sequence.cmx \
+ compile/operators.cmx types/ident.cmx parser/cduce_loc.cmx \
+- types/builtin_defs.cmx types/builtin.cmx types/atoms.cmx
+-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 \
+- driver/cduce_config.cmi
+-parser/cduce_netclient.cmx: runtime/value.cmx parser/url.cmx \
+- driver/cduce_config.cmx
+-runtime/cduce_pxp.cmo: runtime/value.cmi parser/url.cmi schema/schema_xml.cmi \
+- runtime/load_xml.cmi driver/cduce_config.cmi runtime/cduce_pxp.cmi
+-runtime/cduce_pxp.cmx: runtime/value.cmx parser/url.cmx schema/schema_xml.cmx \
+- runtime/load_xml.cmx driver/cduce_config.cmx runtime/cduce_pxp.cmi
+-driver/run.cmo: runtime/value.cmi parser/ulexer.cmi misc/stats.cmi \
++ types/builtin_defs.cmx types/builtin.cmx types/atoms.cmx
++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
++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
++runtime/cduce_pxp.cmo : runtime/value.cmi parser/url.cmi \
++ schema/schema_xml.cmi runtime/load_xml.cmi driver/cduce_config.cmi \
++ runtime/cduce_pxp.cmi
++runtime/cduce_pxp.cmx : runtime/value.cmx parser/url.cmx \
++ schema/schema_xml.cmx runtime/load_xml.cmx driver/cduce_config.cmx \
++ runtime/cduce_pxp.cmi
++runtime/cduce_expat.cmo : runtime/value.cmi parser/url.cmi \
++ schema/schema_xml.cmi runtime/load_xml.cmi driver/cduce_config.cmi \
++ runtime/cduce_expat.cmi
++runtime/cduce_expat.cmx : runtime/value.cmx parser/url.cmx \
++ schema/schema_xml.cmx runtime/load_xml.cmx driver/cduce_config.cmx \
++ runtime/cduce_expat.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
+-driver/run.cmx: runtime/value.cmx parser/ulexer.cmx misc/stats.cmx \
++ driver/cduce_config.cmi driver/cduce.cmi types/builtin.cmi
++driver/run.cmx : runtime/value.cmx parser/ulexer.cmx misc/stats.cmx \
+ driver/librarian.cmx types/ident.cmx misc/html.cmx parser/cduce_loc.cmx \
+- driver/cduce_config.cmx driver/cduce.cmx types/builtin.cmx
+-driver/start.cmo: driver/run.cmo
+-driver/start.cmx: driver/run.cmx
+-driver/webiface.cmo: misc/html.cmi driver/examples.cmo parser/cduce_loc.cmi \
+- driver/cduce.cmi
+-driver/webiface.cmx: misc/html.cmx driver/examples.cmx parser/cduce_loc.cmx \
+- driver/cduce.cmx
+-driver/evaluator.cmo: misc/html.cmi parser/cduce_loc.cmi \
+- driver/cduce_config.cmi driver/cduce.cmi
+-driver/evaluator.cmx: misc/html.cmx parser/cduce_loc.cmx \
+- driver/cduce_config.cmx driver/cduce.cmx
+-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: 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_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 \
+- driver/cduce_config.cmi
+-parser/cduce_netclient.cmx: runtime/value.cmx parser/url.cmx \
+- driver/cduce_config.cmx
+-runtime/cduce_expat.cmo: runtime/value.cmi parser/url.cmi \
++ driver/cduce_config.cmx driver/cduce.cmx types/builtin.cmx
++driver/start.cmo : driver/run.cmo
++driver/start.cmx : driver/run.cmx
++driver/examples.cmo :
++driver/examples.cmx :
++driver/webiface.cmo : misc/html.cmi driver/examples.cmo parser/cduce_loc.cmi \
++ driver/cduce.cmi
++driver/webiface.cmx : misc/html.cmx driver/examples.cmx parser/cduce_loc.cmx \
++ driver/cduce.cmx
++driver/evaluator.cmo : misc/html.cmi parser/cduce_loc.cmi \
++ driver/cduce_config.cmi driver/cduce.cmi
++driver/evaluator.cmx : misc/html.cmx parser/cduce_loc.cmx \
++ driver/cduce_config.cmx driver/cduce.cmx
++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
++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 \
++ driver/cduce_config.cmi
++parser/cduce_netclient.cmx : runtime/value.cmx parser/url.cmx \
++ driver/cduce_config.cmx
++runtime/cduce_expat.cmo : runtime/value.cmi parser/url.cmi \
+ schema/schema_xml.cmi runtime/load_xml.cmi driver/cduce_config.cmi \
+- runtime/cduce_expat.cmi
+-runtime/cduce_expat.cmx: runtime/value.cmx parser/url.cmx \
++ runtime/cduce_expat.cmi
++runtime/cduce_expat.cmx : runtime/value.cmx parser/url.cmx \
+ schema/schema_xml.cmx runtime/load_xml.cmx driver/cduce_config.cmx \
+- runtime/cduce_expat.cmi
+-runtime/cduce_pxp.cmo: runtime/value.cmi parser/url.cmi schema/schema_xml.cmi \
+- runtime/load_xml.cmi driver/cduce_config.cmi runtime/cduce_pxp.cmi
+-runtime/cduce_pxp.cmx: runtime/value.cmx parser/url.cmx schema/schema_xml.cmx \
+- runtime/load_xml.cmx driver/cduce_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
+-types/sortedList.cmi: misc/custom.cmo
+-misc/bool.cmi: misc/custom.cmo
+-types/intervals.cmi: misc/custom.cmo
+-types/chars.cmi: misc/custom.cmo
+-types/atoms.cmi: misc/ns.cmi misc/encodings.cmi misc/custom.cmo
+-types/types.cmi: misc/ns.cmi types/intervals.cmi types/ident.cmo \
+- misc/custom.cmo types/chars.cmi types/atoms.cmi
+-compile/auto_pat.cmi: types/types.cmi types/ident.cmo types/chars.cmi \
+- types/atoms.cmi
+-types/sequence.cmi: types/types.cmi types/atoms.cmi
+-types/builtin_defs.cmi: types/types.cmi types/ident.cmo types/atoms.cmi
+-runtime/value.cmi: types/types.cmi misc/ns.cmi types/intervals.cmi \
++ runtime/cduce_expat.cmi
++runtime/cduce_pxp.cmo : runtime/value.cmi parser/url.cmi \
++ schema/schema_xml.cmi runtime/load_xml.cmi driver/cduce_config.cmi \
++ runtime/cduce_pxp.cmi
++runtime/cduce_pxp.cmx : runtime/value.cmx parser/url.cmx \
++ schema/schema_xml.cmx runtime/load_xml.cmx driver/cduce_config.cmx \
++ runtime/cduce_pxp.cmi
++driver/cduce_config.cmi :
++misc/stats.cmi :
++misc/encodings.cmi : misc/custom.cmo
++misc/upool.cmi : misc/custom.cmo
++misc/pretty.cmi :
++misc/ns.cmi : misc/upool.cmi misc/encodings.cmi misc/custom.cmo
++misc/imap.cmi :
++misc/html.cmi :
++types/compunit.cmi :
++types/sortedList.cmi : misc/custom.cmo
++misc/bool.cmi : misc/custom.cmo
++types/intervals.cmi : misc/custom.cmo
++types/chars.cmi : misc/custom.cmo
++types/atoms.cmi : misc/ns.cmi misc/encodings.cmi misc/custom.cmo
++types/normal.cmi :
++types/types.cmi : misc/ns.cmi types/intervals.cmi types/ident.cmo \
++ misc/custom.cmo types/chars.cmi types/atoms.cmi
++compile/auto_pat.cmi : types/types.cmi types/ident.cmo types/chars.cmi \
++ types/atoms.cmi
++types/sequence.cmi : types/types.cmi types/atoms.cmi
++types/builtin_defs.cmi : types/types.cmi types/ident.cmo types/atoms.cmi
++runtime/value.cmi : types/types.cmi misc/ns.cmi types/intervals.cmi \
+ misc/imap.cmi types/ident.cmo misc/encodings.cmi types/chars.cmi \
+- types/atoms.cmi
+-schema/schema_pcre.cmi: misc/encodings.cmi
+-schema/schema_types.cmi: runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
+- types/atoms.cmi
+-schema/schema_xml.cmi: misc/ns.cmi misc/encodings.cmi
+-schema/schema_common.cmi: runtime/value.cmi types/types.cmi \
++ types/atoms.cmi
++schema/schema_pcre.cmi : misc/encodings.cmi
++schema/schema_types.cmi : runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
++ types/atoms.cmi
++schema/schema_xml.cmi : misc/ns.cmi misc/encodings.cmi
++schema/schema_common.cmi : runtime/value.cmi types/types.cmi \
+ schema/schema_types.cmi misc/ns.cmi types/ident.cmo misc/encodings.cmi \
+- types/atoms.cmi
+-schema/schema_builtin.cmi: runtime/value.cmi types/types.cmi \
+- schema/schema_types.cmi misc/ns.cmi misc/encodings.cmi
+-schema/schema_validator.cmi: runtime/value.cmi schema/schema_types.cmi \
+- misc/encodings.cmi
+-types/patterns.cmi: types/types.cmi types/ident.cmo misc/custom.cmo \
+- compile/auto_pat.cmi
+-compile/print_auto.cmi: compile/auto_pat.cmi
+-compile/lambda.cmi: runtime/value.cmi types/types.cmi \
++ types/atoms.cmi
++schema/schema_builtin.cmi : runtime/value.cmi types/types.cmi \
++ schema/schema_types.cmi misc/ns.cmi misc/encodings.cmi
++schema/schema_validator.cmi : runtime/value.cmi schema/schema_types.cmi \
++ misc/encodings.cmi
++types/patterns.cmi : types/types.cmi types/ident.cmo misc/custom.cmo \
++ compile/auto_pat.cmi
++compile/print_auto.cmi : compile/auto_pat.cmi
++compile/lambda.cmi : runtime/value.cmi types/types.cmi \
+ schema/schema_validator.cmi misc/ns.cmi misc/imap.cmi types/ident.cmo \
+- types/compunit.cmi compile/auto_pat.cmi
+-runtime/run_dispatch.cmi: runtime/value.cmi compile/auto_pat.cmi
+-runtime/explain.cmi: runtime/value.cmi compile/auto_pat.cmi
+-runtime/eval.cmi: runtime/value.cmi misc/ns.cmi compile/lambda.cmi \
+- types/ident.cmo types/compunit.cmi
+-parser/cduce_loc.cmi: misc/html.cmi
+-parser/parser.cmi: parser/ast.cmo
+-typing/typepat.cmi: types/types.cmi types/patterns.cmi types/ident.cmo \
+- misc/encodings.cmi
+-types/externals.cmi: types/types.cmi
+-typing/typer.cmi: types/types.cmi typing/typed.cmo \
++ types/compunit.cmi compile/auto_pat.cmi
++runtime/run_dispatch.cmi : runtime/value.cmi compile/auto_pat.cmi
++runtime/explain.cmi : runtime/value.cmi compile/auto_pat.cmi
++runtime/eval.cmi : runtime/value.cmi misc/ns.cmi compile/lambda.cmi \
++ types/ident.cmo types/compunit.cmi
++parser/cduce_loc.cmi : misc/html.cmi
++parser/url.cmi :
++parser/ulexer.cmi :
++parser/parser.cmi : parser/ast.cmo
++typing/typepat.cmi : types/types.cmi types/patterns.cmi types/ident.cmo \
++ misc/encodings.cmi
++types/externals.cmi : types/types.cmi
++typing/typer.cmi : types/types.cmi typing/typed.cmo \
+ schema/schema_validator.cmi types/patterns.cmi misc/ns.cmi \
+- types/ident.cmo types/compunit.cmi parser/cduce_loc.cmi parser/ast.cmo
+-compile/compile.cmi: runtime/value.cmi types/types.cmi typing/typer.cmi \
++ types/ident.cmo types/compunit.cmi parser/cduce_loc.cmi parser/ast.cmo
++compile/compile.cmi : runtime/value.cmi types/types.cmi typing/typer.cmi \
+ typing/typed.cmo compile/lambda.cmi types/ident.cmo types/compunit.cmi \
+- parser/ast.cmo
+-schema/schema_parser.cmi: schema/schema_types.cmi
+-runtime/load_xml.cmi: runtime/value.cmi
+-runtime/print_xml.cmi: runtime/value.cmi misc/ns.cmi
+-compile/operators.cmi: runtime/value.cmi types/types.cmi parser/cduce_loc.cmi
+-types/builtin.cmi: runtime/value.cmi typing/typer.cmi
+-driver/librarian.cmi: runtime/value.cmi types/types.cmi typing/typer.cmi \
++ parser/ast.cmo
++schema/schema_parser.cmi : schema/schema_types.cmi
++runtime/load_xml.cmi : runtime/value.cmi misc/ns.cmi
++runtime/print_xml.cmi : runtime/value.cmi misc/ns.cmi
++compile/operators.cmi : runtime/value.cmi types/types.cmi \
++ parser/cduce_loc.cmi
++types/builtin.cmi : runtime/value.cmi typing/typer.cmi
++driver/librarian.cmi : runtime/value.cmi types/types.cmi typing/typer.cmi \
+ types/ident.cmo types/externals.cmi types/compunit.cmi \
+- compile/compile.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
++ compile/compile.cmi
++types/sample.cmi : types/types.cmi
++driver/cduce.cmi : runtime/value.cmi types/atoms.cmi
++runtime/cduce_pxp.cmi :
++runtime/cduce_expat.cmi :
++runtime/cduce_expat.cmi :
++runtime/cduce_pxp.cmi :
++schema/schema_types.cmi : runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
++ types/atoms.cmi
++ocamliface/3.x/mltypes.cmo : types/ident.cmo ocamliface/3.x/config.cmo \
++ parser/cduce_loc.cmi ocamliface/3.x/mltypes.cmi
++ocamliface/3.x/mltypes.cmx : types/ident.cmx ocamliface/3.x/config.cmx \
++ parser/cduce_loc.cmx ocamliface/3.x/mltypes.cmi
++ocamliface/3.x/mlstub.cmo : types/types.cmi typing/typer.cmi \
++ types/sequence.cmi misc/ns.cmi ocamliface/3.x/mltypes.cmi \
++ driver/librarian.cmi types/externals.cmi compile/compile.cmi \
++ parser/cduce_loc.cmi driver/cduce_config.cmi types/builtin_defs.cmi \
++ types/atoms.cmi parser/ast.cmo ocamliface/3.x/mlstub.cmi
++ocamliface/3.x/mlstub.cmx : types/types.cmx typing/typer.cmx \
++ types/sequence.cmx misc/ns.cmx ocamliface/3.x/mltypes.cmx \
++ driver/librarian.cmx types/externals.cmx compile/compile.cmx \
++ parser/cduce_loc.cmx driver/cduce_config.cmx types/builtin_defs.cmx \
++ types/atoms.cmx parser/ast.cmx ocamliface/3.x/mlstub.cmi
++ocamliface/3.x/mltypes.cmi : types/types.cmi
++ocamliface/3.x/mlstub.cmi : parser/ast.cmo
++ocamliface/4.01/mltypes.cmo : types/ident.cmo ocamliface/4.01/config.cmo \
++ parser/cduce_loc.cmi ocamliface/4.01/mltypes.cmi
++ocamliface/4.01/mltypes.cmx : types/ident.cmx ocamliface/4.01/config.cmx \
++ parser/cduce_loc.cmx ocamliface/4.01/mltypes.cmi
++ocamliface/4.01/mlstub.cmo : types/types.cmi typing/typer.cmi \
++ types/sequence.cmi misc/ns.cmi ocamliface/4.01/mltypes.cmi \
++ driver/librarian.cmi types/ident.cmo types/externals.cmi \
++ compile/compile.cmi parser/cduce_loc.cmi driver/cduce_config.cmi \
++ types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo \
++ ocamliface/4.01/mlstub.cmi
++ocamliface/4.01/mlstub.cmx : types/types.cmx typing/typer.cmx \
++ types/sequence.cmx misc/ns.cmx ocamliface/4.01/mltypes.cmx \
++ driver/librarian.cmx types/ident.cmx types/externals.cmx \
++ compile/compile.cmx parser/cduce_loc.cmx driver/cduce_config.cmx \
++ types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx \
++ ocamliface/4.01/mlstub.cmi
++ocamliface/4.01/mltypes.cmi : types/types.cmi types/ident.cmo
++ocamliface/4.01/mlstub.cmi : parser/ast.cmo
++ocamliface/4.02/mltypes.cmo : types/ident.cmo ocamliface/4.02/config.cmo \
++ parser/cduce_loc.cmi ocamliface/4.02/mltypes.cmi
++ocamliface/4.02/mltypes.cmx : types/ident.cmx ocamliface/4.02/config.cmx \
++ parser/cduce_loc.cmx ocamliface/4.02/mltypes.cmi
++ocamliface/4.02/mlstub.cmo : types/types.cmi typing/typer.cmi \
++ types/sequence.cmi misc/ns.cmi ocamliface/4.02/mltypes.cmi \
++ driver/librarian.cmi types/ident.cmo types/externals.cmi \
++ compile/compile.cmi parser/cduce_loc.cmi driver/cduce_config.cmi \
++ types/builtin_defs.cmi types/atoms.cmi parser/ast.cmo \
++ ocamliface/4.02/mlstub.cmi
++ocamliface/4.02/mlstub.cmx : types/types.cmx typing/typer.cmx \
++ types/sequence.cmx misc/ns.cmx ocamliface/4.02/mltypes.cmx \
++ driver/librarian.cmx types/ident.cmx types/externals.cmx \
++ compile/compile.cmx parser/cduce_loc.cmx driver/cduce_config.cmx \
++ types/builtin_defs.cmx types/atoms.cmx parser/ast.cmx \
++ ocamliface/4.02/mlstub.cmi
++ocamliface/4.02/mltypes.cmi : types/types.cmi types/ident.cmo
++ocamliface/4.02/mlstub.cmi : parser/ast.cmo
+diff --git a/ocamliface/3.x/Makefile b/ocamliface/3.x/Makefile
+new file mode 100644
+index 0000000..7f0a11e
+--- /dev/null
++++ b/ocamliface/3.x/Makefile
+@@ -0,0 +1,70 @@
++# This Makefile generates caml_cduce.cmo/.cmx
++# It must be called with an OCAML_SRC argument pointing to the root
++# of an OCaml source tree.
++include ../../Makefile.conf
++
++all: caml_cduce.cmo caml_cduce.cmx
++
++STDLIB=$(shell ocamlc -where)
++
++
++ifeq ($(FORPACK),true)
++ FORPACKOPT1=-for-pack Cduce_lib.Caml_cduce
++ FORPACKOPT2=-for-pack Cduce_lib
++else
++ FORPACKOPT1=
++ FORPACKOPT2=
++endif
++
++ocaml_files:
++ mkdir ocaml_files
++ $(HIDE)cp $(patsubst %,$(OCAML_SRC)/%, $(COPY_FILES)) ocaml_files/
++ 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);\
++ ocamlc $(FORPACKOPT2) -pack -o $@ $(OBJECTS); \
++ cp caml_cduce.cmo caml_cduce.cmi ..)
++
++caml_cduce.cmx: ocaml_files
++ @echo "Build $@"
++ (cd ocaml_files; ocamlopt $(FORPACKOPT1) -c $(COMPILE_FILES);\
++ ocamlopt $(FORPACKOPT2) -pack -o $@ $(XOBJECTS); \
++ cp caml_cduce.cmx caml_cduce.o caml_cduce.cmi ..)
++
++clean:
++ rm -Rf ocaml_files *~ *.cm*
++
++COPY_FILES=\
++ typing/annot.mli \
++ utils/misc.ml utils/tbl.ml \
++ utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.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 \
++ typing/subst.ml typing/predef.ml \
++ typing/datarepr.ml typing/env.ml \
++ 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.mli location.ml annot.mli longident.ml \
++ ident.ml path.ml \
++ primitive.ml types.ml \
++ btype.ml oprint.ml \
++ subst.ml predef.ml \
++ datarepr.ml env.ml ctype.mli ctype.ml printtyp.ml
++
++COMPILE_FILES_ML=$(filter %.ml,$(COMPILE_FILES))
++OBJECTS=$(COMPILE_FILES_ML:.ml=.cmo)
++XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
+diff --git a/ocamliface/3.x/config.ml b/ocamliface/3.x/config.ml
+new file mode 100644
+index 0000000..54ca779
+--- /dev/null
++++ b/ocamliface/3.x/config.ml
+@@ -0,0 +1,4 @@
++let standard_library = "STDLIB"
++let load_path = ref ([] : string list)
++let bytecomp_c_compiler = ""
++let bytecomp_c_linker = ""
+diff --git a/ocamliface/3.x/location.ml b/ocamliface/3.x/location.ml
+new file mode 100644
+index 0000000..99a3a24
+--- /dev/null
++++ b/ocamliface/3.x/location.ml
+@@ -0,0 +1,25 @@
++(* 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_error_cur_file = dummy
++let print_error = dummy
++let print = dummy
++let print_warning = dummy
++let prerr_warning = dummy
++let echo_eof = dummy
++let reset = dummy
++let highlight_locations = dummy
+diff --git a/ocamliface/3.x/mlstub.ml b/ocamliface/3.x/mlstub.ml
+new file mode 100644
+index 0000000..042871c
+--- /dev/null
++++ b/ocamliface/3.x/mlstub.ml
+@@ -0,0 +1,717 @@
++(**************************************************************************)
++(* The CDuce compiler *)
++(* Alain Frisch <Alain.Frisch at inria.fr> and the CDuce team *)
++(* Copyright CNRS,INRIA, 2003-2009 (see LICENSE for details) *)
++(**************************************************************************)
++
++#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)
++
++module IntHash =
++ Hashtbl.Make(struct type t = int let hash i = i let equal i j = i == j end)
++
++(* Compute CDuce type *)
++
++let vars = ref [||]
++
++let memo_typ = IntHash.create 13
++
++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< $uid:String.sub s i (String.length s - i)$ >>
++ in
++(* Printf.eprintf "*** %S\n" s; *)
++ aux 0
++
++let consId 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< $uid:String.sub s i (String.length s - i)$ >>
++ in
++ aux 0
++
++let rec typ t =
++ try IntHash.find memo_typ t.uid
++ with Not_found ->
++(* print_int t.uid; print_char ' '; flush stdout; *)
++ let node = Types.make () in
++ IntHash.add memo_typ t.uid node;
++ Types.define node (typ_descr t.def);
++ node
++
++and typ_descr = function
++ | Link t -> typ_descr t.def
++ | Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
++ | Tuple tl -> Types.tuple (List.map typ tl)
++ | PVariant l -> bigcup pvariant l
++ | Variant (_,l,_) -> bigcup variant l
++ | Record (_,l,_) ->
++ let l = List.map (fun (lab,t) -> label lab, typ t) l in
++ Types.record_fields (false,(LabelMap.from_list_disj l))
++ | 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])
++ | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
++ | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
++ | Builtin ("Big_int.big_int", []) -> Builtin_defs.int
++ | Builtin ("Cduce_lib.Value.t", []) -> Types.any
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
++ | Builtin ("Cduce_lib.Atoms.V.t", []) -> Builtin_defs.atom
++ | Builtin ("unit", []) -> Sequence.nil_type
++ | Builtin ("option", [t]) -> Sequence.option (typ t)
++ | Var i -> Types.descr (!vars).(i)
++ | _ -> assert false
++
++and pvariant = function
++ | (lab, None) -> atom lab
++ | (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
++
++and variant = function
++ | (lab, []) -> atom lab
++ | (lab, c) -> Types.tuple (Types.cons (atom lab) :: List.map typ c)
++
++
++(* Syntactic tools *)
++
++let var_counter = ref 0
++let mk_var _ =
++ incr var_counter;
++ Printf.sprintf "x%i" !var_counter
++
++let mk_vars = List.map mk_var
++
++let atom_ascii lab =
++ <:expr< Value.atom_ascii $str: String.escaped lab$ >>
++
++let label_ascii lab =
++ <:expr< Value.label_ascii $str: String.escaped lab$ >>
++
++let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$) >>
++
++let pmatch e l =
++ <:expr< match $e$ with [ $list:l$ ] >>
++
++let rec matches ine oute = function
++ | [v1;v2] ->
++ <: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
++ <:expr< let ($lid:v$,$lid:r$) = Value.get_pair $ine$ in $oute$ >>
++ | [] -> assert false
++
++let list_lit el =
++ List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
++
++let protect e f =
++ match e with
++ | <:expr< $lid:x$ >> -> f e
++ | e ->
++ let x = mk_var () in
++ let r = f <:expr< $lid:x$ >> in
++ <:expr< let $lid:x$ = $e$ in $r$ >>
++
++(* Registered types *)
++
++let gen_types = ref true
++(* currently always off *)
++
++
++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 ->
++ let i = !nb_registered_types in
++ HashTypes.add registered_types t i;
++ incr nb_registered_types;
++ i
++ in
++ <:expr< types.($int:string_of_int n$) >>
++
++let get_registered_types () =
++ let a = Array.make !nb_registered_types Types.empty in
++ HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
++ a
++
++(* OCaml -> CDuce conversions *)
++
++
++let to_cd_gen = ref []
++
++let to_cd_fun_name t =
++ Printf.sprintf "to_cd_%i" t.uid
++
++let to_cd_fun t =
++ to_cd_gen := t :: !to_cd_gen;
++ to_cd_fun_name t
++
++let to_ml_gen = ref []
++
++let to_ml_fun_name t =
++ Printf.sprintf "to_ml_%i" t.uid
++
++let to_ml_fun t =
++ to_ml_gen := t :: !to_ml_gen;
++ to_ml_fun_name t
++
++let rec tuple = function
++ | [v] -> v
++ | v::l -> <:expr< Value.Pair ($v$, $tuple l$) >>
++ | [] -> assert false
++
++let pat_tuple vars =
++ let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
++ <:patt< ($Ast.paCom_of_list pl$) >>
++
++
++let call_lab f l x =
++ if l = "" then <:expr< $f$ $x$ >>
++ else
++ if l.[0] = '?' then
++ let l = String.sub l 1 (String.length l - 1) in
++ <:expr< $f$ (? $l$ : $x$) >>
++ else
++ <:expr< $f$ (~ $l$ : $x$) >>
++
++let abstr_lab l x res =
++ if l = "" then <:expr< fun $lid:x$ -> $res$ >>
++ else
++ if l.[0] = '?' then
++ let l = String.sub l 1 (String.length l - 1) in
++ <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
++ else
++ <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>
++
++
++
++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
++
++and to_cd_descr e = function
++ | Link t -> to_cd e t
++ | Arrow (l,t,s) ->
++ (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
++ protect e
++ (fun y ->
++ let x = mk_var () in
++ 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 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))) *)
++ let vars = mk_vars tl in
++ <:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
++ | PVariant l ->
++ (* match <...> with
++ | `A -> Value.atom_ascii "A"
++ | `B x -> Value.Pair (Value.atom_ascii "B",t(x))
++ *)
++ let cases =
++ List.map
++ (function
++ | (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,_) ->
++ (* match <...> with
++ | P.A -> Value.atom_ascii "A"
++ | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,[]) ->
++ let pat = match lab with (* Stupid Camlp4 *)
++ | "true" -> <:patt< True >>
++ | "false" -> <:patt< False >>
++ | lab -> <:patt< $id: id (p^lab)$ >>
++ in
++ <:match_case< $pat$ -> $atom_ascii lab$ >>
++ | (lab,tl) ->
++ let vars = mk_vars tl in
++ <:match_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,_) ->
++ (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
++ protect e
++ (fun x ->
++ let l =
++ List.map
++ (fun (lab,t) ->
++ let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
++ <:expr< ($label_ascii lab$, $e$) >>)
++ 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$ >>
++ | 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 ("array",[t]) ->
++ <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
++ | Builtin ("Pervasives.ref",[t]) ->
++ (* let x = <...> in
++ Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
++ protect e
++ (fun e ->
++ let y = mk_var () 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
++ let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
++ <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
++ )
++ | Builtin ("Big_int.big_int", []) ->
++ <:expr< Value.ocaml2cduce_bigint $e$ >>
++ | Builtin ("Cduce_lib.Value.t", []) -> e
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
++ <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
++ | Builtin ("Cduce_lib.Atoms.V.t", []) ->
++ <:expr< Value.ocaml2cduce_atom $e$ >>
++ | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
++ | Var _ -> e
++ | Builtin ("option", [t]) ->
++ <:expr< Value.ocaml2cduce_option $lid:to_cd_fun t$ $e$ >>
++
++ | _ -> assert false
++
++and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
++
++(* CDuce -> OCaml conversions *)
++
++
++
++and to_ml (e : Ast.expr) (t : Mltypes.t) =
++(* Format.fprintf Format.err_formatter "to_ml %a at ."
++ Mltypes.print t; *)
++ if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
++ else to_ml_descr e t.def
++
++and to_ml_descr e = function
++ | Link t -> to_ml e t
++ | Arrow (l,t,s) ->
++ (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
++ protect e
++ (fun y ->
++ let x = mk_var () in
++ let arg = to_cd <:expr< $lid:x$ >> t in
++ let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
++ abstr_lab l x res
++ )
++
++ | Tuple tl ->
++ (* let (x1,r) = Value.get_pair <...> in
++ let (x2,r) = Value.get_pair r in
++ ...
++ let (xn-1,xn) = Value.get_pair r in
++ (t1(x1),...,tn(xn)) *)
++
++ let vars = mk_vars tl in
++ matches e <:expr< $tuple_to_ml tl vars$ >> vars
++ | PVariant l ->
++ (* match Value.get_variant <...> with
++ | "A",None -> `A
++ | "B",Some x -> `B (t(x))
++ | _ -> assert false
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,None) ->
++ <:match_case<
++ ($str: String.escaped lab$, None) -> `$lid:lab$ >>
++ | (lab,Some t) ->
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_case<
++ ($str: String.escaped lab$, Some $lid:x$) ->
++ `$lid:lab$ $to_ml ex t$ >>
++ ) l in
++ let cases = cases @ [ <:match_case< _ -> assert False >> ] in
++ pmatch <:expr< Value.get_variant $e$ >> cases
++ | Variant (_,l,false) ->
++ failwith "Private Sum type"
++ | Variant (p,l,true) ->
++ (* match Value.get_variant <...> with
++ | "A",None -> P.A
++ | "B",Some x -> let (x1,r) = x in ...
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,[]) ->
++ let pa = <:patt< ($str: String.escaped lab$, None) >>
++ and e = match lab with (* Stupid Camlp4 *)
++ | "true" -> <:expr< True >>
++ | "false" -> <:expr< False >>
++ | lab -> <:expr< $id:id (p ^ lab)$ >> in
++ <:match_case< $pa$ -> $e$ >>
++ | (lab,[t]) ->
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_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 x = mk_var () in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $ matches
++ <:expr< $lid:x$ >> (
++ List.fold_left
++ (fun x (t, id) ->
++ Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
++ <:expr< $id:consId (p ^ lab)$ >>
++ (List.combine tl vars))
++ vars $ >>
++ ) l in
++ let cases = cases @ [ <:match_case< _ -> assert False >> ] in
++ pmatch <:expr< Value.get_variant $e$ >> cases
++ | Record (_,l,false) ->
++ failwith "Private Record type"
++ | Record (p,l,true) ->
++ (* let x = <...> in
++ { P.l1 = t1(Value.get_field x "l1"); ... } *)
++ protect e
++ (fun x ->
++ let l =
++ List.map
++ (fun (lab,t) ->
++ 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$ >>
++ | Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
++ | Abstract "string" -> <:expr< Value.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$) >>
++ | Builtin ("array",[t]) ->
++ (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
++ <:expr< Array.of_list (List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$)) >>
++ | Builtin ("Pervasives.ref",[t]) ->
++ (* ref t(Eval.eval_apply (Value.get_field <...> "get") Value.nil) *)
++ 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 ("Big_int.big_int", []) ->
++ <:expr< Value.cduce2ocaml_bigint $e$ >>
++ | Builtin ("Cduce_lib.Value.t", []) -> e
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
++ <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
++ | Builtin ("Cduce_lib.Atoms.V.t", []) ->
++ <:expr< Value.cduce2ocaml_atom $e$ >>
++ | Builtin ("unit", []) -> <:expr< ignore $e$ >>
++ | Builtin ("option", [t]) ->
++ <:expr< Value.cduce2ocaml_option $lid:to_ml_fun t$ $e$ >>
++ | Var _ -> e
++ | _ -> assert false
++
++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
++let to_cd_done = IntHash.create 13
++
++let global_transl () =
++ let defs = ref [] in
++ let rec aux hd tl gen don fun_name to_descr =
++ gen := tl;
++ if not (IntHash.mem don hd.uid) then (
++ 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 := <:binding< $p$ = $e$ >> :: !defs
++ );
++ loop ()
++ and loop () = match !to_cd_gen,!to_ml_gen with
++ | hd::tl,_ -> aux hd tl to_cd_gen to_cd_done to_cd_fun_name to_cd_descr
++ | _,hd::tl -> aux hd tl to_ml_gen to_ml_done to_ml_fun_name to_ml_descr
++ | [],[] -> ()
++ in
++ loop ();
++ !defs
++
++(* Check type constraints and generate stub code *)
++
++let err_ppf = Format.err_formatter
++
++let exts = ref []
++
++let check_value ty_env c_env (s,caml_t,t) =
++ (* Find the type for the value in the CDuce module *)
++ let id = (Ns.empty, U.mk s) in
++ let vt =
++ try Typer.find_value id ty_env
++ with Not_found ->
++ Format.fprintf err_ppf
++ "The interface exports a value %s which is not available in the module at ." s;
++ exit 1
++ in
++ (* Compute expected CDuce type *)
++ let et = Types.descr (typ t) in
++
++ (* Check subtyping *)
++ if not (Types.subtype vt et) then
++ (
++ Format.fprintf
++ err_ppf
++ "The type for the value %s is invalid@\n\
++ Expected Caml type:@[%a@]@\n\
++ Expected CDuce type:@[%a@]@\n\
++ Inferred type:@[%a@]@."
++ s
++ print_ocaml caml_t
++ Types.Print.print et
++ Types.Print.print vt;
++ exit 1
++ );
++
++ (* Generate stub code *)
++ 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< $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< $id:id s$ >> t) exts in
++ let g = global_transl () in
++
++ let types = get_registered_types () in
++ let raw = mk types in
++
++ let items_def = List.map (fun (_,_,d) -> d) items in
++ let items_expr = List.map (fun (_,e,_) -> e) items in
++ let items_pat = List.map (fun (p,_,_) -> p) items in
++
++ let str_items =
++ <:str_item<
++ 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 $Ast.biAnd_of_list g$;
++ set_externals [|$Ast.exSem_of_list exts$|];
++ run ();
++ value $Ast.biAnd_of_list items_def$;
++ end in $tup:Ast.exCom_of_list items_expr$ >> in
++
++ print_endline prolog;
++ 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 [];
++ flush oc;
++ ignore (Unix.close_process_out oc) *)
++
++
++let stub_ml name ty_env c_env exts mk =
++ try
++ let name = String.capitalize name in
++ let exts = match (Obj.magic exts : (string * Mltypes.t) list option) with
++ | None -> []
++ | Some exts -> List.iter (fun (_,t) -> Mltypes.reg_uid t) exts; exts in
++ (* First, read the description of ML types for externals.
++ Don't forget to call reg_uid to avoid uid clashes...
++ Do that before reading the cmi. *)
++ let (prolog, values) =
++ try Mltypes.read_cmi name
++ with Not_found -> ("",[]) in
++ stub ty_env c_env exts values mk prolog
++ with Mltypes.Error s -> raise (Cduce_loc.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
++ 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
++ 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 ->
++ Cduce_loc.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
++
++ <:str_item<
++ open Cduce_lib;
++ Cduce_config.init_all ();
++ value rec $Ast.biAnd_of_list g$;
++ $Ast.stSem_of_list exts$;
++ >>
++
++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_module s
++ with Not_found ->
++ failwith ("Cannot resolve " ^ s)
++ in
++ vals @ accu
++ ) [] vals in
++
++ wrapper values
++ with Mltypes.Error s -> raise (Cduce_loc.Generic s)
++
++let make_wrapper fn =
++ let ic = open_in fn in
++ let v = ref [] in
++ (try while true do
++ let s = input_line ic in
++ if s <> "" then
++ match s.[0] with
++ | 'A'..'Z' -> v := s :: !v
++ | '#' -> ()
++ | _ -> failwith "Error in primitive file: names must start with a capitalized letter"
++ done
++ with End_of_file -> ());
++ let s = gen_wrapper !v in
++ Printers.OCaml.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 ();;"
++
++
++(* Dynamic coercions *)
++
++
++(*
++let to_cd_dyn = function
++ | Link t -> to_cd_dyn e t
++ | Arrow (l,t,s) ->
++ let tt = Types.descr (typ t) in
++ let ss = Types.descr (typ s) in
++ let tf = to_ml_dyn t in
++ let sf = to_cd_dyn t in
++ (fun (f : Obj.repr) ->
++ let f = (Obj.magic f : Obj.repr -> Obj.repr) in
++ Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
++ | Tuple tl ->
++ let fs = List.map to_cd_dyn tl in
++ (fun (x : Obj.repr) ->
++ let x = (Obj.magic x : Obj.repr array) in
++ let rec aux i = function
++ | [] -> assert false
++ | [f] -> f x.(i)
++ | f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
++ aux 0 fs)
++*)
++
++
++let register () =
++ Typer.has_ocaml_unit :=
++ (fun cu -> Mltypes.has_cmi (U.get_str cu));
++ Librarian.stub_ml := stub_ml;
++ Externals.register := register;
++ Externals.ext_info := (fun () -> Obj.magic !exts);
++ Librarian.make_wrapper := make_wrapper
++
++let () =
++ Cduce_config.register
++ "ocaml"
++ "OCaml interface"
++ register
+diff --git a/ocamliface/3.x/mlstub.mli b/ocamliface/3.x/mlstub.mli
+new file mode 100644
+index 0000000..e3974de
+--- /dev/null
++++ b/ocamliface/3.x/mlstub.mli
+@@ -0,0 +1,8 @@
++(**************************************************************************)
++(* The CDuce compiler *)
++(* Alain Frisch <Alain.Frisch at inria.fr> and the CDuce team *)
++(* Copyright CNRS,INRIA, 2003-2009 (see LICENSE for details) *)
++(**************************************************************************)
++
++open Camlp4.PreCast
++val gen_wrapper: string list -> Ast.str_item
+diff --git a/ocamliface/3.x/mltypes.ml b/ocamliface/3.x/mltypes.ml
+new file mode 100644
+index 0000000..76cbb89
+--- /dev/null
++++ b/ocamliface/3.x/mltypes.ml
+@@ -0,0 +1,332 @@
++(**************************************************************************)
++(* The CDuce compiler *)
++(* Alain Frisch <Alain.Frisch at inria.fr> and the CDuce team *)
++(* Copyright CNRS,INRIA, 2003-2009 (see LICENSE for details) *)
++(**************************************************************************)
++
++exception Error of string
++
++module Loc = Cduce_loc
++open Caml_cduce
++open Caml_cduce.Types
++
++(* Unfolding of OCaml types *)
++
++exception PolyAbstract of string
++
++let ocaml_env = ref Env.initial
++
++type t = { uid : int; mutable recurs : int; mutable def : def }
++and def =
++ | Link of t
++ | Arrow of string * t * t
++ | Tuple of t list
++ | PVariant of (string * t option) list (* Polymorphic variant *)
++ | Variant of string * (string * t list) list * bool
++ | Record of string * (string * t) list * bool
++ | Builtin of string * t list
++ | Abstract of string
++ | Var of int
++
++module IntMap =
++ Map.Make(struct type t = int let compare : t -> t -> int = compare end)
++module IntSet =
++ Set.Make(struct type t = int let compare : t -> t -> int = compare end)
++module StringSet = Set.Make(struct type t = string let compare : t -> t -> int = compare end)
++
++
++let rec print_sep f sep ppf = function
++ | [] -> ()
++ | [x] -> f ppf x
++ | x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl
++
++let printed = ref IntMap.empty
++
++let rec print_slot ppf slot =
++ if slot.recurs > 0 then
++ (
++ if IntMap.mem slot.uid !printed then
++ Format.fprintf ppf "X%i" slot.uid
++ else (
++ printed := IntMap.add slot.uid () !printed;
++ Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
++ )
++ )
++ else
++ print_def ppf slot.def
++
++and print_def ppf = function
++ | Link t -> print_slot ppf t
++ | Arrow (l,t,s) -> Format.fprintf ppf "%s:%a -> %a" l print_slot t print_slot s
++ | Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
++ | PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
++ | Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
++ | Record (p,l,_) -> Format.fprintf ppf "{%s:%a}" p (print_sep print_field " ; ") l
++ | Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
++ | Abstract s -> Format.fprintf ppf "%s" s
++ | Var i -> Format.fprintf ppf "'a%i" i
++
++
++and print_palt ppf = function
++ | lab, None -> Format.fprintf ppf "`%s" lab
++ | lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
++
++and print_alt ppf = function
++ | (lab,[]) ->
++ Format.fprintf ppf "%s" lab
++ | (lab,l) ->
++ Format.fprintf ppf "%s of [%a]" lab (print_sep print_slot ",") l
++
++and print_field ppf (lab,t) =
++ Format.fprintf ppf "%s:%a" lab print_slot t
++
++
++let print = print_slot
++
++let counter = ref 0
++let new_slot () =
++ incr counter;
++ { uid = !counter; recurs = 0; def = Abstract "DUMMY" }
++
++let reg_uid t =
++ let saved = ref [] in
++ let rec aux t =
++ if t.recurs < 0 then () else begin
++ if t.uid > !counter then counter := t.uid;
++ saved := (t,t.recurs) :: !saved;
++ t.recurs <- (-1);
++ match t.def with
++ | Link t -> aux t
++ | Arrow (_,t1,t2) -> aux t1; aux t2
++ | Tuple tl -> List.iter aux tl
++ | PVariant pl -> List.iter (function (_,Some t) -> aux t | _ -> ()) pl
++ | Variant (_,pl,_) -> List.iter (fun (_,tl) -> List.iter aux tl) pl
++ | Record (_,tl,_) -> List.iter (fun (_,t) -> aux t) tl
++ | Builtin (_,tl) -> List.iter aux tl
++ | _ -> ()
++ end
++ in
++ aux t;
++ List.iter (fun (t,recurs) -> t.recurs <- recurs) !saved
++
++let builtins =
++ List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
++ [
++ "list"; "Pervasives.ref";
++ "unit"; "array";
++ "Big_int.big_int";
++ "option";
++ "Cduce_lib.Value.t";
++ "Cduce_lib.Encodings.Utf8.t";
++ "Cduce_lib.Atoms.V.t";
++ ]
++
++let vars = ref []
++
++let get_var id =
++ try List.assq id !vars
++ with Not_found ->
++ let i = List.length !vars in
++ vars := (id,i) :: !vars;
++ i
++
++let constr_table = Hashtbl.create 1024
++
++type env = { constrs: StringSet.t; seen: IntSet.t; vars: t IntMap.t }
++
++let rec unfold_constr env p args =
++ let args = List.map (unfold env) args in
++ let pn = Path.name p in
++ if StringSet.mem pn builtins
++ then ( let slot = new_slot () in slot.def <- Builtin (pn,args); slot )
++ else
++ let args_id = List.map (fun t -> t.uid) args in
++ let k = (pn,args_id) in
++ try Hashtbl.find constr_table k
++ with Not_found ->
++ if StringSet.mem pn env.constrs then
++ failwith "Polymorphic recursion forbidden";
++ let slot = new_slot () in
++ slot.recurs <- 1;
++ Hashtbl.add constr_table k slot;
++
++ let decl =
++ try Env.find_type p !ocaml_env
++ with Not_found -> failwith ("Cannot resolve path " ^ pn) in
++
++ let env =
++ { env with
++ constrs = StringSet.add pn env.constrs;
++ vars =
++ List.fold_left2
++ (fun vars a t -> IntMap.add a.id t vars)
++ env.vars decl.type_params args } in
++
++ let prefix = match p with
++ | Path.Pident _ -> ""
++ | Path.Pdot (p,_,_) -> Path.name p ^ "."
++ | _ -> assert false in
++
++ slot.def <-
++ (match decl.type_kind, decl.type_manifest with
++ | Type_variant (cstrs), _ ->
++ let cstrs =
++ List.map
++ (fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in
++ Variant (prefix, cstrs, true)
++ | Type_record (f,_), _ ->
++ let f = List.map (fun (l,_,t) -> (l,unfold env t)) f in
++ Record (prefix, f, true)
++ | Type_abstract, Some t ->
++ Link (unfold env t)
++ | Type_abstract, None ->
++ (match args with
++ | [] -> Abstract pn
++ | l ->raise (PolyAbstract pn)));
++ slot
++
++and unfold env ty =
++ if IntSet.mem ty.id env.seen then failwith "Unguarded recursion";
++ let env = { env with seen = IntSet.add ty.id env.seen } in
++ let slot = new_slot () in
++ slot.def <-
++ (match ty.desc with
++ | Tarrow (l,t1,t2,_) ->
++ let t1 = unfold env t1 in
++ let t2 = unfold env t2 in
++ Arrow (l, t1,t2)
++ | Ttuple tyl -> Tuple (List.map (unfold env) tyl)
++ | Tvariant rd ->
++ let fields =
++ List.fold_left
++ (fun accu (lab,f) ->
++ match f with
++ | Rpresent (Some t)
++ | Reither(true, [t], _, _) ->
++ (lab, Some (unfold env t)) :: accu
++ | Rpresent None
++ | Reither(true, [], _, _) -> (lab, None) :: accu
++ | Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
++ | Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
++ ) []
++ rd.row_fields in
++ PVariant fields
++ | Tvar ->
++ (try Link (IntMap.find ty.id env.vars)
++ with Not_found -> Var (get_var ty.id))
++ | Tconstr (p,args,_) ->
++ Link (unfold_constr env p args)
++ | _ -> failwith "Unsupported feature"
++ );
++ slot
++
++let unfold ty =
++ vars := [];
++ Hashtbl.clear constr_table; (* Get rid of that (careful with exceptions) *)
++ let t = unfold { seen = IntSet.empty; constrs = StringSet.empty;
++ vars = IntMap.empty } ty in
++ let n = List.length !vars in
++ vars := [];
++ (t,n)
++
++(* Reading .cmi *)
++
++let unsupported s =
++ raise (Error (Printf.sprintf "Unsupported feature (%s) found in .cmi" s))
++
++let has_cmi name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
++ with Not_found -> false
++
++let find_value v =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let li = Longident.parse v in
++ ocaml_env := Env.initial;
++ let (_,vd) = Env.lookup_value li Env.initial in
++ unfold vd.val_type
++
++let values_of_sig name sg =
++ List.fold_left
++ (fun accu v -> match v with
++ | Tsig_value (id,_) ->
++ let id = Ident.name id in
++ (match id.[0] with
++ | 'a'..'z' | '_' ->
++ let n = name ^ "." ^ id in
++ (try (n, (fst (find_value n))) :: accu
++ with PolyAbstract _ -> accu)
++ | _ -> accu (* operator *))
++ | _ -> accu
++ ) [] sg
++
++
++let load_module name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let li = Longident.parse name in
++ ocaml_env := Env.initial;
++ let (_,mty) = Env.lookup_module li Env.initial in
++ match mty with
++ | Tmty_signature sg -> values_of_sig name sg
++ | _ -> raise (Loc.Generic
++ (Printf.sprintf "Module %s is not a structure" name))
++
++(*
++ let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
++ let sg = Env.read_signature name filename in
++ values_of_sig sg
++*)
++
++let load_module name =
++ try load_module name
++ with Env.Error e ->
++ Env.report_error Format.str_formatter e;
++ let s = Format.flush_str_formatter () in
++ let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
++ name s in
++ raise (Loc.Generic s)
++
++let read_cmi name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
++ let sg = Env.read_signature name filename in
++ ocaml_env := Env.add_signature sg Env.initial;
++ let buf = Buffer.create 1024 in
++ let ppf = Format.formatter_of_buffer buf in
++ let values = ref [] in
++ List.iter
++ (function
++ | Tsig_value (id, {val_type=t;val_kind=Val_reg}) ->
++ let (unf,n) = unfold t in
++ if n !=0 then unsupported "polymorphic value";
++ values := (Ident.name id, t, unf) :: !values
++ | Tsig_type (id,t,rs) ->
++ Format.fprintf ppf "%a at ."
++ !Oprint.out_sig_item (Printtyp.tree_of_type_declaration id t rs);
++ | Tsig_value _ -> unsupported "external value"
++ | Tsig_exception _ -> unsupported "exception"
++ | Tsig_module _ -> unsupported "module"
++ | Tsig_modtype _ -> unsupported "module type"
++ | Tsig_class _ -> unsupported "class"
++ | Tsig_cltype _ -> unsupported "class type"
++ ) sg;
++ (Buffer.contents buf, !values)
++
++let read_cmi name =
++ try read_cmi name
++ with Env.Error e ->
++ Env.report_error Format.str_formatter e;
++ let s = Format.flush_str_formatter () in
++ let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
++ name s in
++ raise (Loc.Generic s)
++
++
++let print_ocaml = Printtyp.type_expr
++
++
++let rec dump_li = function
++ | Longident.Lident s -> print_endline s
++ | Longident.Ldot (li,s) -> dump_li li; print_endline s
++ | _ -> assert false
++
+diff --git a/ocamliface/3.x/mltypes.mli b/ocamliface/3.x/mltypes.mli
+new file mode 100644
+index 0000000..33f8b03
+--- /dev/null
++++ b/ocamliface/3.x/mltypes.mli
+@@ -0,0 +1,40 @@
++(**************************************************************************)
++(* The CDuce compiler *)
++(* Alain Frisch <Alain.Frisch at inria.fr> and the CDuce team *)
++(* Copyright CNRS,INRIA, 2003-2009 (see LICENSE for details) *)
++(**************************************************************************)
++
++open Caml_cduce
++open Asttypes
++open Types
++
++exception Error of string
++
++type t = { uid : int; mutable recurs : int; mutable def : def }
++and def =
++ | Link of t
++ | Arrow of string * t * t
++ | Tuple of t list
++ | PVariant of (string * t option) list (* Polymorphic variant *)
++ | Variant of string * (string * t list) list * bool
++ | Record of string * (string * t) list * bool
++ | Builtin of string * t list
++ | Abstract of string
++ | Var of int
++
++
++val reg_uid: t -> unit
++
++(* Load an external .cmi *)
++val has_cmi: string -> bool
++val load_module: string -> (string * t) list
++
++(* Load the .cmi corresponding to a CDuce compilation unit *)
++val read_cmi: string -> string * (string * Types.type_expr * t) list
++
++val print : Format.formatter -> t -> unit
++val print_ocaml : Format.formatter -> Types.type_expr -> unit
++
++
++val find_value: string -> t * int
++
+diff --git a/ocamliface/4.01/Makefile b/ocamliface/4.01/Makefile
+new file mode 100644
+index 0000000..6167691
+--- /dev/null
++++ b/ocamliface/4.01/Makefile
+@@ -0,0 +1,72 @@
++# This Makefile generates caml_cduce.cmo/.cmx
++# It must be called with an OCAML_SRC argument pointing to the root
++# of an OCaml source tree.
++include ../../Makefile.conf
++
++all: caml_cduce.cmo caml_cduce.cmx
++
++STDLIB=$(shell ocamlc -where)
++
++
++ifeq ($(FORPACK),true)
++ FORPACKOPT1=-for-pack Cduce_lib.Caml_cduce
++ FORPACKOPT2=-for-pack Cduce_lib
++else
++ FORPACKOPT1=
++ FORPACKOPT2=
++endif
++
++ocaml_files:
++ mkdir ocaml_files
++ $(HIDE)cp $(patsubst %,$(OCAML_SRC)/%, $(COPY_FILES)) ocaml_files/
++ 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 | head -1 >> ocaml_files/config.ml
++
++caml_cduce.cmo: ocaml_files
++ @echo "Build $@"
++ (cd ocaml_files; \
++ ocamlc $(FORPACKOPT1) -c $(COMPILE_FILES);\
++ ocamlc $(FORPACKOPT2) -pack -o $@ $(OBJECTS); \
++ cp caml_cduce.cmo caml_cduce.cmi ..)
++
++caml_cduce.cmx: ocaml_files
++ @echo "Build $@"
++ (cd ocaml_files; ocamlopt $(FORPACKOPT1) -c $(COMPILE_FILES);\
++ ocamlopt $(FORPACKOPT2) -pack -o $@ $(XOBJECTS); \
++ cp caml_cduce.cmx caml_cduce.o caml_cduce.cmi ..)
++
++clean:
++ rm -Rf ocaml_files *~ *.cm*
++
++COPY_FILES=\
++ typing/annot.mli \
++ utils/misc.ml utils/tbl.ml \
++ utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.mli \
++ utils/clflags.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 \
++ typing/subst.ml typing/predef.ml \
++ typing/datarepr.ml typing/env.ml \
++ typing/ctype.ml typing/ctype.mli typing/printtyp.ml typing/cmi_format.mli typing/cmi_format.ml
++
++COMPILE_FILES=\
++ warnings.ml location.mli asttypes.mli outcometree.mli annot.mli asttypes.ml \
++ config.ml misc.ml tbl.ml \
++ clflags.mli \
++ clflags.ml consistbl.ml terminfo.ml \
++ location.ml longident.ml \
++ ident.ml path.ml \
++ primitive.ml types.ml \
++ btype.ml oprint.ml \
++ subst.ml predef.ml \
++ datarepr.ml cmi_format.mli cmi_format.ml env.ml ctype.mli ctype.ml printtyp.ml
++
++COMPILE_FILES_ML=$(filter %.ml,$(COMPILE_FILES))
++OBJECTS=$(COMPILE_FILES_ML:.ml=.cmo)
++XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
+diff --git a/ocamliface/4.01/config.ml b/ocamliface/4.01/config.ml
+new file mode 100644
+index 0000000..54ca779
+--- /dev/null
++++ b/ocamliface/4.01/config.ml
+@@ -0,0 +1,4 @@
++let standard_library = "STDLIB"
++let load_path = ref ([] : string list)
++let bytecomp_c_compiler = ""
++let bytecomp_c_linker = ""
+diff --git a/ocamliface/4.01/location.ml b/ocamliface/4.01/location.ml
+new file mode 100644
+index 0000000..4a79b18
+--- /dev/null
++++ b/ocamliface/4.01/location.ml
+@@ -0,0 +1,32 @@
++(* 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 }
++type 'a loc = { txt: 'a; loc: t }
++
++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_error_cur_file = dummy
++let print_error = dummy
++let print = dummy
++let print_warning = dummy
++let prerr_warning = dummy
++let echo_eof = dummy
++let reset = dummy
++let highlight_locations = dummy
++let mknoloc = dummy
++let mkloc = dummy
++let print_loc = dummy
++let print_filename = dummy
++let show_filename = dummy
++let absname = ref true
+diff --git a/ocamliface/4.01/mlstub.ml b/ocamliface/4.01/mlstub.ml
+new file mode 100644
+index 0000000..54c5a84
+--- /dev/null
++++ b/ocamliface/4.01/mlstub.ml
+@@ -0,0 +1,746 @@
++(* 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)
++
++module IntHash =
++ Hashtbl.Make(struct type t = int let hash i = i let equal i j = i == j end)
++
++(* Compute CDuce type *)
++
++let vars = ref [||]
++
++let memo_typ = IntHash.create 13
++
++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< $uid:String.sub s i (String.length s - i)$ >>
++ in
++(* Printf.eprintf "*** %S\n" s; *)
++ aux 0
++
++let consId 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< $uid:String.sub s i (String.length s - i)$ >>
++ in
++ aux 0
++
++let ident_to_string list =
++ let rec _ident_to_string list res = match list with
++ | (id, x) :: rest -> _ident_to_string rest (res @ [id.Caml_cduce.Ident.name, x])
++ | [] -> res
++ in
++ _ident_to_string list [];;
++
++let rec typ t =
++ try IntHash.find memo_typ t.uid
++ with Not_found ->
++(* print_int t.uid; print_char ' '; flush stdout; *)
++ let node = Types.make () in
++ IntHash.add memo_typ t.uid node;
++ Types.define node (typ_descr t.def);
++ node
++
++and typ_descr = function
++ | Link t -> typ_descr t.def
++ | Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
++ | Tuple tl -> Types.tuple (List.map typ tl)
++ | PVariant l -> bigcup pvariant l
++ | Variant (_,l,_) -> bigcup variant l
++ | Record (_,l,_) -> let l = ident_to_string l in
++ let l = List.map (fun (lab,t) -> label lab, typ t) l in
++ Types.record_fields (false, (LabelMap.from_list_disj l))
++ | 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])
++ | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
++ | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
++ | Builtin ("Big_int.big_int", []) -> Builtin_defs.int
++ | Builtin ("Cduce_lib.Value.t", []) -> Types.any
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
++ | Builtin ("Cduce_lib.Atoms.V.t", []) -> Builtin_defs.atom
++ | Builtin ("unit", []) -> Sequence.nil_type
++ | Builtin ("option", [t]) -> Sequence.option (typ t)
++ | Var i -> Types.descr (!vars).(i)
++ | _ -> assert false
++
++and pvariant = function
++ | (lab, None) -> atom lab
++ | (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
++
++and variant = function
++ | (lab, [], None) -> atom lab.Caml_cduce.Ident.name
++ | (lab, [], Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ [o])
++ | (lab, c, Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ (c@[o]))
++ | (lab, c, None) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ c)
++
++
++(* Syntactic tools *)
++
++let var_counter = ref 0
++let mk_var _ =
++ incr var_counter;
++ Printf.sprintf "x%i" !var_counter
++
++let mk_vars = List.map mk_var
++
++let atom_ascii lab =
++ <:expr< Value.atom_ascii $str: String.escaped lab$ >>
++
++let label_ascii lab =
++ <:expr< Value.label_ascii $str: String.escaped lab$ >>
++
++let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$) >>
++
++let pmatch e l =
++ <:expr< match $e$ with [ $list:l$ ] >>
++
++let rec matches ine oute = function
++ | [v1;v2] ->
++ <: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
++ <:expr< let ($lid:v$,$lid:r$) = Value.get_pair $ine$ in $oute$ >>
++ | [] -> assert false
++
++let list_lit el =
++ List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
++
++let protect e f =
++ match e with
++ | <:expr< $lid:x$ >> -> f e
++ | e ->
++ let x = mk_var () in
++ let r = f <:expr< $lid:x$ >> in
++ <:expr< let $lid:x$ = $e$ in $r$ >>
++
++(* Registered types *)
++
++let gen_types = ref true
++(* currently always off *)
++
++
++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 ->
++ let i = !nb_registered_types in
++ HashTypes.add registered_types t i;
++ incr nb_registered_types;
++ i
++ in
++ <:expr< types.($int:string_of_int n$) >>
++
++let get_registered_types () =
++ let a = Array.make !nb_registered_types Types.empty in
++ HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
++ a
++
++(* OCaml -> CDuce conversions *)
++
++
++let to_cd_gen = ref []
++
++let to_cd_fun_name t =
++ Printf.sprintf "to_cd_%i" t.uid
++
++let to_cd_fun t =
++ to_cd_gen := t :: !to_cd_gen;
++ to_cd_fun_name t
++
++let to_ml_gen = ref []
++
++let to_ml_fun_name t =
++ Printf.sprintf "to_ml_%i" t.uid
++
++let to_ml_fun t =
++ to_ml_gen := t :: !to_ml_gen;
++ to_ml_fun_name t
++
++let rec tuple = function
++ | [v] -> v
++ | v::l -> <:expr< Value.Pair ($v$, $tuple l$) >>
++ | [] -> assert false
++
++let pat_tuple vars =
++ let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
++ <:patt< ($Ast.paCom_of_list pl$) >>
++
++
++let call_lab f l x =
++ if l = "" then <:expr< $f$ $x$ >>
++ else
++ if l.[0] = '?' then
++ let l = String.sub l 1 (String.length l - 1) in
++ <:expr< $f$ (? $l$ : $x$) >>
++ else
++ <:expr< $f$ (~ $l$ : $x$) >>
++
++let abstr_lab l x res =
++ if l = "" then <:expr< fun $lid:x$ -> $res$ >>
++ else
++ if l.[0] = '?' then
++ let l = String.sub l 1 (String.length l - 1) in
++ <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
++ else
++ <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>
++
++
++
++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
++
++and to_cd_descr e = function
++ | Link t -> to_cd e t
++ | Arrow (l,t,s) ->
++ (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
++ protect e
++ (fun y ->
++ let x = mk_var () in
++ 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 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))) *)
++ let vars = mk_vars tl in
++ <:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
++ | PVariant l ->
++ (* match <...> with
++ | `A -> Value.atom_ascii "A"
++ | `B x -> Value.Pair (Value.atom_ascii "B",t(x))
++ *)
++ let cases =
++ List.map
++ (function
++ | (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,_) ->
++ (* match <...> with
++ | P.A -> Value.atom_ascii "A"
++ | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,[],None) ->
++ let pat = match lab.Caml_cduce.Ident.name with (* Stupid Camlp4 *)
++ | "true" -> <:patt< True >>
++ | "false" -> <:patt< False >>
++ | lab -> <:patt< $id: id (p^lab)$ >>
++ in
++ <:match_case< $pat$ -> $atom_ascii lab.Caml_cduce.Ident.name$ >>
++ | (lab,tl,Some o) ->
++ let vars = mk_vars (tl@[o]) in
++ <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
++ $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd (tl@[o]) vars)$ >>
++ | (lab,tl,None) ->
++ let vars = mk_vars tl in
++ <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
++ $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd tl vars)$ >>
++ ) l in
++ pmatch e cases
++ | Record (p,l,_) ->
++ (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
++ protect e
++ (fun x ->
++ let l =
++ List.map
++ (fun (lab,t) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
++ <:expr< ($label_ascii lab$, $e$) >>) 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$ >>
++ | 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 ("array",[t]) ->
++ <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
++ | Builtin ("Pervasives.ref",[t]) ->
++ (* let x = <...> in
++ Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
++ protect e
++ (fun e ->
++ let y = mk_var () 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
++ let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
++ <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
++ )
++ | Builtin ("Big_int.big_int", []) ->
++ <:expr< Value.ocaml2cduce_bigint $e$ >>
++ | Builtin ("Cduce_lib.Value.t", []) -> e
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
++ <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
++ | Builtin ("Cduce_lib.Atoms.V.t", []) ->
++ <:expr< Value.ocaml2cduce_atom $e$ >>
++ | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
++ | Var _ -> e
++ | Builtin ("option", [t]) ->
++ <:expr< Value.ocaml2cduce_option $lid:to_cd_fun t$ $e$ >>
++
++ | _ -> assert false
++
++and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
++
++(* CDuce -> OCaml conversions *)
++
++
++
++and to_ml (e : Ast.expr) (t : Mltypes.t) =
++(* Format.fprintf Format.err_formatter "to_ml %a at ."
++ Mltypes.print t; *)
++ if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
++ else to_ml_descr e t.def
++
++and to_ml_descr e = function
++ | Link t -> to_ml e t
++ | Arrow (l,t,s) ->
++ (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
++ protect e
++ (fun y ->
++ let x = mk_var () in
++ let arg = to_cd <:expr< $lid:x$ >> t in
++ let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
++ abstr_lab l x res
++ )
++
++ | Tuple tl ->
++ (* let (x1,r) = Value.get_pair <...> in
++ let (x2,r) = Value.get_pair r in
++ ...
++ let (xn-1,xn) = Value.get_pair r in
++ (t1(x1),...,tn(xn)) *)
++
++ let vars = mk_vars tl in
++ matches e <:expr< $tuple_to_ml tl vars$ >> vars
++ | PVariant l ->
++ (* match Value.get_variant <...> with
++ | "A",None -> `A
++ | "B",Some x -> `B (t(x))
++ | _ -> assert false
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,None) ->
++ <:match_case<
++ ($str: String.escaped lab$, None) -> `$lid:lab$ >>
++ | (lab,Some t) ->
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_case<
++ ($str: String.escaped lab$, Some $lid:x$) ->
++ `$lid:lab$ $to_ml ex t$ >>
++ ) l in
++ let cases = cases @ [ <:match_case< _ -> assert False >> ] in
++ pmatch <:expr< Value.get_variant $e$ >> cases
++ | Variant (_,l,false) ->
++ failwith "Private Sum type"
++ | Variant (p,l,true) ->
++ (* match Value.get_variant <...> with
++ | "A",None -> P.A
++ | "B",Some x -> let (x1,r) = x in ...
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,[],None) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let pa = <:patt< ($str: String.escaped lab$, None) >>
++ and e = match lab with (* Stupid Camlp4 *)
++ | "true" -> <:expr< True >>
++ | "false" -> <:expr< False >>
++ | lab -> <:expr< $id:id (p ^ lab)$ >> in
++ <:match_case< $pa$ -> $e$ >>
++ | (lab,[t],None) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $id:id (p ^ lab)$ $to_ml ex t$ >>
++ | (lab,[],Some o) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $id:id (p ^ lab)$ $to_ml ex o$ >>
++ | (lab,tl,Some o) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let vars = mk_vars (tl@[o]) in
++ let x = mk_var () in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $ matches
++ <:expr< $lid:x$ >> (
++ List.fold_left
++ (fun x (t, id) ->
++ Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
++ <:expr< $id:consId (p ^ lab)$ >>
++ (List.combine (tl@[o]) vars))
++ vars $ >>
++ | (lab,tl,None) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let vars = mk_vars tl in
++ let x = mk_var () in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $ matches
++ <:expr< $lid:x$ >> (
++ List.fold_left
++ (fun x (t, id) ->
++ Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
++ <:expr< $id:consId (p ^ lab)$ >>
++ (List.combine tl vars))
++ vars $ >>
++ ) l in
++ let cases = cases @ [ <:match_case< _ -> assert False >> ] in
++ pmatch <:expr< Value.get_variant $e$ >> cases
++ | Record (_,l,false) ->
++ failwith "Private Record type"
++ | Record (p,l,true) ->
++ (* let x = <...> in
++ { P.l1 = t1(Value.get_field x "l1"); ... } *)
++ protect e
++ (fun x ->
++ let l =
++ List.map
++ (fun (lab,t) ->
++ let lab = lab.Caml_cduce.Ident.name 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$ >>
++ | Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
++ | Abstract "string" -> <:expr< Value.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$) >>
++ | Builtin ("array",[t]) ->
++ (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
++ <:expr< Array.of_list (List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$)) >>
++ | Builtin ("Pervasives.ref",[t]) ->
++ (* ref t(Eval.eval_apply (Value.get_field <...> "get") Value.nil) *)
++ 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 ("Big_int.big_int", []) ->
++ <:expr< Value.cduce2ocaml_bigint $e$ >>
++ | Builtin ("Cduce_lib.Value.t", []) -> e
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
++ <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
++ | Builtin ("Cduce_lib.Atoms.V.t", []) ->
++ <:expr< Value.cduce2ocaml_atom $e$ >>
++ | Builtin ("unit", []) -> <:expr< ignore $e$ >>
++ | Builtin ("option", [t]) ->
++ <:expr< Value.cduce2ocaml_option $lid:to_ml_fun t$ $e$ >>
++ | Var _ -> e
++ | _ -> assert false
++
++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
++let to_cd_done = IntHash.create 13
++
++let global_transl () =
++ let defs = ref [] in
++ let rec aux hd tl gen don fun_name to_descr =
++ gen := tl;
++ if not (IntHash.mem don hd.uid) then (
++ 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 := <:binding< $p$ = $e$ >> :: !defs
++ );
++ loop ()
++ and loop () = match !to_cd_gen,!to_ml_gen with
++ | hd::tl,_ -> aux hd tl to_cd_gen to_cd_done to_cd_fun_name to_cd_descr
++ | _,hd::tl -> aux hd tl to_ml_gen to_ml_done to_ml_fun_name to_ml_descr
++ | [],[] -> ()
++ in
++ loop ();
++ !defs
++
++(* Check type constraints and generate stub code *)
++
++let err_ppf = Format.err_formatter
++
++let exts = ref []
++
++let check_value ty_env c_env (s,caml_t,t) =
++ (* Find the type for the value in the CDuce module *)
++ let id = (Ns.empty, U.mk s) in
++ let vt =
++ try Typer.find_value id ty_env
++ with Not_found ->
++ Format.fprintf err_ppf
++ "The interface exports a value %s which is not available in the module at ." s;
++ exit 1
++ in
++ (* Compute expected CDuce type *)
++ let et = Types.descr (typ t) in
++
++ (* Check subtyping *)
++ if not (Types.subtype vt et) then
++ (
++ Format.fprintf
++ err_ppf
++ "The type for the value %s is invalid@\n\
++ Expected Caml type:@[%a@]@\n\
++ Expected CDuce type:@[%a@]@\n\
++ Inferred type:@[%a@]@."
++ s
++ print_ocaml caml_t
++ Types.Print.print et
++ Types.Print.print vt;
++ exit 1
++ );
++
++ (* Generate stub code *)
++ 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< $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< $id:id s$ >> t) exts in
++ let g = global_transl () in
++
++ let types = get_registered_types () in
++ let raw = mk types in
++
++ let items_def = List.map (fun (_,_,d) -> d) items in
++ let items_expr = List.map (fun (_,e,_) -> e) items in
++ let items_pat = List.map (fun (p,_,_) -> p) items in
++
++ let str_items =
++ <:str_item<
++ 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 $Ast.biAnd_of_list g$;
++ set_externals [|$Ast.exSem_of_list exts$|];
++ run ();
++ value $Ast.biAnd_of_list items_def$;
++ end in $tup:Ast.exCom_of_list items_expr$ >> in
++
++ print_endline prolog;
++ 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 [];
++ flush oc;
++ ignore (Unix.close_process_out oc) *)
++
++
++let stub_ml name ty_env c_env exts mk =
++ try
++ let name = String.capitalize name in
++ let exts = match (Obj.magic exts : (string * Mltypes.t) list option) with
++ | None -> []
++ | Some exts -> List.iter (fun (_,t) -> Mltypes.reg_uid t) exts; exts in
++ (* First, read the description of ML types for externals.
++ Don't forget to call reg_uid to avoid uid clashes...
++ Do that before reading the cmi. *)
++ let (prolog, values) =
++ try Mltypes.read_cmi name
++ with Not_found -> ("",[]) in
++ stub ty_env c_env exts values mk prolog
++ with Mltypes.Error s -> raise (Cduce_loc.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
++ 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
++ 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 ->
++ Cduce_loc.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
++
++ <:str_item<
++ open Cduce_lib;
++ Cduce_config.init_all ();
++ value rec $Ast.biAnd_of_list g$;
++ $Ast.stSem_of_list exts$;
++ >>
++
++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_module s
++ with Not_found ->
++ failwith ("Cannot resolve " ^ s)
++ in
++ vals @ accu
++ ) [] vals in
++
++ wrapper values
++ with Mltypes.Error s -> raise (Cduce_loc.Generic s)
++
++let make_wrapper fn =
++ let ic = open_in fn in
++ let v = ref [] in
++ (try while true do
++ let s = input_line ic in
++ if s <> "" then
++ match s.[0] with
++ | 'A'..'Z' -> v := s :: !v
++ | '#' -> ()
++ | _ -> failwith "Error in primitive file: names must start with a capitalized letter"
++ done
++ with End_of_file -> ());
++ let s = gen_wrapper !v in
++ Printers.OCaml.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 ();;"
++
++
++(* Dynamic coercions *)
++
++
++(*
++let to_cd_dyn = function
++ | Link t -> to_cd_dyn e t
++ | Arrow (l,t,s) ->
++ let tt = Types.descr (typ t) in
++ let ss = Types.descr (typ s) in
++ let tf = to_ml_dyn t in
++ let sf = to_cd_dyn t in
++ (fun (f : Obj.repr) ->
++ let f = (Obj.magic f : Obj.repr -> Obj.repr) in
++ Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
++ | Tuple tl ->
++ let fs = List.map to_cd_dyn tl in
++ (fun (x : Obj.repr) ->
++ let x = (Obj.magic x : Obj.repr array) in
++ let rec aux i = function
++ | [] -> assert false
++ | [f] -> f x.(i)
++ | f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
++ aux 0 fs)
++*)
++
++
++let register () =
++ Typer.has_ocaml_unit :=
++ (fun cu -> Mltypes.has_cmi (U.get_str cu));
++ Librarian.stub_ml := stub_ml;
++ Externals.register := register;
++ Externals.ext_info := (fun () -> Obj.magic !exts);
++ Librarian.make_wrapper := make_wrapper
++
++let () =
++ Cduce_config.register
++ "ocaml"
++ "OCaml interface"
++ register
+diff --git a/ocamliface/4.01/mlstub.mli b/ocamliface/4.01/mlstub.mli
+new file mode 100644
+index 0000000..ffe9d36
+--- /dev/null
++++ b/ocamliface/4.01/mlstub.mli
+@@ -0,0 +1,2 @@
++open Camlp4.PreCast
++val gen_wrapper: string list -> Ast.str_item
+diff --git a/ocamliface/4.01/mltypes.ml b/ocamliface/4.01/mltypes.ml
+new file mode 100644
+index 0000000..de44660
+--- /dev/null
++++ b/ocamliface/4.01/mltypes.ml
+@@ -0,0 +1,332 @@
++exception Error of string
++
++module Loc = Cduce_loc
++open Caml_cduce
++open Caml_cduce.Types
++
++(* Unfolding of OCaml types *)
++
++exception PolyAbstract of string
++
++let ocaml_env = ref Env.initial
++
++type t = { uid : int; mutable recurs : int; mutable def : def }
++and def =
++ | Link of t
++ | Arrow of string * t * t
++ | Tuple of t list
++ | PVariant of (string * t option) list (* Polymorphic variant *)
++ | Variant of string * (Ident.t * t list * t option) list * bool
++ | Record of string * (Ident.t * t) list * bool
++ | Builtin of string * t list
++ | Abstract of string
++ | Var of int
++
++module IntMap =
++ Map.Make(struct type t = int let compare : t -> t -> int = compare end)
++module IntSet =
++ Set.Make(struct type t = int let compare : t -> t -> int = compare end)
++module StringSet = Set.Make(struct type t = string let compare : t -> t -> int = compare end)
++
++
++let rec print_sep f sep ppf = function
++ | [] -> ()
++ | [x] -> f ppf x
++ | x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl
++
++let printed = ref IntMap.empty
++
++let rec print_slot ppf slot =
++ if slot.recurs > 0 then
++ (
++ if IntMap.mem slot.uid !printed then
++ Format.fprintf ppf "X%i" slot.uid
++ else (
++ printed := IntMap.add slot.uid () !printed;
++ Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
++ )
++ )
++ else
++ print_def ppf slot.def
++
++and print_def ppf = function
++ | Link t -> print_slot ppf t
++ | Arrow (l,t,s) -> Format.fprintf ppf "%s:%a -> %a" l print_slot t print_slot s
++ | Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
++ | PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
++ | Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
++ | Record (p,l,_) -> Format.fprintf ppf "{%s:%a}" p (print_sep print_field " ; ") l
++ | Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
++ | Abstract s -> Format.fprintf ppf "%s" s
++ | Var i -> Format.fprintf ppf "'a%i" i
++
++
++and print_palt ppf = function
++ | lab, None -> Format.fprintf ppf "`%s" lab
++ | lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
++
++and print_alt ppf = function
++ | (lab,[],_) ->
++ Format.fprintf ppf "%s" lab.Ident.name
++ | (lab,l,_) ->
++ Format.fprintf ppf "%s of [%a]" lab.Ident.name (print_sep print_slot ",") l
++
++and print_field ppf (lab,t) =
++ Format.fprintf ppf "%s:%a" lab.Ident.name print_slot t
++
++
++let print = print_slot
++
++let counter = ref 0
++let new_slot () =
++ incr counter;
++ { uid = !counter; recurs = 0; def = Abstract "DUMMY" }
++
++let reg_uid t =
++ let saved = ref [] in
++ let rec aux t =
++ if t.recurs < 0 then () else begin
++ if t.uid > !counter then counter := t.uid;
++ saved := (t,t.recurs) :: !saved;
++ t.recurs <- (-1);
++ match t.def with
++ | Link t -> aux t
++ | Arrow (_,t1,t2) -> aux t1; aux t2
++ | Tuple tl -> List.iter aux tl
++ | PVariant pl -> List.iter (function (_,Some t) -> aux t | _ -> ()) pl
++ | Variant (_,pl,_) -> List.iter (function
++ (_,tl,Some o) -> List.iter aux (tl@[o])
++ | (_,tl,None) -> List.iter aux tl) pl
++ | Record (_,tl,_) -> List.iter (fun (_,t) -> aux t) tl
++ | Builtin (_,tl) -> List.iter aux tl
++ | _ -> ()
++ end
++ in
++ aux t;
++ List.iter (fun (t,recurs) -> t.recurs <- recurs) !saved
++
++let builtins =
++ List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
++ [
++ "list"; "Pervasives.ref";
++ "unit"; "array";
++ "Big_int.big_int";
++ "option";
++ "Cduce_lib.Value.t";
++ "Cduce_lib.Encodings.Utf8.t";
++ "Cduce_lib.Atoms.V.t";
++ ]
++
++let vars = ref []
++
++let get_var id =
++ try List.assq id !vars
++ with Not_found ->
++ let i = List.length !vars in
++ vars := (id,i) :: !vars;
++ i
++
++let constr_table = Hashtbl.create 1024
++
++type env = { constrs: StringSet.t; seen: IntSet.t; vars: t IntMap.t }
++
++(* Take the file p, if it is from the builtins, open it; else *)
++let rec unfold_constr env p args =
++ let args = List.map (unfold env) args in
++ let pn = Path.name p in
++ if StringSet.mem pn builtins
++ then ( let slot = new_slot () in slot.def <- Builtin (pn,args); slot )
++ else
++ let args_id = List.map (fun t -> t.uid) args in
++ let k = (pn,args_id) in
++ try Hashtbl.find constr_table k
++ with Not_found ->
++ if StringSet.mem pn env.constrs then
++ failwith "Polymorphic recursion forbidden";
++ let slot = new_slot () in
++ slot.recurs <- 1;
++ Hashtbl.add constr_table k slot;
++
++ let decl =
++ try Env.find_type p !ocaml_env
++ with Not_found -> failwith ("Cannot resolve path " ^ pn) in
++
++ let env =
++ { env with
++ constrs = StringSet.add pn env.constrs;
++ vars =
++ List.fold_left2
++ (fun vars a t -> IntMap.add a.id t vars)
++ env.vars decl.type_params args } in
++
++ let prefix = match p with
++ | Path.Pident _ -> ""
++ | Path.Pdot (p,_,_) -> Path.name p ^ "."
++ | _ -> assert false in
++
++ slot.def <-
++ (match decl.type_kind, decl.type_manifest with
++ | Type_variant (cstrs), _ ->
++ let cstrs =
++ (* TODO: Check this solution *)
++ List.map (function (cst,f,Some o)
++ -> (cst,List.map (unfold env) f,Some (unfold env o))
++ | (cst,f,None) -> (cst,List.map (unfold env) f,None)) cstrs in
++(*OLD: (fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in *)
++ Variant (prefix, cstrs, true)
++ | Type_record (f,_), _ ->
++ let f = List.map (fun (l,_,t) -> (l,unfold env t)) f in
++ Record (prefix, f, true)
++ | Type_abstract, Some t ->
++ Link (unfold env t)
++ | Type_abstract, None ->
++ (match args with
++ | [] -> Abstract pn
++ | l ->raise (PolyAbstract pn)));
++ slot
++
++and unfold env ty =
++ if IntSet.mem ty.id env.seen then failwith "Unguarded recursion";
++ let env = { env with seen = IntSet.add ty.id env.seen } in
++ let slot = new_slot () in
++ slot.def <-
++ (match ty.desc with
++ | Tarrow (l,t1,t2,_) ->
++ let t1 = unfold env t1 in
++ let t2 = unfold env t2 in
++ Arrow (l, t1,t2)
++ | Ttuple tyl -> Tuple (List.map (unfold env) tyl)
++ | Tvariant rd ->
++ let fields =
++ List.fold_left
++ (fun accu (lab,f) ->
++ match f with
++ | Rpresent (Some t)
++ | Reither(true, [t], _, _) ->
++ (lab, Some (unfold env t)) :: accu
++ | Rpresent None
++ | Reither(true, [], _, _) -> (lab, None) :: accu
++ | Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
++ | Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
++ ) []
++ rd.row_fields in
++ PVariant fields
++ | Tvar s ->
++ (try Link (IntMap.find ty.id env.vars)
++ with Not_found -> Var (get_var ty.id))
++ | Tconstr (p,args,_) ->
++ Link (unfold_constr env p args)
++ | _ -> failwith "Unsupported feature"
++ );
++ slot
++
++let unfold ty =
++ vars := [];
++ Hashtbl.clear constr_table; (* Get rid of that (careful with exceptions) *)
++ let t = unfold { seen = IntSet.empty; constrs = StringSet.empty;
++ vars = IntMap.empty } ty in
++ let n = List.length !vars in
++ vars := [];
++ (t,n)
++
++(* Reading .cmi *)
++
++let unsupported s =
++ raise (Error (Printf.sprintf "Unsupported feature (%s) found in .cmi" s))
++
++let has_cmi name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
++ with Not_found -> false
++
++let find_value v =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let li = Longident.parse v in
++ ocaml_env := Env.initial;
++ let (_,vd) = Env.lookup_value li Env.initial in
++ unfold vd.val_type
++
++let values_of_sig name sg =
++ List.fold_left
++ (fun accu v -> match v with
++ | Sig_value (id,_) ->
++ let id = Ident.name id in
++ (match id.[0] with
++ | 'a'..'z' | '_' ->
++ let n = name ^ "." ^ id in
++ (try (n, (fst (find_value n))) :: accu
++ with PolyAbstract _ -> accu)
++ | _ -> accu (* operator *))
++ | _ -> accu
++ ) [] sg
++
++
++let load_module name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let li = Longident.parse name in
++ ocaml_env := Env.initial;
++ let (_,mty) = Env.lookup_module li Env.initial in
++ match mty with
++ | Mty_signature sg -> values_of_sig name sg
++ | _ -> raise (Loc.Generic
++ (Printf.sprintf "Module %s is not a structure" name))
++
++(*
++ let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
++ let sg = Env.read_signature name filename in
++ values_of_sig sg
++*)
++
++let load_module name =
++ try load_module name
++ with Env.Error e ->
++ Env.report_error Format.str_formatter e;
++ let s = Format.flush_str_formatter () in
++ let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
++ name s in
++ raise (Loc.Generic s)
++
++let read_cmi name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
++ let sg = Env.read_signature name filename in
++ ocaml_env := Env.add_signature sg Env.initial;
++ let buf = Buffer.create 1024 in
++ let ppf = Format.formatter_of_buffer buf in
++ let values = ref [] in
++ List.iter
++ (function
++ | Sig_value (id, {val_type=t;val_kind=Val_reg}) ->
++ let (unf,n) = unfold t in
++ if n !=0 then unsupported "polymorphic value";
++ values := (Ident.name id, t, unf) :: !values
++ | Sig_type (id,t,rs) ->
++ Format.fprintf ppf "%a at ."
++ !Oprint.out_sig_item (Printtyp.tree_of_type_declaration id t rs);
++ | Sig_value _ -> unsupported "external value"
++ | Sig_exception _ -> unsupported "exception"
++ | Sig_module _ -> unsupported "module"
++ | Sig_modtype _ -> unsupported "module type"
++ | Sig_class _ -> unsupported "class"
++ | Sig_class_type _ -> unsupported "class type"
++ ) sg;
++ (Buffer.contents buf, !values)
++
++let read_cmi name =
++ try read_cmi name
++ with Env.Error e ->
++ Env.report_error Format.str_formatter e;
++ let s = Format.flush_str_formatter () in
++ let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
++ name s in
++ raise (Loc.Generic s)
++
++
++let print_ocaml = Printtyp.type_expr
++
++
++let rec dump_li = function
++ | Longident.Lident s -> print_endline s
++ | Longident.Ldot (li,s) -> dump_li li; print_endline s
++ | _ -> assert false
++
+diff --git a/ocamliface/4.01/mltypes.mli b/ocamliface/4.01/mltypes.mli
+new file mode 100644
+index 0000000..4f502ad
+--- /dev/null
++++ b/ocamliface/4.01/mltypes.mli
+@@ -0,0 +1,33 @@
++open Caml_cduce
++open Asttypes
++open Types
++
++exception Error of string
++
++type t = { uid : int; mutable recurs : int; mutable def : def }
++and def =
++ | Link of t
++ | Arrow of string * t * t
++ | Tuple of t list
++ | PVariant of (string * t option) list (* Polymorphic variant *)
++ | Variant of string * (Ident.t * t list * t option) list * bool
++ | Record of string * (Ident.t * t) list * bool
++ | Builtin of string * t list
++ | Abstract of string
++ | Var of int
++
++val reg_uid: t -> unit
++
++(* Load an external .cmi *)
++val has_cmi: string -> bool
++val load_module: string -> (string * t) list
++
++(* Load the .cmi corresponding to a CDuce compilation unit *)
++val read_cmi: string -> string * (string * Types.type_expr * t) list
++
++val print : Format.formatter -> t -> unit
++val print_ocaml : Format.formatter -> Types.type_expr -> unit
++
++
++val find_value: string -> t * int
++
+diff --git a/ocamliface/4.02/Makefile b/ocamliface/4.02/Makefile
+new file mode 100644
+index 0000000..c16c975
+--- /dev/null
++++ b/ocamliface/4.02/Makefile
+@@ -0,0 +1,76 @@
++# This Makefile generates caml_cduce.cmo/.cmx
++# It must be called with an OCAML_SRC argument pointing to the root
++# of an OCaml source tree.
++include ../../Makefile.conf
++
++all: caml_cduce.cmo caml_cduce.cmx
++
++STDLIB=$(shell ocamlc -where)
++
++
++ifeq ($(FORPACK),true)
++ FORPACKOPT1=-for-pack Cduce_lib.Caml_cduce
++ FORPACKOPT2=-for-pack Cduce_lib
++else
++ FORPACKOPT1=
++ FORPACKOPT2=
++endif
++
++ocaml_files:
++ mkdir ocaml_files
++ $(HIDE)cp $(patsubst %,$(OCAML_SRC)/%, $(COPY_FILES)) ocaml_files/
++ cp location.ml ocaml_files/location.ml
++ cp parsetree.ml ocaml_files/parsetree.ml
++ cp ast_mapper.ml ocaml_files/ast_mapper.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 | head -1 >> ocaml_files/config.ml
++
++caml_cduce.cmo: ocaml_files
++ @echo "Build $@"
++ (cd ocaml_files; \
++ ocamlc $(FORPACKOPT1) -c $(COMPILE_FILES);\
++ ocamlc $(FORPACKOPT2) -pack -o $@ $(OBJECTS); \
++ cp caml_cduce.cmo caml_cduce.cmi ..)
++
++caml_cduce.cmx: ocaml_files
++ @echo "Build $@"
++ (cd ocaml_files; ocamlopt $(FORPACKOPT1) -c $(COMPILE_FILES);\
++ ocamlopt $(FORPACKOPT2) -pack -o $@ $(XOBJECTS); \
++ cp caml_cduce.cmx caml_cduce.o caml_cduce.cmi ..)
++
++clean:
++ rm -Rf ocaml_files *~ *.cm*
++
++COPY_FILES=\
++ typing/annot.mli \
++ utils/misc.ml utils/tbl.ml \
++ utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.mli \
++ utils/clflags.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 \
++ typing/subst.ml typing/predef.ml \
++ typing/datarepr.ml typing/env.ml \
++ typing/ctype.ml typing/ctype.mli typing/printtyp.ml typing/cmi_format.mli typing/cmi_format.ml
++
++COMPILE_FILES=\
++ warnings.ml location.mli asttypes.mli outcometree.mli annot.mli asttypes.ml \
++ config.ml misc.ml tbl.ml \
++ clflags.mli \
++ clflags.ml consistbl.ml terminfo.ml \
++ location.ml longident.ml \
++ ident.ml path.ml \
++ parsetree.ml \
++ ast_mapper.ml \
++ primitive.ml types.ml \
++ btype.ml oprint.ml \
++ subst.ml predef.ml \
++ datarepr.ml cmi_format.mli cmi_format.ml env.ml ctype.mli ctype.ml printtyp.ml
++
++COMPILE_FILES_ML=$(filter %.ml,$(COMPILE_FILES))
++OBJECTS=$(COMPILE_FILES_ML:.ml=.cmo)
++XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
+diff --git a/ocamliface/4.02/ast_mapper.ml b/ocamliface/4.02/ast_mapper.ml
+new file mode 100644
+index 0000000..9f44559
+--- /dev/null
++++ b/ocamliface/4.02/ast_mapper.ml
+@@ -0,0 +1,5 @@
++open Parsetree
++type mapper = { location : mapper -> Location.t -> Location.t;
++ attributes : mapper -> attribute list -> attribute list }
++let default_mapper = { location = (fun _ x -> x);
++ attributes = (fun _ x -> x); }
+diff --git a/ocamliface/4.02/config.ml b/ocamliface/4.02/config.ml
+new file mode 100644
+index 0000000..54ca779
+--- /dev/null
++++ b/ocamliface/4.02/config.ml
+@@ -0,0 +1,4 @@
++let standard_library = "STDLIB"
++let load_path = ref ([] : string list)
++let bytecomp_c_compiler = ""
++let bytecomp_c_linker = ""
+diff --git a/ocamliface/4.02/location.ml b/ocamliface/4.02/location.ml
+new file mode 100644
+index 0000000..ab0c210
+--- /dev/null
++++ b/ocamliface/4.02/location.ml
+@@ -0,0 +1,49 @@
++(* 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 }
++type 'a loc = { txt: 'a; loc: t }
++type error =
++ {
++ loc: t;
++ msg: string;
++ sub: error list;
++ if_highlight: string; (* alternative message if locations are highlighted *)
++ }
++
++exception Error of error
++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_error_cur_file = dummy
++let print_error = dummy
++let print = dummy
++let print_warning = dummy
++let prerr_warning = dummy
++let echo_eof = dummy
++let reset = dummy
++let highlight_locations = dummy
++let mknoloc = dummy
++let mkloc = dummy
++let print_loc = dummy
++let print_filename = dummy
++let show_filename = dummy
++let absname = ref true
++let report_exception = dummy
++let report_error = dummy
++let register_error_of_exn = dummy
++let error_of_exn = dummy
++let error_of_printer_file = dummy
++let error_of_printer = dummy
++let error ?(loc=none) ?(sub=[]) ?(if_highlight="") = dummy
++let errorf = error
++let absolute_path = dummy
+diff --git a/ocamliface/4.02/mlstub.ml b/ocamliface/4.02/mlstub.ml
+new file mode 100644
+index 0000000..54c5a84
+--- /dev/null
++++ b/ocamliface/4.02/mlstub.ml
+@@ -0,0 +1,746 @@
++(* 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)
++
++module IntHash =
++ Hashtbl.Make(struct type t = int let hash i = i let equal i j = i == j end)
++
++(* Compute CDuce type *)
++
++let vars = ref [||]
++
++let memo_typ = IntHash.create 13
++
++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< $uid:String.sub s i (String.length s - i)$ >>
++ in
++(* Printf.eprintf "*** %S\n" s; *)
++ aux 0
++
++let consId 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< $uid:String.sub s i (String.length s - i)$ >>
++ in
++ aux 0
++
++let ident_to_string list =
++ let rec _ident_to_string list res = match list with
++ | (id, x) :: rest -> _ident_to_string rest (res @ [id.Caml_cduce.Ident.name, x])
++ | [] -> res
++ in
++ _ident_to_string list [];;
++
++let rec typ t =
++ try IntHash.find memo_typ t.uid
++ with Not_found ->
++(* print_int t.uid; print_char ' '; flush stdout; *)
++ let node = Types.make () in
++ IntHash.add memo_typ t.uid node;
++ Types.define node (typ_descr t.def);
++ node
++
++and typ_descr = function
++ | Link t -> typ_descr t.def
++ | Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
++ | Tuple tl -> Types.tuple (List.map typ tl)
++ | PVariant l -> bigcup pvariant l
++ | Variant (_,l,_) -> bigcup variant l
++ | Record (_,l,_) -> let l = ident_to_string l in
++ let l = List.map (fun (lab,t) -> label lab, typ t) l in
++ Types.record_fields (false, (LabelMap.from_list_disj l))
++ | 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])
++ | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
++ | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
++ | Builtin ("Big_int.big_int", []) -> Builtin_defs.int
++ | Builtin ("Cduce_lib.Value.t", []) -> Types.any
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
++ | Builtin ("Cduce_lib.Atoms.V.t", []) -> Builtin_defs.atom
++ | Builtin ("unit", []) -> Sequence.nil_type
++ | Builtin ("option", [t]) -> Sequence.option (typ t)
++ | Var i -> Types.descr (!vars).(i)
++ | _ -> assert false
++
++and pvariant = function
++ | (lab, None) -> atom lab
++ | (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
++
++and variant = function
++ | (lab, [], None) -> atom lab.Caml_cduce.Ident.name
++ | (lab, [], Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ [o])
++ | (lab, c, Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ (c@[o]))
++ | (lab, c, None) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ c)
++
++
++(* Syntactic tools *)
++
++let var_counter = ref 0
++let mk_var _ =
++ incr var_counter;
++ Printf.sprintf "x%i" !var_counter
++
++let mk_vars = List.map mk_var
++
++let atom_ascii lab =
++ <:expr< Value.atom_ascii $str: String.escaped lab$ >>
++
++let label_ascii lab =
++ <:expr< Value.label_ascii $str: String.escaped lab$ >>
++
++let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$) >>
++
++let pmatch e l =
++ <:expr< match $e$ with [ $list:l$ ] >>
++
++let rec matches ine oute = function
++ | [v1;v2] ->
++ <: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
++ <:expr< let ($lid:v$,$lid:r$) = Value.get_pair $ine$ in $oute$ >>
++ | [] -> assert false
++
++let list_lit el =
++ List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
++
++let protect e f =
++ match e with
++ | <:expr< $lid:x$ >> -> f e
++ | e ->
++ let x = mk_var () in
++ let r = f <:expr< $lid:x$ >> in
++ <:expr< let $lid:x$ = $e$ in $r$ >>
++
++(* Registered types *)
++
++let gen_types = ref true
++(* currently always off *)
++
++
++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 ->
++ let i = !nb_registered_types in
++ HashTypes.add registered_types t i;
++ incr nb_registered_types;
++ i
++ in
++ <:expr< types.($int:string_of_int n$) >>
++
++let get_registered_types () =
++ let a = Array.make !nb_registered_types Types.empty in
++ HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
++ a
++
++(* OCaml -> CDuce conversions *)
++
++
++let to_cd_gen = ref []
++
++let to_cd_fun_name t =
++ Printf.sprintf "to_cd_%i" t.uid
++
++let to_cd_fun t =
++ to_cd_gen := t :: !to_cd_gen;
++ to_cd_fun_name t
++
++let to_ml_gen = ref []
++
++let to_ml_fun_name t =
++ Printf.sprintf "to_ml_%i" t.uid
++
++let to_ml_fun t =
++ to_ml_gen := t :: !to_ml_gen;
++ to_ml_fun_name t
++
++let rec tuple = function
++ | [v] -> v
++ | v::l -> <:expr< Value.Pair ($v$, $tuple l$) >>
++ | [] -> assert false
++
++let pat_tuple vars =
++ let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
++ <:patt< ($Ast.paCom_of_list pl$) >>
++
++
++let call_lab f l x =
++ if l = "" then <:expr< $f$ $x$ >>
++ else
++ if l.[0] = '?' then
++ let l = String.sub l 1 (String.length l - 1) in
++ <:expr< $f$ (? $l$ : $x$) >>
++ else
++ <:expr< $f$ (~ $l$ : $x$) >>
++
++let abstr_lab l x res =
++ if l = "" then <:expr< fun $lid:x$ -> $res$ >>
++ else
++ if l.[0] = '?' then
++ let l = String.sub l 1 (String.length l - 1) in
++ <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
++ else
++ <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>
++
++
++
++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
++
++and to_cd_descr e = function
++ | Link t -> to_cd e t
++ | Arrow (l,t,s) ->
++ (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
++ protect e
++ (fun y ->
++ let x = mk_var () in
++ 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 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))) *)
++ let vars = mk_vars tl in
++ <:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
++ | PVariant l ->
++ (* match <...> with
++ | `A -> Value.atom_ascii "A"
++ | `B x -> Value.Pair (Value.atom_ascii "B",t(x))
++ *)
++ let cases =
++ List.map
++ (function
++ | (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,_) ->
++ (* match <...> with
++ | P.A -> Value.atom_ascii "A"
++ | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,[],None) ->
++ let pat = match lab.Caml_cduce.Ident.name with (* Stupid Camlp4 *)
++ | "true" -> <:patt< True >>
++ | "false" -> <:patt< False >>
++ | lab -> <:patt< $id: id (p^lab)$ >>
++ in
++ <:match_case< $pat$ -> $atom_ascii lab.Caml_cduce.Ident.name$ >>
++ | (lab,tl,Some o) ->
++ let vars = mk_vars (tl@[o]) in
++ <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
++ $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd (tl@[o]) vars)$ >>
++ | (lab,tl,None) ->
++ let vars = mk_vars tl in
++ <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
++ $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd tl vars)$ >>
++ ) l in
++ pmatch e cases
++ | Record (p,l,_) ->
++ (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
++ protect e
++ (fun x ->
++ let l =
++ List.map
++ (fun (lab,t) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
++ <:expr< ($label_ascii lab$, $e$) >>) 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$ >>
++ | 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 ("array",[t]) ->
++ <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
++ | Builtin ("Pervasives.ref",[t]) ->
++ (* let x = <...> in
++ Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
++ protect e
++ (fun e ->
++ let y = mk_var () 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
++ let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
++ <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
++ )
++ | Builtin ("Big_int.big_int", []) ->
++ <:expr< Value.ocaml2cduce_bigint $e$ >>
++ | Builtin ("Cduce_lib.Value.t", []) -> e
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
++ <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
++ | Builtin ("Cduce_lib.Atoms.V.t", []) ->
++ <:expr< Value.ocaml2cduce_atom $e$ >>
++ | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
++ | Var _ -> e
++ | Builtin ("option", [t]) ->
++ <:expr< Value.ocaml2cduce_option $lid:to_cd_fun t$ $e$ >>
++
++ | _ -> assert false
++
++and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
++
++(* CDuce -> OCaml conversions *)
++
++
++
++and to_ml (e : Ast.expr) (t : Mltypes.t) =
++(* Format.fprintf Format.err_formatter "to_ml %a at ."
++ Mltypes.print t; *)
++ if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
++ else to_ml_descr e t.def
++
++and to_ml_descr e = function
++ | Link t -> to_ml e t
++ | Arrow (l,t,s) ->
++ (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
++ protect e
++ (fun y ->
++ let x = mk_var () in
++ let arg = to_cd <:expr< $lid:x$ >> t in
++ let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
++ abstr_lab l x res
++ )
++
++ | Tuple tl ->
++ (* let (x1,r) = Value.get_pair <...> in
++ let (x2,r) = Value.get_pair r in
++ ...
++ let (xn-1,xn) = Value.get_pair r in
++ (t1(x1),...,tn(xn)) *)
++
++ let vars = mk_vars tl in
++ matches e <:expr< $tuple_to_ml tl vars$ >> vars
++ | PVariant l ->
++ (* match Value.get_variant <...> with
++ | "A",None -> `A
++ | "B",Some x -> `B (t(x))
++ | _ -> assert false
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,None) ->
++ <:match_case<
++ ($str: String.escaped lab$, None) -> `$lid:lab$ >>
++ | (lab,Some t) ->
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_case<
++ ($str: String.escaped lab$, Some $lid:x$) ->
++ `$lid:lab$ $to_ml ex t$ >>
++ ) l in
++ let cases = cases @ [ <:match_case< _ -> assert False >> ] in
++ pmatch <:expr< Value.get_variant $e$ >> cases
++ | Variant (_,l,false) ->
++ failwith "Private Sum type"
++ | Variant (p,l,true) ->
++ (* match Value.get_variant <...> with
++ | "A",None -> P.A
++ | "B",Some x -> let (x1,r) = x in ...
++ *)
++ let cases =
++ List.map
++ (function
++ | (lab,[],None) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let pa = <:patt< ($str: String.escaped lab$, None) >>
++ and e = match lab with (* Stupid Camlp4 *)
++ | "true" -> <:expr< True >>
++ | "false" -> <:expr< False >>
++ | lab -> <:expr< $id:id (p ^ lab)$ >> in
++ <:match_case< $pa$ -> $e$ >>
++ | (lab,[t],None) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $id:id (p ^ lab)$ $to_ml ex t$ >>
++ | (lab,[],Some o) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let x = mk_var () in
++ let ex = <:expr< $lid:x$ >> in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $id:id (p ^ lab)$ $to_ml ex o$ >>
++ | (lab,tl,Some o) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let vars = mk_vars (tl@[o]) in
++ let x = mk_var () in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $ matches
++ <:expr< $lid:x$ >> (
++ List.fold_left
++ (fun x (t, id) ->
++ Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
++ <:expr< $id:consId (p ^ lab)$ >>
++ (List.combine (tl@[o]) vars))
++ vars $ >>
++ | (lab,tl,None) ->
++ let lab = lab.Caml_cduce.Ident.name in
++ let vars = mk_vars tl in
++ let x = mk_var () in
++ <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
++ $ matches
++ <:expr< $lid:x$ >> (
++ List.fold_left
++ (fun x (t, id) ->
++ Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
++ <:expr< $id:consId (p ^ lab)$ >>
++ (List.combine tl vars))
++ vars $ >>
++ ) l in
++ let cases = cases @ [ <:match_case< _ -> assert False >> ] in
++ pmatch <:expr< Value.get_variant $e$ >> cases
++ | Record (_,l,false) ->
++ failwith "Private Record type"
++ | Record (p,l,true) ->
++ (* let x = <...> in
++ { P.l1 = t1(Value.get_field x "l1"); ... } *)
++ protect e
++ (fun x ->
++ let l =
++ List.map
++ (fun (lab,t) ->
++ let lab = lab.Caml_cduce.Ident.name 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$ >>
++ | Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
++ | Abstract "string" -> <:expr< Value.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$) >>
++ | Builtin ("array",[t]) ->
++ (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
++ <:expr< Array.of_list (List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$)) >>
++ | Builtin ("Pervasives.ref",[t]) ->
++ (* ref t(Eval.eval_apply (Value.get_field <...> "get") Value.nil) *)
++ 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 ("Big_int.big_int", []) ->
++ <:expr< Value.cduce2ocaml_bigint $e$ >>
++ | Builtin ("Cduce_lib.Value.t", []) -> e
++ | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
++ <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
++ | Builtin ("Cduce_lib.Atoms.V.t", []) ->
++ <:expr< Value.cduce2ocaml_atom $e$ >>
++ | Builtin ("unit", []) -> <:expr< ignore $e$ >>
++ | Builtin ("option", [t]) ->
++ <:expr< Value.cduce2ocaml_option $lid:to_ml_fun t$ $e$ >>
++ | Var _ -> e
++ | _ -> assert false
++
++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
++let to_cd_done = IntHash.create 13
++
++let global_transl () =
++ let defs = ref [] in
++ let rec aux hd tl gen don fun_name to_descr =
++ gen := tl;
++ if not (IntHash.mem don hd.uid) then (
++ 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 := <:binding< $p$ = $e$ >> :: !defs
++ );
++ loop ()
++ and loop () = match !to_cd_gen,!to_ml_gen with
++ | hd::tl,_ -> aux hd tl to_cd_gen to_cd_done to_cd_fun_name to_cd_descr
++ | _,hd::tl -> aux hd tl to_ml_gen to_ml_done to_ml_fun_name to_ml_descr
++ | [],[] -> ()
++ in
++ loop ();
++ !defs
++
++(* Check type constraints and generate stub code *)
++
++let err_ppf = Format.err_formatter
++
++let exts = ref []
++
++let check_value ty_env c_env (s,caml_t,t) =
++ (* Find the type for the value in the CDuce module *)
++ let id = (Ns.empty, U.mk s) in
++ let vt =
++ try Typer.find_value id ty_env
++ with Not_found ->
++ Format.fprintf err_ppf
++ "The interface exports a value %s which is not available in the module at ." s;
++ exit 1
++ in
++ (* Compute expected CDuce type *)
++ let et = Types.descr (typ t) in
++
++ (* Check subtyping *)
++ if not (Types.subtype vt et) then
++ (
++ Format.fprintf
++ err_ppf
++ "The type for the value %s is invalid@\n\
++ Expected Caml type:@[%a@]@\n\
++ Expected CDuce type:@[%a@]@\n\
++ Inferred type:@[%a@]@."
++ s
++ print_ocaml caml_t
++ Types.Print.print et
++ Types.Print.print vt;
++ exit 1
++ );
++
++ (* Generate stub code *)
++ 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< $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< $id:id s$ >> t) exts in
++ let g = global_transl () in
++
++ let types = get_registered_types () in
++ let raw = mk types in
++
++ let items_def = List.map (fun (_,_,d) -> d) items in
++ let items_expr = List.map (fun (_,e,_) -> e) items in
++ let items_pat = List.map (fun (p,_,_) -> p) items in
++
++ let str_items =
++ <:str_item<
++ 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 $Ast.biAnd_of_list g$;
++ set_externals [|$Ast.exSem_of_list exts$|];
++ run ();
++ value $Ast.biAnd_of_list items_def$;
++ end in $tup:Ast.exCom_of_list items_expr$ >> in
++
++ print_endline prolog;
++ 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 [];
++ flush oc;
++ ignore (Unix.close_process_out oc) *)
++
++
++let stub_ml name ty_env c_env exts mk =
++ try
++ let name = String.capitalize name in
++ let exts = match (Obj.magic exts : (string * Mltypes.t) list option) with
++ | None -> []
++ | Some exts -> List.iter (fun (_,t) -> Mltypes.reg_uid t) exts; exts in
++ (* First, read the description of ML types for externals.
++ Don't forget to call reg_uid to avoid uid clashes...
++ Do that before reading the cmi. *)
++ let (prolog, values) =
++ try Mltypes.read_cmi name
++ with Not_found -> ("",[]) in
++ stub ty_env c_env exts values mk prolog
++ with Mltypes.Error s -> raise (Cduce_loc.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
++ 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
++ 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 ->
++ Cduce_loc.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
++
++ <:str_item<
++ open Cduce_lib;
++ Cduce_config.init_all ();
++ value rec $Ast.biAnd_of_list g$;
++ $Ast.stSem_of_list exts$;
++ >>
++
++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_module s
++ with Not_found ->
++ failwith ("Cannot resolve " ^ s)
++ in
++ vals @ accu
++ ) [] vals in
++
++ wrapper values
++ with Mltypes.Error s -> raise (Cduce_loc.Generic s)
++
++let make_wrapper fn =
++ let ic = open_in fn in
++ let v = ref [] in
++ (try while true do
++ let s = input_line ic in
++ if s <> "" then
++ match s.[0] with
++ | 'A'..'Z' -> v := s :: !v
++ | '#' -> ()
++ | _ -> failwith "Error in primitive file: names must start with a capitalized letter"
++ done
++ with End_of_file -> ());
++ let s = gen_wrapper !v in
++ Printers.OCaml.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 ();;"
++
++
++(* Dynamic coercions *)
++
++
++(*
++let to_cd_dyn = function
++ | Link t -> to_cd_dyn e t
++ | Arrow (l,t,s) ->
++ let tt = Types.descr (typ t) in
++ let ss = Types.descr (typ s) in
++ let tf = to_ml_dyn t in
++ let sf = to_cd_dyn t in
++ (fun (f : Obj.repr) ->
++ let f = (Obj.magic f : Obj.repr -> Obj.repr) in
++ Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
++ | Tuple tl ->
++ let fs = List.map to_cd_dyn tl in
++ (fun (x : Obj.repr) ->
++ let x = (Obj.magic x : Obj.repr array) in
++ let rec aux i = function
++ | [] -> assert false
++ | [f] -> f x.(i)
++ | f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
++ aux 0 fs)
++*)
++
++
++let register () =
++ Typer.has_ocaml_unit :=
++ (fun cu -> Mltypes.has_cmi (U.get_str cu));
++ Librarian.stub_ml := stub_ml;
++ Externals.register := register;
++ Externals.ext_info := (fun () -> Obj.magic !exts);
++ Librarian.make_wrapper := make_wrapper
++
++let () =
++ Cduce_config.register
++ "ocaml"
++ "OCaml interface"
++ register
+diff --git a/ocamliface/4.02/mlstub.mli b/ocamliface/4.02/mlstub.mli
+new file mode 100644
+index 0000000..ffe9d36
+--- /dev/null
++++ b/ocamliface/4.02/mlstub.mli
+@@ -0,0 +1,2 @@
++open Camlp4.PreCast
++val gen_wrapper: string list -> Ast.str_item
+diff --git a/ocamliface/4.02/mltypes.ml b/ocamliface/4.02/mltypes.ml
+new file mode 100644
+index 0000000..eabe623
+--- /dev/null
++++ b/ocamliface/4.02/mltypes.ml
+@@ -0,0 +1,337 @@
++exception Error of string
++
++module Loc = Cduce_loc
++open Caml_cduce
++open Caml_cduce.Types
++
++(* Unfolding of OCaml types *)
++
++exception PolyAbstract of string
++
++let ocaml_env = ref Env.initial_unsafe_string
++
++type t = { uid : int; mutable recurs : int; mutable def : def }
++and def =
++ | Link of t
++ | Arrow of string * t * t
++ | Tuple of t list
++ | PVariant of (string * t option) list (* Polymorphic variant *)
++ | Variant of string * (Ident.t * t list * t option) list * bool
++ | Record of string * (Ident.t * t) list * bool
++ | Builtin of string * t list
++ | Abstract of string
++ | Var of int
++
++module IntMap =
++ Map.Make(struct type t = int let compare : t -> t -> int = compare end)
++module IntSet =
++ Set.Make(struct type t = int let compare : t -> t -> int = compare end)
++module StringSet = Set.Make(struct type t = string let compare : t -> t -> int = compare end)
++
++
++let rec print_sep f sep ppf = function
++ | [] -> ()
++ | [x] -> f ppf x
++ | x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl
++
++let printed = ref IntMap.empty
++
++let rec print_slot ppf slot =
++ if slot.recurs > 0 then
++ (
++ if IntMap.mem slot.uid !printed then
++ Format.fprintf ppf "X%i" slot.uid
++ else (
++ printed := IntMap.add slot.uid () !printed;
++ Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
++ )
++ )
++ else
++ print_def ppf slot.def
++
++and print_def ppf = function
++ | Link t -> print_slot ppf t
++ | Arrow (l,t,s) -> Format.fprintf ppf "%s:%a -> %a" l print_slot t print_slot s
++ | Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
++ | PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
++ | Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
++ | Record (p,l,_) -> Format.fprintf ppf "{%s:%a}" p (print_sep print_field " ; ") l
++ | Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
++ | Abstract s -> Format.fprintf ppf "%s" s
++ | Var i -> Format.fprintf ppf "'a%i" i
++
++
++and print_palt ppf = function
++ | lab, None -> Format.fprintf ppf "`%s" lab
++ | lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
++
++and print_alt ppf = function
++ | (lab,[],_) ->
++ Format.fprintf ppf "%s" lab.Ident.name
++ | (lab,l,_) ->
++ Format.fprintf ppf "%s of [%a]" lab.Ident.name (print_sep print_slot ",") l
++
++and print_field ppf (lab,t) =
++ Format.fprintf ppf "%s:%a" lab.Ident.name print_slot t
++
++
++let print = print_slot
++
++let counter = ref 0
++let new_slot () =
++ incr counter;
++ { uid = !counter; recurs = 0; def = Abstract "DUMMY" }
++
++let reg_uid t =
++ let saved = ref [] in
++ let rec aux t =
++ if t.recurs < 0 then () else begin
++ if t.uid > !counter then counter := t.uid;
++ saved := (t,t.recurs) :: !saved;
++ t.recurs <- (-1);
++ match t.def with
++ | Link t -> aux t
++ | Arrow (_,t1,t2) -> aux t1; aux t2
++ | Tuple tl -> List.iter aux tl
++ | PVariant pl -> List.iter (function (_,Some t) -> aux t | _ -> ()) pl
++ | Variant (_,pl,_) -> List.iter (function
++ (_,tl,Some o) -> List.iter aux (tl@[o])
++ | (_,tl,None) -> List.iter aux tl) pl
++ | Record (_,tl,_) -> List.iter (fun (_,t) -> aux t) tl
++ | Builtin (_,tl) -> List.iter aux tl
++ | _ -> ()
++ end
++ in
++ aux t;
++ List.iter (fun (t,recurs) -> t.recurs <- recurs) !saved
++
++let builtins =
++ List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
++ [
++ "list"; "Pervasives.ref";
++ "unit"; "array";
++ "Big_int.big_int";
++ "option";
++ "Cduce_lib.Value.t";
++ "Cduce_lib.Encodings.Utf8.t";
++ "Cduce_lib.Atoms.V.t";
++ ]
++
++let vars = ref []
++
++let get_var id =
++ try List.assq id !vars
++ with Not_found ->
++ let i = List.length !vars in
++ vars := (id,i) :: !vars;
++ i
++
++let constr_table = Hashtbl.create 1024
++
++type env = { constrs: StringSet.t; seen: IntSet.t; vars: t IntMap.t }
++
++(* Take the file p, if it is from the builtins, open it; else *)
++let rec unfold_constr env p args =
++ let args = List.map (unfold env) args in
++ let pn = Path.name p in
++ if StringSet.mem pn builtins
++ then ( let slot = new_slot () in slot.def <- Builtin (pn,args); slot )
++ else
++ let args_id = List.map (fun t -> t.uid) args in
++ let k = (pn,args_id) in
++ try Hashtbl.find constr_table k
++ with Not_found ->
++ if StringSet.mem pn env.constrs then
++ failwith "Polymorphic recursion forbidden";
++ let slot = new_slot () in
++ slot.recurs <- 1;
++ Hashtbl.add constr_table k slot;
++
++ let decl =
++ try Env.find_type p !ocaml_env
++ with Not_found -> failwith ("Cannot resolve path " ^ pn) in
++
++ let env =
++ { env with
++ constrs = StringSet.add pn env.constrs;
++ vars =
++ List.fold_left2
++ (fun vars a t -> IntMap.add a.id t vars)
++ env.vars decl.type_params args } in
++
++ let prefix = match p with
++ | Path.Pident _ -> ""
++ | Path.Pdot (p,_,_) -> Path.name p ^ "."
++ | _ -> assert false in
++
++ slot.def <-
++ (match decl.type_kind, decl.type_manifest with
++ | Type_variant (cstrs), _ ->
++ let cstrs =
++ (* TODO: Check this solution *)
++ List.map (function c_decl ->
++ let { cd_id = cst; cd_args = f; cd_res = o; _ } = c_decl in
++ (cst,List.map (unfold env) f,
++ match o with Some o -> Some (unfold env o)
++ | None -> None))
++ cstrs in
++(*OLD: (fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in *)
++ Variant (prefix, cstrs, true)
++ | Type_record (f,_), _ ->
++ let f = List.map (fun {ld_id = l; ld_type = t; _ } -> (l,unfold env t)) f in
++ Record (prefix, f, true)
++ | Type_abstract, Some t ->
++ Link (unfold env t)
++ | Type_abstract, None ->
++ (match args with
++ | [] -> Abstract pn
++ | l ->raise (PolyAbstract pn))
++ | Type_open, _ -> raise (PolyAbstract pn) );
++ slot
++
++and unfold env ty =
++ if IntSet.mem ty.id env.seen then failwith "Unguarded recursion";
++ let env = { env with seen = IntSet.add ty.id env.seen } in
++ let slot = new_slot () in
++ slot.def <-
++ (match ty.desc with
++ | Tarrow (l,t1,t2,_) ->
++ let t1 = unfold env t1 in
++ let t2 = unfold env t2 in
++ Arrow (l, t1,t2)
++ | Ttuple tyl -> Tuple (List.map (unfold env) tyl)
++ | Tvariant rd ->
++ let fields =
++ List.fold_left
++ (fun accu (lab,f) ->
++ match f with
++ | Rpresent (Some t)
++ | Reither(true, [t], _, _) ->
++ (lab, Some (unfold env t)) :: accu
++ | Rpresent None
++ | Reither(true, [], _, _) -> (lab, None) :: accu
++ | Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
++ | Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
++ ) []
++ rd.row_fields in
++ PVariant fields
++ | Tvar s ->
++ (try Link (IntMap.find ty.id env.vars)
++ with Not_found -> Var (get_var ty.id))
++ | Tconstr (p,args,_) ->
++ Link (unfold_constr env p args)
++ | _ -> failwith "Unsupported feature"
++ );
++ slot
++
++let unfold ty =
++ vars := [];
++ Hashtbl.clear constr_table; (* Get rid of that (careful with exceptions) *)
++ let t = unfold { seen = IntSet.empty; constrs = StringSet.empty;
++ vars = IntMap.empty } ty in
++ let n = List.length !vars in
++ vars := [];
++ (t,n)
++
++(* Reading .cmi *)
++
++let unsupported s =
++ raise (Error (Printf.sprintf "Unsupported feature (%s) found in .cmi" s))
++
++let has_cmi name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
++ with Not_found -> false
++
++let find_value v =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let li = Longident.parse v in
++ ocaml_env := Env.initial_unsafe_string;
++ let (_,vd) = Env.lookup_value li Env.initial_unsafe_string in
++ unfold vd.val_type
++
++let values_of_sig name sg =
++ List.fold_left
++ (fun accu v -> match v with
++ | Sig_value (id,_) ->
++ let id = Ident.name id in
++ (match id.[0] with
++ | 'a'..'z' | '_' ->
++ let n = name ^ "." ^ id in
++ (try (n, (fst (find_value n))) :: accu
++ with PolyAbstract _ -> accu)
++ | _ -> accu (* operator *))
++ | _ -> accu
++ ) [] sg
++
++
++let load_module name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let li = Longident.parse name in
++ ocaml_env := Env.initial_unsafe_string;
++ let path = Env.lookup_module ~load:false li Env.initial_unsafe_string in
++ let mty = Env.find_modtype_expansion path Env.initial_unsafe_string in
++ match mty with
++ | Mty_signature sg -> values_of_sig name sg
++ | _ -> raise (Loc.Generic
++ (Printf.sprintf "Module %s is not a structure" name))
++
++(*
++ let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
++ let sg = Env.read_signature name filename in
++ values_of_sig sg
++*)
++
++let load_module name =
++ try load_module name
++ with Env.Error e ->
++ Env.report_error Format.str_formatter e;
++ let s = Format.flush_str_formatter () in
++ let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
++ name s in
++ raise (Loc.Generic s)
++
++let read_cmi name =
++ Config.load_path := Config.standard_library :: !Loc.obj_path;
++ let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
++ let sg = Env.read_signature name filename in
++ ocaml_env := Env.add_signature sg Env.initial_unsafe_string;
++ let buf = Buffer.create 1024 in
++ let ppf = Format.formatter_of_buffer buf in
++ let values = ref [] in
++ List.iter
++ (function
++ | Sig_value (id, {val_type=t;val_kind=Val_reg}) ->
++ let (unf,n) = unfold t in
++ if n !=0 then unsupported "polymorphic value";
++ values := (Ident.name id, t, unf) :: !values
++ | Sig_type (id,t,rs) ->
++ Format.fprintf ppf "%a at ."
++ !Oprint.out_sig_item (Printtyp.tree_of_type_declaration id t rs);
++ | Sig_value _ -> unsupported "external value"
++ | Sig_typext _ -> unsupported "extensible type"
++ | Sig_module _ -> unsupported "module"
++ | Sig_modtype _ -> unsupported "module type"
++ | Sig_class _ -> unsupported "class"
++ | Sig_class_type _ -> unsupported "class type"
++ ) sg;
++ (Buffer.contents buf, !values)
++
++let read_cmi name =
++ try read_cmi name
++ with Env.Error e ->
++ Env.report_error Format.str_formatter e;
++ let s = Format.flush_str_formatter () in
++ let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
++ name s in
++ raise (Loc.Generic s)
++
++
++let print_ocaml = Printtyp.type_expr
++
++
++let rec dump_li = function
++ | Longident.Lident s -> print_endline s
++ | Longident.Ldot (li,s) -> dump_li li; print_endline s
++ | _ -> assert false
++
+diff --git a/ocamliface/4.02/mltypes.mli b/ocamliface/4.02/mltypes.mli
+new file mode 100644
+index 0000000..4f502ad
+--- /dev/null
++++ b/ocamliface/4.02/mltypes.mli
+@@ -0,0 +1,33 @@
++open Caml_cduce
++open Asttypes
++open Types
++
++exception Error of string
++
++type t = { uid : int; mutable recurs : int; mutable def : def }
++and def =
++ | Link of t
++ | Arrow of string * t * t
++ | Tuple of t list
++ | PVariant of (string * t option) list (* Polymorphic variant *)
++ | Variant of string * (Ident.t * t list * t option) list * bool
++ | Record of string * (Ident.t * t) list * bool
++ | Builtin of string * t list
++ | Abstract of string
++ | Var of int
++
++val reg_uid: t -> unit
++
++(* Load an external .cmi *)
++val has_cmi: string -> bool
++val load_module: string -> (string * t) list
++
++(* Load the .cmi corresponding to a CDuce compilation unit *)
++val read_cmi: string -> string * (string * Types.type_expr * t) list
++
++val print : Format.formatter -> t -> unit
++val print_ocaml : Format.formatter -> Types.type_expr -> unit
++
++
++val find_value: string -> t * int
++
+diff --git a/ocamliface/4.02/parsetree.ml b/ocamliface/4.02/parsetree.ml
+new file mode 100644
+index 0000000..135bf5f
+--- /dev/null
++++ b/ocamliface/4.02/parsetree.ml
+@@ -0,0 +1,3 @@
++
++type attribute = string
++type attributes = attribute list
+diff --git a/ocamliface/Makefile b/ocamliface/Makefile
+deleted file mode 100644
+index 0d2e59f..0000000
+--- a/ocamliface/Makefile
++++ /dev/null
+@@ -1,72 +0,0 @@
+-# This Makefile generates caml_cduce.cmo/.cmx
+-# It must be called with an OCAML_SRC argument pointing to the root
+-# of an OCaml source tree.
+-include ../Makefile.conf
+-
+-all: caml_cduce.cmo caml_cduce.cmx
+-
+-STDLIB=$(shell ocamlc -where)
+-
+-
+-ifeq ($(FORPACK),true)
+- FORPACKOPT1=-for-pack Cduce_lib.Caml_cduce
+- FORPACKOPT2=-for-pack Cduce_lib
+-else
+- FORPACKOPT1=
+- FORPACKOPT2=
+-endif
+-
+-ocaml_files:
+- mkdir ocaml_files
+- $(HIDE)cp $(patsubst %,$(OCAML_SRC)/%, $(COPY_FILES)) ocaml_files/
+- 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 | head -1 >> ocaml_files/config.ml
+-
+-caml_cduce.cmo: ocaml_files
+- @echo "Build $@"
+- (cd ocaml_files; \
+- ocamlc $(FORPACKOPT1) -c $(COMPILE_FILES);\
+- ocamlc $(FORPACKOPT2) -pack -o $@ $(OBJECTS); \
+- cp caml_cduce.cmo caml_cduce.cmi ..)
+-
+-caml_cduce.cmx: ocaml_files
+- @echo "Build $@"
+- (cd ocaml_files; ocamlopt $(FORPACKOPT1) -c $(COMPILE_FILES);\
+- ocamlopt $(FORPACKOPT2) -pack -o $@ $(XOBJECTS); \
+- cp caml_cduce.cmx caml_cduce.o caml_cduce.cmi ..)
+-
+-clean:
+- rm -Rf ocaml_files *~ *.cm*
+-
+-COPY_FILES=\
+- typing/annot.mli \
+- utils/misc.ml utils/tbl.ml \
+- utils/consistbl.ml utils/warnings.ml utils/terminfo.ml utils/clflags.mli \
+- utils/clflags.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 \
+- typing/subst.ml typing/predef.ml \
+- typing/datarepr.ml typing/env.ml \
+- typing/ctype.ml typing/ctype.mli typing/printtyp.ml typing/cmi_format.mli typing/cmi_format.ml
+-
+-COMPILE_FILES=\
+- warnings.ml location.mli asttypes.mli outcometree.mli annot.mli asttypes.ml \
+- config.ml misc.ml tbl.ml \
+- clflags.mli \
+- clflags.ml consistbl.ml terminfo.ml \
+- location.ml longident.ml \
+- ident.ml path.ml \
+- primitive.ml types.ml \
+- btype.ml oprint.ml \
+- subst.ml predef.ml \
+- datarepr.ml cmi_format.mli cmi_format.ml env.ml ctype.mli ctype.ml printtyp.ml
+-
+-COMPILE_FILES_ML=$(filter %.ml,$(COMPILE_FILES))
+-OBJECTS=$(COMPILE_FILES_ML:.ml=.cmo)
+-XOBJECTS=$(COMPILE_FILES_ML:.ml=.cmx)
+diff --git a/ocamliface/config.ml b/ocamliface/config.ml
+deleted file mode 100644
+index 54ca779..0000000
+--- a/ocamliface/config.ml
++++ /dev/null
+@@ -1,4 +0,0 @@
+-let standard_library = "STDLIB"
+-let load_path = ref ([] : string list)
+-let bytecomp_c_compiler = ""
+-let bytecomp_c_linker = ""
+diff --git a/ocamliface/location.ml b/ocamliface/location.ml
+deleted file mode 100644
+index 4a79b18..0000000
+--- a/ocamliface/location.ml
++++ /dev/null
+@@ -1,32 +0,0 @@
+-(* 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 }
+-type 'a loc = { txt: 'a; loc: t }
+-
+-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_error_cur_file = dummy
+-let print_error = dummy
+-let print = dummy
+-let print_warning = dummy
+-let prerr_warning = dummy
+-let echo_eof = dummy
+-let reset = dummy
+-let highlight_locations = dummy
+-let mknoloc = dummy
+-let mkloc = dummy
+-let print_loc = dummy
+-let print_filename = dummy
+-let show_filename = dummy
+-let absname = ref true
+diff --git a/ocamliface/mlstub.ml b/ocamliface/mlstub.ml
+deleted file mode 100644
+index 54c5a84..0000000
+--- a/ocamliface/mlstub.ml
++++ /dev/null
+@@ -1,746 +0,0 @@
+-(* 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)
+-
+-module IntHash =
+- Hashtbl.Make(struct type t = int let hash i = i let equal i j = i == j end)
+-
+-(* Compute CDuce type *)
+-
+-let vars = ref [||]
+-
+-let memo_typ = IntHash.create 13
+-
+-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< $uid:String.sub s i (String.length s - i)$ >>
+- in
+-(* Printf.eprintf "*** %S\n" s; *)
+- aux 0
+-
+-let consId 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< $uid:String.sub s i (String.length s - i)$ >>
+- in
+- aux 0
+-
+-let ident_to_string list =
+- let rec _ident_to_string list res = match list with
+- | (id, x) :: rest -> _ident_to_string rest (res @ [id.Caml_cduce.Ident.name, x])
+- | [] -> res
+- in
+- _ident_to_string list [];;
+-
+-let rec typ t =
+- try IntHash.find memo_typ t.uid
+- with Not_found ->
+-(* print_int t.uid; print_char ' '; flush stdout; *)
+- let node = Types.make () in
+- IntHash.add memo_typ t.uid node;
+- Types.define node (typ_descr t.def);
+- node
+-
+-and typ_descr = function
+- | Link t -> typ_descr t.def
+- | Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
+- | Tuple tl -> Types.tuple (List.map typ tl)
+- | PVariant l -> bigcup pvariant l
+- | Variant (_,l,_) -> bigcup variant l
+- | Record (_,l,_) -> let l = ident_to_string l in
+- let l = List.map (fun (lab,t) -> label lab, typ t) l in
+- Types.record_fields (false, (LabelMap.from_list_disj l))
+- | 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])
+- | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
+- | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
+- | Builtin ("Big_int.big_int", []) -> Builtin_defs.int
+- | Builtin ("Cduce_lib.Value.t", []) -> Types.any
+- | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
+- | Builtin ("Cduce_lib.Atoms.V.t", []) -> Builtin_defs.atom
+- | Builtin ("unit", []) -> Sequence.nil_type
+- | Builtin ("option", [t]) -> Sequence.option (typ t)
+- | Var i -> Types.descr (!vars).(i)
+- | _ -> assert false
+-
+-and pvariant = function
+- | (lab, None) -> atom lab
+- | (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
+-
+-and variant = function
+- | (lab, [], None) -> atom lab.Caml_cduce.Ident.name
+- | (lab, [], Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ [o])
+- | (lab, c, Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ (c@[o]))
+- | (lab, c, None) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ c)
+-
+-
+-(* Syntactic tools *)
+-
+-let var_counter = ref 0
+-let mk_var _ =
+- incr var_counter;
+- Printf.sprintf "x%i" !var_counter
+-
+-let mk_vars = List.map mk_var
+-
+-let atom_ascii lab =
+- <:expr< Value.atom_ascii $str: String.escaped lab$ >>
+-
+-let label_ascii lab =
+- <:expr< Value.label_ascii $str: String.escaped lab$ >>
+-
+-let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$) >>
+-
+-let pmatch e l =
+- <:expr< match $e$ with [ $list:l$ ] >>
+-
+-let rec matches ine oute = function
+- | [v1;v2] ->
+- <: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
+- <:expr< let ($lid:v$,$lid:r$) = Value.get_pair $ine$ in $oute$ >>
+- | [] -> assert false
+-
+-let list_lit el =
+- List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
+-
+-let protect e f =
+- match e with
+- | <:expr< $lid:x$ >> -> f e
+- | e ->
+- let x = mk_var () in
+- let r = f <:expr< $lid:x$ >> in
+- <:expr< let $lid:x$ = $e$ in $r$ >>
+-
+-(* Registered types *)
+-
+-let gen_types = ref true
+-(* currently always off *)
+-
+-
+-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 ->
+- let i = !nb_registered_types in
+- HashTypes.add registered_types t i;
+- incr nb_registered_types;
+- i
+- in
+- <:expr< types.($int:string_of_int n$) >>
+-
+-let get_registered_types () =
+- let a = Array.make !nb_registered_types Types.empty in
+- HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
+- a
+-
+-(* OCaml -> CDuce conversions *)
+-
+-
+-let to_cd_gen = ref []
+-
+-let to_cd_fun_name t =
+- Printf.sprintf "to_cd_%i" t.uid
+-
+-let to_cd_fun t =
+- to_cd_gen := t :: !to_cd_gen;
+- to_cd_fun_name t
+-
+-let to_ml_gen = ref []
+-
+-let to_ml_fun_name t =
+- Printf.sprintf "to_ml_%i" t.uid
+-
+-let to_ml_fun t =
+- to_ml_gen := t :: !to_ml_gen;
+- to_ml_fun_name t
+-
+-let rec tuple = function
+- | [v] -> v
+- | v::l -> <:expr< Value.Pair ($v$, $tuple l$) >>
+- | [] -> assert false
+-
+-let pat_tuple vars =
+- let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
+- <:patt< ($Ast.paCom_of_list pl$) >>
+-
+-
+-let call_lab f l x =
+- if l = "" then <:expr< $f$ $x$ >>
+- else
+- if l.[0] = '?' then
+- let l = String.sub l 1 (String.length l - 1) in
+- <:expr< $f$ (? $l$ : $x$) >>
+- else
+- <:expr< $f$ (~ $l$ : $x$) >>
+-
+-let abstr_lab l x res =
+- if l = "" then <:expr< fun $lid:x$ -> $res$ >>
+- else
+- if l.[0] = '?' then
+- let l = String.sub l 1 (String.length l - 1) in
+- <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
+- else
+- <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>
+-
+-
+-
+-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
+-
+-and to_cd_descr e = function
+- | Link t -> to_cd e t
+- | Arrow (l,t,s) ->
+- (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
+- protect e
+- (fun y ->
+- let x = mk_var () in
+- 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 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))) *)
+- let vars = mk_vars tl in
+- <:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
+- | PVariant l ->
+- (* match <...> with
+- | `A -> Value.atom_ascii "A"
+- | `B x -> Value.Pair (Value.atom_ascii "B",t(x))
+- *)
+- let cases =
+- List.map
+- (function
+- | (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,_) ->
+- (* match <...> with
+- | P.A -> Value.atom_ascii "A"
+- | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
+- *)
+- let cases =
+- List.map
+- (function
+- | (lab,[],None) ->
+- let pat = match lab.Caml_cduce.Ident.name with (* Stupid Camlp4 *)
+- | "true" -> <:patt< True >>
+- | "false" -> <:patt< False >>
+- | lab -> <:patt< $id: id (p^lab)$ >>
+- in
+- <:match_case< $pat$ -> $atom_ascii lab.Caml_cduce.Ident.name$ >>
+- | (lab,tl,Some o) ->
+- let vars = mk_vars (tl@[o]) in
+- <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
+- $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd (tl@[o]) vars)$ >>
+- | (lab,tl,None) ->
+- let vars = mk_vars tl in
+- <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
+- $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd tl vars)$ >>
+- ) l in
+- pmatch e cases
+- | Record (p,l,_) ->
+- (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
+- protect e
+- (fun x ->
+- let l =
+- List.map
+- (fun (lab,t) ->
+- let lab = lab.Caml_cduce.Ident.name in
+- let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
+- <:expr< ($label_ascii lab$, $e$) >>) 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$ >>
+- | 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 ("array",[t]) ->
+- <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
+- | Builtin ("Pervasives.ref",[t]) ->
+- (* let x = <...> in
+- Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
+- protect e
+- (fun e ->
+- let y = mk_var () 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
+- let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
+- <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
+- )
+- | Builtin ("Big_int.big_int", []) ->
+- <:expr< Value.ocaml2cduce_bigint $e$ >>
+- | Builtin ("Cduce_lib.Value.t", []) -> e
+- | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
+- <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
+- | Builtin ("Cduce_lib.Atoms.V.t", []) ->
+- <:expr< Value.ocaml2cduce_atom $e$ >>
+- | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
+- | Var _ -> e
+- | Builtin ("option", [t]) ->
+- <:expr< Value.ocaml2cduce_option $lid:to_cd_fun t$ $e$ >>
+-
+- | _ -> assert false
+-
+-and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
+-
+-(* CDuce -> OCaml conversions *)
+-
+-
+-
+-and to_ml (e : Ast.expr) (t : Mltypes.t) =
+-(* Format.fprintf Format.err_formatter "to_ml %a at ."
+- Mltypes.print t; *)
+- if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
+- else to_ml_descr e t.def
+-
+-and to_ml_descr e = function
+- | Link t -> to_ml e t
+- | Arrow (l,t,s) ->
+- (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
+- protect e
+- (fun y ->
+- let x = mk_var () in
+- let arg = to_cd <:expr< $lid:x$ >> t in
+- let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
+- abstr_lab l x res
+- )
+-
+- | Tuple tl ->
+- (* let (x1,r) = Value.get_pair <...> in
+- let (x2,r) = Value.get_pair r in
+- ...
+- let (xn-1,xn) = Value.get_pair r in
+- (t1(x1),...,tn(xn)) *)
+-
+- let vars = mk_vars tl in
+- matches e <:expr< $tuple_to_ml tl vars$ >> vars
+- | PVariant l ->
+- (* match Value.get_variant <...> with
+- | "A",None -> `A
+- | "B",Some x -> `B (t(x))
+- | _ -> assert false
+- *)
+- let cases =
+- List.map
+- (function
+- | (lab,None) ->
+- <:match_case<
+- ($str: String.escaped lab$, None) -> `$lid:lab$ >>
+- | (lab,Some t) ->
+- let x = mk_var () in
+- let ex = <:expr< $lid:x$ >> in
+- <:match_case<
+- ($str: String.escaped lab$, Some $lid:x$) ->
+- `$lid:lab$ $to_ml ex t$ >>
+- ) l in
+- let cases = cases @ [ <:match_case< _ -> assert False >> ] in
+- pmatch <:expr< Value.get_variant $e$ >> cases
+- | Variant (_,l,false) ->
+- failwith "Private Sum type"
+- | Variant (p,l,true) ->
+- (* match Value.get_variant <...> with
+- | "A",None -> P.A
+- | "B",Some x -> let (x1,r) = x in ...
+- *)
+- let cases =
+- List.map
+- (function
+- | (lab,[],None) ->
+- let lab = lab.Caml_cduce.Ident.name in
+- let pa = <:patt< ($str: String.escaped lab$, None) >>
+- and e = match lab with (* Stupid Camlp4 *)
+- | "true" -> <:expr< True >>
+- | "false" -> <:expr< False >>
+- | lab -> <:expr< $id:id (p ^ lab)$ >> in
+- <:match_case< $pa$ -> $e$ >>
+- | (lab,[t],None) ->
+- let lab = lab.Caml_cduce.Ident.name in
+- let x = mk_var () in
+- let ex = <:expr< $lid:x$ >> in
+- <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
+- $id:id (p ^ lab)$ $to_ml ex t$ >>
+- | (lab,[],Some o) ->
+- let lab = lab.Caml_cduce.Ident.name in
+- let x = mk_var () in
+- let ex = <:expr< $lid:x$ >> in
+- <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
+- $id:id (p ^ lab)$ $to_ml ex o$ >>
+- | (lab,tl,Some o) ->
+- let lab = lab.Caml_cduce.Ident.name in
+- let vars = mk_vars (tl@[o]) in
+- let x = mk_var () in
+- <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
+- $ matches
+- <:expr< $lid:x$ >> (
+- List.fold_left
+- (fun x (t, id) ->
+- Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
+- <:expr< $id:consId (p ^ lab)$ >>
+- (List.combine (tl@[o]) vars))
+- vars $ >>
+- | (lab,tl,None) ->
+- let lab = lab.Caml_cduce.Ident.name in
+- let vars = mk_vars tl in
+- let x = mk_var () in
+- <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
+- $ matches
+- <:expr< $lid:x$ >> (
+- List.fold_left
+- (fun x (t, id) ->
+- Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
+- <:expr< $id:consId (p ^ lab)$ >>
+- (List.combine tl vars))
+- vars $ >>
+- ) l in
+- let cases = cases @ [ <:match_case< _ -> assert False >> ] in
+- pmatch <:expr< Value.get_variant $e$ >> cases
+- | Record (_,l,false) ->
+- failwith "Private Record type"
+- | Record (p,l,true) ->
+- (* let x = <...> in
+- { P.l1 = t1(Value.get_field x "l1"); ... } *)
+- protect e
+- (fun x ->
+- let l =
+- List.map
+- (fun (lab,t) ->
+- let lab = lab.Caml_cduce.Ident.name 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$ >>
+- | Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
+- | Abstract "string" -> <:expr< Value.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$) >>
+- | Builtin ("array",[t]) ->
+- (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
+- <:expr< Array.of_list (List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$)) >>
+- | Builtin ("Pervasives.ref",[t]) ->
+- (* ref t(Eval.eval_apply (Value.get_field <...> "get") Value.nil) *)
+- 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 ("Big_int.big_int", []) ->
+- <:expr< Value.cduce2ocaml_bigint $e$ >>
+- | Builtin ("Cduce_lib.Value.t", []) -> e
+- | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
+- <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
+- | Builtin ("Cduce_lib.Atoms.V.t", []) ->
+- <:expr< Value.cduce2ocaml_atom $e$ >>
+- | Builtin ("unit", []) -> <:expr< ignore $e$ >>
+- | Builtin ("option", [t]) ->
+- <:expr< Value.cduce2ocaml_option $lid:to_ml_fun t$ $e$ >>
+- | Var _ -> e
+- | _ -> assert false
+-
+-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
+-let to_cd_done = IntHash.create 13
+-
+-let global_transl () =
+- let defs = ref [] in
+- let rec aux hd tl gen don fun_name to_descr =
+- gen := tl;
+- if not (IntHash.mem don hd.uid) then (
+- 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 := <:binding< $p$ = $e$ >> :: !defs
+- );
+- loop ()
+- and loop () = match !to_cd_gen,!to_ml_gen with
+- | hd::tl,_ -> aux hd tl to_cd_gen to_cd_done to_cd_fun_name to_cd_descr
+- | _,hd::tl -> aux hd tl to_ml_gen to_ml_done to_ml_fun_name to_ml_descr
+- | [],[] -> ()
+- in
+- loop ();
+- !defs
+-
+-(* Check type constraints and generate stub code *)
+-
+-let err_ppf = Format.err_formatter
+-
+-let exts = ref []
+-
+-let check_value ty_env c_env (s,caml_t,t) =
+- (* Find the type for the value in the CDuce module *)
+- let id = (Ns.empty, U.mk s) in
+- let vt =
+- try Typer.find_value id ty_env
+- with Not_found ->
+- Format.fprintf err_ppf
+- "The interface exports a value %s which is not available in the module at ." s;
+- exit 1
+- in
+- (* Compute expected CDuce type *)
+- let et = Types.descr (typ t) in
+-
+- (* Check subtyping *)
+- if not (Types.subtype vt et) then
+- (
+- Format.fprintf
+- err_ppf
+- "The type for the value %s is invalid@\n\
+- Expected Caml type:@[%a@]@\n\
+- Expected CDuce type:@[%a@]@\n\
+- Inferred type:@[%a@]@."
+- s
+- print_ocaml caml_t
+- Types.Print.print et
+- Types.Print.print vt;
+- exit 1
+- );
+-
+- (* Generate stub code *)
+- 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< $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< $id:id s$ >> t) exts in
+- let g = global_transl () in
+-
+- let types = get_registered_types () in
+- let raw = mk types in
+-
+- let items_def = List.map (fun (_,_,d) -> d) items in
+- let items_expr = List.map (fun (_,e,_) -> e) items in
+- let items_pat = List.map (fun (p,_,_) -> p) items in
+-
+- let str_items =
+- <:str_item<
+- 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 $Ast.biAnd_of_list g$;
+- set_externals [|$Ast.exSem_of_list exts$|];
+- run ();
+- value $Ast.biAnd_of_list items_def$;
+- end in $tup:Ast.exCom_of_list items_expr$ >> in
+-
+- print_endline prolog;
+- 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 [];
+- flush oc;
+- ignore (Unix.close_process_out oc) *)
+-
+-
+-let stub_ml name ty_env c_env exts mk =
+- try
+- let name = String.capitalize name in
+- let exts = match (Obj.magic exts : (string * Mltypes.t) list option) with
+- | None -> []
+- | Some exts -> List.iter (fun (_,t) -> Mltypes.reg_uid t) exts; exts in
+- (* First, read the description of ML types for externals.
+- Don't forget to call reg_uid to avoid uid clashes...
+- Do that before reading the cmi. *)
+- let (prolog, values) =
+- try Mltypes.read_cmi name
+- with Not_found -> ("",[]) in
+- stub ty_env c_env exts values mk prolog
+- with Mltypes.Error s -> raise (Cduce_loc.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
+- 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
+- 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 ->
+- Cduce_loc.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
+-
+- <:str_item<
+- open Cduce_lib;
+- Cduce_config.init_all ();
+- value rec $Ast.biAnd_of_list g$;
+- $Ast.stSem_of_list exts$;
+- >>
+-
+-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_module s
+- with Not_found ->
+- failwith ("Cannot resolve " ^ s)
+- in
+- vals @ accu
+- ) [] vals in
+-
+- wrapper values
+- with Mltypes.Error s -> raise (Cduce_loc.Generic s)
+-
+-let make_wrapper fn =
+- let ic = open_in fn in
+- let v = ref [] in
+- (try while true do
+- let s = input_line ic in
+- if s <> "" then
+- match s.[0] with
+- | 'A'..'Z' -> v := s :: !v
+- | '#' -> ()
+- | _ -> failwith "Error in primitive file: names must start with a capitalized letter"
+- done
+- with End_of_file -> ());
+- let s = gen_wrapper !v in
+- Printers.OCaml.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 ();;"
+-
+-
+-(* Dynamic coercions *)
+-
+-
+-(*
+-let to_cd_dyn = function
+- | Link t -> to_cd_dyn e t
+- | Arrow (l,t,s) ->
+- let tt = Types.descr (typ t) in
+- let ss = Types.descr (typ s) in
+- let tf = to_ml_dyn t in
+- let sf = to_cd_dyn t in
+- (fun (f : Obj.repr) ->
+- let f = (Obj.magic f : Obj.repr -> Obj.repr) in
+- Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
+- | Tuple tl ->
+- let fs = List.map to_cd_dyn tl in
+- (fun (x : Obj.repr) ->
+- let x = (Obj.magic x : Obj.repr array) in
+- let rec aux i = function
+- | [] -> assert false
+- | [f] -> f x.(i)
+- | f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
+- aux 0 fs)
+-*)
+-
+-
+-let register () =
+- Typer.has_ocaml_unit :=
+- (fun cu -> Mltypes.has_cmi (U.get_str cu));
+- Librarian.stub_ml := stub_ml;
+- Externals.register := register;
+- Externals.ext_info := (fun () -> Obj.magic !exts);
+- Librarian.make_wrapper := make_wrapper
+-
+-let () =
+- Cduce_config.register
+- "ocaml"
+- "OCaml interface"
+- register
+diff --git a/ocamliface/mlstub.mli b/ocamliface/mlstub.mli
+deleted file mode 100644
+index ffe9d36..0000000
+--- a/ocamliface/mlstub.mli
++++ /dev/null
+@@ -1,2 +0,0 @@
+-open Camlp4.PreCast
+-val gen_wrapper: string list -> Ast.str_item
+diff --git a/ocamliface/mltypes.ml b/ocamliface/mltypes.ml
+deleted file mode 100644
+index de44660..0000000
+--- a/ocamliface/mltypes.ml
++++ /dev/null
+@@ -1,332 +0,0 @@
+-exception Error of string
+-
+-module Loc = Cduce_loc
+-open Caml_cduce
+-open Caml_cduce.Types
+-
+-(* Unfolding of OCaml types *)
+-
+-exception PolyAbstract of string
+-
+-let ocaml_env = ref Env.initial
+-
+-type t = { uid : int; mutable recurs : int; mutable def : def }
+-and def =
+- | Link of t
+- | Arrow of string * t * t
+- | Tuple of t list
+- | PVariant of (string * t option) list (* Polymorphic variant *)
+- | Variant of string * (Ident.t * t list * t option) list * bool
+- | Record of string * (Ident.t * t) list * bool
+- | Builtin of string * t list
+- | Abstract of string
+- | Var of int
+-
+-module IntMap =
+- Map.Make(struct type t = int let compare : t -> t -> int = compare end)
+-module IntSet =
+- Set.Make(struct type t = int let compare : t -> t -> int = compare end)
+-module StringSet = Set.Make(struct type t = string let compare : t -> t -> int = compare end)
+-
+-
+-let rec print_sep f sep ppf = function
+- | [] -> ()
+- | [x] -> f ppf x
+- | x::tl -> Format.fprintf ppf "%a%s" f x sep; print_sep f sep ppf tl
+-
+-let printed = ref IntMap.empty
+-
+-let rec print_slot ppf slot =
+- if slot.recurs > 0 then
+- (
+- if IntMap.mem slot.uid !printed then
+- Format.fprintf ppf "X%i" slot.uid
+- else (
+- printed := IntMap.add slot.uid () !printed;
+- Format.fprintf ppf "X%i:=%a" slot.uid print_def slot.def
+- )
+- )
+- else
+- print_def ppf slot.def
+-
+-and print_def ppf = function
+- | Link t -> print_slot ppf t
+- | Arrow (l,t,s) -> Format.fprintf ppf "%s:%a -> %a" l print_slot t print_slot s
+- | Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
+- | PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
+- | Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
+- | Record (p,l,_) -> Format.fprintf ppf "{%s:%a}" p (print_sep print_field " ; ") l
+- | Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
+- | Abstract s -> Format.fprintf ppf "%s" s
+- | Var i -> Format.fprintf ppf "'a%i" i
+-
+-
+-and print_palt ppf = function
+- | lab, None -> Format.fprintf ppf "`%s" lab
+- | lab, Some t -> Format.fprintf ppf "`%s of %a" lab print_slot t
+-
+-and print_alt ppf = function
+- | (lab,[],_) ->
+- Format.fprintf ppf "%s" lab.Ident.name
+- | (lab,l,_) ->
+- Format.fprintf ppf "%s of [%a]" lab.Ident.name (print_sep print_slot ",") l
+-
+-and print_field ppf (lab,t) =
+- Format.fprintf ppf "%s:%a" lab.Ident.name print_slot t
+-
+-
+-let print = print_slot
+-
+-let counter = ref 0
+-let new_slot () =
+- incr counter;
+- { uid = !counter; recurs = 0; def = Abstract "DUMMY" }
+-
+-let reg_uid t =
+- let saved = ref [] in
+- let rec aux t =
+- if t.recurs < 0 then () else begin
+- if t.uid > !counter then counter := t.uid;
+- saved := (t,t.recurs) :: !saved;
+- t.recurs <- (-1);
+- match t.def with
+- | Link t -> aux t
+- | Arrow (_,t1,t2) -> aux t1; aux t2
+- | Tuple tl -> List.iter aux tl
+- | PVariant pl -> List.iter (function (_,Some t) -> aux t | _ -> ()) pl
+- | Variant (_,pl,_) -> List.iter (function
+- (_,tl,Some o) -> List.iter aux (tl@[o])
+- | (_,tl,None) -> List.iter aux tl) pl
+- | Record (_,tl,_) -> List.iter (fun (_,t) -> aux t) tl
+- | Builtin (_,tl) -> List.iter aux tl
+- | _ -> ()
+- end
+- in
+- aux t;
+- List.iter (fun (t,recurs) -> t.recurs <- recurs) !saved
+-
+-let builtins =
+- List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
+- [
+- "list"; "Pervasives.ref";
+- "unit"; "array";
+- "Big_int.big_int";
+- "option";
+- "Cduce_lib.Value.t";
+- "Cduce_lib.Encodings.Utf8.t";
+- "Cduce_lib.Atoms.V.t";
+- ]
+-
+-let vars = ref []
+-
+-let get_var id =
+- try List.assq id !vars
+- with Not_found ->
+- let i = List.length !vars in
+- vars := (id,i) :: !vars;
+- i
+-
+-let constr_table = Hashtbl.create 1024
+-
+-type env = { constrs: StringSet.t; seen: IntSet.t; vars: t IntMap.t }
+-
+-(* Take the file p, if it is from the builtins, open it; else *)
+-let rec unfold_constr env p args =
+- let args = List.map (unfold env) args in
+- let pn = Path.name p in
+- if StringSet.mem pn builtins
+- then ( let slot = new_slot () in slot.def <- Builtin (pn,args); slot )
+- else
+- let args_id = List.map (fun t -> t.uid) args in
+- let k = (pn,args_id) in
+- try Hashtbl.find constr_table k
+- with Not_found ->
+- if StringSet.mem pn env.constrs then
+- failwith "Polymorphic recursion forbidden";
+- let slot = new_slot () in
+- slot.recurs <- 1;
+- Hashtbl.add constr_table k slot;
+-
+- let decl =
+- try Env.find_type p !ocaml_env
+- with Not_found -> failwith ("Cannot resolve path " ^ pn) in
+-
+- let env =
+- { env with
+- constrs = StringSet.add pn env.constrs;
+- vars =
+- List.fold_left2
+- (fun vars a t -> IntMap.add a.id t vars)
+- env.vars decl.type_params args } in
+-
+- let prefix = match p with
+- | Path.Pident _ -> ""
+- | Path.Pdot (p,_,_) -> Path.name p ^ "."
+- | _ -> assert false in
+-
+- slot.def <-
+- (match decl.type_kind, decl.type_manifest with
+- | Type_variant (cstrs), _ ->
+- let cstrs =
+- (* TODO: Check this solution *)
+- List.map (function (cst,f,Some o)
+- -> (cst,List.map (unfold env) f,Some (unfold env o))
+- | (cst,f,None) -> (cst,List.map (unfold env) f,None)) cstrs in
+-(*OLD: (fun (cst,f) -> (cst,List.map (unfold env) f)) cstrs in *)
+- Variant (prefix, cstrs, true)
+- | Type_record (f,_), _ ->
+- let f = List.map (fun (l,_,t) -> (l,unfold env t)) f in
+- Record (prefix, f, true)
+- | Type_abstract, Some t ->
+- Link (unfold env t)
+- | Type_abstract, None ->
+- (match args with
+- | [] -> Abstract pn
+- | l ->raise (PolyAbstract pn)));
+- slot
+-
+-and unfold env ty =
+- if IntSet.mem ty.id env.seen then failwith "Unguarded recursion";
+- let env = { env with seen = IntSet.add ty.id env.seen } in
+- let slot = new_slot () in
+- slot.def <-
+- (match ty.desc with
+- | Tarrow (l,t1,t2,_) ->
+- let t1 = unfold env t1 in
+- let t2 = unfold env t2 in
+- Arrow (l, t1,t2)
+- | Ttuple tyl -> Tuple (List.map (unfold env) tyl)
+- | Tvariant rd ->
+- let fields =
+- List.fold_left
+- (fun accu (lab,f) ->
+- match f with
+- | Rpresent (Some t)
+- | Reither(true, [t], _, _) ->
+- (lab, Some (unfold env t)) :: accu
+- | Rpresent None
+- | Reither(true, [], _, _) -> (lab, None) :: accu
+- | Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
+- | Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
+- ) []
+- rd.row_fields in
+- PVariant fields
+- | Tvar s ->
+- (try Link (IntMap.find ty.id env.vars)
+- with Not_found -> Var (get_var ty.id))
+- | Tconstr (p,args,_) ->
+- Link (unfold_constr env p args)
+- | _ -> failwith "Unsupported feature"
+- );
+- slot
+-
+-let unfold ty =
+- vars := [];
+- Hashtbl.clear constr_table; (* Get rid of that (careful with exceptions) *)
+- let t = unfold { seen = IntSet.empty; constrs = StringSet.empty;
+- vars = IntMap.empty } ty in
+- let n = List.length !vars in
+- vars := [];
+- (t,n)
+-
+-(* Reading .cmi *)
+-
+-let unsupported s =
+- raise (Error (Printf.sprintf "Unsupported feature (%s) found in .cmi" s))
+-
+-let has_cmi name =
+- Config.load_path := Config.standard_library :: !Loc.obj_path;
+- try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
+- with Not_found -> false
+-
+-let find_value v =
+- Config.load_path := Config.standard_library :: !Loc.obj_path;
+- let li = Longident.parse v in
+- ocaml_env := Env.initial;
+- let (_,vd) = Env.lookup_value li Env.initial in
+- unfold vd.val_type
+-
+-let values_of_sig name sg =
+- List.fold_left
+- (fun accu v -> match v with
+- | Sig_value (id,_) ->
+- let id = Ident.name id in
+- (match id.[0] with
+- | 'a'..'z' | '_' ->
+- let n = name ^ "." ^ id in
+- (try (n, (fst (find_value n))) :: accu
+- with PolyAbstract _ -> accu)
+- | _ -> accu (* operator *))
+- | _ -> accu
+- ) [] sg
+-
+-
+-let load_module name =
+- Config.load_path := Config.standard_library :: !Loc.obj_path;
+- let li = Longident.parse name in
+- ocaml_env := Env.initial;
+- let (_,mty) = Env.lookup_module li Env.initial in
+- match mty with
+- | Mty_signature sg -> values_of_sig name sg
+- | _ -> raise (Loc.Generic
+- (Printf.sprintf "Module %s is not a structure" name))
+-
+-(*
+- let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
+- let sg = Env.read_signature name filename in
+- values_of_sig sg
+-*)
+-
+-let load_module name =
+- try load_module name
+- with Env.Error e ->
+- Env.report_error Format.str_formatter e;
+- let s = Format.flush_str_formatter () in
+- let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
+- name s in
+- raise (Loc.Generic s)
+-
+-let read_cmi name =
+- Config.load_path := Config.standard_library :: !Loc.obj_path;
+- let filename = Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi") in
+- let sg = Env.read_signature name filename in
+- ocaml_env := Env.add_signature sg Env.initial;
+- let buf = Buffer.create 1024 in
+- let ppf = Format.formatter_of_buffer buf in
+- let values = ref [] in
+- List.iter
+- (function
+- | Sig_value (id, {val_type=t;val_kind=Val_reg}) ->
+- let (unf,n) = unfold t in
+- if n !=0 then unsupported "polymorphic value";
+- values := (Ident.name id, t, unf) :: !values
+- | Sig_type (id,t,rs) ->
+- Format.fprintf ppf "%a at ."
+- !Oprint.out_sig_item (Printtyp.tree_of_type_declaration id t rs);
+- | Sig_value _ -> unsupported "external value"
+- | Sig_exception _ -> unsupported "exception"
+- | Sig_module _ -> unsupported "module"
+- | Sig_modtype _ -> unsupported "module type"
+- | Sig_class _ -> unsupported "class"
+- | Sig_class_type _ -> unsupported "class type"
+- ) sg;
+- (Buffer.contents buf, !values)
+-
+-let read_cmi name =
+- try read_cmi name
+- with Env.Error e ->
+- Env.report_error Format.str_formatter e;
+- let s = Format.flush_str_formatter () in
+- let s = Printf.sprintf "Error while reading OCaml interface %s: %s"
+- name s in
+- raise (Loc.Generic s)
+-
+-
+-let print_ocaml = Printtyp.type_expr
+-
+-
+-let rec dump_li = function
+- | Longident.Lident s -> print_endline s
+- | Longident.Ldot (li,s) -> dump_li li; print_endline s
+- | _ -> assert false
+-
+diff --git a/ocamliface/mltypes.mli b/ocamliface/mltypes.mli
+deleted file mode 100644
+index 4f502ad..0000000
+--- a/ocamliface/mltypes.mli
++++ /dev/null
+@@ -1,33 +0,0 @@
+-open Caml_cduce
+-open Asttypes
+-open Types
+-
+-exception Error of string
+-
+-type t = { uid : int; mutable recurs : int; mutable def : def }
+-and def =
+- | Link of t
+- | Arrow of string * t * t
+- | Tuple of t list
+- | PVariant of (string * t option) list (* Polymorphic variant *)
+- | Variant of string * (Ident.t * t list * t option) list * bool
+- | Record of string * (Ident.t * t) list * bool
+- | Builtin of string * t list
+- | Abstract of string
+- | Var of int
+-
+-val reg_uid: t -> unit
+-
+-(* Load an external .cmi *)
+-val has_cmi: string -> bool
+-val load_module: string -> (string * t) list
+-
+-(* Load the .cmi corresponding to a CDuce compilation unit *)
+-val read_cmi: string -> string * (string * Types.type_expr * t) list
+-
+-val print : Format.formatter -> t -> unit
+-val print_ocaml : Format.formatter -> Types.type_expr -> unit
+-
+-
+-val find_value: string -> t * int
+-
+--
+1.9.3
+
diff --git a/cduce.spec b/cduce.spec
index 364f117..edb2f18 100644
--- a/cduce.spec
+++ b/cduce.spec
@@ -12,7 +12,7 @@
Name: cduce
Version: 0.6.0
-Release: 3%{?dist}
+Release: 4%{?dist}
Summary: Modern XML-oriented functional language
License: BSD
@@ -25,8 +25,13 @@ Source1: http://caml.inria.fr/distrib/ocaml-%{ocaml_major}/ocaml-%{ocaml_
Source2: http://debian.glondu.net/debian/ocaml-3.12.0/pool/ocamlduce/ocamlduce_3.12.0.0.orig.tar.gz
%endif
-# Build fix for OCaml 4.02.
-Patch1: cduce_ocaml_4.02.0.patch
+# Build fixes for OCaml 4.02.
+# All upstream on the 'stable-for-ocaml-4.02' branch.
+Patch1: 0001-Change-the-default-inlining-from-10000-to-100-OCaml-.patch
+Patch2: 0002-Do-not-rely-on-a-load-directive-at-the-top-of-parser.patch
+Patch3: 0003-Fix-the-compilation-of-ocaml-bindings.patch
+Patch4: 0004-Detect-OCaml-version-used-for-the-ocaml-bridge-in-th.patch
+Patch5: 0005-Make-it-possible-compile-the-ocaml-cduce-interface-a.patch
ExcludeArch: ppc64 s390 s390x sparc64
@@ -87,6 +92,10 @@ incorporates CDuce extensions for working with XML documents.
%endif
%patch1 -p1
+%patch2 -p1
+%patch3 -p1
+%patch4 -p1
+%patch5 -p1
./configure --prefix=%{_prefix} \
--bindir=%{_bindir} \
@@ -168,6 +177,9 @@ popd
%changelog
+* Sun Aug 03 2014 Richard W.M. Jones <rjones at redhat.com> - 0.6.0-4
+- Import upstream patches which might fix build on OCaml 4.02.
+
* Sat Aug 02 2014 Richard W.M. Jones <rjones at redhat.com> - 0.6.0-3
- ocaml-4.02.0-0.8.git10e45753.fc22 rebuild.
More information about the scm-commits
mailing list