mlstub.ml 22.3 KB
Newer Older
1 2
(* TODO:
   - optimizations: generate labels and atoms only once.
3
   - translate record to open record on positive occurence
4 5 6 7
*)

open Mltypes
open Ident
8 9 10
open Camlp4.PreCast

let _loc = Loc.ghost
11

12
module IntMap =
13 14 15 16 17 18 19
  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 *)

20 21
let vars = ref [||]

22 23 24
let memo_typ = IntHash.create 13

let atom lab = Types.atom (Atoms.atom (Atoms.V.mk_ascii lab))
25
let label lab = Label.mk (Ns.empty, U.mk lab)
26 27
let bigcup f l = List.fold_left (fun accu x -> Types.cup accu (f x)) Types.empty l

28 29 30 31 32 33
let id s =
  let rec aux i : Ast.ident =
    try
      let j = String.index_from s i '.' in
      <:ident< $uid:String.sub s i (j - i)$.$aux (j+1)$ >>
    with Not_found ->
34
      <:ident< $uid:String.sub s i (String.length s - i)$ >>
35 36 37 38
  in
(*  Printf.eprintf "*** %S\n" s; *)
  aux 0

39 40 41 42 43 44 45 46 47 48
let consId s =
  let rec aux i : Ast.ident =
    try
      let j = String.index_from s i '.' in
      <:ident< $uid:String.sub s i (j - i)$.$aux (j+1)$ >>
    with Not_found ->
      <:ident< $uid:String.sub s i (String.length s - i)$ >>
  in
  aux 0

49
let ident_to_string list =
Julien Lopez's avatar
Julien Lopez committed
50
  List.map (fun (id, x) -> id.Caml_cduce.Ident.name, x) list
51

52 53 54
let rec typ t =
  try IntHash.find memo_typ t.uid
  with Not_found ->
55
(*    print_int t.uid; print_char ' '; flush stdout; *)
56 57 58 59 60 61 62
    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
63
  | Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
64 65
  | Tuple tl -> Types.tuple (List.map typ tl)
  | PVariant l -> bigcup pvariant l
66
  | Variant (_,l,_) -> bigcup variant l
67 68 69
  | Record (_,l,_) -> let l = ident_to_string l in
		      let l = List.map (fun (lab,t) -> label lab, typ t) l in
		      Types.record_fields (false, (LabelMap.from_list_disj l))
70 71 72
  | Abstract "int" -> Builtin_defs.caml_int
  | Abstract "char" -> Builtin_defs.char_latin1
  | Abstract "string" -> Builtin_defs.string_latin1
73
  | Abstract s -> Types.abstract (Types.Abstracts.atom s)
74 75
  | Builtin ("list", [t])
  | Builtin ("array", [t]) -> Types.descr (Sequence.star_node (typ t))
76
  | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
77
  | Builtin ("Big_int.big_int", []) -> Builtin_defs.int
78
  | Builtin ("Cduce_lib.Value.t", []) -> Types.any
79
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) -> Builtin_defs.string
80
  | Builtin ("Cduce_lib.Atoms.V.t", []) -> Builtin_defs.atom
81
  | Builtin ("unit", []) -> Sequence.nil_type
82
  | Builtin ("option", [t]) -> Sequence.option (typ t)
83
  | Var i -> Types.descr (!vars).(i)
84
  | _ -> assert false
85

86 87 88 89 90
and pvariant = function
  | (lab, None) -> atom lab
  | (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)

and variant = function
91 92 93 94
  | (lab, [], None) -> atom lab.Caml_cduce.Ident.name
  | (lab, [], Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ [o])
  | (lab, c, Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ (c@[o]))
  | (lab, c, None) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ c)
95 96 97 98


(* Syntactic tools *)

99 100 101 102
let var_counter = ref 0
let mk_var _ =
  incr var_counter;
  Printf.sprintf "x%i" !var_counter
103

104
let mk_vars = List.map mk_var
105 106 107 108 109 110 111

let atom_ascii lab =
  <:expr< Value.atom_ascii $str: String.escaped lab$ >>

