improving error msg

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/contracts@11004 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

7 files changed, 64 insertions, 9 deletions

diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index effb0fcd2c..a8ef4a2e88 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -357,7 +357,7 @@ and transl_structure fields cc rootpath  = function
 
 
 (* val transl_str_contracts : core_contract list -> 
-                              (Path.t, contract_declaration) Tbl.t ->
+                              (Path.t, contract_declaration) Ident.tbl ->
                               Typedtree.structure -> 
                               Typedtree.structure       *)
 
@@ -422,14 +422,47 @@ let rec transl_str_contracts contract_decls opened_contracts strs =
  | (other_str :: rem) -> other_str :: (transl_str_contracts contract_decls 
 					                    opened_contracts rem)
 	 
+
+(* transl_toplevel_contracts is called in toplevel/toploop.ml 
+   it is for ocaml interactive tool *)
+
+let transl_toplevel_contracts env str = 
+ let rec extract_contracts xs = 
+        match xs with
+           | [] -> ([], Ident.empty)		 
+           | (Tstr_mty_contracts(t) :: rem) ->
+               let (current_contracts, mty_opened_contracts) = extract_contracts rem in 
+               (current_contracts, Ident.merge t mty_opened_contracts)
+	   | (Tstr_opened_contracts(t) :: rem) ->
+	       let (current_contracts, mty_opened_contracts) = extract_contracts rem in
+	       (current_contracts, Ident.merge t mty_opened_contracts) 
+           | ((Tstr_contract (ds)) :: rem) -> 
+	       let (current_contracts, mty_opened_contracts) = extract_contracts rem in	       
+	       (ds@current_contracts, mty_opened_contracts)
+           | (_::rem) -> extract_contracts rem
+  in
+  let (tstr_contracts, mty_opened_contracts) = extract_contracts str in
+  (* Format.fprintf Format.std_formatter "I am translmod 1: %a\n" 
+   (Tbl.print Printtyp.path fmt_contract_declaration) mty_opened_contracts; *)
+  let checked_tstr_contracts = List.map (fun c -> 
+                 let new_c_desc = contract_id_in_contract 
+                                    Ident.empty
+                                    tstr_contracts 
+				    mty_opened_contracts 
+                                    (Some c.ttopctr_id)
+                                    c.ttopctr_desc in
+                 {c with ttopctr_desc = new_c_desc}) tstr_contracts in
+  transl_str_contracts checked_tstr_contracts mty_opened_contracts str 
+
 (* Function trasl_contracts does a typedtree-to-typedtree transformation that 
 transforms contract declarations away i.e. embed it into the definitions. 
 Tstr_contract(ds) contains contracts declared in the current module while
 Tstr_opened_contracts(t) contains imported contracts.
 Function transl_contracts is called in driver/compile.ml *)
 
-and transl_contracts (str, cc) = 
-  let rec extract_contracts xs = 
+
+let transl_contracts (str, cc) = 
+ let rec extract_contracts xs = 
         match xs with
            | [] -> ([], Ident.empty)		 
            | (Tstr_mty_contracts(t) :: rem) ->
@@ -444,6 +477,8 @@ and transl_contracts (str, cc) =
            | (_::rem) -> extract_contracts rem
   in
   let (tstr_contracts, mty_opened_contracts) = extract_contracts str in
+  (* Format.fprintf Format.std_formatter "I am translmod 2: %a\n" 
+  (Tbl.print Printtyp.path fmt_contract_declaration) mty_opened_contracts; *)
   let checked_tstr_contracts = List.map (fun c -> 
                  let new_c_desc = contract_id_in_contract 
                                     Ident.empty
@@ -454,8 +489,7 @@ and transl_contracts (str, cc) =
                  {c with ttopctr_desc = new_c_desc}) tstr_contracts in
   (transl_str_contracts checked_tstr_contracts mty_opened_contracts str, cc)
 
-
-
+ 
 (* Update forward declaration in Translcore *)
 let _ =
   Translcore.transl_module := transl_module
