[r2004-06-27 21:11:51 by afrisch] New ocaml interface

Original author: afrisch
Date: 2004-06-27 21:11:54+00:00

Makefile.distrib

@@ -82,19 +82,14 @@ endif
 ifneq ($(ML_INTERFACE), false)
   SYNTAX += -symbol ML_INTERFACE=
   ML_LIB = oCaml_all.$(EXTENSION_LIB)
-  ML_INTERFACE_OBJ = \
-	cdo2cmo/ml_types.cmo \
-	cdo2cmo/ml_cduce.cmo \
-	cdo2cmo/ml_ocaml.cmo \
-	cdo2cmo/ml_checker.cmo \
-	cdo2cmo/ml_generator.cmo
+  ML_INTERFACE_OBJ = ocamliface/mltypes.cmo ocamliface/mlstub.cmo
 else
   ML_INTERFACE_OBJ = 
 endif
 
 INSTALL := $(shell which install)
 
-all: cduce dtd2cduce validate
+all: cduce dtd2cduce validate cdo2ml
 
 ifneq ($(ML_INTERFACE), false)
 all: cdml.$(EXTENSION_LIB)
@@ -103,13 +98,12 @@ endif
 install: all
 	mkdir -p $(BINDIR)
 	mkdir -p $(MANDIR)/man1
-	$(INSTALL) -m755 cduce$(EXE) dtd2cduce$(EXE) validate$(EXE) $(BINDIR)/
+	$(INSTALL) -m755 cduce$(EXE) dtd2cduce$(EXE) \
+                         validate$(EXE) cdo2ml$(EXE) $(BINDIR)/
 	$(INSTALL) -m644 doc/cduce.1 $(MANDIR)/man1/
 	$(INSTALL) -m644 doc/dtd2cduce.1 $(MANDIR)/man1/
 	$(INSTALL) -m644 doc/validate.1 $(MANDIR)/man1/
-
 ifneq ($(ML_INTERFACE), false)
-install_cdml:
 	$(OCAMLFIND) install cduce META \
          cdml.$(EXTENSION_LIB) cdo2cmo/cdml.cmi \
          cDuce_all.cmi oCaml_all.$(EXTENSION_LIB) \
@@ -117,8 +111,11 @@ install_cdml:
 endif
 
 uninstall:
-	rm $(BINDIR)/cduce$(EXE) $(BINDIR)/dtd2cduce$(EXE) $(BINDIR)/validate$(EXE)
-	rm $(MANDIR)/man1/cduce.1 $(MANDIR)/man1/dtd2cduce.1 $(MANDIR)/man1/validate.1
+	rm -f $(BINDIR)/cduce$(EXE) $(BINDIR)/dtd2cduce$(EXE) \
+	  $(BINDIR)/validate$(EXE) $(BINDIR)/cdo2ml$(EXE)
+	rm -f $(MANDIR)/man1/cduce.1 $(MANDIR)/man1/dtd2cduce.1 \
+	  $(MANDIR)/man1/validate.1
+	ocamlfind remove cduce
 
 help:
 	@echo "GOALS"
@@ -136,7 +133,7 @@ help:
 
 # Source directories 
 
-DIRS = misc parser schema typing types compile runtime driver query cdo2cmo
+DIRS = misc parser schema typing types compile runtime driver query cdo2cmo ocamliface
 CLEAN_DIRS = $(DIRS) tools tests
 
 # Objects to build
@@ -193,6 +190,10 @@ ALL_OBJECTS = $(OBJECTS) $(CQL_OBJECTS) \
  $(CQL_OBJECTS_RUN)
 ALL_INTERFACES = schema/schema_types.mli 
 
+ifneq ($(ML_INTERFACE), false)
+  ALL_INTERFACES += ocamliface/mltypes.mli ocamluface/mlstub.mli
+endif
+
 DEPEND = $(ALL_OBJECTS:.cmo=.ml) $(ALL_OBJECTS:.cmo=.mli) $(ALL_INTERFACES)
 
 INCLUDES = $(DIRS:%=-I %)
