Merge branch 'elaboration-of-attributes'

11 files changed, 148 insertions, 47 deletions

diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml
index 91941d74..f2fbf255 100644
--- a/cfrontend/C2C.ml
+++ b/cfrontend/C2C.ml
@@ -260,6 +260,20 @@ let builtins =
   Builtins.({ typedefs = builtins_generic.typedefs @ CBuiltins.builtins.typedefs;
     functions = builtins_generic.Builtins.functions @ CBuiltins.builtins.functions })
 
+(** ** The known attributes *)
+
+let attributes = [
+  (* type-related *)
+  ("aligned", Cutil.Attr_type);
+  (* struct-related *)
+  ("packed", Cutil.Attr_struct);
+  (* function-related *)
+  ("noreturn", Cutil.Attr_function);
+  (* name-related *)
+  ("section", Cutil.Attr_name)
+]
+  
+
 (** ** Functions used to handle string literals *)
 
 let stringNum = ref 0   (* number of next global for string literals *)
@@ -1091,7 +1105,7 @@ let convertFundef loc env fd =
   Hashtbl.add decl_atom id'
     { a_storage = fd.fd_storage;
       a_alignment = None;
-      a_sections = Sections.for_function env id' fd.fd_ret;
+      a_sections = Sections.for_function env id' fd.fd_attrib;
       a_access = Sections.Access_default;
       a_inline = fd.fd_inline && not fd.fd_vararg;  (* PR#15 *)
       a_loc = loc };
diff --git a/common/Sections.ml b/common/Sections.ml
index b792581f..1c2e8291 100644
--- a/common/Sections.ml
+++ b/common/Sections.ml
@@ -189,8 +189,7 @@ let for_variable env id ty init =
 
 (* Determine sections for a function definition *)
 
-let for_function env id ty_res =
-  let attr = Cutil.attributes_of_type env ty_res in
+let for_function env id attr =
   let si_code =
     try
       (* 1- Section explicitly associated with #use_section *)
diff --git a/common/Sections.mli b/common/Sections.mli
index 8a13fb8a..b83b0bb4 100644
--- a/common/Sections.mli
+++ b/common/Sections.mli
@@ -47,5 +47,5 @@ val use_section_for: AST.ident -> string -> bool
 
 val for_variable: Env.t -> AST.ident -> C.typ -> bool ->
                                           section_name * access_mode
-val for_function: Env.t -> AST.ident -> C.typ -> section_name list
+val for_function: Env.t -> AST.ident -> C.attributes -> section_name list
 val for_stringlit: unit -> section_name
diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml
index 2a110104..0a927873 100644
--- a/cparser/Cprint.ml
+++ b/cparser/Cprint.ml
@@ -142,13 +142,14 @@ let rec dcl ?(pp_indication=true) pp ty n =
       dcl pp t n'
   | TArray(t, sz, a) ->
       let n' pp =
+        n pp;
         begin match a with
-        | [] -> n pp
-        | _  -> fprintf pp " (%a%t)" attributes a n
+        | [] -> fprintf pp "["
+        | _  -> fprintf pp "[%a " attributes a
         end;
         begin match sz with
-        | None -> fprintf pp "[]"
-        | Some i -> fprintf pp "[%Ld]" i
+        | None -> fprintf pp "]"
+        | Some i -> fprintf pp "%Ld]" i
         end in
       dcl pp t n'
   | TFun(tres, args, vararg, a) ->
@@ -156,10 +157,8 @@ let rec dcl ?(pp_indication=true) pp ty n =
         dcl pp ty
           (fun pp -> fprintf pp " %a" ident id) in
       let n' pp =
-        begin match a with
-        | [] -> n pp
-        | _  -> fprintf pp " (%a%t)" attributes a n
-        end;
+        attributes pp a;
+        n pp;
         fprintf pp "(";
         if pp_indication then fprintf pp "@[<hov 0>";
         begin match args with
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index 9f893fb0..8a59c147 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,18 +92,35 @@ let rec remove_custom_attributes (names: string list)  (al: attributes) =
   | a :: tl ->
       a :: remove_custom_attributes names tl
 
+(* Classification of attributes *)
+
+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
+
+let declare_attribute name cls =
+  Hashtbl.replace attr_class (normalize_attrname name) cls
+
+let declare_attributes l =
+  List.iter (fun (n,c) -> declare_attribute n c) l
+
+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
+
 (* Is an attribute a ISO C standard attribute? *)
 
 let attr_is_standard = function
   | AConst | AVolatile | ARestrict -> true
   | AAlignas _ | Attr _ -> false
 
-(* Is an attribute type-related (true) or variable-related (false)? *)
-
-let attr_is_type_related = function
-  | Attr(("packed" | "__packed__"), _) -> true
-  | _ -> 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 5e560e44..4eaa9e4a 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -52,15 +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)? *)
+
+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 9995be5c..69830122 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -474,6 +474,19 @@ 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.
+   If the type is a function type, keep function-related attributes
+   attached to the type. *)
+
+let get_nontype_attrs env ty =
+  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)
 
 (* Elaboration of a type specifier.  Returns 5-tuple:
      (storage class, "inline" flag, "typedef" flag, elaborated type, new env)
@@ -518,14 +531,15 @@ let rec elab_specifier keep_ty ?(only = false) loc env specifier =
 
   let simple ty = (!sto, !inline, !noreturn ,!typedef, add_attributes_type !attr ty, env) in
 
-  (* As done in CIL, partition !attr into type-related attributes,
+  (* As done in CIL, partition !attr into struct-related attributes,
      which are returned, and other attributes, which are left in !attr.
-     The returned type-related attributes are applied to the
+     The returned struct-related attributes are applied to the
      struct/union/enum being defined.
-     The leftover non-type-related attributes will be applied
+     The leftover non-struct-related attributes will be applied
      to the variable being defined. *)
-  let get_type_attrs () =
-    let (ta, nta) = List.partition attr_is_type_related !attr in
+  let get_struct_attrs () =
+    let (ta, nta) =
+      List.partition (fun a -> class_of_attribute a = Attr_struct) !attr in
     attr := nta;
     ta in
 
@@ -584,21 +598,21 @@ let rec elab_specifier keep_ty ?(only = false) loc env specifier =
 
     | [Cabs.Tstruct_union(STRUCT, id, optmembers, a)] ->
         let a' =
-          add_attributes (get_type_attrs()) (elab_attributes env a) in
+          add_attributes (get_struct_attrs()) (elab_attributes env a) in
         let (id', env') =
           elab_struct_or_union keep_ty only Struct loc id optmembers a' env in
         (!sto, !inline, !noreturn, !typedef, TStruct(id', !attr), env')
 
     | [Cabs.Tstruct_union(UNION, id, optmembers, a)] ->
         let a' =
-          add_attributes (get_type_attrs()) (elab_attributes env a) in
+          add_attributes (get_struct_attrs()) (elab_attributes env a) in
         let (id', env') =
           elab_struct_or_union keep_ty only Union loc id optmembers a' env in
         (!sto, !inline, !noreturn, !typedef, TUnion(id', !attr), env')
 
     | [Cabs.Tenum(id, optmembers, a)] ->
         let a' =
-          add_attributes (get_type_attrs()) (elab_attributes env a) in
+          add_attributes (get_struct_attrs()) (elab_attributes env a) in
         let (id', env') =
           elab_enum only loc id optmembers a' env in
         (!sto, !inline, !noreturn, !typedef, TEnum(id', !attr), env')
@@ -631,7 +645,8 @@ and elab_type_declarator keep_ty loc env ty kr_ok = function
   | Cabs.JUSTBASE ->
       ((ty, None), env)
   | Cabs.ARRAY(d, cv_specs, sz) ->
-      let a = elab_cvspecs env cv_specs in
+      let (ty, a) = get_nontype_attrs env ty in
+      let a = add_attributes a (elab_cvspecs env cv_specs) in
       let sz' =
         match sz with
         | None ->
@@ -649,22 +664,25 @@ and elab_type_declarator keep_ty loc env ty kr_ok = function
                 Some 1L in (* produces better error messages later *)
        elab_type_declarator  keep_ty  loc env (TArray(ty, sz', a)) kr_ok  d
   | Cabs.PTR(cv_specs, d) ->
-      let a = elab_cvspecs env cv_specs in
+      let (ty, a) = get_nontype_attrs env ty in
+      let a = add_attributes a (elab_cvspecs env cv_specs) in
       elab_type_declarator keep_ty  loc env (TPtr(ty, a)) kr_ok d
   | Cabs.PROTO(d, (params, vararg)) ->
       elab_return_type loc env ty;
+      let (ty, a) = get_nontype_attrs env ty in
       let params',env' = elab_parameters keep_ty env params in
       let env = if  keep_ty then Env.add_types env env' else env in
-      elab_type_declarator  keep_ty  loc env (TFun(ty, Some params', vararg, [])) kr_ok d
+      elab_type_declarator  keep_ty  loc env (TFun(ty, Some params', vararg, a)) kr_ok d
   | Cabs.PROTO_OLD(d, params) ->
       elab_return_type loc env ty;
+      let (ty, a) = get_nontype_attrs env ty in
       match params with
       | [] ->
-        elab_type_declarator  keep_ty loc env (TFun(ty, None, false, [])) kr_ok d
+        elab_type_declarator  keep_ty loc env (TFun(ty, None, false, a)) kr_ok d
       | _ ->
         if not kr_ok || d <> Cabs.JUSTBASE then
           fatal_error loc "illegal old-style K&R function definition";
-        ((TFun(ty, None, false, []), Some params), env)
+        ((TFun(ty, None, false, a), Some params), env)
 
 (* Elaboration of parameters in a prototype *)
 
@@ -738,12 +756,14 @@ and elab_init_name_group keep_ty loc env (spec, namelist) =
     let a = elab_attributes env attr in
     if inl && not (is_function_type env ty) then
       error loc "'inline' can only appear on functions";
-    if noret then begin
-      warning loc Celeven_extension "_Noreturn functions are a C11 extension";
-      if not (is_function_type env ty) then
-        error loc "'_Noreturn' can only appear on functions";
-    end;
-    ((id, add_attributes_type a ty, init), env1) in
+    let a' =
+      if noret then begin
+        warning loc Celeven_extension "_Noreturn functions are a C11 extension";
+        if not (is_function_type env ty) then
+          error loc "'_Noreturn' can only appear on functions";
+        add_attributes [Attr("noreturn",[])] a
+      end else a in
+    ((id, add_attributes_type a' ty, init), env1) in
   (mmap elab_one_name env' namelist, sto, tydef)
 
 (* Elaboration of a field group *)
@@ -2328,17 +2348,19 @@ let elab_fundef env spec name defs body loc =
       { sdesc = Sblock (List.map mkdecl extra_decls @ [body2]);
         sloc = no_loc }
     end in
-  if noret then begin
+  (* Handling of _Noreturn and of attribute("noreturn") *)
+  if noret then
     warning loc Celeven_extension "_Noreturn functions are a C11 extension";
-    if contains_return body1 then
-      warning loc Invalid_noreturn "function '%s' declared 'noreturn' should not return" s;
-  end;
+  if (noret || find_custom_attributes ["noreturn"; "__noreturn__"] attr <> [])
+  && contains_return body1 then
+    warning loc Invalid_noreturn "function '%s' declared 'noreturn' should not return" s;
   (* Build and emit function definition *)
   let fn =
     { fd_storage = sto1;
       fd_inline = inline;
       fd_name = fun_id;
-      fd_attrib = attr;
+      fd_attrib = if noret then add_attributes [Attr("noreturn",[])] attr
+                           else attr;
       fd_ret = ty_ret;
       fd_params = params;
       fd_vararg = vararg;
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 *)
diff --git a/test/regression/attribs1.c b/test/regression/attribs1.c
index 808610b7..0650b189 100644
--- a/test/regression/attribs1.c
+++ b/test/regression/attribs1.c
@@ -24,7 +24,7 @@ __attribute((__section__("myconst"))) const int e = 12;
 const char filler4 = 1;
 __attribute((__section__("myconst"))) const int f = 34;
 
-__attribute((__section__("mycode"))) int myfunc(int x) { return x + 1; }
+__attribute((__section__("mycode"))) int * myfunc(int * x) { return x + 1; }
 
 /* Alignment with typedefs and structs */