@@ -790,6 +824,8 @@ let transl_toplevel_definition str =
   reset_labels ();
   make_sequence transl_toplevel_item_and_close str
 
+
+
 (* Compile the initialization code for a packed library *)
 
 let get_component = function
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index 4acae94b69..ebe8093c92 100644
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -20,6 +20,7 @@ open Lambda
 
 type module_coercion = Types.module_coercion
 
+val transl_toplevel_contracts : Env.t -> structure -> structure
 val transl_contracts: structure * module_coercion -> structure * module_coercion
 val transl_implementation: string -> structure * module_coercion -> lambda
 val transl_store_phrases: string -> structure -> int * lambda
diff --git a/typing/env.ml b/typing/env.ml
index e5d5de960c..068dd5f40b 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -50,7 +50,7 @@ type t = {
   constrs: (Path.t * constructor_description) Ident.tbl; 
   labels: (Path.t * label_description) Ident.tbl;
   types: (Path.t * type_declaration) Ident.tbl;
-  contracts: (Path.t * contract_declaration) Ident.tbl;
+  contracts: (Path.t * contract_declaration) Ident.tbl; 
   modules: (Path.t * module_type) Ident.tbl;
   modtypes: (Path.t * modtype_declaration) Ident.tbl;
   components: (Path.t * module_components) Ident.tbl;
@@ -278,7 +278,7 @@ and find_cltype =
 and find_constructor = 
   find (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
 and find_contract =
-  find (fun env -> env.contracts) (fun sc -> sc.comp_contracts) 
+  find (fun env -> env.contracts) (fun sc -> sc.comp_contracts)
 
 let fetch_contracts env = env.contracts
 
diff --git a/typing/ident.ml b/typing/ident.ml
index b9221d8f55..0a76e03420 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -220,3 +220,15 @@ let rec map f = function
                                        data = f k.data;
                                        previous = k.previous}, map f r, i)
 
+
+let rec iter f = function
+    Empty -> ()
+  | Node(l, k, r, _) ->
+      iter f l; f k; iter f r
+
+let print_tbl print_key print_data ppf tbl =
+  let print_tbl ppf tbl =
+    iter (fun d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key d.ident print_data d.data)
+      tbl in
+  fprintf ppf "@[<hv 2>[[%a]]@]" print_tbl tbl
+
diff --git a/typing/ident.mli b/typing/ident.mli
index 28c802e9b2..0358192dcd 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -65,3 +65,8 @@ val get_known_new_name: t -> t list -> t
 val merge: 'a tbl -> 'a tbl -> 'a tbl
 val raw_keys: t tbl -> t list
 (* val find: Path.t -> 'a tbl -> 'a *)
+
+
+val print_tbl: (Format.formatter -> t -> unit) -> (Format.formatter -> 'a -> unit) ->
+           Format.formatter -> 'a tbl -> unit
+
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 918630cdd8..0f5a6152ae 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -96,7 +96,8 @@ and expression_desc =
 
 and blame = 
  (*   Blame of Location.t * Path.t option *)
-  | Caller of Location.t * Path.t option * Path.t 
+  | Caller of Location.t * Path.t option (* caller *)
+                         * Path.t (* callee *)
   | Callee of Location.t * Path.t
   | UnknownBlame (* this is to blame the context of the function,
                     which is unknown at callee site *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index e8d42cf45a..68b5fea58c 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -196,7 +196,7 @@ val expression_desc_to_iface: (expression -> Types.expression) ->
                               expression_desc -> Types.expression_desc
 val core_contract_to_iface: core_contract -> Types.core_contract
 val contract_declaration_to_iface: contract_declaration -> Types.contract_declaration
-
+val contract_declaration_from_iface: Types.contract_declaration -> contract_declaration
 val core_contract_from_iface: Types.core_contract -> core_contract
  
 val ensuresC : core_contract -> expression -> blame -> expression_desc