@@ -233,6 +234,9 @@ dtd2cduce: $(DTD2CDUCE:.cmo=.$(EXTENSION))
 validate: $(VALIDATE_OBJECTS:.cmo=.$(EXTENSION)) tools/validate.$(EXTENSION)
 	$(LINK) $(INCLUDES) -o $@ $^
 
+cdo2ml: ocamliface/cdo2ml.ml
+	ocamlc -o $@ -pp camlp4o -I +camlp4 camlp4.cma pr_o.cmo $^
+
 .PHONY: compute_depend
 compute_depend: $(DEPEND_OCAMLDEP)
 	echo $(DEPEND)

compile/compile.ml

@@ -43,6 +43,12 @@ let find x env =
   with Not_found -> 
     failwith ("Compile: cannot find " ^ (Ident.to_string x))
 
+let find_slot x env =
+  match find x env with
+    | Lambda.Ext (_,slot) -> slot
+    | _ -> assert false
+ 
+
 let from_comp_unit = ref (fun cu -> assert false)
 
 let find_ext cu x =

compile/compile.mli

@@ -17,7 +17,7 @@ val enter_global : env -> id -> env
 val enter_globals : env -> id list -> env
 *)
 val find : id -> env -> var_loc
-
+val find_slot : id -> env -> int
 
 val compile_expr : env -> Typed.texpr -> Lambda.expr
 

depend

@@ -73,11 +73,11 @@ compile/lambda.cmo: types/ident.cmo types/patterns.cmi misc/serialize.cmi \
 compile/lambda.cmx: types/ident.cmx types/patterns.cmx misc/serialize.cmx \
     types/types.cmx 
 runtime/value.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
-    types/ident.cmo types/intervals.cmi compile/lambda.cmo types/sequence.cmi \
-    types/types.cmi runtime/value.cmi 
+    types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.cmi \
+    types/sequence.cmi types/types.cmi runtime/value.cmi 
 runtime/value.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
-    types/ident.cmx types/intervals.cmx compile/lambda.cmx types/sequence.cmx \
-    types/types.cmx runtime/value.cmi 
+    types/ident.cmx types/intervals.cmx compile/lambda.cmx misc/ns.cmx \
+    types/sequence.cmx types/types.cmx runtime/value.cmi 
 schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
     runtime/value.cmi schema/schema_types.cmi 
 schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
@@ -220,42 +220,28 @@ driver/librarian.cmx: types/builtin.cmx compile/compile.cmx \
     misc/encodings.cmx runtime/eval.cmx types/ident.cmx compile/lambda.cmx \
     parser/location.cmx parser/parser.cmx misc/serialize.cmx typing/typer.cmx \
     types/types.cmx runtime/value.cmx driver/librarian.cmi 
-cdo2cmo/ml_types.cmo: types/types.cmi 
-cdo2cmo/ml_types.cmx: types/types.cmx 
-cdo2cmo/ml_cduce.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
-    compile/compile.cmi misc/encodings.cmi types/ident.cmo \
-    types/intervals.cmi compile/lambda.cmo driver/librarian.cmi \
-    cdo2cmo/ml_types.cmo misc/ns.cmi types/sequence.cmi typing/typer.cmi \
-    types/types.cmi 
-cdo2cmo/ml_cduce.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
-    compile/compile.cmx misc/encodings.cmx types/ident.cmx \
-    types/intervals.cmx compile/lambda.cmx driver/librarian.cmx \
-    cdo2cmo/ml_types.cmx misc/ns.cmx types/sequence.cmx typing/typer.cmx \
-    types/types.cmx 
-cdo2cmo/ml_ocaml.cmo: driver/librarian.cmi cdo2cmo/ml_types.cmo 
-cdo2cmo/ml_ocaml.cmx: driver/librarian.cmx cdo2cmo/ml_types.cmx 
-cdo2cmo/ml_checker.cmo: cdo2cmo/ml_cduce.cmo cdo2cmo/ml_ocaml.cmo \
-    cdo2cmo/ml_types.cmo 
-cdo2cmo/ml_checker.cmx: cdo2cmo/ml_cduce.cmx cdo2cmo/ml_ocaml.cmx \
-    cdo2cmo/ml_types.cmx 
-cdo2cmo/ml_generator.cmo: cdo2cmo/ml_cduce.cmo cdo2cmo/ml_ocaml.cmo \
-    cdo2cmo/ml_types.cmo 
-cdo2cmo/ml_generator.cmx: cdo2cmo/ml_cduce.cmx cdo2cmo/ml_ocaml.cmx \
-    cdo2cmo/ml_types.cmx 
+ocamliface/mltypes.cmo: cdo2cmo/asttypes.cmo types/ident.cmo types/types.cmi \
+    ocamliface/mltypes.cmi 
+ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx types/types.cmx \
+    ocamliface/mltypes.cmi 
+ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
+    compile/compile.cmi types/ident.cmo ocamliface/mltypes.cmi misc/ns.cmi \
+    types/sequence.cmi typing/typer.cmi types/types.cmi ocamliface/mlstub.cmi 
+ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
+    compile/compile.cmx types/ident.cmx ocamliface/mltypes.cmx misc/ns.cmx \
+    types/sequence.cmx typing/typer.cmx types/types.cmx ocamliface/mlstub.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmi compile/compile.cmi \
     misc/encodings.cmi runtime/eval.cmi runtime/explain.cmi types/ident.cmo \
