Use Attr_helper in typing/typedecl.ml

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

.depend

@@ -350,16 +350,16 @@ typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \
     typing/predef.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
-    parsing/ast_helper.cmi typing/typedecl.cmi
+    utils/clflags.cmi typing/btype.cmi parsing/attr_helper.cmi \
+    parsing/asttypes.cmi parsing/ast_helper.cmi typing/typedecl.cmi
 typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \
     typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \
     typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx \
     typing/predef.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \
     typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
-    parsing/ast_helper.cmx typing/typedecl.cmi
+    utils/clflags.cmx typing/btype.cmx parsing/attr_helper.cmx \
+    parsing/asttypes.cmi parsing/ast_helper.cmx typing/typedecl.cmi
 typing/typedtreeIter.cmo : typing/typedtree.cmi utils/misc.cmi \
     parsing/asttypes.cmi typing/typedtreeIter.cmi
 typing/typedtreeIter.cmx : typing/typedtree.cmx utils/misc.cmx \

typing/typedecl.ml

@@ -21,10 +21,6 @@ open Typetexp
 
 type native_repr_kind = Unboxed | Untagged
 
-let string_of_native_repr_kind = function
-  | Unboxed -> "unboxed"
-  | Untagged -> "untagged"
-
 type error =
     Repeated_parameter
   | Duplicate_constructor of string
@@ -52,7 +48,6 @@ type error =
   | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
   | Val_in_structure
-  | Invalid_native_repr_attribute_payload of native_repr_kind
   | Multiple_native_repr_attributes
   | Cannot_unbox_or_untag_type of native_repr_kind
 
@@ -1367,25 +1362,16 @@ type native_repr_attribute =
 
 let get_native_repr_attribute core_type =
   match
-    List.filter
-      (fun (n, _) ->
-         match n.Location.txt with
-         | "unboxed" | "untagged" -> true
-         | _ -> false)
-      core_type.ptyp_attributes
+    let attrs = core_type.ptyp_attributes in
+    Attr_helper.get_no_payload_attribute "unboxed"  attrs,
+    Attr_helper.get_no_payload_attribute "untagged" attrs
   with
-  | [] ->
+  | None, None ->
     Native_repr_attr_absent
-  | _ :: (n, _) :: _ ->
-    raise (Error (n.Location.loc, Multiple_native_repr_attributes))
-  | [(n, payload)] ->
-    let kind = if n.txt = "unboxed" then Unboxed else Untagged in
-    match payload with
-    | PStr [] ->
-      Native_repr_attr_present kind
-    | _ ->
-      raise (Error (n.Location.loc,
-                    Invalid_native_repr_attribute_payload kind))
+  | Some _, None -> Native_repr_attr_present Unboxed
+  | None, Some _ -> Native_repr_attr_present Untagged
+  | Some { Location.loc }, _ ->
+    raise (Error (loc, Multiple_native_repr_attributes))
 
 let native_repr_of_type env kind ty =
   match kind, (Ctype.expand_head_opt env ty).desc with
@@ -1791,9 +1777,6 @@ let report_error ppf = function
         "cannot be checked"
   | Val_in_structure ->
       fprintf ppf "Value declarations are only allowed in signatures"
-  | Invalid_native_repr_attribute_payload kind ->
-      fprintf ppf "[@@%s] attribute does not accept a payload"
-        (string_of_native_repr_kind kind)
   | Multiple_native_repr_attributes ->
       fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
   | Cannot_unbox_or_untag_type Unboxed ->

typing/typedecl.mli

@@ -85,7 +85,6 @@ type error =
   | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
   | Val_in_structure
-  | Invalid_native_repr_attribute_payload of native_repr_kind
   | Multiple_native_repr_attributes
   | Cannot_unbox_or_untag_type of native_repr_kind