binary-annot: new version saving .types file even when a typing error occurs

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

7 files changed, 117 insertions, 40 deletions

diff --git a/ChangeLog.txt b/ChangeLog.txt
new file mode 100644
index 0000000000..4edf3439a8
--- /dev/null
+++ b/ChangeLog.txt
@@ -0,0 +1,10 @@
+2010-11-13:
+ * Introduced new type to save partial typedtrees in case of error:
+    * [| Saved_implementation str |] if no error
+    * An array of Typedtree.Saved_... otherwise
+
+2010-11-11: first version
+ * Applied previous patch from 3.12.0 on trunk release r10789
+ * Fixed two bugs 
+ * Improved pretty-printing of parsetree
+ * Pass the testsuite with same results as trunk/, except modified locations
diff --git a/README.txt b/README.txt
index fec190ba71..d4a1c43b5e 100644
--- a/README.txt
+++ b/README.txt
@@ -2,10 +2,12 @@ Binary Annotations
 ==================
 
 Author: Fabrice LE FESSANT (INRIA/OCamlPro)
-Date: 2010/11/03-2010/11/11
+Date: 2010/11/03 - 2010/11/13
 
 The goal of this branch is to replace textual .annot files by binary .types
-files, containing the Typedtree of the compiled file.
+files, containing the Typedtree of the compiled file. If compilation
+succeeded, the file contains a [| Saved_implementation str |], and otherwise,
+it contains an array of all the typed nodes that were correctly typed.
 
 - Typedtree has been extended to become a superset of Parsetree
 - It is possible to revert from Typedtree to Parsetree
@@ -33,4 +35,4 @@ val print_structure : Format.formatter -> Parsetree.structure -> unit
 
 Contributions:
   The first version of the parsetree pretty-printer was contributed
-by BER-metaocaml and fixed.
+by BER-metaocaml and improved.
diff --git a/ocaml-binary-annot/typing/typeclass.ml b/ocaml-binary-annot/typing/typeclass.ml
index 329c48fdf9..a5aa7a151c 100644
--- a/ocaml-binary-annot/typing/typeclass.ml
+++ b/ocaml-binary-annot/typing/typeclass.ml
@@ -187,6 +187,7 @@ let rec limited_generalize rv =
 
 (* Record a class type *)
 let rc node =
+  Typedtree.add_saved_type (Saved_class_expr node);
   Stypes.record (Stypes.Ti_class node);
   node
 
diff --git a/ocaml-binary-annot/typing/typecore.ml b/ocaml-binary-annot/typing/typecore.ml
index 0fddab846f..a46ff94444 100644
--- a/ocaml-binary-annot/typing/typecore.ml
+++ b/ocaml-binary-annot/typing/typecore.ml
@@ -91,10 +91,12 @@ let type_object =
   or [Typedtree.pattern] that will end up in the typed AST.
 *)
 let re node =
+  Typedtree.add_saved_type (Saved_expression node);
   Stypes.record (Stypes.Ti_expr node);
   node
 ;;
 let rp node =
+  Typedtree.add_saved_type (Saved_pattern node);
   Stypes.record (Stypes.Ti_pat node);
   node
 ;;
@@ -1721,8 +1723,7 @@ let rec type_exp env sexp =
       let (path, newenv) = !type_open env sexp.pexp_loc lid in
       let exp = type_exp newenv e in
       re { exp with exp_desc = Texp_open (path, exp); }
-
-
+  
 and type_label_exp create env loc ty (lid, sarg) =
   let (path, label) = Typetexp.find_label env sarg.pexp_loc lid in
   begin_def ();
diff --git a/ocaml-binary-annot/typing/typedtree.ml b/ocaml-binary-annot/typing/typedtree.ml
index adb34b4385..9e587b1011 100644
--- a/ocaml-binary-annot/typing/typedtree.ml
+++ b/ocaml-binary-annot/typing/typedtree.ml
@@ -346,6 +346,26 @@ and 'a class_infos =
     ci_variance: (bool * bool) list;
     ci_loc: Location.t }
 
