Refactor the classification of attributes

Introduce Cutil.class_of_attribute to return the class of the given attribute: one among
Attr_type  attribute related to types  (e.g. "aligned")
Attr_struct attribute related to struct/union/enum types (e.g. "packed")
Attr_function attribute related to function types (e.g. "noreturn")
Attr_name  attribute related to variable and function declarations (e.g. "section")
Attr_unknown  attribute was not declared

Cutil.declare_attribute is used to associate a class to a custom attribute.
Standard attributes (const, volatile, _Alignas, etc) are Attr_type.

cfronted/C2C.ml: declare the few attributes that CompCert honors currently.
cparser/GCC.ml: a bigger list of attributes taken from GCC, for reference only.

7 files changed, 101 insertions, 23 deletions

diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml
index b7fe5fb0..183af347 100644
--- a/cfrontend/C2C.ml
+++ b/cfrontend/C2C.ml
@@ -267,6 +267,19 @@ let builtins =
   { typedefs = builtins_generic.typedefs @ CBuiltins.builtins.typedefs;
     functions = builtins_generic.functions @ CBuiltins.builtins.functions }
 
+(** ** The known attributes *)
+
+let attributes = [
+  (* type-related *)
+  ("aligned", Cutil.Attr_type);
+  (* struct-related *)
+  ("packed", Cutil.Attr_struct);
+  (* function-related (currently none) *)
+  (* name-related *)
+  ("section", Cutil.Attr_name)
+]
+  
+
 (** ** Functions used to handle string literals *)
 
 let stringNum = ref 0   (* number of next global for string literals *)
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index 21e6f71e..44d16ea1 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -37,6 +37,15 @@ module IdentMap = Map.Make(Ident)
 
 (* Operations on attributes *)
 
+(* Normalize the name of an attribute, removing starting and trailing '__' *)
+
+let re_normalize_attrname = Str.regexp "^__\\(.*\\)__$"
+
+let normalize_attrname a =
+  if Str.string_match re_normalize_attrname a 0
+  then Str.matched_group 1 a
+  else a
+
 (* Lists of attributes are kept sorted in increasing order *)
 
 let rec add_attributes (al1: attributes) (al2: attributes) =
@@ -83,23 +92,34 @@ let rec remove_custom_attributes (names: string list)  (al: attributes) =
   | a :: tl ->
       a :: remove_custom_attributes names tl
 
-(* Is an attribute a ISO C standard attribute? *)
+(* Classification of attributes *)
 
-let attr_is_standard = function
-  | AConst | AVolatile | ARestrict -> true
-  | AAlignas _ | Attr _ -> false
+type attribute_class =
+  | Attr_name           (* Attribute applies to the names being declared  *)
+  | Attr_type           (* Attribute applies to types *)
+  | Attr_struct         (* Attribute applies to struct, union and enum *)
+  | Attr_function       (* Attribute applies to function types and decls *)
+  | Attr_unknown        (* Unknown attribute *)
+      
+let attr_class : (string, attribute_class) Hashtbl.t = Hashtbl.create 32
 
-(* Is an attribute type-related (true) or variable-related (false)? *)
+let declare_attribute name cls =
+  Hashtbl.replace attr_class (normalize_attrname name) cls
 
-let attr_is_type_related = function
-  | AConst | AVolatile | ARestrict | AAlignas _ -> true
-  | Attr(_, _) -> false
+let declare_attributes l =
+  List.iter (fun (n,c) -> declare_attribute n c) l
 
-(* Is an attribute related to structs, unions and enum (true) or not (false)? *)
+let class_of_attribute = function
+  | AConst | AVolatile | ARestrict | AAlignas _ -> Attr_type
+  | Attr(name, args) ->
+      try Hashtbl.find attr_class (normalize_attrname name)
+      with Not_found -> Attr_unknown
 
-let attr_is_struct_related = function
-  | Attr(("packed" | "__packed__"), _) -> true
-  | _ -> false
+(* Is an attribute a ISO C standard attribute? *)
+
+let attr_is_standard = function
+  | AConst | AVolatile | ARestrict -> true
+  | AAlignas _ | Attr _ -> false
 
 (* Is an attribute applicable to a whole array (true) or only to
    array elements (false)? *)
diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli
index 4906a8a8..4e62879b 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -52,17 +52,32 @@ val erase_attributes_type : Env.t -> typ -> typ
   (* Erase the attributes of the given type. *)
 val change_attributes_type : Env.t -> (attributes -> attributes) -> typ -> typ
   (* Apply the given function to the top-level attributes of the given type *)
-val attr_is_type_related: attribute -> bool
-  (* Is an attribute type-related (true) or variable-related (false)? *)
-val attr_is_struct_related: attribute -> bool
-  (* Is an attribute related to structs, unions and enum (true) or not (false)? *)
+
+type attribute_class =
+  | Attr_name           (* Attribute applies to the names being declared  *)
+  | Attr_type           (* Attribute applies to types *)
+  | Attr_struct         (* Attribute applies to struct, union and enum *)
+  | Attr_function       (* Attribute applies to function types and decls *)
+  | Attr_unknown        (* Not a declared attribute *)
+
+val declare_attribute: string -> attribute_class -> unit
+val declare_attributes: (string * attribute_class) list -> unit
+  (* Register the given custom attribute names with the given classes. *)
+val class_of_attribute: attribute -> attribute_class
+  (* Return the class of the given attribute.  Standard attributes
+     have class [Attr_type].  Custom attributes have the class that
+     was given to them using [declare_attribute], or [Attr_unknown]
+     if not declared. *)
 val attr_inherited_by_members: attribute -> bool
   (* Is an attribute of a composite inherited by members of the composite? *)
+
+
 val strip_attributes_type: typ -> attribute list -> typ
   (* Remove all attributes from the given type that are not contained in the list *)
 val strip_last_attribute: typ -> attribute option * typ
   (* Remove the last top level attribute and return it *)
 
+
 (* Type compatibility *)
 
 type attr_handling =
diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index cc66f04b..5d2a5cfe 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -478,12 +478,17 @@ let typespec_rank = function (* Don't change this *)
 let typespec_order t1 t2 = compare (typespec_rank t1) (typespec_rank t2)
 
 (* Auxiliary for type declarator elaboration.  Remove the non-type-related
-   attributes from the given type and return those attributes separately. *)
+   attributes from the given type and return those attributes separately.
+   If the type is a function type, keep function-related attributes
+   attached to the type. *)
 
 let get_nontype_attrs env ty =
-  let nta =
-    List.filter (fun a -> not (attr_is_type_related a))
-                (attributes_of_type env ty) in
+  let to_be_removed a =
+    match class_of_attribute a with
+    | Attr_type -> false
+    | Attr_function -> not (is_function_type env ty)
+    | _ -> true in
+  let nta = List.filter to_be_removed (attributes_of_type env ty) in
   (remove_attributes_type env nta ty, nta)
 
 (* Is a specifier an anonymous struct/union in the sense of ISO C2011? *)
@@ -544,7 +549,8 @@ let rec elab_specifier keep_ty ?(only = false) loc env specifier =
      The leftover non-struct-related attributes will be applied
      to the variable being defined. *)
   let get_struct_attrs () =
-    let (ta, nta) = List.partition attr_is_struct_related !attr in
+    let (ta, nta) =
+      List.partition (fun a -> class_of_attribute a = Attr_struct) !attr in
     attr := nta;
     ta in
 
diff --git a/cparser/GCC.ml b/cparser/GCC.ml
index f7f64a4e..010d12f3 100644
--- a/cparser/GCC.ml
+++ b/cparser/GCC.ml
@@ -13,7 +13,7 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-(* GCC built-ins *)
+(* GCC built-ins and attributes *)
 
 open C
 open Cutil
@@ -221,3 +221,25 @@ let builtins = {
   "__builtin_va_copy",  (voidType, [ voidPtrType; voidPtrType ], false)
 ]
 }
+
+let attributes = [ (* a subset of those of GCC 5 *)
+  (* type-related *)
+  ("aligned", Attr_type); ("may_alias", Attr_type); ("visibility", Attr_type);
+  (* struct-related *)
+  ("packed", Attr_struct); ("designated_init", Attr_struct);
+  (* function-related *)
+  ("cdecl", Attr_function); ("stdcall", Attr_function);
+  ("fastcall", Attr_function); ("thiscall", Attr_function);
+  ("const", Attr_function); ("noreturn", Attr_name);
+  (* name-related *)
+  ("cleanup", Attr_name); ("common", Attr_name); ("nocommon", Attr_name);
+  ("deprecated", Attr_name); ("section", Attr_name);
+  ("shared", Attr_name); ("tls_model", Attr_name); ("unused", Attr_name);
+  ("used", Attr_name); ("weak", Attr_name);
+  ("dllimport", Attr_name); ("dllexport", Attr_name);
+  ("alway_inline", Attr_name); ("gnu_inline", Attr_name);
+  ("artificial", Attr_name); ("flatten", Attr_name);
+  ("error", Attr_name); ("warning", Attr_name);
+  ("constructor", Attr_name); ("destructor", Attr_name);
+  ("externally_visible", Attr_name); ("interrupt", Attr_name)
+]
diff --git a/cparser/GCC.mli b/cparser/GCC.mli
index 76f40372..f26d12df 100644
--- a/cparser/GCC.mli
+++ b/cparser/GCC.mli
@@ -13,6 +13,7 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-(* GCC built-ins *)
+(* GCC built-ins and attributes *)
 
 val builtins: Builtins.t
+val attributes: (string * Cutil.attribute_class) list
diff --git a/driver/Driver.ml b/driver/Driver.ml
index 3219b7b7..9d5ed3b3 100755
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -540,6 +540,7 @@ let _ =
       | _         -> assert false
       end;
     Builtins.set C2C.builtins;
+    Cutil.declare_attributes C2C.attributes;
     CPragmas.initialize();
     parse_cmdline cmdline_actions;
     DebugInit.init (); (* Initialize the debug functions *)