Merge branch 'master' into mppa_postpass

Conflicts:
	.gitignore
	runtime/include/stdbool.h

5 files changed, 88 insertions, 27 deletions

diff --git a/cparser/Checks.ml b/cparser/Checks.ml
index 62d85c1b..a30cde7d 100644
--- a/cparser/Checks.ml
+++ b/cparser/Checks.ml
@@ -18,19 +18,12 @@ open Diagnostics
 open Cutil
 open Env
 
-let attribute_string = function
-  | AConst -> "const"
-  | AVolatile -> "volatile"
-  | ARestrict -> "restrict"
-  | AAlignas n -> "_Alignas"
-  | Attr(name, _) ->  name
-
 let unknown_attrs loc attrs =
   let unknown attr =
     let attr_class = class_of_attribute attr in
     if attr_class = Attr_unknown then
       warning loc Unknown_attribute
-        "unknown attribute '%s' ignored" (attribute_string attr) in
+        "unknown attribute '%s' ignored" (name_of_attribute attr) in
   List.iter unknown attrs
 
 let unknown_attrs_typ env loc ty =
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index ea9713d5..cf67015a 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -95,7 +95,10 @@ let rec remove_custom_attributes (names: string list)  (al: attributes) =
 (* Classification of attributes *)
 
 type attribute_class =
-  | Attr_name           (* Attribute applies to the names being declared  *)
+  | Attr_object         (* Attribute applies to the object being declared
+                           (function, global variable, local variable)  *)
+  | Attr_name           (* Attribute applies to the name being declared
+                          (object, struct/union member, struct/union/enum tag *)
   | Attr_type           (* Attribute applies to types *)
   | Attr_struct         (* Attribute applies to struct, union and enum *)
   | Attr_function       (* Attribute applies to function types and decls *)
@@ -111,11 +114,20 @@ let declare_attributes l =
 
 let class_of_attribute = function
   | AConst | AVolatile | ARestrict -> Attr_type
-  | AAlignas _ -> Attr_name
+  | AAlignas _ -> Attr_object
   | Attr(name, args) ->
       try Hashtbl.find attr_class (normalize_attrname name)
       with Not_found -> Attr_unknown
 
+(* Name for printing an attribute *)
+
+let name_of_attribute = function
+  | AConst -> "const"
+  | AVolatile -> "volatile"
+  | ARestrict -> "restrict"
+  | AAlignas n -> "_Alignas"
+  | Attr(name, _) ->  name
+
 (* Is an attribute a ISO C standard attribute? *)
 
 let attr_is_standard = function
@@ -163,7 +175,10 @@ let rec unroll env t =
       unroll env (add_attributes_type attr ty)
   | _ -> t
 
-(* Extracting the attributes of a type *)
+(* Extracting the attributes of a type, including the attributes
+   attached to typedefs, structs and unions.  In other words,
+   typedefs are unrolled and composite definitions expanded
+   before extracting the attributes.  *)
 
 let rec attributes_of_type env t =
   match t with
@@ -190,6 +205,23 @@ let rec attributes_of_type env t =
       | exception Env.Error(Env.Unbound_tag _) -> a
       end
 
+(* Extracting the attributes of a type, excluding the attributes
+   attached to typedefs, structs and unions.  In other words,
+   typedefs are not unrolled and composite definitions are not expanded. *)
+
+let rec attributes_of_type_no_expand t =
+  match t with
+  | TVoid a -> a
+  | TInt(ik, a) -> a
+  | TFloat(fk, a) -> a
+  | TPtr(ty, a) -> a
+  | TArray(ty, sz, a) -> add_attributes a (attributes_of_type_no_expand ty)
+  | TFun(ty, params, vararg, a) -> a
+  | TNamed(s, a) -> a
+  | TStruct(s, a) -> a
+  | TUnion(s, a) -> a
+  | TEnum(s, a) -> a
+
 (* Changing the attributes of a type (at top-level) *)
 (* Same hack as above for array types. *)
 
diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli
index dc9dc0cc..5a1e9af3 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -50,6 +50,8 @@ val remove_custom_attributes : string list -> attributes -> attributes
      in the given list of names. *)
 val attributes_of_type : Env.t -> typ -> attributes
   (* Return the attributes of the given type, expanding typedefs if needed. *)
