aspects.ads, [...]: Add entries for aspect Obsolescent.

2014-08-04  Robert Dewar  <dewar@adacore.com>

	* aspects.ads, aspects.adb: Add entries for aspect Obsolescent.
	* gnat_rm.texi: Add documentation for aspect Obsolescent.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Implement aspect
	Obsolescent.
	(Check_Aspect_At_Freeze_Point): Add dummy entry for pragma Obsolescent.
	* s-osprim-mingw.adb: Minor reformatting.
	* sem_res.adb (Is_Atomic_Ref_With_Address): New function
	(Resolve_Indexed_Component): Rework warnings for non-atomic access
	(Resolve_Selected_Component): Add warnings for non-atomic access.

From-SVN: r213588

gcc/ada/ChangeLog

+2014-08-04  Robert Dewar  <dewar@adacore.com>
+
+	* aspects.ads, aspects.adb: Add entries for aspect Obsolescent.
+	* gnat_rm.texi: Add documentation for aspect Obsolescent.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Implement aspect
+	Obsolescent.
+	(Check_Aspect_At_Freeze_Point): Add dummy entry for pragma Obsolescent.
+	* s-osprim-mingw.adb: Minor reformatting.
+	* sem_res.adb (Is_Atomic_Ref_With_Address): New function
+	(Resolve_Indexed_Component): Rework warnings for non-atomic access
+	(Resolve_Selected_Component): Add warnings for non-atomic access.
+
 2014-08-04  Doug Rupp  <rupp@adacore.com>
 
 	* g-calend.adb (timeval_to_duration, duration_to_timeval): Change sec

gcc/ada/aspects.adb

@@ -546,6 +546,7 @@ package body Aspects is
     Aspect_Machine_Radix                => Aspect_Machine_Radix,
     Aspect_No_Elaboration_Code_All      => Aspect_No_Elaboration_Code_All,
     Aspect_No_Return                    => Aspect_No_Return,
+    Aspect_Obsolescent                  => Aspect_Obsolescent,
     Aspect_Object_Size                  => Aspect_Object_Size,
     Aspect_Output                       => Aspect_Output,
     Aspect_Pack                         => Aspect_Pack,

gcc/ada/aspects.ads

@@ -109,6 +109,7 @@ package Aspects is
       Aspect_Linker_Section,                -- GNAT
       Aspect_Machine_Radix,
       Aspect_Object_Size,                   -- GNAT
+      Aspect_Obsolescent,                   -- GNAT
       Aspect_Output,
       Aspect_Part_Of,                       -- GNAT
       Aspect_Post,
@@ -333,6 +334,7 @@ package Aspects is
       Aspect_Linker_Section            => Expression,
       Aspect_Machine_Radix             => Expression,
       Aspect_Object_Size               => Expression,
+      Aspect_Obsolescent               => Optional_Expression,
       Aspect_Output                    => Name,
       Aspect_Part_Of                   => Expression,
       Aspect_Post                      => Expression,
@@ -433,6 +435,7 @@ package Aspects is
       Aspect_No_Elaboration_Code_All      => Name_No_Elaboration_Code_All,
       Aspect_No_Return                    => Name_No_Return,
       Aspect_Object_Size                  => Name_Object_Size,
+      Aspect_Obsolescent                  => Name_Obsolescent,
       Aspect_Output                       => Name_Output,
       Aspect_Pack                         => Name_Pack,
       Aspect_Part_Of                      => Name_Part_Of,
@@ -688,6 +691,7 @@ package Aspects is
       Aspect_Initial_Condition            => Never_Delay,
       Aspect_Initializes                  => Never_Delay,
       Aspect_No_Elaboration_Code_All      => Never_Delay,
+      Aspect_Obsolescent                  => Never_Delay,
       Aspect_Part_Of                      => Never_Delay,
       Aspect_Refined_Depends              => Never_Delay,
       Aspect_Refined_Global               => Never_Delay,

gcc/ada/gnat_rm.texi

