Commit 80c5e328 authored by Pietro Abate's avatar Pietro Abate
Browse files

[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
parent b3119cfd
...@@ -193,8 +193,8 @@ let abstr_lab l x res = ...@@ -193,8 +193,8 @@ let abstr_lab l x res =
let rec to_cd e t = let rec to_cd e t =
(* Format.fprintf Format.std_formatter "to_cd %a [uid=%i; recurs=%i]@." (* Format.fprintf Format.err_formatter "to_cd %a [uid=%i; recurs=%i]@."
Mltypes.print t t.uid t.recurs; *) Mltypes.print t t.uid t.recurs; *)
if t.recurs > 0 then <:expr< $lid:to_cd_fun t$ $e$ >> if t.recurs > 0 then <:expr< $lid:to_cd_fun t$ $e$ >>
else to_cd_descr e t.def 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 ...@@ -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 = and to_ml e t =
(* Format.fprintf Format.std_formatter "to_ml %a@." (* Format.fprintf Format.err_formatter "to_ml %a@."
Mltypes.print t; *) Mltypes.print t; *)
if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >> if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
else to_ml_descr e t.def else to_ml_descr e t.def
...@@ -478,7 +478,6 @@ let check_value ty_env c_env (s,caml_t,t) = ...@@ -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; "The interface exports a value %s which is not available in the module@." s;
exit 1 exit 1
in in
(* Compute expected CDuce type *) (* Compute expected CDuce type *)
let et = Types.descr (typ t) in let et = Types.descr (typ t) in
...@@ -541,23 +540,27 @@ let stub ty_env c_env exts values mk prolog = ...@@ -541,23 +540,27 @@ let stub ty_env c_env exts values mk prolog =
$list:m$ $list:m$
end in $items_expr$ >>, (Lexing.dummy_pos, Lexing.dummy_pos) ] in 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; 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 let oc = Unix.open_process_out exe in
Marshal.to_channel oc str_items []; Marshal.to_channel oc str_items [];
flush oc; flush oc;
ignore (Unix.close_process_out oc) ignore (Unix.close_process_out oc) *)
let stub_ml name ty_env c_env exts mk = let stub_ml name ty_env c_env exts mk =
try try
let name = String.capitalize name in 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) = let (prolog, values) =
try Mltypes.read_cmi name try Mltypes.read_cmi name
with Not_found -> ("",[]) in 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 stub ty_env c_env exts values mk prolog
with Mltypes.Error s -> raise (Location.Generic s) with Mltypes.Error s -> raise (Location.Generic s)
......
...@@ -83,6 +83,27 @@ let new_slot () = ...@@ -83,6 +83,27 @@ let new_slot () =
incr counter; incr counter;
{ uid = !counter; recurs = 0; def = Abstract "DUMMY" } { 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 = let builtins =
List.fold_left (fun m x -> StringSet.add x m) StringSet.empty List.fold_left (fun m x -> StringSet.add x m) StringSet.empty
[ [
......
...@@ -17,6 +17,8 @@ and def = ...@@ -17,6 +17,8 @@ and def =
| Var of int | Var of int
val reg_uid: t -> unit
(* Load an external .cmi *) (* Load an external .cmi *)
val has_cmi: string -> bool val has_cmi: string -> bool
val load_module: string -> (string * t) list val load_module: string -> (string * t) list
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment