[r2005-07-15 13:20:10 by afrisch] Uid clashes + get rid of cdo2ml

Original author: afrisch
Date: 2005-07-15 13:20:10+00:00

ocamliface/mlstub.ml

@@ -193,8 +193,8 @@ let abstr_lab l x res =
 
 
 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; *)
+(*  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
 
@@ -315,8 +315,8 @@ and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl
 
 
 and to_ml e t =
-(*  Format.fprintf Format.std_formatter "to_ml %a@."
-    Mltypes.print t; *)
+(*  Format.fprintf Format.err_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
 
@@ -478,7 +478,6 @@ let check_value ty_env c_env (s,caml_t,t) =
       "The interface exports a value %s which is not available in the module@." s;
       exit 1
   in
-
   (* Compute expected CDuce type *)
   let et = Types.descr (typ t) in
 
@@ -541,23 +540,27 @@ let stub ty_env c_env exts values mk prolog =
 	  $list:m$ 
 	end in $items_expr$ >>, (Lexing.dummy_pos, Lexing.dummy_pos) ] in
 
-  let exe = Filename.concat (Filename.dirname Sys.argv.(0)) "cdo2ml" in
   print_endline prolog;
+  !Pcaml.print_implem str_items
+(*  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)
+  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
-    let exts = match exts with
-      | None -> []
-      | Some exts -> Obj.magic exts in
     stub ty_env c_env exts values mk prolog
   with Mltypes.Error s -> raise (Location.Generic s)
 

ocamliface/mltypes.ml

@@ -83,6 +83,27 @@ 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
     [

ocamliface/mltypes.mli

@@ -17,6 +17,8 @@ and def =
   | Var of int
 
 
+val reg_uid: t -> unit
+
 (* Load an external .cmi *)
 val has_cmi: string -> bool
 val load_module: string -> (string * t) list