-    driver/librarian.cmi parser/location.cmi cdo2cmo/ml_cduce.cmo \
-    cdo2cmo/ml_checker.cmo cdo2cmo/ml_generator.cmo cdo2cmo/ml_ocaml.cmo \
-    misc/ns.cmi parser/parser.cmi types/patterns.cmi types/sample.cmi \
-    schema/schema_common.cmi misc/state.cmi typing/typer.cmi types/types.cmi \
-    parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi 
+    driver/librarian.cmi parser/location.cmi ocamliface/mlstub.cmi \
+    ocamliface/mltypes.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
+    types/sample.cmi schema/schema_common.cmi misc/state.cmi typing/typer.cmi \
+    types/types.cmi parser/ulexer.cmi runtime/value.cmi driver/cduce.cmi 
 driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
     misc/encodings.cmx runtime/eval.cmx runtime/explain.cmx types/ident.cmx \
-    driver/librarian.cmx parser/location.cmx cdo2cmo/ml_cduce.cmx \
-    cdo2cmo/ml_checker.cmx cdo2cmo/ml_generator.cmx cdo2cmo/ml_ocaml.cmx \
-    misc/ns.cmx parser/parser.cmx types/patterns.cmx types/sample.cmx \
-    schema/schema_common.cmx misc/state.cmx typing/typer.cmx types/types.cmx \
-    parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi 
+    driver/librarian.cmx parser/location.cmx ocamliface/mlstub.cmx \
+    ocamliface/mltypes.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
+    types/sample.cmx schema/schema_common.cmx misc/state.cmx typing/typer.cmx \
+    types/types.cmx parser/ulexer.cmx runtime/value.cmx driver/cduce.cmi 
 query/query.cmo: parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
     types/chars.cmi types/ident.cmo types/intervals.cmi parser/location.cmi \
     parser/parser.cmi types/types.cmi query/query.cmi 
@@ -331,6 +317,9 @@ compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
     typing/typer.cmi types/types.cmi runtime/value.cmi 
 types/builtin.cmi: typing/typer.cmi runtime/value.cmi 
 driver/librarian.cmi: types/types.cmi 
+ocamliface/mltypes.cmi: cdo2cmo/asttypes.cmo types/types.cmi 
+ocamliface/mlstub.cmi: ocamliface/mltypes.cmi types/types.cmi 
 query/query.cmi: parser/ast.cmo 
 schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
     runtime/value.cmi 
+ocamliface/mltypes.cmi: cdo2cmo/asttypes.cmo types/types.cmi 

driver/cduce.ml

 open Location
 open Ident
 
-ifdef ML_INTERFACE then module ML = Ml_ocaml;;
-
 exception InvalidInputFilename of string
 exception InvalidObjectFilename of string
 
@@ -278,52 +276,17 @@ let topinput = run Parser.top_phrases
 let script = run Parser.prog
 
 ifdef ML_INTERFACE then 