+val attributes_of_type_no_expand : typ -> attributes
+  (* Return the attributes of the given type, without expanding typedefs. *)
 val add_attributes_type : attributes -> typ -> typ
   (* Add the given set of attributes to those of the given type. *)
 val remove_attributes_type : Env.t -> attributes -> typ -> typ
@@ -62,7 +64,10 @@ val has_std_alignas :  Env.t -> typ -> bool
   (* Do the attributes of the type contain the C11 _Alignas attribute *)
 
 type attribute_class =
-  | Attr_name           (* Attribute applies to the names being declared  *)
+  | Attr_object         (* Attribute applies to the object being declared
+                          (function, global variable, local variable)  *)
+  | Attr_name           (* Attribute applies to the name being declared
+                          (object, struct/union member, struct/union/enum tag *)
   | Attr_type           (* Attribute applies to types *)
   | Attr_struct         (* Attribute applies to struct, union and enum *)
   | Attr_function       (* Attribute applies to function types and decls *)
@@ -76,6 +81,8 @@ val class_of_attribute: attribute -> attribute_class
      have class [Attr_type].  Custom attributes have the class that
      was given to them using [declare_attribute], or [Attr_unknown]
      if not declared. *)
+val name_of_attribute: attribute -> string
+  (* Name for printing an attribute *)
 val attr_inherited_by_members: attribute -> bool
   (* Is an attribute of a composite inherited by members of the composite? *)
 
diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index 718261b4..7a0b05de 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -535,8 +535,11 @@ let elab_attribute env = function
             (List.flatten
                (List.map (elab_gcc_attr loc env) l)))
   | PACKED_ATTR (args, loc) ->
-      enter_gcc_attr loc 
+    begin try
+      enter_gcc_attr loc
         (Attr("__packed__", List.map (elab_attr_arg loc env) args))
+      with Wrong_attr_arg -> error loc "ill-formed 'packed' attribute"; []
+    end
   | ALIGNAS_ATTR ([a], loc) ->
       warning loc Celeven_extension "'_Alignas' is a C11 extension";
       begin match elab_attr_arg loc env a with
@@ -595,7 +598,7 @@ let get_nontype_attrs env ty =
     | 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
