viewcvs.cgi/ocamliface/mlstub.ml

#load "q_MLast.cmo";;

(* TODO:
   - optimizations: generate labels and atoms only once.
   - translate record to open record on positive occurence
*)


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 vars = ref [||]

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_fields (false,(LabelMap.from_list_disj l))
  | Abstract "int" -> Builtin_defs.caml_int
  | Abstract "char" -> Builtin_defs.char_latin1
  | Abstract "string" -> Builtin_defs.string_latin1
  | Abstract s -> Types.abstract (Types.Abstract.atom s)
  | Builtin ("list", [t])
  | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
  | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
  | Builtin ("Big_int.big_int", []) -> Builtin_defs.int
  | Builtin ("Cduce_lib.Value.t", []) -> Types.any
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
  | Builtin ("unit", []) -> Sequence.nil_type
  | Builtin ("option", [t]) -> Sequence.option (typ t)
  | Var i -> Types.descr (!vars).(i)
  | _ -> 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 var_counter = ref 0
let mk_var _ =
  incr var_counter;
  Printf.sprintf "x%i" !var_counter

let mk_vars = List.map mk_var

let loc = (Lexing.dummy_pos,Lexing.dummy_pos)

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 r = mk_var () in
      let oute = matches <:expr< $lid:r$ >> oute vl in
      let_in <:patt<($lid:v$,$lid:r$)>> <:expr< Value.get_pair $ine$ >> oute
  | [] -> assert false

let list_lit el =
  List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>

let protect e f =
  match e with
    | <:expr< $lid:x$ >> -> f e
    | e ->
        let x = mk_var () in
        let r = f <:expr< $lid:x$ >> in
        <:expr< let $lid:x$ = $e$ in $r$ >> 

(* Registered types *)

let gen_types = ref true

module HashTypes = Hashtbl.Make(Types)
let registered_types = HashTypes.create 13
let nb_registered_types = ref 0

let register_type t =
  assert(!gen_types);
  let n =
    try HashTypes.find registered_types t
    with Not_found ->
      let i = !nb_registered_types in
      HashTypes.add registered_types t i;
      incr nb_registered_types;
      i 
  in
  <:expr< types.($int:string_of_int n$) >>

let get_registered_types () =
  let a = Array.make !nb_registered_types Types.empty in
  HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
  a

