Attributes on expresions (etc) are now stored in the expression record, to facilitate pattern matching on structured fragments of AST while ignoring attributes. Introducing a new Ast_helper module to help creating AST fragments.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13381 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
author: Alain Frisch <alain@frisch.fr> 2013-03-08 14:59:45 +0000
committer: Alain Frisch <alain@frisch.fr> 2013-03-08 14:59:45 +0000
commit: b0987fd69307b9bd08966fa74c0a9547c4d2af31 (patch)
tree: 2758a7868e65842952a622872808b508c16eae99 /tools
parent: 556d070fdbf0cf584f8198bfae3dedf1193ce01a (diff)
4 files changed, 27 insertions, 44 deletions
diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index babcb6bfe..8c5e187f5 100644
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -38,7 +38,7 @@ opt.opt: ocamldep.opt read_cmt.opt
 CAMLDEP_OBJ=depend.cmo ocamldep.cmo
 CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo \
-  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo \
+  syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \
   ccomp.cmo pparse.cmo
 
 ocamldep: depend.cmi $(CAMLDEP_OBJ)
@@ -64,7 +64,7 @@ install::
 CSLPROF=ocamlprof.cmo
 CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo \
-  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+  syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
 
 ocamlprof: $(CSLPROF) profiling.cmo
 	$(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF)
@@ -165,7 +165,7 @@ clean::
 
 ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo \
-  syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
+  syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
 
 addlabels: addlabels.cmo
 	$(CAMLC) $(LINKFLAGS) -w sl -o addlabels \
@@ -211,6 +211,7 @@ READ_CMT= \
           ../parsing/longident.cmo \
           ../parsing/lexer.cmo \
           ../parsing/pprintast.cmo \
+          ../parsing/ast_helper.cmo \
           ../typing/ident.cmo \
           ../typing/path.cmo \
           ../typing/types.cmo \
diff --git a/tools/depend.ml b/tools/depend.ml
index 9274459b2..27d5b5204 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -53,7 +53,6 @@ let rec add_type bv ty =
         fl
   | Ptyp_poly(_, t) -> add_type bv t
   | Ptyp_package pt -> add_package_type bv pt
-  | Ptyp_attribute (e, _) -> add_type bv e
   | Ptyp_extension _ -> ()
 
 and add_package_type bv (lid, l) =
@@ -124,7 +123,6 @@ let rec add_pattern bv pat =
   | Ppat_type li -> add bv li
   | Ppat_lazy p -> add_pattern bv p
   | Ppat_unpack id -> pattern_bv := StringSet.add id.txt !pattern_bv
-  | Ppat_attribute (p, _) -> add_pattern bv p
   | Ppat_extension _ -> ()
 
 let add_pattern bv pat =
@@ -179,7 +177,6 @@ let rec add_expr bv exp =
   | Pexp_newtype (_, e) -> add_expr bv e
   | Pexp_pack m -> add_module bv m
   | Pexp_open (m, e) -> addmodule bv m; add_expr bv e
-  | Pexp_attribute (e, _) -> add_expr bv e
   | Pexp_extension _ -> ()
 
 and add_pat_expr_list bv pel =
@@ -206,10 +203,7 @@ and add_modtype bv mty =
                 | (_, Pwith_modsubst (lid)) -> addmodule bv lid)
         cstrl
   | Pmty_typeof m -> add_module bv m
-  | Pmty_attribute(modl, _) ->
-      add_modtype bv modl
-  | Pmty_extension _ ->
-      ()
+  | Pmty_extension _ -> ()
 
 and add_signature bv = function
     [] -> ()
@@ -259,8 +253,6 @@ and add_module bv modl =
       add_module bv modl; add_modtype bv mty
   | Pmod_unpack(e) ->
       add_expr bv e
-  | Pmod_attribute(modl, _) ->
-      add_module bv modl
   | Pmod_extension _ ->
       ()
 
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 5ad7936ef..92933f756 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -283,7 +283,6 @@ and rw_exp iflag sexp =
   | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
   | Pexp_open (_, e) -> rewrite_exp iflag e
   | Pexp_pack (smod) -> rewrite_mod iflag smod
-  | Pexp_attribute (e, _) -> rewrite_exp iflag e
   | Pexp_extension _ -> ()
 
 and rewrite_ifbody iflag ghost sifbody =
@@ -359,7 +358,6 @@ and rewrite_mod iflag smod =
   | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
   | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
   | Pmod_unpack(sexp) -> rewrite_exp iflag sexp
-  | Pmod_attribute (smod, _) -> rewrite_mod iflag smod
   | Pmod_extension _ -> ()
 
 and rewrite_str_item iflag item =
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 0f6cac1ce..7b663214e 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -13,6 +13,7 @@
 open Asttypes
 open Typedtree
 open Parsetree