@@ -313,6 +313,7 @@ Implementation Defined Aspects
 * Aspect Linker_Section::
 * Aspect No_Elaboration_Code_All::
 * Aspect Object_Size::
+* Aspect Obsolescent::
 * Aspect Part_Of::
 * Aspect Persistent_BSS::
 * Aspect Predicate::
@@ -8068,6 +8069,7 @@ clause.
 * Aspect Lock_Free::
 * Aspect No_Elaboration_Code_All::
 * Aspect Object_Size::
+* Aspect Obsolescent::
 * Aspect Part_Of::
 * Aspect Persistent_BSS::
 * Aspect Predicate::
@@ -8350,6 +8352,14 @@ statement for a program unit.
 This aspect is equivalent to an @code{Object_Size} attribute definition
 clause.
 
+@node Aspect Obsolescent
+@unnumberedsec Aspect Obsolescent
+@findex Obsolsecent
+@noindent
+This aspect is equivalent to an @code{Obsolescent} pragma. Note that the
+evaluation of this aspect happens at the point of occurrence, it is not
+delayed until the freeze point.
+
 @node Aspect Part_Of
 @unnumberedsec Aspect Part_Of
 @findex Part_Of

gcc/ada/s-osprim-mingw.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2013, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2014, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL is free software; you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -87,15 +87,15 @@ package body System.OS_Primitives is
    --  the base data for the changes to get undetected.
 
    type Signature_Type is mod 2**32;
-   Signature     : Signature_Type := 0;
+   Signature : Signature_Type := 0;
    pragma Atomic (Signature);
 
    procedure Get_Base_Time (Data : out Clock_Data);
    --  Retrieve the base time and base ticks. These values will be used by
    --  clock to compute the current time by adding to it a fraction of the
-   --  performance counter. This is for the implementation of a
-   --  high-resolution clock. Note that this routine does not change the base
-   --  monotonic values used by the monotonic clock.
+   --  performance counter. This is for the implementation of a high-resolution
+   --  clock. Note that this routine does not change the base monotonic values
+   --  used by the monotonic clock.
 
    -----------
    -- Clock --

gcc/ada/sem_ch13.adb

@@ -2388,6 +2388,25 @@ package body Sem_Ch13 is
                   goto Continue;
                end Initializes;
 
+               --  Obsolescent
+
+               when Aspect_Obsolescent => declare
+                  Args : List_Id;
+
+               begin
+                  if No (Expr) then
+                     Args := No_List;
+                  else
+                     Args := New_List (
+                       Make_Pragma_Argument_Association (Sloc (Expr),
+                         Expression => Relocate_Node (Expr)));
+                  end if;
+
+                  Make_Aitem_Pragma
+                    (Pragma_Argument_Associations => Args,
+                     Pragma_Name                  => Chars (Id));
+               end;
+
                --  Part_Of
 
                when Aspect_Part_Of =>
@@ -8758,6 +8777,7 @@ package body Sem_Ch13 is
               Aspect_Implicit_Dereference      |
               Aspect_Initial_Condition         |
               Aspect_Initializes               |
+              Aspect_Obsolescent               |
               Aspect_Part_Of                   |
               Aspect_Post                      |
               Aspect_Postcondition             |

gcc/ada/sem_res.adb

@@ -128,6 +128,11 @@ package body Sem_Res is
    --  for restriction No_Direct_Boolean_Operators. This procedure also handles
    --  the style check for Style_Check_Boolean_And_Or.
 
+   function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean;
+   --  N is either an indexed component or a selected component. This function
+   --  returns true if the prefix refers to an object that has an address
+   --  clause (the case in which we may want to issue a warning).
+
    function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
    --  Determine whether E is an access type declared by an access declaration,
    --  and not an (anonymous) allocator type.
@@ -1131,6 +1136,29 @@ package body Sem_Res is
       end if;
    end Check_Parameterless_Call;
 