(* 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 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 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 call_lab f l x =
  if l = "" then <:expr< $f$ $x$ >>
  else
    if l.[0] = '?' then 
      let l = String.sub l 1 (String.length l - 1) in
      <:expr< $f$ (? $l$ : $x$) >>
    else 
      <:expr< $f$ (~ $l$ : $x$) >>

let abstr_lab l x res =
  if l = "" then <:expr< fun $lid:x$ -> $res$ >>
  else
    if l.[0] = '?' then 
      let l = String.sub l 1 (String.length l - 1) in
      <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
    else
      <:expr< fun ~ $l$ : $lid: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; *)
  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 (l,t,s) -> 
      (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
      protect e 
      (fun y ->
         let x = mk_var () in
         let arg = to_ml <:expr< $lid:x$ >> t in
         let res = to_cd (call_lab y l arg) s in
         let abs = <:expr< fun $lid:x$ -> $res$ >> in
         let iface =
           if !gen_types then
             let tt = register_type (Types.descr (typ t)) in
             let ss = register_type (Types.descr (typ s)) in
             <:expr< Some [($tt$,$ss$)] >>
           else <:expr< None >> in
         <:expr< Value.Abstraction ($iface$,$abs$) >>
      )
  | 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 (p,l,_) ->
      (* match <...> with 
         | P.A -> Value.atom_ascii "A" 
         | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
      *)
      let cases = 
        List.map
          (function 
             | (lab,[]) ->
                 let pat = match lab with (* Stupid Camlp4 *)
                    | "true" -> <:patt< True >>
                    | "false" -> <:patt< False >>
                    | lab -> <:patt< $lid:p^lab$ >>
                 in
                 pat, atom_ascii lab
             | (lab,tl) -> 
                 let vars = mk_vars tl in
                 <:patt< $lid:p^lab$ $pat_tuple vars$ >>,
                 tuple (atom_ascii lab :: tuple_to_cd tl vars)
          ) l in
      pmatch e cases
  | Record (p,l,_) ->
      (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
      protect e
      (fun x ->
         let l = 
           List.map
             (fun (lab,t) ->
                let e = to_cd <:expr<$x$.$lid:p^lab$>> t in
                <:expr< ($label_ascii lab$, $e$) >>)
             l
         in
         <:expr< Value.record $list_lit l$ >>)

  | Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
  | Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
  | Abstract "string" -> <:expr< Value.ocaml2cduce_string $e$ >>
  | Abstract s -> <:expr< Value.abstract $str:String.escaped s$ $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$) >>
  | Builtin ("array",[t]) ->
      <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
  | Builtin ("Pervasives.ref",[t]) ->
      (* let x = <...> in 
         Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
      protect e 
      (fun e ->
         let y = mk_var () in
         let tt = if !gen_types then 
           let t = register_type (Types.descr (typ t)) in
           <:expr< Some $t$ >> 
         else
           <:expr< None >> in
         let get_x = <:expr< $e$.val >> in
         let get = <:expr< fun () -> $to_cd get_x t$ >> in
         let tr_y = to_ml <:expr< $lid:y$ >> t in
         let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
         <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
      )
  | Builtin ("Big_int.big_int", []) -> 
      <:expr< Value.ocaml2cduce_bigint $e$ >>
  | Builtin ("Cduce_lib.Value.t", []) -> e
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> 
      <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
  | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
  | Var _ -> e
  | Builtin ("option", [t]) ->
      <:expr< Value.ocaml2cduce_option $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 *)


and 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 (l,t,s) -> 
      (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
      protect e 
      (fun y ->
         let x = mk_var () in
         let arg = to_cd <:expr< $lid:x$ >> t in
         let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
         abstr_lab l 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))
         | _ -> assert false
      *)
      let x = mk_var () in
      let cases = 
        List.map 
          (function 
             | (lab,None) -> 
                 <:patt< ($str: String.escaped lab$, None) >>,
                 <:expr< `$lid:lab$ >>
             | (lab,Some t) ->
                 let x = mk_var () in
                 let ex = <:expr< $lid:x$ >> in
                 <: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"
  | Variant (p,l,true) ->
      (* match Value.get_variant <...> with 
         | "A",None -> P.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:p^lab$ >>)
             | (lab,[t]) ->
                 let x = mk_var () in
                 let ex = <:expr< $lid:x$ >> in
                 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
                 <:expr< $lid:p^lab$ $to_ml ex t$ >>
             | (lab,tl) ->
                 let vars = mk_vars tl in
                 let el = tuple_to_ml tl vars in
                 let x = mk_var () in
                 <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
                 matches <:expr< $lid:x$ >> 
                         <:expr< $lid:p^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"
  | Record (p,l,true) ->
      (* let x = <...> in
         { P.l1 = t1(Value.get_field x "l1"); ... } *)
      protect e 
      (fun x ->
         let l = 
           List.map
             (fun (lab,t) ->
                (<:patt< $lid:p^lab$>>,
                 to_ml 
                 <:expr< Value.get_field $x$ $label_ascii lab$ >> t)) l in
         <:expr< {$list:l$} >>)

  | Abstract "int" -> <:expr< Value.cduce2ocaml_int $e$ >>
  | Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
  | Abstract "string" -> <:expr< Value.cduce2ocaml_string $e$ >>
  | Abstract s -> <:expr< Value.get_abstract $e$ >>
  | Builtin ("list",[t]) ->
      (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
      <:expr< List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$) >>
  | Builtin ("array",[t]) ->
      (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
      <:expr< Array.of_list (List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$)) >>
  | Builtin ("Pervasives.ref",[t]) ->
      (* ref t(Eval.eval_apply (Value.get_field <...> "get") Value.nil)  *)
      let e = <:expr< Value.get_field $e$ $label_ascii "get"$ >> in
      let e = <:expr< Eval.eval_apply $e$ Value.nil >> in
      <:expr< Pervasives.ref $to_ml e t$ >>
  | Builtin ("Big_int.big_int", []) -> 
      <:expr< Value.cduce2ocaml_bigint $e$ >>
  | Builtin ("Cduce_lib.Value.t", []) -> e
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> 
      <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
  | Builtin ("unit", []) -> <:expr< ignore $e$ >>
  | Builtin ("option", [t]) ->
      <:expr< Value.cduce2ocaml_option $lid:to_ml_fun t$ $e$ >>
  | Var _ -> e
  | _ -> assert false

and tuple_to_ml tl vars = List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars


let to_ml_done = IntHash.create 13
let to_cd_done = IntHash.create 13

let global_transl () = 
  let defs = ref [] in
  let rec aux hd tl gen don fun_name to_descr =
    gen := tl;
    if not (IntHash.mem don hd.uid) then (
      IntHash.add don hd.uid ();
      let p = <:patt< $lid:fun_name hd$ >> in
      let e = <:expr< fun x -> $to_descr <:expr< x >> hd.def$ >> in
      defs := (p,e) :: !defs
    );
    loop ()
  and loop () = match !to_cd_gen,!to_ml_gen with
    | hd::tl,_ -> aux hd tl to_cd_gen to_cd_done to_cd_fun_name to_cd_descr
    | _,hd::tl -> aux hd tl to_ml_gen to_ml_done to_ml_fun_name to_ml_descr
    | [],[] -> ()
  in
  loop ();
  !defs

(* Check type constraints and generate stub code *)

let err_ppf = Format.err_formatter

let exts = ref []

let check_value ty_env c_env (s,caml_t,t) =
  (* Find the type for the value in the CDuce module *)
  let id = Id.mk (Ns.empty, U.mk s) in
  let vt = 
    try Typer.find_value id ty_env
    with Not_found ->
      Format.fprintf err_ppf
      "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

  (* Check subtyping *)
  if not (Types.subtype vt et) then
    (
      Format.fprintf
       err_ppf
       "The type for the value %s is invalid@\n\
        Expected Caml type:@[%a@]@\n\
        Expected CDuce type:@[%a@]@\n\
        Inferred type:@[%a@]@."
       s
       print_ocaml caml_t
       Types.Print.print et
       Types.Print.print vt;
      exit 1
    );
   
  (* 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$ >>, <:expr< C.$uid:x$ >>, (<:patt< $uid:x$ >>, e)

let stub name ty_env c_env values =
  gen_types := true;
  let items = List.map (check_value ty_env c_env) values in

  let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $lid:s$ >> t) !exts in
  let g = global_transl () in

  (* 
     let (v1,v2,...,vn) = 
     let module C = struct
      let cu = ...
      open Cduce_lib
      Config.init_all ()
      let types = ...
      let rec <global translation functions>
      <fills external slots>
      <run the unit>
      let <stubs for values>
     end in (C.x1,...,C.xn)
  *)

  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 Cduce_lib >>;
      <:str_item< Config.init_all () >>;
      <:str_item< value types = Librarian.registered_types cu >> ] @
    (if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @    [ <:str_item< Librarian.set_externals cu [|$list:exts$|] >>;
    <: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 stub_ml cu ty_env c_env = 
  try
    let name = String.capitalize cu in
    let (prolog, values) = 
      try Mltypes.read_cmi name
      with Not_found ->  ("",[]) in
    let code = stub cu ty_env c_env values in
    Some (Obj.magic (prolog,code)),
    get_registered_types ()
  with Mltypes.Error s -> raise (Location.Generic s)


let register b s args = 
  try
    let (t,n) = Mltypes.find_value s in
    let m = List.length args in
    if n <> m then
      Location.raise_generic
        (Printf.sprintf 
           "Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
    let i = if b then
      let i = List.length !exts in
      exts := (s, t) :: !exts;
      i
    else
      0 in
    
    vars := Array.of_list args;
    let cdt = Types.descr (typ t) in
    vars := [| |];
    i,cdt
  with Not_found -> 
    Location.raise_generic
      (Printf.sprintf "Cannot resolve ocaml external %s" s)

(* Generation of wrappers *)

let wrapper values =
  gen_types := false;
  let exts = List.rev_map 
    (fun (s,t) ->
       let v = to_cd <:expr< $lid:s$ >> t in
       <:str_item< 
         Librarian.register_static_external $str:String.escaped s$ $v$ >>)
    values in
  let g = global_transl () in

  let m = if g = [] then exts else <:str_item< value rec $list:g$ >>::exts in
  let m = [ <:str_item< open Cduce_lib >>;
            <:str_item< Config.init_all () >>] @ m in

  <:str_item< declare $list:m$ end >>


let gen_wrapper vals =
  try
    let values = List.fold_left
      (fun accu s ->
         try (s,fst (Mltypes.find_value s)) :: accu
         with Not_found ->
           let vals = 
             try Mltypes.load_module s
             with Not_found ->
               failwith ("Cannot resolve " ^ s)
           in
           vals @ accu
      ) [] vals in

    wrapper values
  with Mltypes.Error s -> raise (Location.Generic s)


(* Dynamic coercions *)


(*
let to_cd_dyn = function
  | Link t -> to_cd_dyn e t
  | Arrow (l,t,s) ->
      let tt = Types.descr (typ t) in
      let ss = Types.descr (typ s) in
      let tf = to_ml_dyn t in
      let sf = to_cd_dyn t in
      (fun (f : Obj.repr) ->
         let f = (Obj.magic f : Obj.repr -> Obj.repr) in
         Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
  | Tuple tl -> 
      let fs = List.map to_cd_dyn tl in
      (fun (x : Obj.repr) ->
         let x = (Obj.magic x : Obj.repr array) in
         let rec aux i = function
           | [] -> assert false
           | [f] -> f x.(i)
           | f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
         aux 0 fs)
*)


let register () =
  Typer.has_ocaml_unit :=
    (fun cu -> Mltypes.has_cmi (U.get_str cu));
  Librarian.stub_ml := stub_ml;
  Externals.register := register

let () =
  Config.register 
    "ocaml" 
    "OCaml interface" 
    register
1	abate	1146	#load "q_MLast.cmo";;
2
3			(* TODO:
4			- optimizations: generate labels and atoms only once.
5	abate	1163	- translate record to open record on positive occurence
6	abate	1146	*)
7
8
9			open Mltypes
10			open Ident
11
12			module IntMap =
13			Map.Make(struct type t = int let compare : t -> t -> int = compare end)
14
15			module IntHash =
16			Hashtbl.Make(struct type t = int let hash i = i let equal i j = i == j end)
17
18			(* Compute CDuce type *)
19
20	abate	1167	let vars = ref [\|\|]
21
22	abate	1146	let memo_typ = IntHash.create 13
23
24			let atom lab = Types.atom (Atoms.atom (Atoms.V.mk_ascii lab))
25			let label lab = LabelPool.mk (Ns.empty, U.mk lab)
26			let bigcup f l = List.fold_left (fun accu x -> Types.cup accu (f x)) Types.empty l
27
28			let rec typ t =
29			try IntHash.find memo_typ t.uid
30			with Not_found ->
31			let node = Types.make () in
32			IntHash.add memo_typ t.uid node;
33			Types.define node (typ_descr t.def);
34			node
35
36			and typ_descr = function
37			\| Link t -> typ_descr t.def
38	abate	1172	\| Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
39	abate	1146	\| Tuple tl -> Types.tuple (List.map typ tl)
40			\| PVariant l -> bigcup pvariant l
41	abate	1171	\| Variant (_,l,_) -> bigcup variant l
42			\| Record (_,l,_) ->
43	abate	1146	let l = List.map (fun (lab,t) -> label lab, typ t) l in
44	abate	1609	Types.record_fields (false,(LabelMap.from_list_disj l))
45	abate	1146	\| Abstract "int" -> Builtin_defs.caml_int
46			\| Abstract "char" -> Builtin_defs.char_latin1
47			\| Abstract "string" -> Builtin_defs.string_latin1
48	abate	1151	\| Abstract s -> Types.abstract (Types.Abstract.atom s)
49	abate	1201	\| Builtin ("list", [t])
50			\| Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
51	abate	1148	\| Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
52	abate	1217	\| Builtin ("Big_int.big_int", []) -> Builtin_defs.int
53	abate	1189	\| Builtin ("Cduce_lib.Value.t", []) -> Types.any
54	abate	1215	\| Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
55	abate	1151	\| Builtin ("unit", []) -> Sequence.nil_type
56	abate	1509	\| Builtin ("option", [t]) -> Sequence.option (typ t)
57	abate	1167	\| Var i -> Types.descr (!vars).(i)
58	abate	1146	\| _ -> assert false
59
60			and pvariant = function
61			\| (lab, None) -> atom lab
62			\| (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
63
64			and variant = function
65			\| (lab, []) -> atom lab
66			\| (lab, c) -> Types.tuple (Types.cons (atom lab) :: List.map typ c)
67
68
69			(* Syntactic tools *)
70
71	abate	1152	let var_counter = ref 0
72			let mk_var _ =
73			incr var_counter;
74			Printf.sprintf "x%i" !var_counter
75	abate	1146
76	abate	1152	let mk_vars = List.map mk_var
77	abate	1146
78	abate	1256	let loc = (Lexing.dummy_pos,Lexing.dummy_pos)
79	abate	1146
80			let let_in p e body =
81			<:expr< let $list:[ p, e ]$ in $body$ >>
82
83			let atom_ascii lab =
84			<:expr< Value.atom_ascii $str: String.escaped lab$ >>
85
86			let label_ascii lab =
87			<:expr< Value.label_ascii $str: String.escaped lab$ >>
88
89			let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$) >>
90
91			let pmatch e l =
92			let l = List.map (fun (p,e) -> p,None,e) l in
93			<:expr< match $e$ with [ $list:l$ ] >>
94
95			let rec matches ine oute = function
96			\| [v1;v2] ->
97			let_in <:patt<($lid:v1$,$lid:v2$)>> <:expr< Value.get_pair $ine$ >> oute
98			\| v::vl ->
99	abate	1152	let r = mk_var () in
100			let oute = matches <:expr< $lid:r$ >> oute vl in
101			let_in <:patt<($lid:v$,$lid:r$)>> <:expr< Value.get_pair $ine$ >> oute
102	abate	1146	\| [] -> assert false
103
104			let list_lit el =
105			List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
106
107	abate	1154	let protect e f =
108			match e with
109			\| <:expr< $lid:x$ >> -> f e
110			\| e ->
111			let x = mk_var () in
112			let r = f <:expr< $lid:x$ >> in
113			<:expr< let $lid:x$ = $e$ in $r$ >>
114
115	abate	1152	(* Registered types *)
116
117	abate	1497	let gen_types = ref true
118
119	abate	1152	module HashTypes = Hashtbl.Make(Types)
120			let registered_types = HashTypes.create 13
121			let nb_registered_types = ref 0
122
123			let register_type t =
124	abate	1497	assert(!gen_types);
125	abate	1152	let n =
126			try HashTypes.find registered_types t
127			with Not_found ->
128			let i = !nb_registered_types in
129			HashTypes.add registered_types t i;
130			incr nb_registered_types;
131			i
132			in
133			<:expr< types.($int:string_of_int n$) >>
134
135			let get_registered_types () =
136			let a = Array.make !nb_registered_types Types.empty in
137			HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
138			a
139
140	abate	1146	(* OCaml -> CDuce conversions *)
141
142	abate	1152
143	abate	1146	let to_cd_gen = ref []
144
145			let to_cd_fun_name t =
146			Printf.sprintf "to_cd_%i" t.uid
147
148			let to_cd_fun t =
149			to_cd_gen := t :: !to_cd_gen;
150			to_cd_fun_name t
151
152	abate	1152	let to_ml_gen = ref []
153
154			let to_ml_fun_name t =
155			Printf.sprintf "to_ml_%i" t.uid
156
157			let to_ml_fun t =
158			to_ml_gen := t :: !to_ml_gen;
159			to_ml_fun_name t
160
161	abate	1146	let rec tuple = function
162			\| [v] -> v
163			\| v::l -> <:expr< Value.Pair ($v$, $tuple l$) >>
164			\| [] -> assert false
165
166			let pat_tuple vars =
167			let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
168			<:patt< ($list:pl$) >>
169
170
171	abate	1172	let call_lab f l x =
172			if l = "" then <:expr< $f$ $x$ >>
173			else
174			if l.[0] = '?' then
175			let l = String.sub l 1 (String.length l - 1) in
176			<:expr< $f$ (? $l$ : $x$) >>
177			else
178			<:expr< $f$ (~ $l$ : $x$) >>
179
180			let abstr_lab l x res =
181			if l = "" then <:expr< fun $lid:x$ -> $res$ >>
182			else
183			if l.[0] = '?' then
184			let l = String.sub l 1 (String.length l - 1) in
185			<:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
186			else
187			<:expr< fun ~ $l$ : $lid:x$ -> $res$ >>
188
189
190
191	abate	1146	let rec to_cd e t =
192			(* Format.fprintf Format.std_formatter "to_cd %a [uid=%i; recurs=%i]@."
193			Mltypes.print t t.uid t.recurs; *)
194			if t.recurs > 0 then <:expr< $lid:to_cd_fun t$ $e$ >>
195			else to_cd_descr e t.def
196
197			and to_cd_descr e = function
198			\| Link t -> to_cd e t
199	abate	1172	\| Arrow (l,t,s) ->
200			(* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
201	abate	1154	protect e
202			(fun y ->
203			let x = mk_var () in
204			let arg = to_ml <:expr< $lid:x$ >> t in
205	abate	1172	let res = to_cd (call_lab y l arg) s in
206	abate	1154	let abs = <:expr< fun $lid:x$ -> $res$ >> in
207	abate	1497	let iface =
208			if !gen_types then
209			let tt = register_type (Types.descr (typ t)) in
210			let ss = register_type (Types.descr (typ s)) in
211			<:expr< Some [($tt$,$ss$)] >>
212			else <:expr< None >> in
213			<:expr< Value.Abstraction ($iface$,$abs$) >>
214	abate	1154	)
215	abate	1146	\| Tuple tl ->
216			(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
217			let vars = mk_vars tl in
218			let_in (pat_tuple vars) e (tuple (tuple_to_cd tl vars))
219			\| PVariant l ->
220			(* match <...> with
221			\| `A -> Value.atom_ascii "A"
222			\| `B x -> Value.Pair (Value.atom_ascii "B",t(x))
223			*)
224			let cases =
225			List.map
226			(function
227			\| (lab,None) -> <:patt< `$lid:lab$ >>, atom_ascii lab
228			\| (lab,Some t) ->
229			<:patt< `$lid:lab$ x >>,
230			pair (atom_ascii lab) (to_cd <:expr< x >> t)
231			) l in
232			pmatch e cases
233	abate	1171	\| Variant (p,l,_) ->
234	abate	1146	(* match <...> with
235	abate	1171	\| P.A -> Value.atom_ascii "A"
236			\| P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
237	abate	1146	*)
238			let cases =
239			List.map
240			(function
241	abate	1497	\| (lab,[]) ->
242			let pat = match lab with (* Stupid Camlp4 *)
243			\| "true" -> <:patt< True >>
244			\| "false" -> <:patt< False >>
245			\| lab -> <:patt< $lid:p^lab$ >>
246			in
247			pat, atom_ascii lab
248	abate	1146	\| (lab,tl) ->
249			let vars = mk_vars tl in
250	abate	1171	<:patt< $lid:p^lab$ $pat_tuple vars$ >>,
251	abate	1146	tuple (atom_ascii lab :: tuple_to_cd tl vars)
252			) l in
253			pmatch e cases
254	abate	1171	\| Record (p,l,_) ->
255			(* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
256	abate	1154	protect e
257			(fun x ->
258			let l =
259			List.map
260			(fun (lab,t) ->
261	abate	1171	let e = to_cd <:expr<$x$.$lid:p^lab$>> t in
262	abate	1154	<:expr< ($label_ascii lab$, $e$) >>)
263			l
264			in
265			<:expr< Value.record $list_lit l$ >>)
266	abate	1497
267	abate	1165	\| Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
268			\| Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
269			\| Abstract "string" -> <:expr< Value.ocaml2cduce_string $e$ >>
270	abate	1151	\| Abstract s -> <:expr< Value.abstract $str:String.escaped s$ $e$ >>
271	abate	1146	\| Builtin ("list",[t]) ->
272			(* Value.sequence_rev (List.rev_map fun_t <...>) *)
273			<:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ $e$) >>
274	abate	1201	\| Builtin ("array",[t]) ->
275			<:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
276	abate	1148	\| Builtin ("Pervasives.ref",[t]) ->
277	abate	1154	(* let x = <...> in
278			Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
279			protect e
280			(fun e ->
281			let y = mk_var () in
282	abate	1497	let tt = if !gen_types then
283			let t = register_type (Types.descr (typ t)) in
284			<:expr< Some $t$ >>
285			else
286			<:expr< None >> in
287	abate	1154	let get_x = <:expr< $e$.val >> in
288			let get = <:expr< fun () -> $to_cd get_x t$ >> in
289			let tr_y = to_ml <:expr< $lid:y$ >> t in
290			let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
291			<:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
292			)
293	abate	1217	\| Builtin ("Big_int.big_int", []) ->
294			<:expr< Value.ocaml2cduce_bigint $e$ >>
295	abate	1189	\| Builtin ("Cduce_lib.Value.t", []) -> e
296	abate	1215	\| Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
297			<:expr< Value.ocaml2cduce_string_utf8 $e$ >>
298	abate	1151	\| Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
299	abate	1167	\| Var _ -> e
300	abate	1509	\| Builtin ("option", [t]) ->
301			<:expr< Value.ocaml2cduce_option $lid:to_cd_fun t$ $e$ >>
302
303	abate	1146	\| _ -> assert false
304
305			and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
306
307			(* CDuce -> OCaml conversions *)
308
309
310
311	abate	1152	and to_ml e t =
312	abate	1146	(* Format.fprintf Format.std_formatter "to_ml %a@."
313			Mltypes.print t; *)
314			if t.recurs > 0 then <:expr< $lid:to_ml_fun t$ $e$ >>
315			else to_ml_descr e t.def
316
317			and to_ml_descr e = function
318			\| Link t -> to_ml e t
319	abate	1172	\| Arrow (l,t,s) ->
320			(* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
321	abate	1154	protect e
322			(fun y ->
323			let x = mk_var () in
324			let arg = to_cd <:expr< $lid:x$ >> t in
325			let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
326	abate	1172	abstr_lab l x res
327	abate	1154	)
328	abate	1146
329			\| Tuple tl ->
330			(* let (x1,r) = Value.get_pair <...> in
331			let (x2,r) = Value.get_pair r in
332			...
333			let (xn-1,xn) = Value.get_pair r in
334			(t1(x1),...,tn(xn)) *)
335
336			let vars = mk_vars tl in
337			let el = tuple_to_ml tl vars in
338			matches e <:expr< ($list:el$) >> vars
339			\| PVariant l ->
340			(* match Value.get_variant <...> with
341			\| "A",None -> `A
342			\| "B",Some x -> `B (t(x))
343	abate	1164	\| _ -> assert false
344	abate	1146	*)
345	abate	1152	let x = mk_var () in
346	abate	1146	let cases =
347			List.map
348			(function
349			\| (lab,None) ->
350			<:patt< ($str: String.escaped lab$, None) >>,
351			<:expr< `$lid:lab$ >>
352			\| (lab,Some t) ->
353	abate	1152	let x = mk_var () in
354			let ex = <:expr< $lid:x$ >> in
355			<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
356			<:expr< `$lid:lab$ $to_ml ex t$ >>
357	abate	1146	) l in
358	abate	1171	let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
359	abate	1146	pmatch <:expr< Value.get_variant $e$ >> cases
360	abate	1171	\| Variant (_,l,false) ->
361	abate	1146	failwith "Private Sum type"
362	abate	1171	\| Variant (p,l,true) ->
363	abate	1146	(* match Value.get_variant <...> with
364	abate	1171	\| "A",None -> P.A
365	abate	1146	\| "B",Some x -> let (x1,r) = x in ...
366			*)
367			let cases =
368			List.map
369			(function
370			\| (lab,[]) ->
371			<:patt< ($str: String.escaped lab$, None) >>,
372			(match lab with (* Stupid Camlp4 *)
373			\| "true" -> <:expr< True >>
374			\| "false" -> <:expr< False >>
375	abate	1171	\| lab -> <:expr< $lid:p^lab$ >>)
376	abate	1146	\| (lab,[t]) ->
377	abate	1152	let x = mk_var () in
378			let ex = <:expr< $lid:x$ >> in
379			<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
380	abate	1171	<:expr< $lid:p^lab$ $to_ml ex t$ >>
381	abate	1146	\| (lab,tl) ->
382			let vars = mk_vars tl in
383			let el = tuple_to_ml tl vars in
384	abate	1152	let x = mk_var () in
385			<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
386			matches <:expr< $lid:x$ >>
387	abate	1171	<:expr< $lid:p^lab$ ($list:el$) >> vars
388	abate	1146	) l in
389	abate	1164	let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
390	abate	1146	pmatch <:expr< Value.get_variant $e$ >> cases
391	abate	1171	\| Record (_,l,false) ->
392	abate	1146	failwith "Private Record type"
393	abate	1171	\| Record (p,l,true) ->
394	abate	1146	(* let x = <...> in
395	abate	1171	{ P.l1 = t1(Value.get_field x "l1"); ... } *)
396	abate	1154	protect e
397			(fun x ->
398			let l =
399			List.map
400			(fun (lab,t) ->
401	abate	1171	(<:patt< $lid:p^lab$>>,
402	abate	1154	to_ml
403			<:expr< Value.get_field $x$ $label_ascii lab$ >> t)) l in
404			<:expr< {$list:l$} >>)
405	abate	1146
406	abate	1165	\| Abstract "int" -> <:expr< Value.cduce2ocaml_int $e$ >>
407			\| Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
408			\| Abstract "string" -> <:expr< Value.cduce2ocaml_string $e$ >>
409	abate	1151	\| Abstract s -> <:expr< Value.get_abstract $e$ >>
410	abate	1146	\| Builtin ("list",[t]) ->
411			(* List.rev_map fun_t (Value.get_sequence_rev <...> *)
412			<:expr< List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$) >>
413	abate	1201	\| Builtin ("array",[t]) ->
414			(* List.rev_map fun_t (Value.get_sequence_rev <...> *)
415			<:expr< Array.of_list (List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$)) >>
416	abate	1148	\| Builtin ("Pervasives.ref",[t]) ->
417			(* ref t(Eval.eval_apply (Value.get_field <...> "get") Value.nil) *)
418			let e = <:expr< Value.get_field $e$ $label_ascii "get"$ >> in
419			let e = <:expr< Eval.eval_apply $e$ Value.nil >> in
420			<:expr< Pervasives.ref $to_ml e t$ >>
421	abate	1217	\| Builtin ("Big_int.big_int", []) ->
422			<:expr< Value.cduce2ocaml_bigint $e$ >>
423	abate	1189	\| Builtin ("Cduce_lib.Value.t", []) -> e
424	abate	1215	\| Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
425			<:expr< Value.cduce2ocaml_string_utf8 $e$ >>
426	abate	1151	\| Builtin ("unit", []) -> <:expr< ignore $e$ >>
427	abate	1509	\| Builtin ("option", [t]) ->
428			<:expr< Value.cduce2ocaml_option $lid:to_ml_fun t$ $e$ >>
429	abate	1167	\| Var _ -> e
430	abate	1146	\| _ -> assert false
431
432			and tuple_to_ml tl vars = List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars
433
434
435			let to_ml_done = IntHash.create 13
436			let to_cd_done = IntHash.create 13
437
438			let global_transl () =
439			let defs = ref [] in
440			let rec aux hd tl gen don fun_name to_descr =
441			gen := tl;
442			if not (IntHash.mem don hd.uid) then (
443			IntHash.add don hd.uid ();
444			let p = <:patt< $lid:fun_name hd$ >> in
445			let e = <:expr< fun x -> $to_descr <:expr< x >> hd.def$ >> in
446			defs := (p,e) :: !defs
447			);
448			loop ()
449			and loop () = match !to_cd_gen,!to_ml_gen with
450			\| hd::tl,_ -> aux hd tl to_cd_gen to_cd_done to_cd_fun_name to_cd_descr
451			\| _,hd::tl -> aux hd tl to_ml_gen to_ml_done to_ml_fun_name to_ml_descr
452			\| [],[] -> ()
453			in
454			loop ();
455			!defs
456
457			(* Check type constraints and generate stub code *)
458
459	abate	1147	let err_ppf = Format.err_formatter
460
461	abate	1156	let exts = ref []
462
463	abate	1147	let check_value ty_env c_env (s,caml_t,t) =
464	abate	1146	(* Find the type for the value in the CDuce module *)
465	abate	1495	let id = Id.mk (Ns.empty, U.mk s) in
466	abate	1146	let vt =
467			try Typer.find_value id ty_env
468			with Not_found ->
469	abate	1147	Format.fprintf err_ppf
470			"The interface exports a value %s which is not available in the module@." s;
471	abate	1146	exit 1
472			in
473
474			(* Compute expected CDuce type *)
475			let et = Types.descr (typ t) in
476
477			(* Check subtyping *)
478			if not (Types.subtype vt et) then
479			(
480			Format.fprintf
481	abate	1147	err_ppf
482			"The type for the value %s is invalid@\n\
483			Expected Caml type:@[%a@]@\n\
484			Expected CDuce type:@[%a@]@\n\
485			Inferred type:@[%a@]@."
486	abate	1146	s
487	abate	1147	print_ocaml caml_t
488	abate	1146	Types.Print.print et
489			Types.Print.print vt;
490			exit 1
491			);
492
493			(* Generate stub code *)
494			(* let x = t(Eval.get_slot cu slot) *)
495	abate	1164	let x = mk_var () in
496	abate	1146	let slot = Compile.find_slot id c_env in
497			let e = to_ml <:expr< Eval.get_slot cu $int:string_of_int slot$ >> t in
498	abate	1164	<:patt< $uid:s$ >>, <:expr< C.$uid:x$ >>, (<:patt< $uid:x$ >>, e)
499	abate	1146
500	abate	1152	let stub name ty_env c_env values =
501	abate	1497	gen_types := true;
502	abate	1146	let items = List.map (check_value ty_env c_env) values in
503	abate	1156
504	abate	1177	let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $lid:s$ >> t) !exts in
505	abate	1146	let g = global_transl () in
506
507	abate	1164	(*
508			let (v1,v2,...,vn) =
509			let module C = struct
510			let cu = ...
511	abate	1189	open Cduce_lib
512	abate	1202	Config.init_all ()
513	abate	1164	let types = ...
514			let rec <global translation functions>
515			<fills external slots>
516			<run the unit>
517			let <stubs for values>
518			end in (C.x1,...,C.xn)
519	abate	1146	*)
520
521	abate	1164	let items_def = List.map (fun (_,_,d) -> d) items in
522			let items_expr = List.map (fun (_,e,_) -> e) items in
523			let items_pat = List.map (fun (p,_,_) -> p) items in
524	abate	1146
525	abate	1164	let m =
526	abate	1189	[ <:str_item< open Cduce_lib >>;
527	abate	1202	<:str_item< Config.init_all () >>;
528	abate	1164	<:str_item< value types = Librarian.registered_types cu >> ] @
529	abate	1497	(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @ [ <:str_item< Librarian.set_externals cu [\|$list:exts$\|] >>;
530	abate	1164	<:str_item< Librarian.run cu >> ] @
531			(if items = [] then [] else [ <:str_item< value $list:items_def$ >> ]) in
532	abate	1146
533	abate	1164	let items_expr =
534			match items_expr with
535			\| [] -> <:expr< () >>
536			\| l -> <:expr< ($list:l$) >> in
537	abate	1146
538	abate	1164	<:patt< ($list:items_pat$) >>, m, items_expr
539
540	abate	1497	let stub_ml cu ty_env c_env =
541			try
542			let name = String.capitalize cu in
543			let (prolog, values) =
544			try Mltypes.read_cmi name
545			with Not_found -> ("",[]) in
546			let code = stub cu ty_env c_env values in
547			Some (Obj.magic (prolog,code)),
548			get_registered_types ()
549			with Mltypes.Error s -> raise (Location.Generic s)
550	abate	1164
551	abate	1497
552			let register b s args =
553			try
554			let (t,n) = Mltypes.find_value s in
555			let m = List.length args in
556			if n <> m then
557			Location.raise_generic
558			(Printf.sprintf
559			"Wrong arity for external symbol %s (real arity = %i; given = %i)" s n m);
560			let i = if b then
561			let i = List.length !exts in
562			exts := (s, t) :: !exts;
563			i
564			else
565			0 in
566
567			vars := Array.of_list args;
568			let cdt = Types.descr (typ t) in
569			vars := [\| \|];
570			i,cdt
571			with Not_found ->
572			Location.raise_generic
573			(Printf.sprintf "Cannot resolve ocaml external %s" s)
574
575			(* Generation of wrappers *)
576
577			let wrapper values =
578			gen_types := false;
579			let exts = List.rev_map
580	abate	1509	(fun (s,t) ->
581	abate	1497	let v = to_cd <:expr< $lid:s$ >> t in
582			<:str_item<
583			Librarian.register_static_external $str:String.escaped s$ $v$ >>)
584			values in
585			let g = global_transl () in
586
587			let m = if g = [] then exts else <:str_item< value rec $list:g$ >>::exts in
588			let m = [ <:str_item< open Cduce_lib >>;
589	abate	1508	<:str_item< Config.init_all () >>] @ m in
590	abate	1497
591			<:str_item< declare $list:m$ end >>
592
593
594			let gen_wrapper vals =
595			try
596			let values = List.fold_left
597			(fun accu s ->
598			try (s,fst (Mltypes.find_value s)) :: accu
599			with Not_found ->
600			let vals =
601	abate	1715	try Mltypes.load_module s
602	abate	1497	with Not_found ->
603			failwith ("Cannot resolve " ^ s)
604			in
605			vals @ accu
606			) [] vals in
607
608			wrapper values
609			with Mltypes.Error s -> raise (Location.Generic s)
610
611
612			(* Dynamic coercions *)
613
614
615			(*
616			let to_cd_dyn = function
617			\| Link t -> to_cd_dyn e t
618			\| Arrow (l,t,s) ->
619			let tt = Types.descr (typ t) in
620			let ss = Types.descr (typ s) in
621			let tf = to_ml_dyn t in
622			let sf = to_cd_dyn t in
623			(fun (f : Obj.repr) ->
624			let f = (Obj.magic f : Obj.repr -> Obj.repr) in
625			Value.Abstraction ([tt,ss],fun x -> sf (f (tf x))))
626			\| Tuple tl ->
627			let fs = List.map to_cd_dyn tl in
628			(fun (x : Obj.repr) ->
629			let x = (Obj.magic x : Obj.repr array) in
630			let rec aux i = function
631			\| [] -> assert false
632			\| [f] -> f x.(i)
633			\| f::tl -> Value.Pair (f x.(i), aux (succ i) tl) in
634			aux 0 fs)
635			*)
636
637
638	abate	1188	let register () =
639	abate	1496	Typer.has_ocaml_unit :=
640			(fun cu -> Mltypes.has_cmi (U.get_str cu));
641	abate	1497	Librarian.stub_ml := stub_ml;
642			Externals.register := register
643	abate	1156
644	abate	1188	let () =
645			Config.register
646			"ocaml"
647			"OCaml interface"
648			register