[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.mli

+val stub: 
+  string -> Types.CompUnit.t -> (string * Mltypes.t) list -> 
+  MLast.str_item list

ocamliface/mltypes.ml

+(* ocamlc -o mltypes -I .. oCaml_all.cma mltypes.ml *)
+
+
+open OCaml_all
+open Asttypes
+open Types
+
+(* Unfolding of OCaml types *)
+
+let ocaml_env = ref Env.initial
+
+type t = { uid : int; mutable recurs : int; mutable def : def }
+and def =
+  | Link of t
+  | Arrow of t * t
+  | Tuple of t list
+  | PVariant of (string * t option) list  (* Polymorphic variant *)
+  | Variant of (string * t list) list * bool
+  | Record of (string * t) list * bool
+  | Builtin of string * t list
+  | Abstract of string
+
+module IntMap = 
+  Map.Make(struct type t = int let compare : t -> t -> int = compare end)
+module StringMap = 
+  Map.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 (t,s) -> Format.fprintf ppf "%a -> %a" 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 (l,_) -> Format.fprintf ppf "[%a]" (print_sep print_alt " | ") l
+  | Record (l,_) -> Format.fprintf ppf "{%a}" (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
+
+
+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 builtins =
+  List.fold_left (fun m x -> StringMap.add x () m) StringMap.empty
+    ["list"]
+
+let rec unfold seen constrs ty =
+  try
+    let t = IntMap.find ty.id seen in
+    t.recurs <- t.recurs + 1;
+    t
+  with Not_found ->
+    let slot = new_slot () in
+    let seen = IntMap.add ty.id slot seen in
+    let loop = unfold seen constrs in
+    slot.def <-
+    (match ty.desc with
+       | Tarrow (_,t1,t2,_) -> Arrow (loop t1, loop t2)
+       | Ttuple tyl -> Tuple (List.map loop tyl)
+       | Tvariant rd ->
+	   let fields = 
+	     List.map
+	       (fun (lab,f) -> 
+		  match f with
+		    | Rpresent (Some t) -> (lab, Some (loop t))
+		    | Rpresent None -> (lab, None)
+		    | _ -> assert false)
+	       rd.row_fields in
+	   PVariant fields
+       | Tvar -> assert false
+       | Tconstr (p,args,_) ->
+	   let args = List.map loop args in
+	   let pn = Path.name p in
+	   if StringMap.mem pn builtins 
+	   then Builtin (pn,args)
+	   else
+	     let decl = 
+	       try Env.find_type p !ocaml_env
+	       with Not_found ->
+		 failwith ("Cannot resolve path " ^ pn) in
+	     (try
+		let (s,args') = StringMap.find pn constrs in
+		List.iter2 
+		  (fun a a' -> 
+		     if a.uid != a'.uid then 
+		       failwith "Polymorphic recursion forbidden") args args';
+		s.recurs <- s.recurs + 1;
+		Link s
+	      with Not_found ->
+		let seen = 
+		  List.fold_left2 
+		    (fun seen a v -> a.recurs <- a.recurs - 1; IntMap.add v.id a seen)
+		    seen args decl.type_params in
+		let constrs = StringMap.add pn (slot,args) constrs in
+		let loop = unfold seen constrs in
+		(match decl.type_kind, decl.type_manifest with
+		   | Type_variant (cstrs,pub), _ ->
+		       let cstrs =
+			 List.map (fun (cst,f) -> (cst,List.map loop f)) cstrs in
+		       Variant (cstrs, pub = Public)
+		   | Type_record (f,_,pub), _ ->
+		       let f = List.map (fun (l,_,t) -> (l,loop t)) f in
+		       Record (f, pub = Public)
+		   | Type_abstract, Some t ->
+		       Link (loop t)
+		   | Type_abstract, None ->
+		       (match args with
+			  | [] -> Abstract (Path.name p)
+			  | _ -> failwith "Polymorphic abstract type")))
+       | _ -> failwith "Unsupported feature"
+    );
+    slot
+
+let unfold = unfold IntMap.empty StringMap.empty
+
+(* Reading .cmi *)
+
+open Config
+
+let read_cmi name =
+  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}) -> 
+	   values := (Ident.name id, unfold t) :: !values
+       | Tsig_type (id,t) -> 
+	   Format.fprintf ppf "%a@." (Printtyp.type_declaration id) t
+       | _ -> failwith "Unsupported feature in .cmi"
+    ) sg;
+  (Buffer.contents buf, !values)
+
+let _ =
+  Config.load_path := [".";"/home/frisch/godi/lib/ocaml/std-lib"]
+
+(*
+  let (p,d) = Env.lookup_type (Longident.parse (Sys.argv.(1))) Env.initial in
+  match d.type_manifest with
+    | Some ty -> 
+	Format.fprintf Format.std_formatter "%a@." print_slot (unfold ty)
+    | None -> assert false
+*)

