[r2004-05-14 10:32:34 by jdemouth] New code generator.

Original author: jdemouth
Date: 2004-05-14 10:32:34+00:00

cdo2cmo/cdml.ml

@@ -2,12 +2,32 @@ open CDuce_all
 
 type any
 
+type 'a cd2ml = Value.t -> 'a
+
+type 'a ml2cd = 'a -> Value.t
+
 let initialize modname =
   let cu = Types.CompUnit.mk ( Ident.U.mk_latin1 modname ) in
   Librarian.import cu;
   Librarian.run cu;
   cu
 
+let identity x = x
+
+let mk_atom s = Value.Atom ( Atoms.V.mk_ascii s )
+
+let atom_to_string v = Ns.QName.to_string ( Atoms.V.value v )
+
+let mk_qname s = Ns.mk_ascii "", Encodings.Utf8.mk s
+
+let record_field map s =
+  let pool = Ident.LabelPool.mk ( mk_qname s ) in
+  Ident.LabelMap.assoc pool map
+
+let ocaml2cduce_arrow fa fb f =
+  let func = fun x -> fb ( f ( fa x ) ) in
+  Value.Abstraction ( [], func )
+
 let ocaml2cduce_bool = function 
   | true -> Value.Atom ( Atoms.V.mk_ascii "true" )
   | false -> Value.Atom ( Atoms.V.mk_ascii "false" )
@@ -32,11 +52,68 @@ let cduce2ocaml_int = function
   | Value.Integer i -> Intervals.V.get_int i
   | _ -> assert false
 
+let ocaml2cduce_list f l =
+  Value.sequence ( List.map f l )
+
+let rec cduce2ocaml_list_aux tail f = function
+  | Value.Atom _ -> tail
+  | Value.Pair ( hd, tl ) -> 
+      cduce2ocaml_list_aux ( tail @ [ f hd ] ) f tl
+  | Value.Concat ( l1, l2 ) ->
+      cduce2ocaml_list_aux ( cduce2ocaml_list_aux tail f l1 ) f l2
+  | _ -> assert false
+
+let cduce2ocaml_list f = cduce2ocaml_list_aux [] f
+
+let ocaml2cduce_option f = function
+  | None -> Value.nil
+  | Some value -> f value
+
+let cduce2ocaml_option f = function
+  | Value.Atom v when Ns.QName.to_string ( Atoms.V.value v ) = "nil" -> None
+  | value -> Some ( f value )
+
+let ocaml2cduce_unit () =
+  Value.sequence []
+
+let cduce2ocaml_unit = fun _ -> ()
+
+let ocaml2cduce_ref f1 f2 r =
+  let nget = Ns.mk_ascii "", Encodings.Utf8.mk "get" in
+  let fget = fun _ -> f1 !r in
+  let fget = Value.Abstraction ( [], fget ) in
+  let nset = Ns.mk_ascii "", Encodings.Utf8.mk "set" in
+  let fset = fun v -> r := f2 v; ocaml2cduce_unit () in
+  let fset = Value.Abstraction ( [], fset ) in
+  Value.vrecord [ nget, fget; nset, fset ]
+
+let cduce2ocaml_ref f = function
+  | _ -> assert false
+
 let ocaml2cduce_string s =
   Value.string_latin1 s
 
 let cduce2ocaml_string s = 
   Value.get_string_latin1 s
 
-let ocaml2cduce_unit () =
-  Value.sequence []
+let ocaml2cduce_tuple_2 fa fb ( a, b ) =
+  Value.Pair ( fa a, fb b )
+
+let ocaml2cduce_tuple_3 fa fb fc ( a, b, c ) =
+  Value.Pair ( fa a, Value.Pair ( fb b, fc c ) )
+
+let ocaml2cduce_tuple_4 fa fb fc fd ( a, b, c, d ) =
+  Value.Pair ( fa a, Value.Pair ( fb b, Value.Pair ( fc c, fd d ) ) )
+
+let cduce2ocaml_tuple_2 fa fb = function
+  | Value.Pair ( a, b ) -> fa a, fb b
+  | _ -> assert false
+
+let cduce2ocaml_tuple_3 fa fb fc = function
+  | Value.Pair ( a, Value.Pair ( b, c ) ) -> fa a, fb b, fc c
+  | _ -> assert false
+
+let cduce2ocaml_tuple_4 fa fb fc fd = function
+  | Value.Pair ( a, Value.Pair ( b, Value.Pair ( c, d ) ) ) ->
+      fa a, fb b, fc c, fd d
+  | _ -> assert false

cdo2cmo/cdml.mli

@@ -3,8 +3,24 @@ type any
 
 open CDuce_all
 
+type 'a cd2ml = Value.t -> 'a
+
+type 'a ml2cd = 'a -> Value.t
+
 val initialize : string -> Types.CompUnit.t
 
