Move detection of more builtin attributes to new module.

Author: alainfrisch

parsing/builtin_attributes.ml

@@ -156,3 +156,18 @@ let with_warning_attribute attrs f =
   with exn ->
     warning_leave_scope ();
     raise exn
+
+
+let warn_on_literal_pattern =
+  List.exists
+    (function
+      | ({txt="ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern"; _}, _) -> true
+      | _ -> false
+    )
+
+let explicit_arity =
+  List.exists
+    (function
+      | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
+      | _ -> false
+    )

parsing/builtin_attributes.mli

@@ -17,7 +17,8 @@
    ocaml.ppwarning
    ocaml.warning
    ocaml.warnerror
-
+   ocaml.explicit_arity (for camlp4/camlp5)
+   ocaml.warn_on_literal_pattern
 *)
 
 
@@ -34,3 +35,6 @@ val warning_attribute: Parsetree.attributes -> unit
 val with_warning_attribute: Parsetree.attributes -> (unit -> 'a) -> 'a
 
 val emit_external_warnings: Ast_mapper.mapper
+
+val warn_on_literal_pattern: Parsetree.attributes -> bool
+val explicit_arity: Parsetree.attributes -> bool

typing/typecore.ml

@@ -305,20 +305,6 @@ let extract_label_names sexp env ty =
   with Not_found ->
     assert false
 
-let explicit_arity =
-  List.exists
-    (function
-      | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
-      | _ -> false
-    )
-
-let warn_on_literal_pattern =
-  List.exists
-    (function
-      | ({txt="ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern"; _}, _) -> true
-      | _ -> false
-    )
-
 (* Typing of patterns *)
 
 (* unification inside type_pat*)
@@ -1115,7 +1101,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
         match sarg with
           None -> []
         | Some {ppat_desc = Ppat_tuple spl} when
-            constr.cstr_arity > 1 || explicit_arity sp.ppat_attributes
+            constr.cstr_arity > 1 ||
+            Builtin_attributes.explicit_arity sp.ppat_attributes
           -> spl
         | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
             if constr.cstr_arity = 0 then
@@ -1124,9 +1111,11 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
             replicate_list sp constr.cstr_arity
         | Some sp -> [sp] in
       begin match sargs with
-      | [{ppat_desc = Ppat_constant _} as sp] when warn_on_literal_pattern constr.cstr_attributes ->
-            Location.prerr_warning sp.ppat_loc
-              Warnings.Fragile_literal_pattern
+      | [{ppat_desc = Ppat_constant _} as sp]
+        when Builtin_attributes.warn_on_literal_pattern
+            constr.cstr_attributes ->
+          Location.prerr_warning sp.ppat_loc
+            Warnings.Fragile_literal_pattern
       | _ -> ()
       end;
       if List.length sargs <> constr.cstr_arity then
@@ -3557,7 +3546,7 @@ and type_construct env loc lid sarg ty_expected attrs =
     match sarg with
       None -> []
     | Some {pexp_desc = Pexp_tuple sel} when
-        constr.cstr_arity > 1 || explicit_arity attrs
+        constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
       -> sel
     | Some se -> [se] in
   if List.length sargs <> constr.cstr_arity then