ocamliface/mltypes.mli

+open OCaml_all
+open Asttypes
+open Types
+
+type t = { uid : int; mutable recurs : int; mutable def : def }
+and def =
+  | Link of t
+  | Arrow of t * t
+  | Tuple of t list
+  | PVariant of (string * t option) list  (* Polymorphic variant *)
+  | Variant of (string * t list) list * bool
+  | Record of (string * t) list * bool
+  | Builtin of string * t list
+  | Abstract of string
+
+
+val read_cmi: string -> string * (string * t) list
+
+val print : Format.formatter -> t -> unit

runtime/eval.ml

@@ -64,6 +64,7 @@ let pop () =
 let get_global = ref (fun cu pos -> assert false)
 let set_global = ref (fun cu pos -> assert false)
 
+let get_slot cu pos = !get_global cu pos
 
 let eval_var env = function
   | Env i -> env.(i)

runtime/eval.mli

@@ -8,6 +8,8 @@ val eval_binary_op : (int -> (t -> t -> t)) ref
 val get_global: (Types.CompUnit.t -> int -> t) ref
 val set_global: (Types.CompUnit.t -> int -> t -> unit) ref
 
+val get_slot : Types.CompUnit.t -> int -> t
+
 val dump: Format.formatter -> unit
 val push: Value.t -> unit
 val var: var_loc -> t

runtime/value.ml

@@ -53,6 +53,12 @@ let rec sequence = function
   | [] -> nil
   | h::t -> Pair (h, sequence t)
 
+let rec sequence_rev accu = function
+  | [] -> accu
+  | h::t -> sequence_rev (Pair (h,accu)) t
+
+let sequence_rev l = sequence_rev nil l
+
 let concat v1 v2 = 
   match (v1,v2) with
     | (Atom _, v) | (v, Atom _) -> v
@@ -527,3 +533,44 @@ let failwith' s = raise (CDuceExn (string_latin1 s))
 let raise' v = raise (CDuceExn v)
 
 let () = dump_forward := dump_xml
+
+let get_pair v =
+  match normalize v with
+    | Pair (x,y) -> (x,y)
+    | _ -> assert false
+
+(* TODO: tail-rec version of get_sequence *)
+
+let rec get_sequence v =
+  match normalize v with
+    | Pair (x,y) -> x :: (get_sequence y)
+    | _ -> []
+
+let rec get_sequence_rev accu v =
+  match normalize v with
+    | Pair (x,y) -> get_sequence_rev (x::accu) y
+    | _ -> accu
+
+let get_sequence_rev v = get_sequence_rev [] v
+
+  
+let atom_ascii s =
+  Atom (Atoms.V.mk_ascii s)
+
+let get_variant = function
+  | Atom a -> Atoms.V.get_ascii a, None
+  | v -> match normalize v with
+      | Pair (Atom a,x) -> Atoms.V.get_ascii a, Some x
+      | _ -> assert false
+
+let label_ascii s =
+  LabelPool.mk (Ns.empty, U.mk s)
+
+let record l =
+  Record (LabelMap.from_list_disj l)
+
+
+let get_field v l =
+  match v with
+    | Record fields -> LabelMap.assoc l fields
+    | _ -> raise Not_found

runtime/value.mli

@@ -50,6 +50,16 @@ val vbool : bool -> t
 val vrecord : (Ns.qname * t) list -> t
 
 val sequence : t list -> t
+val sequence_rev : t list -> t
+val get_sequence : t -> t list
+val get_sequence_rev : t -> t list
+
+val atom_ascii : string -> t
+val label_ascii : string -> label
+val record : (label * t) list -> t
+val get_field : t -> label -> t
+
+val get_variant : t -> string * t option
 
   (* iterator on the content of an Xml value. First callback is invoked on Utf8
   character children; second callback is invoked on other children values *)
@@ -72,6 +82,8 @@ val get_int : t -> int
   (** @return an associative list of fields from a Record value *)