| 398 |
|
|
| 399 |
let err_ppf = Format.err_formatter |
let err_ppf = Format.err_formatter |
| 400 |
|
|
| 401 |
|
let exts = ref [] |
| 402 |
|
|
| 403 |
let check_value ty_env c_env (s,caml_t,t) = |
let check_value ty_env c_env (s,caml_t,t) = |
| 404 |
(* Find the type for the value in the CDuce module *) |
(* Find the type for the value in the CDuce module *) |
| 405 |
let id = Id.mk (U.mk s) in |
let id = Id.mk (U.mk s) in |
| 438 |
|
|
| 439 |
let stub name ty_env c_env values = |
let stub name ty_env c_env values = |
| 440 |
let items = List.map (check_value ty_env c_env) values in |
let items = List.map (check_value ty_env c_env) values in |
| 441 |
let g = global_transl () in |
let exts = |
| 442 |
|
List.map |
| 443 |
|
(fun (s,i,t) -> |
| 444 |
|
let c = to_cd <:expr< $lid:s$ >> t in |
| 445 |
|
<:str_item< Eval.set_slot cu $int:string_of_int i$ $c$ >> |
| 446 |
|
) !exts in |
| 447 |
|
|
| 448 |
|
|
| 449 |
|
let g = global_transl () in |
| 450 |
|
|
| 451 |
(* open Cdml |
(* open Cdml |
| 452 |
open CDuce_all |
open CDuce_all |
| 453 |
let cu = Cdml.initialize <modname> |
let cu = Cdml.initialize <modname> |
| 454 |
let rec <global translation functions> |
let rec <global translation functions> |
| 455 |
|
<fills external slots> |
| 456 |
|
<run the unit> |
| 457 |
let <stubs for values> |
let <stubs for values> |
| 458 |
*) |
*) |
| 459 |
|
|
| 460 |
[ <:str_item< open Cdml >>; |
[ <:str_item< open Cdml >>; |
| 461 |
<:str_item< open CDuce_all >>; |
<:str_item< open CDuce_all >>; |
| 462 |
<:str_item< value cu = Cdml.initialize $str: String.escaped name$ >>; |
<:str_item< value cu = Cdml.initialize $str: String.escaped name$ >>; |
| 463 |
<:str_item< value types = Librarian.registered_types cu >> |
<:str_item< value types = Librarian.registered_types cu >>; |
| 464 |
|
<:str_item< declare $list:exts$ end >>; |
| 465 |
|
<:str_item< Librarian.run cu >> |
| 466 |
] @ |
] @ |
| 467 |
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @ |
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @ |
| 468 |
[ <:str_item< value $list:items$ >> ] |
[ <:str_item< value $list:items$ >> ] |
| 470 |
|
|
| 471 |
|
|
| 472 |
let () = |
let () = |
| 473 |
Librarian.stub_ml := fun cu ty_env c_env -> |
Librarian.stub_ml := |
| 474 |
|
(fun cu ty_env c_env -> |
| 475 |
try |
try |
| 476 |
let name = String.capitalize cu in |
let name = String.capitalize cu in |
| 477 |
let (prolog, values) = Mltypes.read_cmi name in |
let (prolog, values) = Mltypes.read_cmi name in |
| 481 |
with |
with |
| 482 |
| Mltypes.Error s -> raise (Location.Generic s) |
| Mltypes.Error s -> raise (Location.Generic s) |
| 483 |
| Not_found -> Printf.eprintf "Warning: no caml interface\n"; None, [||] |
| Not_found -> Printf.eprintf "Warning: no caml interface\n"; None, [||] |
| 484 |
|
); |
| 485 |
|
|
| 486 |
|
Externals.register_external := |
| 487 |
|
(fun s i -> |
| 488 |
|
let t = |
| 489 |
|
try Mltypes.find_value s |
| 490 |
|
with Not_found -> |
| 491 |
|
Printf.eprintf "Cannot resolve the external symbol %s\n" s; |
| 492 |
|
exit 1 |
| 493 |
|
in |
| 494 |
|
exts := (s, i, t) :: !exts; |
| 495 |
|
fun () -> Types.descr (typ t) |
| 496 |
|
) |
Parent Directory
| 
Revision Log
| 
Patch