New implementation of cmt2annot, based on an OO iterator for typed trees. Mostly work for Partial_implementation (#5816).

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

5 files changed, 579 insertions, 242 deletions

diff --git a/tools/.depend b/tools/.depend
index ad310b457..8d07e60cf 100644
--- a/tools/.depend
+++ b/tools/.depend
@@ -1,24 +1,28 @@
 depend.cmi : ../parsing/parsetree.cmi
 profiling.cmi :
-typedtreeIter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi
+tast_iter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi
 untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \
     ../parsing/parsetree.cmi ../parsing/longident.cmi
 addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \
     ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi
 addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
     ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi
-cmt2annot.cmo : typedtreeIter.cmi ../typing/typedtree.cmi \
-    ../typing/stypes.cmi ../typing/path.cmi ../typing/oprint.cmi \
-    ../parsing/location.cmi ../typing/ident.cmi ../typing/env.cmi \
+ast_mapper.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
+    ../parsing/location.cmi ../utils/config.cmi ../parsing/asttypes.cmi
+ast_mapper.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
+    ../parsing/location.cmx ../utils/config.cmx ../parsing/asttypes.cmi
+cmt2annot.cmo : untypeast.cmi ../typing/types.cmi \
+    ../typing/typedtreeIter.cmi ../typing/typedtree.cmi tast_iter.cmi \
+    ../typing/stypes.cmi ../parsing/pprintast.cmi ../typing/path.cmi \
+    ../typing/oprint.cmi ../parsing/location.cmi ../typing/ident.cmi \
+    ../typing/envaux.cmi ../typing/env.cmi ../utils/config.cmi \
     ../typing/cmt_format.cmi ../parsing/asttypes.cmi ../typing/annot.cmi
-cmt2annot.cmx : typedtreeIter.cmx ../typing/typedtree.cmx \
-    ../typing/stypes.cmx ../typing/path.cmx ../typing/oprint.cmx \
-    ../parsing/location.cmx ../typing/ident.cmx ../typing/env.cmx \
+cmt2annot.cmx : untypeast.cmx ../typing/types.cmx \
+    ../typing/typedtreeIter.cmx ../typing/typedtree.cmx tast_iter.cmx \
+    ../typing/stypes.cmx ../parsing/pprintast.cmx ../typing/path.cmx \
+    ../typing/oprint.cmx ../parsing/location.cmx ../typing/ident.cmx \
+    ../typing/envaux.cmx ../typing/env.cmx ../utils/config.cmx \
     ../typing/cmt_format.cmx ../parsing/asttypes.cmi ../typing/annot.cmi
-cmt2ml.cmo : untypeast.cmi ../typing/typedtree.cmi pprintast.cmo \
-    ../typing/cmt_format.cmi
-cmt2ml.cmx : untypeast.cmx ../typing/typedtree.cmx pprintast.cmx \
-    ../typing/cmt_format.cmx
 cvt_emit.cmo :
 cvt_emit.cmx :
 depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \
@@ -37,26 +41,32 @@ dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \
     ../bytecomp/instruct.cmx ../typing/ident.cmx ../bytecomp/emitcode.cmx \
     ../utils/config.cmx ../bytecomp/cmo_format.cmi \
     ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi
+eqparsetree.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
+    ../parsing/location.cmi ../parsing/asttypes.cmi
+eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
+    ../parsing/location.cmx ../parsing/asttypes.cmi
 myocamlbuild_config.cmo :
 myocamlbuild_config.cmx :
 objinfo.cmo : ../utils/misc.cmi ../utils/config.cmi \
     ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
-    ../asmcomp/clambda.cmi ../bytecomp/bytesections.cmi
+    ../typing/cmi_format.cmi ../asmcomp/clambda.cmi \
+    ../bytecomp/bytesections.cmi
 objinfo.cmx : ../utils/misc.cmx ../utils/config.cmx \
     ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
-    ../asmcomp/clambda.cmx ../bytecomp/bytesections.cmx
+    ../typing/cmi_format.cmx ../asmcomp/clambda.cmx \
+    ../bytecomp/bytesections.cmx
 ocaml299to3.cmo :
 ocaml299to3.cmx :
 ocamlcp.cmo : ../driver/main_args.cmi
 ocamlcp.cmx : ../driver/main_args.cmx
-ocamldep.cmo : ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \
-    ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \
-    ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \
-    ../utils/config.cmi ../utils/clflags.cmi
-ocamldep.cmx : ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \
-    ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \
-    ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \
-    ../utils/config.cmx ../utils/clflags.cmx
+ocamldep.cmo : ../parsing/syntaxerr.cmi ../driver/pparse.cmi \
+    ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \
+    ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
+    depend.cmi ../utils/config.cmi ../utils/clflags.cmi
+ocamldep.cmx : ../parsing/syntaxerr.cmx ../driver/pparse.cmx \
+    ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \
+    ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
+    depend.cmx ../utils/config.cmx ../utils/clflags.cmx
 ocamlmklib.cmo : myocamlbuild_config.cmo
 ocamlmklib.cmx : myocamlbuild_config.cmx
 ocamlmktop.cmo : ../utils/ccomp.cmi
@@ -73,10 +83,6 @@ ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \
     ../utils/clflags.cmx
 opnames.cmo :
 opnames.cmx :
-pprintast.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \
-    ../parsing/location.cmi ../parsing/asttypes.cmi
-pprintast.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \
-    ../parsing/location.cmx ../parsing/asttypes.cmi
 primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
 primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
 profiling.cmo : profiling.cmi
@@ -85,10 +91,10 @@ read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi
 read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
 scrapelabels.cmo :
 scrapelabels.cmx :
-typedtreeIter.cmo : ../typing/typedtree.cmi ../utils/misc.cmi \
-    ../parsing/asttypes.cmi typedtreeIter.cmi
-typedtreeIter.cmx : ../typing/typedtree.cmx ../utils/misc.cmx \
-    ../parsing/asttypes.cmi typedtreeIter.cmi
+tast_iter.cmo : ../typing/typedtree.cmi ../parsing/asttypes.cmi \
+    tast_iter.cmi
+tast_iter.cmx : ../typing/typedtree.cmx ../parsing/asttypes.cmi \
+    tast_iter.cmi
 untypeast.cmo : ../typing/typedtree.cmi ../typing/path.cmi \
     ../parsing/parsetree.cmi ../utils/misc.cmi ../parsing/longident.cmi \
     ../typing/ident.cmi ../parsing/asttypes.cmi untypeast.cmi
diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index f55734147..503960593 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -24,7 +24,7 @@ LINKFLAGS=$(INCLUDES)
 all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \
      objinfo read_cmt
 
-all: ast_mapper.cmo
+all: ast_mapper.cmo tast_iter.cmo
 
 # scrapelabels addlabels
 
@@ -233,6 +233,7 @@ READ_CMT= \
           ../typing/stypes.cmo \
           \
           untypeast.cmo \
+          tast_iter.cmo \
           cmt2annot.cmo read_cmt.cmo
 
 read_cmt: $(READ_CMT)
diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml
index 31a5468f6..9632e48b5 100644
--- a/tools/cmt2annot.ml
+++ b/tools/cmt2annot.ml
@@ -12,112 +12,48 @@
 
 (* Generate an .annot file from a .cmt file. *)
 
+open Asttypes
 open Typedtree
-open TypedtreeIter
 
-let pattern_scopes = ref []
+let bind_variables scope =
+  object
+    inherit Tast_iter.iter as super
 
-let push_None () =
-  pattern_scopes := None :: !pattern_scopes
-let push_Some annot =
-  pattern_scopes := (Some annot) :: !pattern_scopes
-let pop_scope () =
-  match !pattern_scopes with
-    [] -> assert false
-  | _ :: scopes -> pattern_scopes := scopes
-
-let rebuild_env = ref false
-
-module ForIterator = struct
-    open Asttypes
-
-    include DefaultIteratorArgument
-
-    let structure_begin_scopes = ref []
-    let structure_end_scopes = ref []
+    method! pattern pat =
+      super # pattern pat;
+      match pat.pat_desc with
+      | Tpat_var (id, _) | Tpat_alias (_, id, _) ->
+          Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, Annot.Idef scope))
+      | _ -> ()
+  end
 