-  let check_ml cu id out_dir out =
-    let fnam = String.copy cu in
-    String.set fnam 0 ( Char.lowercase ( String.get fnam 0 ) );
-
-    let cmi_not_found () =
-      let name = fnam ^ ".mli" in
-      let has_cmi = List.exists (
-	fun dir -> Sys.file_exists ( Filename.concat dir name )
-      ) !Librarian.obj_path in
-      if has_cmi then 
-	Format.eprintf 
-	  "Warning: found %s.mli but no %s.cmi: forgotten compilation?@." 
-	  fnam fnam;
-      String.set fnam 0 ( Char.lowercase ( String.get fnam 0 ) );
-    in
-    let cmi_found file = 
-      try
-	let ml_cu = ML.CompUnit.from_bytecode file cu
-	and cd_cu = Ml_cduce.CompUnit.from_types_cu cu id in
-	Ml_checker.run ml_cu cd_cu;
-	let out = open_out ( Filename.concat out_dir (fnam ^ ".ml") ) in
-	let fmt = Format.formatter_of_out_channel out in
-	Ml_generator.ML.generate fmt fnam ml_cu cd_cu;
-	close_out out 
-      with
-	  OCaml_all.Env.Error e -> 
-	    OCaml_all.Env.report_error Format.err_formatter e;
-	    exit 1
-	    
-    in
-    let name = fnam ^ ".cmi" in
-    let file = 
-      try
-	let file = List.find ( 
-	  fun dir -> Sys.file_exists ( Filename.concat dir name ) 
-	) !Librarian.obj_path in
-	if file = "" then None
-	else Some (Filename.concat file name)
-      with Not_found -> None 
-    in
-    match file with
-      | Some file -> cmi_found file
-      | None -> cmi_not_found ()
-
+  let stub_ml cu id =
+    try
+      let name = String.capitalize cu in
+      let (prolog, values) = Mltypes.read_cmi name in
+      let stub = Mlstub.stub cu id values in
+      Some (prolog,stub)
+    with Not_found ->
+      Printf.eprintf "Warning: no caml interface\n";
+      None
 else 
-  let check_ml cu id out_dir out = ();;
+  let stub_ml cu id = None;;
 
 let compile src out_dir =
   try
@@ -337,8 +300,8 @@ let compile src out_dir =
     let out = Filename.concat out_dir (cu ^ ".cdo") in
     let id = Types.CompUnit.mk (U.mk_latin1 cu) in
     Librarian.compile !verbose id src;
-    Librarian.save id out;
-    check_ml cu id out_dir out;
+    let stub = stub_ml cu id in
+    Librarian.save id out stub;
     exit 0
   with exn -> catch_exn Format.err_formatter exn; exit 1
   

driver/librarian.ml