let label_ascii lab =
  <:expr< Value.label_ascii $str: String.escaped lab$ >>

112
let pair e1 e2 = <:expr< Value.Pair ($e1$,$e2$, Value.Mono) >>
113

114
let pmatch e l =
115 116 117 118
  <:expr< match $e$ with [ $list:l$ ] >>

let rec matches ine oute = function
  | [v1;v2] ->
119
      <:expr< let ($lid:v1$,$lid:v2$) = Value.get_pair $ine$ in $oute$ >>
120
  | v::vl ->
121 122
      let r = mk_var () in
      let oute = matches <:expr< $lid:r$ >> oute vl in
123
      <:expr< let ($lid:v$,$lid:r$) = Value.get_pair $ine$ in $oute$ >>
124 125 126 127 128
  | [] -> assert false

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

129 130 131 132 133 134
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
135
	<:expr< let $lid:x$ = $e$ in $r$ >>
136

137 138
(* Registered types *)

139
let gen_types = ref true
140 141
(* currently always off *)

142

143 144 145 146 147
module HashTypes = Hashtbl.Make(Types)
let registered_types = HashTypes.create 13
let nb_registered_types = ref 0

let register_type t =
148
  assert(!gen_types);
149 150 151 152 153 154
  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;
155
      i
156 157 158 159 160 161 162 163
  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

164 165
(* OCaml -> CDuce conversions *)

166

167 168
let to_cd_gen = ref []

169
let to_cd_fun_name t =
170 171 172 173 174 175
  Printf.sprintf "to_cd_%i" t.uid

let to_cd_fun t =
  to_cd_gen := t :: !to_cd_gen;
  to_cd_fun_name t

176 177 178 179 180 181 182 183 184
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

185 186
let rec tuple = function
  | [v] -> v
187
  | v::l -> <:expr< Value.Pair ($v$, $tuple l$, Value.Mono) >>
188 189
  | [] -> assert false

190
let pat_tuple vars =
191
  let pl = List.map (fun id -> <:patt< $lid:id$ >>) vars in
192
  <:patt< ($Ast.paCom_of_list pl$) >>
193 194


195 196 197
let call_lab f l x =
  if l = "" then <:expr< $f$ $x$ >>
  else
198
    if l.[0] = '?' then
199 200
      let l = String.sub l 1 (String.length l - 1) in
      <:expr< $f$ (? $l$ : $x$) >>
201
    else
202 203 204 205 206
      <:expr< $f$ (~ $l$ : $x$) >>

let abstr_lab l x res =
  if l = "" then <:expr< fun $lid:x$ -> $res$ >>
  else
207
    if l.[0] = '?' then
208 209 210 211 212 213 214
      let l = String.sub l 1 (String.length l - 1) in
      <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
    else
      <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>



215
let rec to_cd e t =
216 217
(*  Format.fprintf Format.err_formatter "to_cd %a [uid=%i; recurs=%i]@."
    Mltypes.print t t.uid t.recurs;  *)
218
  if t.recurs > 0 then <:expr< $lid:to_cd_fun t$ $e$ >>
219
  else to_cd_descr e t.def
220 221 222

and to_cd_descr e = function
  | Link t -> to_cd e t
223
  | Arrow (l,t,s) ->