-    let rec find_last list =
-      match list with
-        [] -> assert false
-      | [x] -> x
-      | _ :: tail -> find_last tail
+let bind_bindings scope bindings =
+  let o = bind_variables scope in
+  List.iter (fun (p, _) -> o # pattern p) bindings
 
-    let enter_structure str =
-      match str.str_items with
-        [] -> ()
-      | _ ->
-          let loc =
-            match !structure_end_scopes with
-              [] -> Location.none
-            | _ ->
-                let s = find_last str.str_items in
-                s.str_loc
-          in
-          structure_end_scopes := loc :: !structure_end_scopes;
+let bind_cases l =
+  List.iter (fun (p, e) -> (bind_variables e.exp_loc) # pattern p) l
 
-          let rec iter list =
-            match list with
-              [] -> assert false
-            | [ { str_desc = Tstr_value (Nonrecursive, _); str_loc = loc } ] ->
-                structure_begin_scopes := loc.Location.loc_end
-                  :: !structure_begin_scopes
-            | [ _ ] -> ()
-            | item :: tail ->
-                iter tail;
-                match item, tail with
-                  { str_desc = Tstr_value (Nonrecursive,_) },
-                  { str_loc = loc } :: _ ->
-                    structure_begin_scopes := loc.Location.loc_start
-                      :: !structure_begin_scopes
-                | _ -> ()
-          in
-          iter str.str_items
+let iterator rebuild_env =
+  object(this)
+    val scope = Location.none  (* scope of the surrounding structure *)
 
-    let leave_structure str =
-      match str.str_items with
-        [] -> ()
-      | _ ->
-          match !structure_end_scopes with
-            [] -> assert false
-          | _ :: scopes -> structure_end_scopes := scopes
+    inherit Tast_iter.iter as super
 
-    let enter_class_expr node =
-      Stypes.record (Stypes.Ti_class node)
-    let enter_module_expr node =
-      Stypes.record (Stypes.Ti_mod node)
+    method! class_expr node =
+      Stypes.record (Stypes.Ti_class node);
+      super # class_expr node
 
-    let add_variable pat id =
-      match !pattern_scopes with
-      | [] -> assert false
-      | None :: _ -> ()
-      | (Some s) :: _ ->
-          Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, s))
+    method! module_expr node =
+      Stypes.record (Stypes.Ti_mod node);
+      Tast_iter.module_expr {< scope = node.mod_loc >} node
 
-    let enter_pattern pat =
-      match pat.pat_desc with
-      | Tpat_var (id, _)
-      | Tpat_alias (_, id,_)
-        -> add_variable pat id
-      | Tpat_any -> ()
-      | Tpat_constant _
-      | Tpat_tuple _
-      | Tpat_construct _
-      | Tpat_lazy _
-      | Tpat_or _
-      | Tpat_array _
-      | Tpat_record _
-      | Tpat_variant _
-        -> ()
-
-    let leave_pattern pat =
-      Stypes.record (Stypes.Ti_pat pat)
-
-    let enter_expression exp =
-      match exp.exp_desc with
-        Texp_ident (path, _, _) ->
+    method! expression exp =
+      begin match exp.exp_desc with
+      | Texp_ident (path, _, _) ->
           let full_name = Path.name ~paren:Oprint.parenthesized_ident path in
           let env =
-            if !rebuild_env then
+            if rebuild_env then
               try
                 Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
               with Envaux.Error err ->
@@ -137,152 +73,90 @@ module ForIterator = struct
           in
           Stypes.record
             (Stypes.An_ident (exp.exp_loc, full_name , annot))
-
-      | Texp_let (rec_flag, _, body) ->
-          begin
-            match rec_flag with
-            | Recursive -> push_Some (Annot.Idef exp.exp_loc)
-            | Nonrecursive -> push_Some (Annot.Idef body.exp_loc)
-            | Default -> push_None ()
-          end
-      | Texp_function _ -> push_None ()
-      | Texp_match _ -> push_None ()
-      | Texp_try _ -> push_None ()
-      | _ -> ()
-
-    let leave_expression exp =
-      if not exp.exp_loc.Location.loc_ghost then
-        Stypes.record (Stypes.Ti_expr exp);
-      match exp.exp_desc with
-      | Texp_let _
-      | Texp_function _
-      | Texp_match _
-      | Texp_try _
-        -> pop_scope ()
+      | Texp_let (Recursive, bindings, _) ->
+          bind_bindings exp.exp_loc bindings
+      | Texp_let (Nonrecursive, bindings, body) ->
+          bind_bindings body.exp_loc bindings
+      | Texp_function (_, f, _)
+      | Texp_match (_, f, _)
+      | Texp_try (_, f) ->
+          bind_cases f
       | _ -> ()
+      end;
+      Stypes.record (Stypes.Ti_expr exp);
+      super # expression exp
 