+  
+  
+  
+  
+type saved_type =
+| Saved_implementation of structure
+| Saved_structure of structure
+| Saved_structure_item of structure_item
+| Saved_signature of signature
+| Saved_signature_item of signature_item
+| Saved_expression of expression
+| Saved_module_type of module_type
+| Saved_pattern of pattern
+| Saved_class_expr of class_expr
+  
+let saved_types = ref []
+let get_saved_types () = !saved_types
+let set_saved_types list = saved_types := list
+let add_saved_type s = saved_types := s :: !saved_types
+  
 (* Auxiliary functions over the a.s.t. *)
 
 let iter_pattern_desc f = function
@@ -3371,4 +3391,4 @@ let toplevel_phrase ppf x =
 end
 
 let print_structure = ParsetreePrint.structure
-  
\ No newline at end of file
+  
diff --git a/ocaml-binary-annot/typing/typedtree.mli b/ocaml-binary-annot/typing/typedtree.mli
index 71cd6d6433..78e8a0d699 100644
--- a/ocaml-binary-annot/typing/typedtree.mli
+++ b/ocaml-binary-annot/typing/typedtree.mli
@@ -368,3 +368,20 @@ val untype_structure : structure -> Parsetree.structure
 val untype_signature : signature -> Parsetree.signature
 
 val print_structure : Format.formatter -> Parsetree.structure -> unit
+
+  
+type saved_type =
+| Saved_implementation of structure
+| Saved_structure of structure
+| Saved_structure_item of structure_item
+| Saved_signature of signature
+| Saved_signature_item of signature_item
+| Saved_expression of expression
+| Saved_module_type of module_type
+| Saved_pattern of pattern
+| Saved_class_expr of class_expr
+  
+val get_saved_types : unit -> saved_type list 
+val set_saved_types : saved_type list -> unit
+val add_saved_type : saved_type -> unit
+  
\ No newline at end of file
diff --git a/ocaml-binary-annot/typing/typemod.ml b/ocaml-binary-annot/typing/typemod.ml
index 01f426c2b5..db4bd98fcf 100644
--- a/ocaml-binary-annot/typing/typemod.ml
+++ b/ocaml-binary-annot/typing/typemod.ml
@@ -358,13 +358,19 @@ let transl_modtype_longident loc env lid =
   let (path, info) = Typetexp.find_modtype env loc lid in
   path
 
-let mty desc typ loc = {
+let mkmty desc typ loc = 
+  let mty = {
     mty_desc = desc;
     mty_type = typ;
     mty_loc = loc;
-  }
+    } in
+  Typedtree.add_saved_type (Saved_module_type mty);
+  mty
 
-let mksig desc loc = { sig_desc = desc; sig_loc = loc }
+let mksig desc loc = 
+  let sg = { sig_desc = desc; sig_loc = loc } in
+  Typedtree.add_saved_type (Saved_signature_item sg);
+  sg
 
 (* let signature sg = List.map (fun item -> item.sig_type) sg *)
 
@@ -373,15 +379,15 @@ let rec transl_modtype env smty =
   match smty.pmty_desc with
     Pmty_ident lid ->
       let path = transl_modtype_longident loc env lid in
-      mty (Tmty_ident path) (Mty_ident path) loc
+      mkmty (Tmty_ident path) (Mty_ident path) loc
   | Pmty_signature ssg ->
       let sg = transl_signature env ssg in
-      mty (Tmty_signature sg) (Mty_signature sg.sig_type) loc
+      mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) loc
   | Pmty_functor(param, sarg, sres) ->
       let arg = transl_modtype env sarg in
       let (id, newenv) = Env.enter_module param arg.mty_type env in
       let res = transl_modtype newenv sres in
-      mty (Tmty_functor (id, arg, res))
+      mkmty (Tmty_functor (id, arg, res))
       (Mty_functor(id, arg.mty_type, res.mty_type)) loc
   | Pmty_with(sbody, constraints) ->
       let body = transl_modtype env sbody in
@@ -394,11 +400,11 @@ let rec transl_modtype env smty =
             (tcstr :: tcstrs, sg)
         )
         ([],init_sg) constraints in
-      mty (Tmty_with ( body, tcstrs))
+      mkmty (Tmty_with ( body, tcstrs))
       (Mtype.freshen (Mty_signature final_sg)) loc 
   | Pmty_typeof smod ->
       let tmod = !type_module_type_of_fwd env smod in
