[r2004-03-16 14:22:02 by jdemouth] Correction de bugs -- changement du message d'erreur.

Original author: jdemouth
Date: 2004-03-16 14:22:02+00:00

cdo2cmo/ml_cduce.ml

@@ -72,7 +72,7 @@ and from_decl left array = function
 		let desc = from_desc left array hd in
 		Types.times node desc
 	    | _  ->
-		let tuple = tuple_of_list left array list in
+		let tuple = variant_of_list left array list in
 		Types.times node tuple 
 	  in
 	  Types.cup t desc
@@ -130,8 +130,24 @@ and from_desc left array = function
       node
   | ML_var id -> 
       from_desc left array array.( id )
-  
+
 and tuple_of_list left array list = 
+  let rec internal tail = function 
+    | hd :: [] -> 
+	let node = Types.make () in
+	let desc = from_desc left array hd in
+	Types.define node ( Types.times desc tail );
+	node
+    | hd :: tl ->
+	let node = Types.make () in
+	let desc = from_desc left array hd in
+	Types.define node ( Types.times desc tail );
+	internal node tl 
+    | [] -> assert false in
+  let tail = from_desc left array ( List.hd list ) in
+  internal tail ( List.tl list )  
+
+and variant_of_list left array list = 
   let rec internal tail = function 
     | hd :: [] -> 
 	let node = Types.make () in

cdo2cmo/ml_checker.ml

 ifdef ML_INTERFACE then
 type error =
   | Undefined_value of string * string
-  | Type_mismatch of string * Ml_ocaml.Type.t * Ml_cduce.Type.t
+  | Type_mismatch of string * Ml_ocaml.Type.t * Ml_cduce.Type.t * Ml_cduce.Type.t
 
 ifdef ML_INTERFACE then
 exception Error of error
@@ -12,12 +12,14 @@ let error e = raise ( Error e )
 ifdef ML_INTERFACE then
 let report_error = function
   | Undefined_value ( file, func ) ->
-      Format.eprintf "cdo2cmo : error in file %s.cmi:@." file;
+      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, ml_t, cd_t ) ->
-      Format.eprintf "cdo2cmo : error in file %s.cmi:@." file;
+  | Type_mismatch ( file, ml_t, ml_cd_t, cd_t ) ->
+      Format.eprintf "cduce2ocaml : error in file %s.cmi:@." file;
       Ml_cduce.Type.print Format.err_formatter cd_t;
       Format.eprintf "\nis not a subtype of@.";
+      Ml_cduce.Type.print Format.err_formatter ml_cd_t;
+      Format.eprintf "\nwhich is the canonical translation of@.";
       Ml_ocaml.Type.print Format.err_formatter ( true, [ ml_t ] )
 
 (***********************************************************************************)
@@ -25,6 +27,7 @@ let report_error = function
 ifdef ML_INTERFACE then
 let run ml_cu cd_cu =
   let file = Ml_cduce.CompUnit.module_name cd_cu in
+  String.set file 0 ( Char.lowercase ( String.get file 0 ) );
   try Ml_ocaml.CompUnit.iter (
     fun ( _, list ) -> match list with
       | [ { Ml_types.ml_kind = Ml_types.ML_value } as ml_t ] -> (
@@ -32,7 +35,7 @@ let run ml_cu cd_cu =
 	    let cd_type = Ml_cduce.Type.from_ocaml ml_t
 	    and cd_base = Ml_cduce.CompUnit.find_value cd_cu ml_t.Ml_types.ml_name in
 	    if not ( Ml_cduce.Type.is_subtype cd_base cd_type )
-	    then error ( Type_mismatch ( file, ml_t, cd_base ) );
+	    then error ( Type_mismatch ( file, ml_t, cd_type, cd_base ) );
 	  with Not_found ->
 	    error ( Undefined_value ( file, ml_t.Ml_types.ml_name ) ) )
       | _ -> () 

cdo2cmo/ml_generator.ml

@@ -299,19 +299,23 @@ and dump_code fmt name = function
 	| _ -> assert false in
       let rec print_list n = function
 	| [ d1 ; d2 ] ->
+	    Format.fprintf fmt "(@.";
 	    dump_code fmt ( Format.sprintf "cdo2cmo__%d" n ) d1;
-	    Format.fprintf fmt ",@.";
-	    dump_code fmt ( Format.sprintf "cdo2cmo__%d" ( n + 1 ) ) d2
+	    Format.fprintf fmt "), (@.";
+	    dump_code fmt ( Format.sprintf "cdo2cmo__%d" ( n + 1 ) ) d2;
+	    Format.fprintf fmt ")@."
 	| hd :: tl ->
+	    Format.fprintf fmt "(@.";
 	    dump_code fmt ( Format.sprintf "cdo2cmo__%d" n ) hd;
-	    Format.fprintf fmt ",@.";
+	    Format.fprintf fmt "),@.";
 	    print_list ( n + 1 ) tl 
 	| _ -> assert false in
-      Format.fprintf fmt "let ";
+      Format.fprintf fmt "match %s with " name;
       proj 0 list;
-      Format.fprintf fmt "= %s in (@." name;
+      Format.fprintf fmt "-> (@.";
       print_list 0 list;
-      Format.fprintf fmt ")@."
+      Format.fprintf fmt ")@.";
+      Format.fprintf fmt " | _ -> assert false@."
   | To_OCaml_type id ->
       Format.fprintf fmt "cduce2ocaml__%s %s@." id name
   | To_OCaml_unit ->