-    let enter_binding pat exp =
-      let scope =
-        match !pattern_scopes with
-        | [] -> assert false
-        | None :: _ -> Some (Annot.Idef exp.exp_loc)
-        | scope :: _ -> scope
-      in
-      pattern_scopes := scope :: !pattern_scopes
-
-    let leave_binding _ _ =
-      pop_scope ()
-
-    let enter_class_expr exp =
-      match exp.cl_desc with
-      | Tcl_fun _ -> push_None ()
-      | Tcl_let _ -> push_None ()
-      | _ -> ()
-
-    let leave_class_expr exp =
-      match exp.cl_desc with
-      | Tcl_fun _
-      | Tcl_let _ -> pop_scope ()
-      | _ -> ()
-
-    let enter_class_structure _ =
-      push_None ()
-
-    let leave_class_structure _ =
-      pop_scope ()
-
-(*
-    let enter_class_field cf =
-      match cf.cf_desc with
-        Tcf_let _ -> push_None ()
-      | _ -> ()
-
-    let leave_class_field cf =
-      match cf.cf_desc with
-        Tcf_let _ -> pop_scope ()
-      | _ -> ()
-*)
+    method! pattern pat =
+      super # pattern pat;
+      Stypes.record (Stypes.Ti_pat pat)
 
-    let enter_structure_item s =
-      Stypes.record_phrase s.str_loc;
-      match s.str_desc with
-        Tstr_value (rec_flag, _) ->
-          begin
-            let loc = s.str_loc in
-            let scope = match !structure_end_scopes with
-                [] -> assert false
-              | scope :: _ -> scope
-            in
-            match rec_flag with
-            | Recursive -> push_Some
-                  (Annot.Idef { scope with
-                    Location.loc_start = loc.Location.loc_start})
-            | Nonrecursive ->
-(* TODO: do it lazily, when we start the next element ! *)
-(*
-                 let start = match srem with
-                  | [] -> loc.Location.loc_end
-                  | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
-in  *)
-                let start =
-                  match !structure_begin_scopes with
-                    [] -> assert false
-                  | loc :: tail ->
-                      structure_begin_scopes := tail;
-                      loc
-                in
-                push_Some (Annot.Idef {scope with Location.loc_start = start})
-            | Default -> push_None ()
+    method private structure_item_rem s rem =
+      begin match s with
+      | {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} ->
+          let open Location in
+          let doit loc_start = bind_bindings {scope with loc_start} bindings in
+          begin match rec_flag, rem with
+          | Default, _ -> ()
+          | Recursive, _ -> doit loc.loc_start
+          | Nonrecursive, [] -> doit loc.loc_end
+          | Nonrecursive,  {str_loc = loc2} :: _ -> doit loc2.loc_start
           end
-      | _ -> ()
-
-    let leave_structure_item s =
-      match s.str_desc with
-        Tstr_value _ -> pop_scope ()
-      | _ -> ()
-
+      | _ ->
+          ()
+      end;
+      Stypes.record_phrase s.str_loc;
+      super # structure_item s
+
+    method! structure_item s =
+      (* This will be used for Partial_structure_item.
+         We don't have here the location of the "next" item,
+         this will give a slightly different scope for the non-recursive
+         binding case. *)
+      this # structure_item_rem s []
+
+    method! structure l =
+      let rec loop = function
+        | str :: rem -> this # structure_item_rem str rem; loop rem
+        | [] -> ()
+      in
+      loop l.str_items
 
+(* TODO: support binding for Tcl_fun, Tcl_let, etc *)
   end
 
-module Iterator = MakeIterator(ForIterator)
-
-let binary_part x =
-  let open Iterator in
+let binary_part iter x =
   let open Cmt_format in
   match x with
-  | Partial_structure x -> iter_structure x
-  | Partial_structure_item x -> iter_structure_item x
-  | Partial_expression x -> iter_expression x
-  | Partial_pattern x -> iter_pattern x
-  | Partial_class_expr x -> iter_class_expr x
-  | Partial_signature x -> iter_signature x
-  | Partial_signature_item x -> iter_signature_item x
-  | Partial_module_type x -> iter_module_type x
+  | Partial_structure x -> iter # structure x
+  | Partial_structure_item x -> iter # structure_item x
+  | Partial_expression x -> iter # expression x
+  | Partial_pattern x -> iter # pattern x
+  | Partial_class_expr x -> iter # class_expr x
+  | Partial_signature x -> iter # signature x
+  | Partial_signature_item x -> iter # signature_item x
+  | Partial_module_type x -> iter # module_type x
 
 let gen_annot target_filename filename {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} =
   let open Cmt_format in
   Envaux.reset_cache ();
   Config.load_path := cmt_loadpath;
-  rebuild_env := cmt_use_summaries;
   let target_filename =
     match target_filename with
     | None -> Some (filename ^ ".annot")
     | Some "-" -> None
     | Some filename -> target_filename
   in