-      mty (Tmty_typeof tmod) tmod.mod_type loc
+      mkmty (Tmty_typeof tmod) tmod.mod_type loc
 
 
 and transl_signature env sg =
@@ -515,9 +521,12 @@ and transl_signature env sg =
                      Sig_type(i', d', rs);
                      Sig_type(i'', d'', rs)])
                  classes [rem])
-    in
+  in
+  let previous_saved_types = Typedtree.get_saved_types () in
   let (trem, rem) = transl_sig env sg in
-  { sig_items = trem; sig_type =  rem }
+  let sg = { sig_items = trem; sig_type =  rem } in
+  Typedtree.set_saved_types ( (Saved_signature sg) :: previous_saved_types );
+  sg
 
 and transl_modtype_info env sinfo =
   match sinfo with
@@ -747,7 +756,10 @@ let wrap_constraint env arg mty explicit =
 
 (* Type a module value expression *)
 
-let mkstr desc loc = { str_desc = desc; str_loc = loc }
+let mkstr desc loc =
+  let str = { str_desc = desc; str_loc = loc } in
+  Typedtree.add_saved_type (Saved_structure_item str);
+  str
 
 let rec type_module sttn funct_body anchor env smod =
   match smod.pmod_desc with
@@ -1024,8 +1036,11 @@ and type_structure funct_body anchor env sstr scope =
   in
   if !Clflags.annotations
   then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
-    let (items, sg, finalenv) = type_struct env sstr in
-      { str_items = items; str_type = sg }, sg, finalenv
+  let previous_saved_types = Typedtree.get_saved_types () in
+  let (items, sg, finalenv) = type_struct env sstr in
+  let str = { str_items = items; str_type = sg } in
+  Typedtree.set_saved_types (( Saved_structure str) :: previous_saved_types);
+  str, sg, finalenv
 
 let type_module = type_module true false None
 let type_structure = type_structure false None
@@ -1157,28 +1172,39 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
   end
 
 let type_implementation sourcefile outputprefix modulename initial_env ast =
-  let (str, coercion) = type_implementation sourcefile outputprefix modulename initial_env ast in
-  if !Clflags.annotations then begin
-      let oc = open_out (outputprefix ^ ".types") in
-      output_value oc str;
-      close_out oc;
-
-      let oc = open_out (outputprefix ^ "_ast2src.ml") in
-      let ppf = Format.formatter_of_out_channel oc in
-      Typedtree.print_structure ppf ast;
-      Format.pp_print_flush ppf ();
-      close_out oc;
-
-      
-      let oc = open_out (outputprefix ^ "_typ2src.ml") in
-      let ppf = Format.formatter_of_out_channel oc in
-      Typedtree.print_structure ppf (Typedtree.untype_structure str);
-      Format.pp_print_flush ppf ();
-      close_out oc;
+  try
+    Typedtree.set_saved_types [];
+    let (str, coercion) = type_implementation sourcefile outputprefix modulename initial_env ast in
+    if !Clflags.annotations then begin
+        Typedtree.set_saved_types [];
+        let oc = open_out (outputprefix ^ ".types") in
+        output_value oc [| Saved_implementation str |];
+        close_out oc;
+        
+        let oc = open_out (outputprefix ^ "_ast2src.ml") in
+        let ppf = Format.formatter_of_out_channel oc in
+        Typedtree.print_structure ppf ast;
+        Format.pp_print_flush ppf ();
+        close_out oc;
+        
+        
+        let oc = open_out (outputprefix ^ "_typ2src.ml") in
+        let ppf = Format.formatter_of_out_channel oc in
+        Typedtree.print_structure ppf (Typedtree.untype_structure str);
+        Format.pp_print_flush ppf ();
+        close_out oc;
       
-    end;
-  (str, coercion)
-
+      end;
+    (str, coercion)
+  with e ->
+      if !Clflags.annotations then begin
+          let oc = open_out (outputprefix ^ ".types") in
+          output_value oc (Array.of_list (Typedtree.get_saved_types ()));
+          close_out oc;
+        end;      
+      Typedtree.set_saved_types  [];
+      raise e
+    
 (* "Packaging" of several compilation units into one unit
    having them as sub-modules.  *)