224
      (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
225
    protect e
226
      (fun y ->
227 228 229 230 231 232 233 234 235 236
	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
237
	<:expr< Value.Abstraction ($iface$,$abs$, Value.Mono) >>
238
      )
239
  | Tuple tl ->
240
      (* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
241 242
    let vars = mk_vars tl in
    <:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
243
  | PVariant l ->
244 245
      (* match <...> with
	 | `A -> Value.atom_ascii "A"
246 247
	 | `B x -> Value.Pair (Value.atom_ascii "B",t(x))
      *)
248
    let cases =
249
      List.map
250
	(function
251 252 253 254 255
	  | (lab,None) -> <:match_case< `$lid:lab$ -> $atom_ascii lab$ >>
	  | (lab,Some t) -> <:match_case< `$lid:lab$ x ->
	    $pair (atom_ascii lab) (to_cd <:expr< x >> t)$ >>
	) l in
    pmatch e cases
256
  | Variant (p,l,_) ->
257 258
      (* match <...> with
	 | P.A -> Value.atom_ascii "A"
259
	 | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
260
      *)
261
    let cases =
262
      List.map
263
	(function
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
	  | (lab,[],None) ->
	    let pat = match lab.Caml_cduce.Ident.name with (* Stupid Camlp4 *)
	      | "true" -> <:patt< True >>
	      | "false" -> <:patt< False >>
	      | lab -> <:patt< $id: id (p^lab)$ >>
	    in
            <:match_case< $pat$ -> $atom_ascii lab.Caml_cduce.Ident.name$ >>
	  | (lab,tl,Some o) ->
            let vars = mk_vars (tl@[o]) in
            <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
            $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd (tl@[o]) vars)$ >>
	  | (lab,tl,None) ->
            let vars = mk_vars tl in
            <:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
            $tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd tl vars)$ >>
        ) l in
    pmatch e cases
281 282
  | Record (p,l,_) ->
      (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
283
    protect e
284
      (fun x ->
285
	let l =
286 287 288 289 290 291 292
	  List.map
	    (fun (lab,t) ->
	      let lab = lab.Caml_cduce.Ident.name in
	      let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
	      <:expr< ($label_ascii lab$, $e$) >>) l
       in
       <:expr< Value.record $list_lit l$ >>)
293

294 295 296
  | Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
  | Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
  | Abstract "string" -> <:expr< Value.ocaml2cduce_string $e$ >>
297
  | Abstract s -> <:expr< Value.abstract $str:String.escaped s$ $e$ >>
298 299 300
  | Builtin ("list",[t]) ->
      (* Value.sequence_rev (List.rev_map fun_t <...>) *)
      <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ $e$) >>
301 302
  | Builtin ("array",[t]) ->
      <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ (Array.to_list $e$)) >>
303
  | Builtin ("Pervasives.ref",[t]) ->