+  let iterator = iterator cmt_use_summaries in
   match cmt_annots with
   | Implementation typedtree ->
-      Iterator.iter_structure typedtree;
+      iterator # structure typedtree;
       Stypes.dump target_filename
   | Interface _ ->
       Printf.fprintf stderr "Cannot generate annotations for interface file\n%!";
       exit 2
-(* this does not work, probably because of the crazy imperative implementation of the traversal *)
-(*
   | Partial_implementation parts ->
-      Array.iter binary_part parts;
+      Array.iter (binary_part iterator) parts;
       Stypes.dump target_filename
-*)
   | _ ->
       Printf.fprintf stderr "File was generated with an error\n%!";
       exit 2
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
new file mode 100644
index 000000000..d36520e82
--- /dev/null
+++ b/tools/tast_iter.ml
@@ -0,0 +1,376 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Asttypes
+open Typedtree
+
+let opt f = function None -> () | Some x -> f x
+
+let structure sub str =
+  List.iter (sub # structure_item) str.str_items
+
+let structure_item sub x =
+  match x.str_desc with
+  | Tstr_eval exp -> sub # expression exp
+  | Tstr_value (rec_flag, list) -> sub # bindings (rec_flag, list)
+  | Tstr_primitive (id, _, v) -> sub # value_description v
+  | Tstr_type list ->
+      List.iter (fun (id, _, decl) -> sub # type_declaration decl) list
+  | Tstr_exception (id, _, decl) -> sub # exception_declaration decl
+  | Tstr_exn_rebind (id, _, p, _) -> ()
+  | Tstr_module (id, _, mexpr) -> sub # module_expr mexpr
+  | Tstr_recmodule list ->
+      List.iter
+        (fun (id, _, mtype, mexpr) ->
+          sub # module_type mtype;
+          sub # module_expr mexpr
+        )
+        list
+  | Tstr_modtype (id, _, mtype) -> sub # module_type mtype
+  | Tstr_open _ -> ()
+  | Tstr_class list ->
+      List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list
+  | Tstr_class_type list ->
+      List.iter (fun (id, _, ct) -> sub # class_type ct.ci_expr) list
+  | Tstr_include (mexpr, _) -> sub # module_expr mexpr
+
+let value_description sub x =
+  sub # core_type x.val_desc
+
+let type_declaration sub decl =
+  List.iter
+    (fun (ct1, ct2, loc) -> sub # core_type ct1; sub # core_type ct2)
+    decl.typ_cstrs;
+  begin match decl.typ_kind with
+  | Ttype_abstract -> ()
+  | Ttype_variant list ->
+      List.iter (fun (s, _, cts, loc) -> List.iter (sub # core_type) cts) list
+  | Ttype_record list ->
+      List.iter (fun (s, _, mut, ct, loc) -> sub # core_type ct) list
+  end;
+  opt (sub # core_type) decl.typ_manifest
+
+let exception_declaration sub decl =
+  List.iter (sub # core_type) decl.exn_params
+
+let pattern sub pat =
+  let extra = function
+    | Tpat_type _
+    | Tpat_unpack -> ()
+    | Tpat_constraint ct -> sub # core_type ct
+  in
+  List.iter (fun (c, _) -> extra c) pat.pat_extra;
+  match pat.pat_desc with
+  | Tpat_any
+  | Tpat_var _
+  | Tpat_constant _ -> ()
+  | Tpat_tuple l
+  | Tpat_construct (_, _, l, _) -> List.iter (sub # pattern) l
+  | Tpat_variant (_, po, _) -> opt (sub # pattern) po
+  | Tpat_record (l, _) -> List.iter (fun (_, _, pat) -> sub # pattern pat) l
+  | Tpat_array l -> List.iter (sub # pattern) l
+  | Tpat_or (p1, p2, _) -> sub # pattern p1; sub # pattern p2
+  | Tpat_alias (p, _, _)
+  | Tpat_lazy p -> sub # pattern p
+
+let expression sub exp =
+  let extra = function
+    | Texp_constraint (cty1, cty2) ->
+        opt (sub # core_type) cty1; opt (sub # core_type) cty2
+    | Texp_open _
+    | Texp_newtype _ -> ()
+    | Texp_poly cto -> opt (sub # core_type) cto
+  in
+  List.iter (function (c, _) -> extra c) exp.exp_extra;
+  match exp.exp_desc with
+  | Texp_ident _
+  | Texp_constant _ -> ()
+  | Texp_let (rec_flag, list, exp) ->
+      sub # bindings (rec_flag, list);
+      sub # expression exp
+  | Texp_function (_, cases, _) ->
+      sub # bindings (Nonrecursive, cases)
+  | Texp_apply (exp, list) ->
+      sub # expression exp;
+      List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list
+  | Texp_match (exp, list, _) ->
+      sub # expression exp;
+      sub # bindings (Nonrecursive, list)
+  | Texp_try (exp, list) ->
+      sub # expression exp;
+      sub # bindings (Nonrecursive, list)
+  | Texp_tuple list ->
+      List.iter (sub # expression) list
+  | Texp_construct (_, _, args, _) ->
+      List.iter (sub # expression) args
+  | Texp_variant (_, expo) ->
+      opt (sub # expression) expo
+  | Texp_record (list, expo) ->
+      List.iter (fun (_, _, exp) -> sub # expression exp) list;
+      opt (sub # expression) expo
+  | Texp_field (exp, _, label) ->
+      sub # expression exp
+  | Texp_setfield (exp1, _, label, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_array list ->
+      List.iter (sub # expression) list
+  | Texp_ifthenelse (exp1, exp2, expo) ->
+      sub # expression exp1;
+      sub # expression exp2;
+      opt (sub # expression) expo
+  | Texp_sequence (exp1, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_while (exp1, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_for (id, _, exp1, exp2, dir, exp3) ->
+      sub # expression exp1;
+      sub # expression exp2;
+      sub # expression exp3
+  | Texp_when (exp1, exp2) ->
+      sub # expression exp1;
+      sub # expression exp2
+  | Texp_send (exp, meth, expo) ->
+      sub # expression exp;
+      opt (sub # expression) expo
+  | Texp_new (path, _, _) -> ()
+  | Texp_instvar (_, path, _) -> ()
+  | Texp_setinstvar (_, _, _, exp) ->
+      sub # expression exp
+  | Texp_override (_, list) ->
+      List.iter (fun (path, _, exp) -> sub # expression exp) list
+  | Texp_letmodule (id, _, mexpr, exp) ->
+      sub # module_expr mexpr;
+      sub # expression exp
+  | Texp_assert exp -> sub # expression exp
+  | Texp_assertfalse -> ()
+  | Texp_lazy exp -> sub # expression exp
+  | Texp_object (cl, _) ->
+      sub # class_structure cl
+  | Texp_pack (mexpr) ->
+      sub # module_expr mexpr
+
+
+let package_type sub pack =
+  List.iter (fun (s, ct) -> sub # core_type ct) pack.pack_fields
+
+let signature sub sg =
+  List.iter (sub # signature_item) sg.sig_items
+
+let signature_item sub item =
+  match item.sig_desc with
+  | Tsig_value (id, _, v) ->
+      sub # value_description v
+  | Tsig_type list ->
+      List.iter (fun (id, _, decl) -> sub # type_declaration decl) list
+  | Tsig_exception (id, _, decl) ->
+      sub # exception_declaration decl
+  | Tsig_module (id, _, mtype) ->
+      sub # module_type mtype
+  | Tsig_recmodule list ->
+      List.iter (fun (id, _, mtype) -> sub # module_type mtype) list
+  | Tsig_modtype (id, _, mdecl) ->
+      sub # modtype_declaration mdecl
+  | Tsig_open _ -> ()
+  | Tsig_include (mty,_) -> sub # module_type mty
+  | Tsig_class list ->
+      List.iter (sub # class_description) list
+  | Tsig_class_type list ->
+      List.iter (sub # class_type_declaration) list
+
+let modtype_declaration sub mdecl =
+  match mdecl with
+  | Tmodtype_abstract -> ()
+  | Tmodtype_manifest mtype -> sub # module_type mtype
+
+let class_description sub cd =
+  sub # class_type cd.ci_expr
+
+let class_type_declaration sub cd =
+  sub # class_type cd.ci_expr
+
+let module_type sub mty =
+  match mty.mty_desc with
+  | Tmty_ident (path, _) -> ()
+  | Tmty_signature sg -> sub # signature sg
+  | Tmty_functor (id, _, mtype1, mtype2) ->
+      sub # module_type mtype1; sub # module_type mtype2
+  | Tmty_with (mtype, list) ->
+      sub # module_type mtype;
+      List.iter (fun (_, _, withc) -> sub # with_constraint withc) list
+  | Tmty_typeof mexpr ->
+      sub # module_expr mexpr
+
+let with_constraint sub cstr =
+  match cstr with
+  | Twith_type decl -> sub # type_declaration decl
+  | Twith_module _ -> ()
+  | Twith_typesubst decl -> sub # type_declaration decl
+  | Twith_modsubst _ -> ()
+
+let module_expr sub mexpr =
+  match mexpr.mod_desc with
+  | Tmod_ident (p, _) -> ()
+  | Tmod_structure st -> sub # structure st
+  | Tmod_functor (id, _, mtype, mexpr) ->
+      sub # module_type mtype;
+      sub # module_expr mexpr
+  | Tmod_apply (mexp1, mexp2, _) ->
+      sub # module_expr mexp1;
+      sub # module_expr mexp2
+  | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) ->
+      sub # module_expr mexpr
+  | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
+      sub # module_expr mexpr;
+      sub # module_type mtype
+  | Tmod_unpack (exp, mty) ->
+      sub # expression exp
+(*          sub # module_type mty *)
+
+let class_expr sub cexpr =
+  match cexpr.cl_desc with
+  | Tcl_constraint (cl, None, _, _, _ ) ->
+      sub # class_expr cl;
+  | Tcl_structure clstr -> sub # class_structure clstr
+  | Tcl_fun (label, pat, priv, cl, partial) ->
+      sub # pattern pat;
+      List.iter (fun (id, _, exp) -> sub # expression exp) priv;
+      sub # class_expr cl
+  | Tcl_apply (cl, args) ->
+      sub # class_expr cl;
+      List.iter (fun (label, expo, _) -> opt (sub # expression) expo) args
+  | Tcl_let (rec_flat, bindings, ivars, cl) ->
+      sub # bindings (rec_flat, bindings);
+      List.iter (fun (id, _, exp) -> sub # expression exp) ivars;
+      sub # class_expr cl
+  | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+      sub # class_expr cl;
+      sub # class_type clty
+  | Tcl_ident (_, _, tyl) ->
+      List.iter (sub # core_type) tyl
+
+let class_type sub ct =
+  match ct.cltyp_desc with
+  | Tcty_signature csg -> sub # class_signature csg
+  | Tcty_constr (path, _, list) -> List.iter (sub # core_type) list
+  | Tcty_fun (label, ct, cl) ->
+      sub # core_type ct;
+      sub # class_type cl
+
+let class_signature sub cs =
+  sub # core_type cs.csig_self;
+  List.iter (sub # class_type_field) cs.csig_fields
+
+let class_type_field sub ctf =
+  match ctf.ctf_desc with
+  | Tctf_inher ct -> sub # class_type ct
+  | Tctf_val (s, mut, virt, ct) ->
+      sub # core_type ct
+  | Tctf_virt  (s, priv, ct) ->
+      sub # core_type ct
+  | Tctf_meth  (s, priv, ct) ->
+      sub # core_type ct
+  | Tctf_cstr  (ct1, ct2) ->
+      sub # core_type ct1;
+      sub # core_type ct2
+
+let core_type sub ct =
+  match ct.ctyp_desc with
+  | Ttyp_any -> ()
+  | Ttyp_var s -> ()
+  | Ttyp_arrow (label, ct1, ct2) ->
+      sub # core_type ct1;
+      sub # core_type ct2
+  | Ttyp_tuple list -> List.iter (sub # core_type) list
+  | Ttyp_constr (path, _, list) ->
+      List.iter (sub # core_type) list
+  | Ttyp_object list ->
+      List.iter (sub # core_field_type) list
+  | Ttyp_class (path, _, list, labels) ->
+      List.iter (sub # core_type) list
+  | Ttyp_alias (ct, s) ->
+      sub # core_type ct
+  | Ttyp_variant (list, bool, labels) ->
+      List.iter (sub # row_field) list
+  | Ttyp_poly (list, ct) -> sub # core_type ct
+  | Ttyp_package pack -> sub # package_type pack
+
+let core_field_type sub cft =
+  match cft.field_desc with
+  | Tcfield_var -> ()
+  | Tcfield (s, ct) -> sub # core_type ct
+
+let class_structure sub cs =
+  sub # pattern cs.cstr_pat;
+  List.iter (sub # class_field) cs.cstr_fields
+
+let row_field sub rf =
+  match rf with
+  | Ttag (label, bool, list) -> List.iter (sub # core_type) list
+  | Tinherit ct -> sub # core_type ct
+
+let class_field sub cf =
+  match cf.cf_desc with
+  | Tcf_inher (ovf, cl, super, _vals, _meths) ->
+      sub # class_expr cl
+  | Tcf_constr (cty, cty') ->
+      sub # core_type cty;
+      sub # core_type cty'
+  | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) ->
+      sub # core_type cty
+  | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) ->
+      sub # expression exp
+  | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) ->
+      sub # core_type cty
+  | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) ->
+      sub # expression exp
+  | Tcf_init exp ->
+      sub # expression exp
+
+let bindings sub (rec_flag, list) =
+  List.iter (sub # binding) list
+
+let binding sub (pat, exp) =
+  sub # pattern pat;
+  sub # expression exp
+
+class iter = object(this)
+  method binding = binding this
+  method bindings = bindings this
+  method class_description = class_description this
+  method class_expr = class_expr this
+  method class_field = class_field this
+  method class_signature = class_signature this
+  method class_structure = class_structure this
+  method class_type = class_type this
+  method class_type_declaration = class_type_declaration this
+  method class_type_field = class_type_field this
+  method core_field_type = core_field_type this
+  method core_type = core_type this
+  method exception_declaration = exception_declaration this
+  method expression = expression this
+  method modtype_declaration = modtype_declaration this
+  method module_expr = module_expr this
+  method module_type = module_type this
+  method package_type = package_type this
+  method pattern = pattern this
+  method row_field = row_field this
+  method signature = signature this
+  method signature_item = signature_item this
+  method structure = structure this
+  method structure_item = structure_item this
+  method type_declaration = type_declaration this
+  method value_description = value_description this
+  method with_constraint = with_constraint this
+end
diff --git a/tools/tast_iter.mli b/tools/tast_iter.mli
new file mode 100644
index 000000000..cc9bbcae4
--- /dev/null
+++ b/tools/tast_iter.mli
@@ -0,0 +1,80 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                        Alain Frisch, LexiFi                         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Asttypes
+open Typedtree
+
+class iter: object
+  method binding: (pattern * expression) -> unit
+  method bindings: (rec_flag * (pattern * expression) list) -> unit
+  method class_description: class_description -> unit
+  method class_expr: class_expr -> unit
+  method class_field: class_field -> unit
+  method class_signature: class_signature -> unit
+  method class_structure: class_structure -> unit
+  method class_type: class_type -> unit
+  method class_type_declaration: class_type_declaration -> unit
+  method class_type_field: class_type_field -> unit
+  method core_field_type: core_field_type -> unit
+  method core_type: core_type -> unit
+  method exception_declaration: exception_declaration -> unit
+  method expression: expression -> unit
+  method modtype_declaration: modtype_declaration -> unit
+  method module_expr: module_expr -> unit
+  method module_type: module_type -> unit
+  method package_type: package_type -> unit
+  method pattern: pattern -> unit
+  method row_field: row_field -> unit
+  method signature: signature -> unit
+  method signature_item: signature_item -> unit
+  method structure: structure -> unit
+  method structure_item: structure_item -> unit
+  method type_declaration: type_declaration -> unit
+  method value_description: value_description -> unit
+  method with_constraint: with_constraint -> unit
+end
+(** Recursive iterator class. By inheriting from it and
+    overriding selected methods, it is possible to implement
+    custom behavior for specific kinds of nodes. *)
+
+(** {2 One-level iterators} *)
+
+(** The following functions apply the provided iterator to each
+    sub-component of the argument. *)
+
+val binding: iter -> (pattern * expression) -> unit
+val bindings: iter -> (rec_flag * (pattern * expression) list) -> unit
+val class_description: iter -> class_description -> unit
+val class_expr: iter -> class_expr -> unit
+val class_field: iter -> class_field -> unit
+val class_signature: iter -> class_signature -> unit
+val class_structure: iter -> class_structure -> unit
+val class_type: iter -> class_type -> unit
+val class_type_declaration: iter -> class_type_declaration -> unit
+val class_type_field: iter -> class_type_field -> unit
+val core_field_type: iter -> core_field_type -> unit
+val core_type: iter -> core_type -> unit
+val exception_declaration: iter -> exception_declaration -> unit
+val expression: iter -> expression -> unit
+val modtype_declaration: iter -> modtype_declaration -> unit
+val module_expr: iter -> module_expr -> unit
+val module_type: iter -> module_type -> unit
+val package_type: iter -> package_type -> unit
+val pattern: iter -> pattern -> unit
+val row_field: iter -> row_field -> unit
+val signature: iter -> signature -> unit
+val signature_item: iter -> signature_item -> unit
+val structure: iter -> structure -> unit
+val structure_item: iter -> structure_item -> unit
+val type_declaration: iter -> type_declaration -> unit
+val value_description: iter -> value_description -> unit
+val with_constraint: iter -> with_constraint -> unit