+open Ast_helper
 
 (*
 Some notes:
@@ -57,17 +58,17 @@ and untype_structure_item item =
     | Tstr_exn_rebind (_id, name, _p, lid) ->
         Pstr_exn_rebind (name, lid, [])
     | Tstr_module (_id, name, mexpr) ->
-        Pstr_module {pmb_name = name; pmb_expr = untype_module_expr mexpr; pmb_attributes = []}
+        Pstr_module (Mb.mk name (untype_module_expr mexpr))
     | Tstr_recmodule list ->
         Pstr_recmodule
           (List.map
              (fun (_id, name, mtype, mexpr) ->
-               {pmb_name = name;
-                pmb_expr = {pmod_loc = Location.none;
-                            pmod_desc = Pmod_constraint(
-                            untype_module_expr mexpr,
-                            untype_module_type mtype)};
-                pmb_attributes = []})
+               Mb.mk name
+                 (Mod.constraint_
+                    (untype_module_expr mexpr)
+                    (untype_module_type mtype)
+                 )
+             )
              list)
     | Tstr_modtype (_id, name, mtype) ->
         Pstr_modtype {pmtb_name=name; pmtb_type=untype_module_type mtype;
@@ -175,9 +176,11 @@ and untype_pattern pat =
         Ppat_construct (lid,
           (match args with
               [] -> None
-            | args -> Some
-                  { ppat_desc = Ppat_tuple (List.map untype_pattern args);
-                  ppat_loc = pat.pat_loc; }
+            | args ->
+                Some
+                  (Pat.tuple ~loc:pat.pat_loc
+                     (List.map untype_pattern args)
+                  )
           ), explicit_arity)
     | Tpat_variant (label, pato, _) ->
         Ppat_variant (label, match pato with
@@ -190,10 +193,7 @@ and untype_pattern pat =
     | Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2)
     | Tpat_lazy p -> Ppat_lazy (untype_pattern p)
   in
-  {
-    ppat_desc = desc;
-    ppat_loc = pat.pat_loc;
-  }
+  Pat.mk ~loc:pat.pat_loc desc
 
 and option f x = match x with None -> None | Some e -> Some (f e)
 
@@ -208,8 +208,7 @@ and untype_extra (extra, loc) sexp =
     | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto)
     | Texp_newtype s -> Pexp_newtype (s, sexp)
   in
-  { pexp_desc = desc;
-    pexp_loc = loc }
+  Exp.mk ~loc desc
 
 and untype_expression exp =
   let desc =
@@ -247,9 +246,9 @@ and untype_expression exp =
           (match args with
               [] -> None
           | [ arg ] -> Some (untype_expression arg)
-          | args -> Some
-            { pexp_desc = Pexp_tuple (List.map untype_expression args);
-              pexp_loc = exp.exp_loc; }
+          | args ->
+              Some
+                (Exp.tuple ~loc:exp.exp_loc (List.map untype_expression args))
           ), explicit_arity)
     | Texp_variant (label, expo) ->
         Pexp_variant (label, match expo with
@@ -310,8 +309,7 @@ and untype_expression exp =
         Pexp_pack (untype_module_expr mexpr)
   in
   List.fold_right untype_extra exp.exp_extra
-    { pexp_loc = exp.exp_loc;
-      pexp_desc = desc }
+    (Exp.mk ~loc:exp.exp_loc desc)
 
 and untype_package_type pack =
   (pack.pack_txt,
@@ -393,10 +391,7 @@ and untype_module_type mty =
     | Tmty_typeof mexpr ->
         Pmty_typeof (untype_module_expr mexpr)
   in
-  {
-    pmty_desc = desc;
-    pmty_loc = mty.mty_loc;
-  }
+  Mty.mk ~loc:mty.mty_loc desc
 
 and untype_with_constraint lid cstr =
   match cstr with
@@ -428,10 +423,7 @@ and untype_module_expr mexpr =
         (* TODO , untype_package_type pack) *)
 
   in
-  {
-    pmod_desc = desc;
-    pmod_loc = mexpr.mod_loc;
-  }
+  Mod.mk ~loc:mexpr.mod_loc desc
 
 and untype_class_expr cexpr =
   let desc = match cexpr.cl_desc with
@@ -524,7 +516,7 @@ and untype_core_type ct =
     | Ttyp_poly (list, ct) -> Ptyp_poly (list, untype_core_type ct)
     | Ttyp_package pack -> Ptyp_package (untype_package_type pack)
   in
-  { ptyp_desc = desc; ptyp_loc = ct.ctyp_loc }
+  Typ.mk ~loc:ct.ctyp_loc desc
 
 and untype_core_field_type cft =
   { pfield_desc = (match cft.field_desc with
author	Alain Frisch <alain@frisch.fr>	2013-03-08 14:59:45 +0000
committer	Alain Frisch <alain@frisch.fr>	2013-03-08 14:59:45 +0000
commit	b0987fd69307b9bd08966fa74c0a9547c4d2af31 (patch)
tree	2758a7868e65842952a622872808b508c16eae99 /tools
parent	556d070fdbf0cf584f8198bfae3dedf1193ce01a (diff)