304
      (* let x = <...> in
305
         Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
306
      protect e
307 308
      (fun e ->
	 let y = mk_var () in
309
	 let tt = if !gen_types then
310
	   let t = register_type (Types.descr (typ t)) in
311
	   <:expr< Some $t$ >>
312 313
	 else
	   <:expr< None >> in
314 315 316 317 318 319
	 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$ >>
      )
320
  | Builtin ("Big_int.big_int", []) ->
321
      <:expr< Value.ocaml2cduce_bigint $e$ >>
322
  | Builtin ("Cduce_lib.Value.t", []) -> e
323
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
324
      <:expr< Value.ocaml2cduce_string_utf8 $e$ >>
325 326
  | Builtin ("Cduce_lib.Atoms.V.t", []) ->
      <:expr< Value.ocaml2cduce_atom $e$ >>
327
  | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
328
  | Var _ -> e
329 330 331
  | Builtin ("option", [t]) ->
      <:expr< Value.ocaml2cduce_option $lid:to_cd_fun t$ $e$ >>

332 333 334 335 336 337 338 339
  | _ -> assert false

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

(* CDuce -> OCaml conversions *)



340
and to_ml (e : Ast.expr) (t : Mltypes.t) =
341 342
(*  Format.fprintf Format.err_formatter "to_ml %a@."
    Mltypes.print t;  *)
343 344 345 346 347
  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
348
  | Arrow (l,t,s) ->
349
      (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
350
      protect e
351 352 353 354
      (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
355
	 abstr_lab l x res
356
      )
357

358
  | Tuple tl ->
359 360 361 362 363 364 365
      (* 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
366
      matches e <:expr< $tuple_to_ml tl vars$ >> vars
367
  | PVariant l ->
368 369
      (* match Value.get_variant <...> with
	 | "A",None -> `A
370
	 | "B",Some x -> `B (t(x))
371
	 | _ -> assert false
372
      *)
373 374 375 376 377
      let cases =
	List.map
	  (function
	     | (lab,None) ->
		 <:match_case<
378
		   ($str: String.escaped lab$, None) -> `$lid:lab$ >>
379
	     | (lab,Some t) ->
380 381
		 let x = mk_var () in
		 let ex = <:expr< $lid:x$ >> in
382
		 <:match_case<
383 384
		   ($str: String.escaped lab$, Some $lid:x$) ->
	           `$lid:lab$ $to_ml ex t$ >>
385
	  ) l in
386
      let cases = cases @ [ <:match_case< _ -> assert False >> ] in
387
      pmatch <:expr< Value.get_variant $e$ >> cases
388
  | Variant (_,l,false) ->
389
      failwith "Private Sum type"
390
  | Variant (p,l,true) ->
391 392 393
      (* match Value.get_variant <...> with
	 | "A",None -> P.A
	 | "B",Some x -> let (x1,r) = x in ...
394
      *)
395 396 397 398
      let cases =
	List.map
	  (function
	     | (lab,[],None) ->
399
	       let lab = lab.Caml_cduce.Ident.name in
400 401
		 let pa = <:patt< ($str: String.escaped lab$, None) >>
		 and e = match lab with (* Stupid Camlp4 *)
402 403
		    | "true" -> <:expr< True >>
		    | "false" -> <:expr< False >>
404 405
		    | lab -> <:expr< $id:id (p ^ lab)$ >> in
		 <:match_case< $pa$ -> $e$ >>
406 407
	     | (lab,[t],None) ->
	       let lab = lab.Caml_cduce.Ident.name in
408 409
		 let x = mk_var () in
		 let ex = <:expr< $lid:x$ >> in
410 411
		 <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
		  $id:id (p ^ lab)$ $to_ml ex t$ >>
412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432
	     | (lab,[],Some o) ->
	       let lab = lab.Caml_cduce.Ident.name in
		 let x = mk_var () in
		 let ex = <:expr< $lid:x$ >> in
		 <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
		  $id:id (p ^ lab)$ $to_ml ex o$ >>
	     | (lab,tl,Some o) ->
	       let lab = lab.Caml_cduce.Ident.name in
		 let vars = mk_vars (tl@[o]) in
		 let x = mk_var () in
		 <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
   	       $ matches
               <:expr< $lid:x$ >> (
                      List.fold_left
                        (fun x (t, id) ->
                          Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
                 <:expr< $id:consId (p ^ lab)$ >>
                        (List.combine (tl@[o]) vars))
                 vars $ >>
	     | (lab,tl,None) ->
	       let lab = lab.Caml_cduce.Ident.name in
433
		 let vars = mk_vars tl in
434
		 let x = mk_var () in
435
		 <:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
436 437 438 439 440 441 442 443
   	       $ matches
               <:expr< $lid:x$ >> (
                      List.fold_left
                        (fun x (t, id) ->
                          Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
                 <:expr< $id:consId (p ^ lab)$ >>
                        (List.combine tl vars))
                 vars $ >>
444
	  ) l in
445
      let cases = cases @ [ <:match_case< _ -> assert False >> ] in
446
      pmatch <:expr< Value.get_variant $e$ >> cases
447
  | Record (_,l,false) ->
448
      failwith "Private Record type"
449
  | Record (p,l,true) ->
450
      (* let x = <...> in
451
	 { P.l1 = t1(Value.get_field x "l1"); ... } *)
452
      protect e
453
      (fun x ->
454
	 let l =
455 456
	   List.map
	     (fun (lab,t) ->
457
	       let lab = lab.Caml_cduce.Ident.name in
458
		let e =
459 460
		  to_ml <:expr< Value.get_field $x$ $label_ascii lab$ >> t in
		<:rec_binding< $id: id (p^lab)$ = $e$ >>) l in
461
	 <:expr< {$list:l$} >>)
462

463 464 465
  | Abstract "int" -> <:expr< Value.cduce2ocaml_int $e$ >>
  | Abstract "char" -> <:expr< Value.cduce2ocaml_char $e$ >>
  | Abstract "string" -> <:expr< Value.cduce2ocaml_string $e$ >>
466
  | Abstract s -> <:expr< Value.get_abstract $e$ >>
467 468 469
  | 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$) >>
470 471 472
  | 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$)) >>
473 474 475 476 477
  | 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$ >>
478
  | Builtin ("Big_int.big_int", []) ->
479
      <:expr< Value.cduce2ocaml_bigint $e$ >>
480
  | Builtin ("Cduce_lib.Value.t", []) -> e
481
  | Builtin ("Cduce_lib.Encodings.Utf8.t", []) ->
482
      <:expr< Value.cduce2ocaml_string_utf8 $e$ >>
483 484
  | Builtin ("Cduce_lib.Atoms.V.t", []) ->
      <:expr< Value.cduce2ocaml_atom $e$ >>
485
  | Builtin ("unit", []) -> <:expr< ignore $e$ >>
486 487
  | Builtin ("option", [t]) ->
      <:expr< Value.cduce2ocaml_option $lid:to_ml_fun t$ $e$ >>
488
  | Var _ -> e
489 490
  | _ -> assert false

491
and tuple_to_ml tl vars =
492
  Ast.exCom_of_list
493
    (List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars)
494 495 496 497 498


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

499
let global_transl () =
500 501 502 503 504 505 506
  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
507
      defs := <:binding< $p$ = $e$ >> :: !defs
508 509 510 511 512 513 514 515 516 517 518 519
    );
    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 *)

