Commit 05fe99a5 authored by Pietro Abate's avatar Pietro Abate
Browse files

[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
parent 6974f756
......@@ -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
......
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 ) ) )
| _ -> ()
......
......@@ -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 ->
......
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