Commit 7ce36d7b authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-06-28 09:40:00 by afrisch] Does not export new values. Avoid non-exhaustive pm.

Original author: afrisch
Date: 2004-06-28 09:40:01+00:00
parent 5a5a933f
#load "q_MLast.cmo";;
let loc = (-1,-1)
let usage =
......@@ -11,6 +13,11 @@ let usage =
let err () = prerr_endline usage; exit 1
let str = String.escaped
let list_lit el =
List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
let () =
let fn,static =
match Array.length Sys.argv with
......@@ -27,7 +34,7 @@ let () =
exit 1 in
let (name,digest,depend,raw,stub) :
string * Digest.t * (string*string) list * string *
(string * MLast.str_item list) option =
(string * 'a) option =
input_value ic in
let (prolog,code) =
match stub with
......@@ -36,21 +43,28 @@ let () =
exit 1
| Some x -> x in
print_endline "(* Automatically generated by cdo2ml.ml. Do no edit ! *)";
print_endline prolog;
if static then
(
Printf.printf
"let cu = CDuce_all.Librarian.register_unit %S %S %S ["
name raw digest;
List.iter (fun (cu,chk) -> Printf.printf "(%S,%S)" cu chk) depend;
Printf.printf "]\n"
)
else
(
Printf.printf "let cu = CDuce_all.Librarian.load_unit %S %S\n"
name digest
);
let cu =
if static then
let dep =
list_lit
(List.map
(fun (cu,chk) -> <:expr< ($str:str cu$,$str:str chk$) >>)
depend)
in
<:expr< CDuce_all.Librarian.register_unit
$str:str name$ $str:str raw$ $str:str digest$ $dep$ >>
else
<:expr< CDuce_all.Librarian.load_unit $str:str name$ $str:str digest$ >>
in
let cu = <:str_item< value cu = $cu$ >> in
print_endline prolog;
let code = List.map (fun x -> (x,loc)) code in
!Pcaml.print_implem code
let (pat,items,exp) = code in
let items = cu :: items in
let str_items =
[ <:str_item<
value $pat$ = let module C = struct $list:items$ end in $exp$ >> ]
in
let str_items = List.map (fun x -> (x,loc)) str_items in
!Pcaml.print_implem str_items
......@@ -288,6 +288,7 @@ and to_ml_descr e = function
(* match Value.get_variant <...> with
| "A",None -> `A
| "B",Some x -> `B (t(x))
| _ -> assert false
*)
let x = mk_var () in
let cases =
......@@ -302,6 +303,7 @@ and to_ml_descr e = function
<: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"
......@@ -332,6 +334,7 @@ and to_ml_descr e = function
matches <:expr< $lid:x$ >>
<:expr< $lid: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"
......@@ -427,9 +430,10 @@ let check_value ty_env c_env (s,caml_t,t) =
(* 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$ >>, e
<:patt< $uid:s$ >>, <:expr< C.$uid:x$ >>, (<:patt< $uid:x$ >>, e)
let stub name ty_env c_env values =
let items = List.map (check_value ty_env c_env) values in
......@@ -443,25 +447,39 @@ let stub name ty_env c_env values =
let g = global_transl () in
(* open Cdml
open CDuce_all
let cu = Cdml.initialize <modname>
let rec <global translation functions>
<fills external slots>
<run the unit>
let <stubs for values>
(*
let (v1,v2,...,vn) =
let module C = struct
let cu = ...
open Cdml
open CDuce_all
let types = ...
let rec <global translation functions>
<fills external slots>
<run the unit>
let <stubs for values>
end in (C.x1,...,C.xn)
*)
[ <:str_item< open Cdml >>;
<:str_item< open CDuce_all >>;
(* <:str_item< value cu = Cdml.initialize $str:String.escaped name$ >>; *)
<:str_item< value types = Librarian.registered_types cu >>;
<:str_item< declare $list:exts$ end >>;
<:str_item< Librarian.run cu >>
] @
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
(if items = [] then [] else [ <:str_item< value $list:items$ >> ])
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 Cdml >>;
<:str_item< open CDuce_all >>;
<:str_item< value types = Librarian.registered_types cu >> ] @
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @
[ <:str_item< declare $list:exts$ end >>;
<: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 () =
......
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