+   --------------------------------
+   -- Is_Atomic_Ref_With_Address --
+   --------------------------------
+
+   function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is
+      Pref : constant Node_Id := Prefix (N);
+
+   begin
+      if not Is_Entity_Name (Pref) then
+         return False;
+
+      else
+         declare
+            Pent : constant Entity_Id := Entity (Pref);
+            Ptyp : constant Entity_Id := Etype (Pent);
+         begin
+            return not Is_Access_Type (Ptyp)
+              and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent))
+              and then Present (Address_Clause (Pent));
+         end;
+      end if;
+   end Is_Atomic_Ref_With_Address;
+
    -----------------------------
    -- Is_Definite_Access_Type --
    -----------------------------
@@ -7973,19 +8001,20 @@ package body Sem_Res is
          Eval_Indexed_Component (N);
       end if;
 
-      --  If the array type is atomic, and is packed, and we are in a left side
-      --  context, then this is worth a warning, since we have a situation
-      --  where the access to the component may cause extra read/writes of
-      --  the atomic array object, which could be considered unexpected.
+      --  If the array type is atomic, and the component is not atomic, then
+      --  this is worth a warning, since we have a situation where the access
+      --  to the component may cause extra read/writes of the atomic array
+      --  object, or partial word accesses, which could be unexpected.
 
       if Nkind (N) = N_Indexed_Component
-        and then (Is_Atomic (Array_Type)
-                   or else (Is_Entity_Name (Prefix (N))
-                             and then Is_Atomic (Entity (Prefix (N)))))
-        and then Is_Bit_Packed_Array (Array_Type)
-        and then Is_LHS (N) = Yes
+        and then Is_Atomic_Ref_With_Address (N)
+        and then not (Has_Atomic_Components (Array_Type)
+                       or else (Is_Entity_Name (Prefix (N))
+                                 and then Has_Atomic_Components
+                                            (Entity (Prefix (N)))))
+        and then not Is_Atomic (Component_Type (Array_Type))
       then
-         Error_Msg_N ("??assignment to component of packed atomic array",
+         Error_Msg_N ("??access to non-atomic component of atomic array",
                       Prefix (N));
          Error_Msg_N ("??\may cause unexpected accesses to atomic object",
                       Prefix (N));
@@ -9293,7 +9322,7 @@ package body Sem_Res is
    procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
       Comp  : Entity_Id;
       Comp1 : Entity_Id        := Empty; -- prevent junk warning
-      P     : constant Node_Id := Prefix  (N);
+      P     : constant Node_Id := Prefix (N);
       S     : constant Node_Id := Selector_Name (N);
       T     : Entity_Id        := Etype (P);
       I     : Interp_Index;
@@ -9470,22 +9499,22 @@ package body Sem_Res is
       --  Note: No Eval processing is required, because the prefix is of a
       --  record type, or protected type, and neither can possibly be static.
 
-      --  If the array type is atomic, and is packed, and we are in a left side
-      --  context, then this is worth a warning, since we have a situation
-      --  where the access to the component may cause extra read/writes of the
-      --  atomic array object, which could be considered unexpected.
+      --  If the record type is atomic, and the component is non-atomic, then
+      --  this is worth a warning, since we have a situation where the access
+      --  to the component may cause extra read/writes of the atomic array
+      --  object, or partial word accesses, both of which may be unexpected.
 
       if Nkind (N) = N_Selected_Component
-        and then (Is_Atomic (T)
-                   or else (Is_Entity_Name (Prefix (N))
-                             and then Is_Atomic (Entity (Prefix (N)))))
-        and then Is_Packed (T)
-        and then Is_LHS (N) = Yes
+        and then Is_Atomic_Ref_With_Address (N)
+        and then not Is_Atomic (Entity (S))
+        and then not Is_Atomic (Etype (Entity (S)))
       then
          Error_Msg_N
-           ("??assignment to component of packed atomic record", Prefix (N));
+           ("??access to non-atomic component of atomic record",
+            Prefix (N));
          Error_Msg_N
-           ("\??may cause unexpected accesses to atomic object", Prefix (N));
+           ("\??may cause unexpected accesses to atomic object",
+            Prefix (N));
       end if;
 
       Analyze_Dimension (N);