+val identity : Value.t -> Value.t
+
+val mk_atom : string -> Value.t
+
+val atom_to_string : Atoms.V.t -> string
+
+val mk_qname : string -> Ns.qname
+
+val record_field : Value.t Ident.label_map -> string -> Value.t
+
+val ocaml2cduce_arrow : 'a cd2ml -> 'b ml2cd -> ( 'a -> 'b ) -> Value.t
+
 val ocaml2cduce_bool : bool -> Value.t
 
 val cduce2ocaml_bool : Value.t -> bool
@@ -17,8 +33,34 @@ val ocaml2cduce_int : int -> Value.t
 
 val cduce2ocaml_int : Value.t -> int
 
+val ocaml2cduce_list : 'a ml2cd -> 'a list -> Value.t
+
+val cduce2ocaml_list : 'a cd2ml -> Value.t -> 'a list
+
+val ocaml2cduce_option : 'a ml2cd -> 'a option -> Value.t
+
+val cduce2ocaml_option : 'a cd2ml -> Value.t -> 'a option
+
+val ocaml2cduce_ref : 'a ml2cd -> 'a cd2ml -> 'a ref -> Value.t
+
+val cduce2ocaml_ref : 'a cd2ml -> Value.t -> 'a ref
+
 val ocaml2cduce_string : string -> Value.t
 
 val cduce2ocaml_string : Value.t -> string
 
+val ocaml2cduce_tuple_2 : 'a ml2cd -> 'b ml2cd -> 'a * 'b -> Value.t
+
+val ocaml2cduce_tuple_3 : 'a ml2cd -> 'b ml2cd -> 'c ml2cd -> 'a * 'b * 'c -> Value.t
+
+val ocaml2cduce_tuple_4 : 'a ml2cd -> 'b ml2cd -> 'c ml2cd -> 'd ml2cd -> 'a * 'b * 'c * 'd -> Value.t
+
+val cduce2ocaml_tuple_2 : 'a cd2ml -> 'b cd2ml -> Value.t -> 'a * 'b
+
+val cduce2ocaml_tuple_3 : 'a cd2ml -> 'b cd2ml -> 'c cd2ml -> Value.t -> 'a * 'b * 'c
+
+val cduce2ocaml_tuple_4 : 'a cd2ml -> 'b cd2ml -> 'c cd2ml -> 'd cd2ml -> Value.t -> 'a * 'b * 'c * 'd
+
 val ocaml2cduce_unit : unit -> Value.t
+
+val cduce2ocaml_unit : Value.t -> unit

cdo2cmo/ml_checker.ml

@@ -4,7 +4,7 @@ module Ty = Ml_types
 
 type error =
   | Undefined_value of string * string
-  | Type_mismatch of string * string * ML.Type.t * CD.Type.t * CD.Type.t
+  | Type_mismatch of string * ML.Type.t * CD.Type.t * CD.Type.t
 
 exception Error of error
 
@@ -14,25 +14,25 @@ let report_error = function
   | Undefined_value ( file, func ) ->
       Format.eprintf "cduce2ocaml : error in file %s.cmi:@." file;
       Format.eprintf "Value %s has no counterpart in file %s.cdo@." func file
-  | Type_mismatch ( file, modname, ml_t, ml_cd_t, cd_t ) ->
+  | Type_mismatch ( file, ml_t, ml_cd_t, cd_t ) ->
       Format.eprintf "cduce2ocaml : error in file %s.cmi:@." file;
       CD.Type.print Format.err_formatter cd_t;
       Format.eprintf "\nis not a subtype of@.";
       CD.Type.print Format.err_formatter ml_cd_t;
       Format.eprintf "\nwhich is the canonical translation of@.";
-      ML.Type.print Format.err_formatter modname ml_t
+      ML.Type.print_declaration Format.err_formatter ml_t
 
 (***********************************************************************************)
 
-let hnode_checker file modname cduce_cu hnode = match hnode.Ty.h_nodes with
+let hnode_checker file cduce_cu hnode = match hnode.Ty.h_nodes with
   | [ { Ty.n_kind = Ty.ML_value } as caml_type ] ->
       begin
-	let value_name = ML.ptos ( ML.Function modname ) caml_type.Ty.n_name in
+	let value_name = ML.ptos `Function caml_type.Ty.n_name in
 	try
 	  let cduce_type = CD.Type.from_ocaml caml_type in
 	  let cduce_base = CD.CompUnit.find_value cduce_cu value_name in
 	  if not ( CD.Type.is_subtype cduce_base cduce_type )
-	  then error ( Type_mismatch ( file, modname, hnode, cduce_type, cduce_base ) );
+	  then error ( Type_mismatch ( file, hnode, cduce_type, cduce_base ) );
 	with Not_found ->
 	  error ( Undefined_value ( file, value_name ) )
       end
@@ -43,6 +43,6 @@ let run caml_cu cduce_cu =
   let file = String.copy modname in
   String.set file 0 ( Char.lowercase ( String.get modname 0 ) );
   try 
-    ML.CompUnit.iter ( hnode_checker file modname cduce_cu ) caml_cu
+    ML.CompUnit.iter ( hnode_checker file cduce_cu ) caml_cu
   with Error e -> 
     report_error e; exit 1