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 loc = (-1,-1)
let usage = let usage =
...@@ -11,6 +13,11 @@ let usage = ...@@ -11,6 +13,11 @@ let usage =
let err () = prerr_endline usage; exit 1 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 () =
let fn,static = let fn,static =
match Array.length Sys.argv with match Array.length Sys.argv with
...@@ -27,7 +34,7 @@ let () = ...@@ -27,7 +34,7 @@ let () =
exit 1 in exit 1 in
let (name,digest,depend,raw,stub) : let (name,digest,depend,raw,stub) :
string * Digest.t * (string*string) list * string * string * Digest.t * (string*string) list * string *
(string * MLast.str_item list) option = (string * 'a) option =
input_value ic in input_value ic in
let (prolog,code) = let (prolog,code) =
match stub with match stub with
...@@ -36,21 +43,28 @@ let () = ...@@ -36,21 +43,28 @@ let () =
exit 1 exit 1
| Some x -> x in | Some x -> x in
print_endline "(* Automatically generated by cdo2ml.ml. Do no edit ! *)"; print_endline "(* Automatically generated by cdo2ml.ml. Do no edit ! *)";
print_endline prolog;
if static then let cu =
( if static then
Printf.printf let dep =
"let cu = CDuce_all.Librarian.register_unit %S %S %S [" list_lit
name raw digest; (List.map
List.iter (fun (cu,chk) -> Printf.printf "(%S,%S)" cu chk) depend; (fun (cu,chk) -> <:expr< ($str:str cu$,$str:str chk$) >>)
Printf.printf "]\n" depend)
) in
else <:expr< CDuce_all.Librarian.register_unit
( $str:str name$ $str:str raw$ $str:str digest$ $dep$ >>
Printf.printf "let cu = CDuce_all.Librarian.load_unit %S %S\n" else
name digest <: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 (pat,items,exp) = code in
let code = List.map (fun x -> (x,loc)) code in let items = cu :: items in
!Pcaml.print_implem code 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 ...@@ -288,6 +288,7 @@ and to_ml_descr e = function
(* match Value.get_variant <...> with (* match Value.get_variant <...> with
| "A",None -> `A | "A",None -> `A
| "B",Some x -> `B (t(x)) | "B",Some x -> `B (t(x))
| _ -> assert false
*) *)
let x = mk_var () in let x = mk_var () in
let cases = let cases =
...@@ -302,6 +303,7 @@ and to_ml_descr e = function ...@@ -302,6 +303,7 @@ and to_ml_descr e = function
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>, <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
<:expr< `$lid:lab$ $to_ml ex t$ >> <:expr< `$lid:lab$ $to_ml ex t$ >>
) l in ) l in
let cases = cases @ [ <:patt< _ >>, <:expr< assert false >> ] in
pmatch <:expr< Value.get_variant $e$ >> cases pmatch <:expr< Value.get_variant $e$ >> cases
| Variant (l,false) -> | Variant (l,false) ->
failwith "Private Sum type" failwith "Private Sum type"
...@@ -332,6 +334,7 @@ and to_ml_descr e = function ...@@ -332,6 +334,7 @@ and to_ml_descr e = function
matches <:expr< $lid:x$ >> matches <:expr< $lid:x$ >>
<:expr< $lid:lab$ ($list:el$) >> vars <:expr< $lid:lab$ ($list:el$) >> vars
) l in ) l in
let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
pmatch <:expr< Value.get_variant $e$ >> cases pmatch <:expr< Value.get_variant $e$ >> cases
| Record (l,false) -> | Record (l,false) ->
failwith "Private Record type" failwith "Private Record type"
...@@ -427,9 +430,10 @@ let check_value ty_env c_env (s,caml_t,t) = ...@@ -427,9 +430,10 @@ let check_value ty_env c_env (s,caml_t,t) =
(* Generate stub code *) (* Generate stub code *)
(* let x = t(Eval.get_slot cu slot) *) (* let x = t(Eval.get_slot cu slot) *)
let x = mk_var () in
let slot = Compile.find_slot id c_env 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 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 stub name ty_env c_env values =
let items = List.map (check_value ty_env c_env) values in let items = List.map (check_value ty_env c_env) values in
...@@ -443,25 +447,39 @@ let stub name ty_env c_env values = ...@@ -443,25 +447,39 @@ let stub name ty_env c_env values =
let g = global_transl () in let g = global_transl () in
(* open Cdml (*
open CDuce_all let (v1,v2,...,vn) =
let cu = Cdml.initialize <modname> let module C = struct
let rec <global translation functions> let cu = ...
<fills external slots> open Cdml
<run the unit> open CDuce_all
let <stubs for values> 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 >>; let items_def = List.map (fun (_,_,d) -> d) items in
<:str_item< open CDuce_all >>; let items_expr = List.map (fun (_,e,_) -> e) items in
(* <:str_item< value cu = Cdml.initialize $str:String.escaped name$ >>; *) let items_pat = List.map (fun (p,_,_) -> p) items in
<:str_item< value types = Librarian.registered_types cu >>;
<:str_item< declare $list:exts$ end >>; let m =
<:str_item< Librarian.run cu >> [ <:str_item< open Cdml >>;
] @ <:str_item< open CDuce_all >>;
(if g = [] then [] else [ <:str_item< value rec $list:g$ >> ]) @ <:str_item< value types = Librarian.registered_types cu >> ] @
(if items = [] then [] else [ <:str_item< value $list:items$ >> ]) (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 () = 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