+  let nta = List.filter to_be_removed (attributes_of_type_no_expand ty) in
   (remove_attributes_type env nta ty, nta)
 
 (* Elaboration of a type specifier.  Returns 6-tuple:
@@ -653,15 +656,31 @@ let rec elab_specifier ?(only = false) loc env specifier =
     restrict_check ty;
     (!sto, !inline, !noreturn ,!typedef, add_attributes_type !attr ty, env) in
 
-  (* As done in CIL, partition !attr into struct-related attributes,
+  (* Partition !attr into name- and struct-related attributes,
      which are returned, and other attributes, which are left in !attr.
-     The returned struct-related attributes are applied to the
+     The returned name-or-struct-related attributes are applied to the
      struct/union/enum being defined.
-     The leftover non-struct-related attributes will be applied
-     to the variable being defined. *)
-  let get_struct_attrs () =
+     The leftover attributes (e.g. object attributes) will be applied
+     to the variable being defined.
+     If [optmembers] is [None], name-related attributes are not returned
+     but left in !attr.  This corresponds to two use cases:
+     - A use of an already-defined struct/union/enum.  In this case
+       the name-related attributes should go to the name being declared.
+       Sending them to the struct/union/enum would cause them to be ignored,
+       with a warning.  The struct-related attributes go to the 
+       struct/union/enum, are ignored, and cause a warning.
+     - An incomplete declaration of a struct/union.  In this case
+       the name- and struct-related attributes are just ignored,
+       like GCC does.
+  *)
+  let get_definition_attrs optmembers =
     let (ta, nta) =
-      List.partition (fun a -> class_of_attribute a = Attr_struct) !attr in
+      List.partition
+        (fun a -> match class_of_attribute a with
+                  | Attr_struct -> true
+                  | Attr_name -> optmembers <> None
+                  | _ -> false)
+        !attr in
     attr := nta;
     ta in
 
@@ -720,7 +739,8 @@ let rec elab_specifier ?(only = false) loc env specifier =
 
     | [Cabs.Tstruct_union(STRUCT, id, optmembers, a)] ->
         let a' =
-          add_attributes (get_struct_attrs()) (elab_attributes env a) in
+          add_attributes (get_definition_attrs optmembers)
+                         (elab_attributes env a) in
         let (id', env') =
           elab_struct_or_union only Struct loc id optmembers a' env in
         let ty =  TStruct(id', !attr) in
@@ -729,7 +749,8 @@ let rec elab_specifier ?(only = false) loc env specifier =
 
     | [Cabs.Tstruct_union(UNION, id, optmembers, a)] ->
         let a' =
-          add_attributes (get_struct_attrs()) (elab_attributes env a) in
+          add_attributes (get_definition_attrs optmembers)
+                         (elab_attributes env a) in
         let (id', env') =
           elab_struct_or_union only Union loc id optmembers a' env in
         let ty =  TUnion(id', !attr) in
@@ -738,7 +759,8 @@ let rec elab_specifier ?(only = false) loc env specifier =
 
     | [Cabs.Tenum(id, optmembers, a)] ->
         let a' =
-          add_attributes (get_struct_attrs()) (elab_attributes env a) in
+          add_attributes (get_definition_attrs optmembers)
+                         (elab_attributes env a) in
         let (id', env') =
           elab_enum only loc id optmembers a' env in
         let ty = TEnum (id', !attr) in
@@ -2359,6 +2381,13 @@ let enter_typedefs loc env sto dl =
       error loc "initializer in typedef";
     if has_std_alignas env ty then
       error loc "alignment specified for typedef '%s'" s;
+    List.iter
+      (fun a -> match class_of_attribute a with
+                | Attr_object | Attr_struct ->
+                    error loc "attribute '%s' not allowed in 'typedef'"
+                              (name_of_attribute a)
+                | _ -> ())
+      (attributes_of_type_no_expand ty);
     match previous_def Env.lookup_typedef env s with
     | Some (s',ty') when Env.in_current_scope env s' ->
         if equal_types env ty ty' then begin
diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml
index a2c91c0a..3c27f3a9 100644
--- a/cparser/PackedStructs.ml
+++ b/cparser/PackedStructs.ml
@@ -36,7 +36,7 @@ let byteswapped_fields : (ident * string, unit) Hashtbl.t
 
 let rec can_byte_swap env ty =
   match unroll env ty with
-  | TInt(ik, _) -> (sizeof_ikind ik <= !config.sizeof_ptr (*FIXME*), sizeof_ikind ik > 1)
+  | TInt(ik, _) -> (sizeof_ikind ik <= !config.sizeof_intreg, sizeof_ikind ik > 1)
   | TEnum(_, _) -> (true, sizeof_ikind enum_ikind > 1)
   | TPtr(_, _) -> (true, true)          (* tolerance? *)
   | TArray(ty_elt, _, _) -> can_byte_swap env ty_elt
@@ -66,7 +66,7 @@ let transf_field_decl mfa swapped loc env struct_id f =
   if swapped then begin
     let (can_swap, must_swap) = can_byte_swap env f.fld_typ in
     if not can_swap then
-      error loc "cannot byte-swap field of type '%a'"
+      fatal_error loc "cannot byte-swap field of type '%a'"
         Cprint.typ f.fld_typ;
     if must_swap then
       Hashtbl.add byteswapped_fields (struct_id, f.fld_name) ()
@@ -141,7 +141,7 @@ let use_reversed = ref false
 let bswap_read loc env lval =
   let ty = lval.etyp in
   let (bsize, aty) = accessor_type loc env ty in
-  assert (bsize = 16 || bsize = 32 || (bsize = 64 && !config.sizeof_ptr = 8));
+  assert (bsize = 16 || bsize = 32 || (bsize = 64 && !config.sizeof_intreg = 8));
   try
     if !use_reversed then begin
       let (id, fty) =
@@ -168,7 +168,7 @@ let bswap_write loc env lhs rhs =
   let ty = lhs.etyp in
   let (bsize, aty) =
     accessor_type loc env ty in
-  assert (bsize = 16 || bsize = 32 || (bsize = 64 && !config.sizeof_ptr = 8));
+  assert (bsize = 16 || bsize = 32 || (bsize = 64 && !config.sizeof_intreg = 8));
   try
     if !use_reversed then begin
       let (id, fty) =