Commit c78699d9 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2004-06-27 21:11:54+00:00
parent 2fb71995
......@@ -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)
......
......@@ -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 =
......
......@@ -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
......
......@@ -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
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
......
......@@ -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
......
......@@ -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
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
#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$ >>