@@ -29,7 +29,7 @@ let mk (typing,compile,code) =
     status = `Unevaluated;
   }
 
-let magic = "CDUCE:compunit:00002"
+let magic = "CDUCE:compunit:00003"
 
 let obj_path = ref [ "" ]
 
@@ -67,7 +67,7 @@ let find_obj id =
     List.find (fun p -> Sys.file_exists (Filename.concat p base)) !obj_path in
   Filename.concat p base
 
-let save id out =
+let save id out extra =
   protect_op "Save compilation unit";
   let cu = find id in
   C.enter id;
@@ -92,7 +92,7 @@ let save id out =
   let depend = Serialize.Put.run serialize_dep depend in
   let digest = Digest.string raw in
   let oc = open_out out in
-  Marshal.to_channel oc (digest,depend,raw) [];
+  Marshal.to_channel oc (digest,depend,raw,extra) [];
   close_out oc
   
   

driver/librarian.mli

@@ -10,5 +10,5 @@ val compile: bool -> Types.CompUnit.t -> string -> unit
 val run: Types.CompUnit.t -> unit
 val import: Types.CompUnit.t -> unit
 val import_and_run: Types.CompUnit.t -> unit
-val save: Types.CompUnit.t -> string -> unit
+val save: Types.CompUnit.t -> string -> 'a -> unit
 

ocamliface/cdo2ml.ml

+let loc = (-1,-1)
+
+let usage =
+"Usage: cdo2ml <module>.cdo
+
+ Can also be used as a preprocessor for OCaml:
+
+ ocamlc -c -pp cdo2ml -impl <module>.cdo
+" 
+
+let () =
+  let fn = 
+    if Array.length Sys.argv != 2 then (prerr_endline usage; exit 1)
+    else Sys.argv.(1) in
+  let ic = 
+    try open_in (Sys.argv.(1))
+    with Sys_error x ->
+      prerr_endline x;
+      exit 1 in
+  let (digest,depend,raw,extra) = input_value ic in
+  let (prolog,code) = 
+    match extra with
+      | None ->
+	  Printf.eprintf "Error: no stub found in this cdo file !\n";
+	  exit 1
+      | Some x -> x in
+  print_endline "(* Automatically generated by cdo2ml.ml. Do no edit ! *)";
+  print_endline prolog;
+  let code = List.map (fun x -> (x,loc)) code in
+  !Pcaml.print_implem code

ocamliface/mlstub.ml

+#load "q_MLast.cmo";;
+
+(* TODO:
+   - optimizations: generate labels and atoms only once.
+   - implement functions OCaml -> CDuce 
+*)
+
+
+open Mltypes
+open Ident
+
+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 memo_typ = IntHash.create 13
+
+let atom lab = Types.atom (Atoms.atom (Atoms.V.mk_ascii lab))
+let label lab = LabelPool.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 rec typ t =
+  try IntHash.find memo_typ t.uid
+  with Not_found ->
+    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' (false,(LabelMap.from_list_disj l))
+  | Abstract "int" -> Builtin_defs.caml_int
+  | Abstract "char" -> Builtin_defs.char_latin1
+  | Abstract "string" -> Builtin_defs.string_latin1
+  | Builtin ("list", [t]) -> Types.descr (Sequence.star_node (typ t))
+  | _ -> 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 mk_vars l = 
+  let i = ref 0 in
+  List.map (fun t -> incr i; Printf.sprintf "x%i" !i) l
+
+let loc = (-1,-1)
+
+let let_in p e body =
+  <:expr< let $list:[ p, e ]$ in $body$ >>
+
+let atom_ascii lab =
+  <:expr< Value.atom_ascii $str: String.escaped lab$ >>
+
+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 = 
+  let l = List.map (fun (p,e) -> p,None,e) l in
+  <:expr< match $e$ with [ $list:l$ ] >>
+
+let rec matches ine oute = function
+  | [v1;v2] ->
+      let_in <:patt<($lid:v1$,$lid:v2$)>> <:expr< Value.get_pair $ine$ >> oute
+  | v::vl ->
+      let oute = matches <:expr< r >> oute vl in
+      let_in <:patt<($lid:v$,r)>> <:expr< Value.get_pair $ine$ >> oute
+  | [] -> assert false
+
+let list_lit el =
+  List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
+
+(* 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 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< ($list:pl$) >>
+
+
+let rec to_cd e t =
+(*  Format.fprintf Format.std_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 (t,s) -> failwith "to_cd: Arrow. TODO"
+  | Tuple tl -> 
+      (* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
+      let vars = mk_vars tl in
+      let_in (pat_tuple vars) e (tuple (tuple_to_cd tl vars))
+  | 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) -> <:patt< `$lid:lab$ >>, atom_ascii lab
+	     | (lab,Some t) -> 
+		 <:patt< `$lid:lab$ x >>, 
+		 pair (atom_ascii lab) (to_cd <:expr< x >> t)
+	  ) l in
+      pmatch e cases
+  | Variant (l,_) ->
+      (* match <...> with 
+	 | A -> Value.atom_ascii "A" 
+	 | B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
+      *)
+      let cases = 
+	List.map
+	  (function 
+	     | (lab,[]) -> <:patt< $uid:lab$ >>, atom_ascii lab
+	     | (lab,tl) -> 
+		 let vars = mk_vars tl in
+		 <:patt< $uid:lab$ $pat_tuple vars$ >>,
+		 tuple (atom_ascii lab :: tuple_to_cd tl vars)
+	  ) l in
+      pmatch e cases
+  | Record (l,_) ->
+      (* let x = <...> in Value.record [ l1,t1(x.l1); ...; ln,x.ln ] *)
+      let l = 
+	List.map
+	  (fun (lab,t) ->
+	     let e = to_cd <:expr<x.$lid:lab$>> t in
+	     <:expr< ($label_ascii lab$, $e$) >>)
+	  l
+      in
+      let_in <:patt< x >> e <:expr< Value.record $list_lit l$ >>
+      
+  | Abstract "int" -> <:expr< ocaml2cduce_int $e$ >>
+  | Abstract "char" -> <:expr< ocaml2cduce_char $e$ >>
+  | Abstract "string" -> <:expr< ocaml2cduce_string $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$) >>
+  | _ -> assert false
+
+and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
+
+(* CDuce -> OCaml conversions *)
+
+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 to_ml e t =
+(*  Format.fprintf Format.std_formatter "to_ml %a@."
+    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 (t,s) -> 
+      (* fun x -> s(Eval.eval_apply <...> (t(x))) *)
+      let arg = to_cd <:expr< x >> t in
+      let res = to_ml <:expr< Eval.eval_apply $e$ $arg$ >> s in
+      <:expr< fun 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
+      let el = tuple_to_ml tl vars in
+      matches e <:expr< ($list:el$) >> vars
+  | PVariant l ->
+      (* match Value.get_variant <...> with 
+	 | "A",None -> `A 
+	 | "B",Some x -> `B (t(x))
+      *)
+      let cases = 
+	List.map 
+	  (function 
+	     | (lab,None) -> 
+		 <:patt< ($str: String.escaped lab$, None) >>,
+		 <:expr< `$lid:lab$ >>
+	     | (lab,Some t) ->
+		 <:patt< ($str: String.escaped lab$, Some x) >>,
+		 <:expr< `$lid:lab$ $to_ml <:expr< x >> t$ >>
+	  ) l in
+      pmatch <:expr< Value.get_variant $e$ >> cases
+  | Variant (l,false) ->
+      failwith "Private Sum type"
+  | Variant (l,true) ->
+      (* match Value.get_variant <...> with 
+	 | "A",None -> A 
+	 | "B",Some x -> let (x1,r) = x in ... 
+      *)
+      let cases = 
+	List.map 
+	  (function 
+	     | (lab,[]) -> 
+		 <:patt< ($str: String.escaped lab$, None) >>,
+		 (match lab with (* Stupid Camlp4 *)
+		    | "true" -> <:expr< True >>
+		    | "false" -> <:expr< False >>
+		    | lab -> <:expr< $lid:lab$ >>)
+	     | (lab,[t]) ->
+		 <:patt< ($str: String.escaped lab$, Some x) >>,
+		 <:expr< $lid:lab$ $to_ml <:expr< x >> t$ >>
+	     | (lab,tl) ->
+		 let vars = mk_vars tl in
+		 let el = tuple_to_ml tl vars in
+		 <:patt< ($str: String.escaped lab$, Some x) >>,
+		 matches <:expr< x >> <:expr< $lid:lab$ ($list:el$) >> vars
+	  ) l in
+      pmatch <:expr< Value.get_variant $e$ >> cases
+  | Record (l,false) ->
+      failwith "Private Record type"
+  | Record (l,true) ->
+      (* let x = <...> in
+	 { l1 = t1(Value.get_field x "l1"); ... } *)
+      let l = 
+	List.map
+	  (fun (lab,t) ->
+	     (<:patt< $uid:lab$>>,
+	      to_ml <:expr< Value.get_field x $label_ascii lab$ >> t)) l in
+      let_in <:patt< x >> e <:expr< {$list:l$} >>
+
+  | Abstract "int" -> <:expr< cduce2ocaml_int $e$ >>
+  | Abstract "char" -> <:expr< cduce2ocaml_char $e$ >>
+  | Abstract "string" -> <:expr< cduce2ocaml_string $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$) >>
+  | _ -> assert false
+
+and tuple_to_ml tl vars = List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars
+