[r2004-06-28 09:40:00 by afrisch] Does not export new values. Avoid non-exhaustive pm.

Original author: afrisch
Date: 2004-06-28 09:40:01+00:00

ocamliface/cdo2ml.ml

+#load "q_MLast.cmo";;
+
 let loc = (-1,-1)
 
 let usage =
@@ -11,6 +13,11 @@ let usage =
 
 let err () = prerr_endline usage; exit 1
 
+let str = String.escaped
+
+let list_lit el =
+  List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
+
 let () =
   let fn,static = 
     match Array.length Sys.argv with
@@ -27,7 +34,7 @@ let () =
       exit 1 in
   let (name,digest,depend,raw,stub) : 
     string * Digest.t * (string*string) list * string * 
-    (string * MLast.str_item list) option =
+    (string * 'a) option =
     input_value ic in
   let (prolog,code) = 
     match stub with
@@ -36,21 +43,28 @@ let () =
 	  exit 1
       | Some x -> x in
   print_endline "(* Automatically generated by cdo2ml.ml. Do no edit ! *)";
+  print_endline prolog;
 
-  if static then
-    (
-      Printf.printf
-       "let cu = CDuce_all.Librarian.register_unit %S %S %S ["
-       name raw digest;
-      List.iter (fun (cu,chk) -> Printf.printf "(%S,%S)" cu chk) depend;
-      Printf.printf "]\n"
-    ) 
-  else 
-    (
-      Printf.printf "let cu = CDuce_all.Librarian.load_unit %S %S\n"
-       name digest
-    );
+  let cu =
+    if static then
+      let dep = 
+	list_lit 
+	  (List.map 
+	     (fun (cu,chk) -> <:expr< ($str:str cu$,$str:str chk$) >>)
+	     depend)
+      in
+      <:expr< CDuce_all.Librarian.register_unit 
+	$str:str name$ $str:str raw$ $str:str digest$ $dep$ >>
+    else 
+      <:expr< CDuce_all.Librarian.load_unit $str:str name$ $str:str digest$ >>
+  in
+  let cu = <:str_item< value cu = $cu$ >> in
 
-  print_endline prolog;
-  let code = List.map (fun x -> (x,loc)) code in
-  !Pcaml.print_implem code
+  let (pat,items,exp) = code in
+  let items = cu :: items in
+  let str_items = 
+    [ <:str_item< 
+      value $pat$ = let module C = struct $list:items$ end in $exp$ >> ]
+  in
+  let str_items = List.map (fun x -> (x,loc)) str_items in
+  !Pcaml.print_implem str_items

ocamliface/mlstub.ml

@@ -288,6 +288,7 @@ and to_ml_descr e = function
       (* match Value.get_variant <...> with 
 	 | "A",None -> `A 
 	 | "B",Some x -> `B (t(x))
+	 | _ -> assert false
       *)
       let x = mk_var () in
       let cases = 
@@ -302,6 +303,7 @@ and to_ml_descr e = function
 		 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
 		 <:expr< `$lid:lab$ $to_ml ex t$ >>
 	  ) l in
+      let cases = cases @ [ <:patt< _ >>, <:expr< assert false >> ] in
       pmatch <:expr< Value.get_variant $e$ >> cases
   | Variant (l,false) ->
       failwith "Private Sum type"
@@ -332,6 +334,7 @@ and to_ml_descr e = function
 		 matches <:expr< $lid:x$ >> 
 		         <:expr< $lid:lab$ ($list:el$) >> vars
 	  ) l in
+      let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
       pmatch <:expr< Value.get_variant $e$ >> cases
   | Record (l,false) ->
       failwith "Private Record type"
@@ -427,9 +430,10 @@ let check_value ty_env c_env (s,caml_t,t) =
    
   (* Generate stub code *)
   (* let x = t(Eval.get_slot cu slot) *)
+  let x = mk_var () in
   let slot = Compile.find_slot id c_env in
   let e = to_ml <:expr< Eval.get_slot cu $int:string_of_int slot$ >> t in
-  <:patt< $uid:s$ >>, e
+  <:patt< $uid:s$ >>, <:expr< C.$uid:x$ >>, (<:patt< $uid:x$ >>, e)
 
 let stub name ty_env c_env values =
   let items = List.map (check_value ty_env c_env) values in
@@ -443,25 +447,39 @@ let stub name ty_env c_env values =
 
   let g = global_transl () in
 
-  (* open Cdml
-     open CDuce_all
-     let cu = Cdml.initialize <modname>
-     let rec <global translation functions>
-     <fills external slots>
-     <run the unit>
-     let <stubs for values>
+  (* 
+     let (v1,v2,...,vn) = 
+     let module C = struct
+      let cu = ...
+      open Cdml
+      open CDuce_all
+      let types = ...
+      let rec <global translation functions>
+      <fills external slots>
+      <run the unit>
+      let <stubs for values>
+     end in (C.x1,...,C.xn)
   *)
 
-  [ <:str_item< open Cdml >>;
-    <:str_item< open CDuce_all >>;
-(*    <:str_item< value cu = Cdml.initialize $str:String.escaped name$ >>; *)
-    <:str_item< value types = Librarian.registered_types cu >>;
-    <:str_item< declare $list:exts$ end >>;
-    <:str_item< Librarian.run cu >>
-  ] @
-  (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
-  (if items = [] then [] else [ <:str_item< value $list:items$ >> ])
-
+  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 m = 
+    [ <:str_item< open Cdml >>;
+      <:str_item< open CDuce_all >>;
+      <:str_item< value types = Librarian.registered_types cu >> ] @
+    (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
+    [ <:str_item< declare $list:exts$ end >>;
+    <:str_item< Librarian.run cu >> ] @
+    (if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in
+
+  let items_expr = 
+    match items_expr with 
+      | [] -> <:expr< () >> 
+      | l -> <:expr< ($list:l$) >> in
+
+  <:patt< ($list:items_pat$) >>, m, items_expr
 
 
 let () =