520 521
let err_ppf = Format.err_formatter

522 523
let exts = ref []

524
let check_value ty_env c_env (s,caml_t,t) =
525
  (* Find the type for the value in the CDuce module *)
526
  let id = (Ns.empty, U.mk s) in
527
  let vt =
528 529
    try Typer.find_value id ty_env
    with Not_found ->
530 531
      Format.fprintf err_ppf
      "The interface exports a value %s which is not available in the module@." s;
532 533 534 535 536 537 538 539 540
      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
541 542 543 544 545
       err_ppf
       "The type for the value %s is invalid@\n\
        Expected Caml type:@[%a@]@\n\
        Expected CDuce type:@[%a@]@\n\
        Inferred type:@[%a@]@."
546
       s
547
       print_ocaml caml_t
Pietro Abate's avatar
Pietro Abate committed
548 549
       Types.Print.pp_type et
       Types.Print.pp_type vt;
550 551
      exit 1
    );
552

553
  (* Generate stub code *)
554
  let x = mk_var () in
555
  let slot = Compile.find_slot id c_env in
556
  let e = to_ml <:expr< slots.($int:string_of_int slot$) >> t in
557 558 559 560 561 562 563 564 565 566 567 568 569
  <:patt< $lid:s$ >>, <:expr< C.$lid:x$ >>, <:binding< $lid:x$ = $e$ >>

module Cleaner = Camlp4.Struct.CleanAst.Make(Ast)

let cleaner = object
  inherit Cleaner.clean_ast as super
  method str_item st =
    match super#str_item st with
      | <:str_item< value $rec:_$ $ <:binding< >> $ >> ->
	<:str_item< >>
      | x -> x
end

570

571 572
let stub ty_env c_env exts values mk prolog =
  gen_types := false;
573
  let items = List.map (check_value ty_env c_env) values in
574

575
  let exts = List.rev_map (fun (s,t) -> to_cd <:expr< $id:id s$ >> t) exts in
576 577
  let g = global_transl () in

578 579
  let types = get_registered_types () in
  let raw = mk types in
580

581 582 583 584
  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

585 586 587
  let str_items =
    <:str_item<
      value $tup:Ast.paCom_of_list items_pat$ =
588 589 590
        let module C = struct
	  open Cduce_lib;
	  Cduce_config.init_all ();
591
	  value (types,set_externals,slots,run) =
592
	    Librarian.ocaml_stub $str:String.escaped raw$;
593
	  value rec $Ast.biAnd_of_list g$;
594
	  set_externals [|$Ast.exSem_of_list exts$|];
595
	  run ();
596
	  value $Ast.biAnd_of_list items_def$;
597
	end in $tup:Ast.exCom_of_list items_expr$ >> in
598

599
  print_endline prolog;
600 601
  try Printers.OCaml.print_implem (cleaner # str_item str_items)
  with exn -> Format.printf "@."; raise exn
602
(*  let exe = Filename.concat (Filename.dirname Sys.argv.(0)) "cdo2ml" in
603 604 605
  let oc = Unix.open_process_out exe in
  Marshal.to_channel oc str_items [];
  flush oc;
606
  ignore (Unix.close_process_out oc) *)
607

608

609
let stub_ml name ty_env c_env exts mk =
610
  try
611
    let name = String.capitalize name in
612 613 614 615 616 617
    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. *)
618
    let (prolog, values) =
619 620
      try Mltypes.read_cmi name
      with Not_found ->  ("",[]) in
621
    stub ty_env c_env exts values mk prolog
622
  with Mltypes.Error s -> raise (Cduce_loc.Generic s)
623 624


625
let register b s args =
626 627 628 629
  try
    let (t,n) = Mltypes.find_value s in
    let m = List.length args in
    if n <> m then
630
      Cduce_loc.raise_generic
631
	(Printf.sprintf
632 633 634 635 636 637 638
	   "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
639

640 641 642 643
    vars := Array.of_list args;
    let cdt = Types.descr (typ t) in
    vars := [| |];
    i,cdt
644
  with Not_found ->
645
    Cduce_loc.raise_generic
646 647 648 649 650 651
      (Printf.sprintf "Cannot resolve ocaml external %s" s)

(* Generation of wrappers *)

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

660 661
  <:str_item<
    open Cduce_lib;
662
    Cduce_config.init_all ();
663 664
    value rec $Ast.biAnd_of_list g$;
    $Ast.stSem_of_list exts$;
665
  >>
666 667 668 669 670 671 672

let gen_wrapper vals =
  try
    let values = List.fold_left
      (fun accu s ->
	 try (s,fst (Mltypes.find_value s)) :: accu
	 with Not_found ->
673
	   let vals =
674
	     try Mltypes.load_module s
675 676 677 678 679 680 681
	     with Not_found ->
	       failwith ("Cannot resolve " ^ s)
	   in
	   vals @ accu
      ) [] vals in

    wrapper values
682
  with Mltypes.Error s -> raise (Cduce_loc.Generic s)
683

684
let make_wrapper fn =
685 686
  let ic = open_in fn in
  let v = ref [] in
687
  (try while true do
688 689 690
     let s = input_line ic in
     if s <> "" then
       match s.[0] with
691
	 | 'A'..'Z' -> v := s :: !v
692 693
	 | '#' -> ()
	 | _ -> failwith "Error in primitive file: names must start with a capitalized letter"
694
   done
695 696
   with End_of_file -> ());
  let s = gen_wrapper !v in
697 698 699
  Printers.OCaml.print_implem s;
  print_endline "let () = Cduce_loc.obj_path := [";
  List.iter (fun s -> Printf.printf "  %S;\n" s) !Cduce_loc.obj_path;
700 701 702
  print_endline " ];;";
  print_endline "let () = Run.main ();;"

703 704 705 706 707 708 709 710 711 712 713 714 715 716 717

(* 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))))
718
  | Tuple tl ->
719 720 721 722 723 724 725 726 727 728
      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)
*)

729

730
let register () =
731 732
  Typer.has_ocaml_unit :=
    (fun cu -> Mltypes.has_cmi (U.get_str cu));
733
  Librarian.stub_ml := stub_ml;
734
  Externals.register := register;
735 736
  Externals.ext_info := (fun () -> Obj.magic !exts);
  Librarian.make_wrapper := make_wrapper
737

738
let () =
739 740 741
  Cduce_config.register
    "ocaml"
    "OCaml interface"
742
    register