[multiple changes]

2011-11-21  Arnaud Charlet  <charlet@adacore.com>

	* s-taprop-irix.adb, s-taprop-solaris.adb (Create_Task): Use
	Unrestricted_Access to deal with fact that we properly detect the
	error if Access is used.
	* gcc-interface/Make-lang.in: Update dependencies.

2011-11-21  Yannick Moy  <moy@adacore.com>

	* exp_prag.adb (Expand_Pragma_Check): Place error on first character
	of expression.
	* sem_res.adb (Resolve_Short_Circuit): Place error on first
	character of expression.

2011-11-21  Yannick Moy  <moy@adacore.com>

	* exp_util.adb (Remove_Side_Effects): Do nothing in Alfa mode.

2011-11-21  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference, case
	Max_Size_In_Storage_Elements): Account for the size of the
	hidden list header which precedes controlled objects allocated
	on the heap.
	* rtsfind.ads: Add RE_Header_Size_With_Padding to the runtime
	tables.
	* sinfo.adb (Header_Size_Added): New routine.
	(Set_Header_Size_Added): New routine.
	* sinfo.ads: Add flag Controlled_Header_Added along with
	associated comment.
	(Header_Size_Added): New inlined routine.
	(Set_Header_Size_Added): New inlined routine.
	* s-stposu.adb (Allocate_Any_Controlled): Use
	Header_Size_With_Padding to calculate the proper
	size of the header.
	(Deallocate_Any_Controlled): Use
	Header_Size_With_Padding to calculate the proper size
	of the header.	(Header_Size_With_Padding): New routine.
	(Nearest_Multiple_Rounded_Up): Removed along with its uses.
	* s-stposu.ads (Header_Size_With_Padding): New routine.

2011-11-21  Ed Schonberg  <schonberg@adacore.com>

	* aspects.adb: Aspect specifications are allowed on renaming
	declarations
	* par-ch6.adb (P_Subprogram): Parse aspect specifications in a
	subprogram renaming declaration

From-SVN: r181576

gcc/ada/ChangeLog

+2011-11-21  Arnaud Charlet  <charlet@adacore.com>
+
+	* s-taprop-irix.adb, s-taprop-solaris.adb (Create_Task): Use
+	Unrestricted_Access to deal with fact that we properly detect the
+	error if Access is used.
+	* gcc-interface/Make-lang.in: Update dependencies.
+
+2011-11-21  Yannick Moy  <moy@adacore.com>
+
+	* exp_prag.adb (Expand_Pragma_Check): Place error on first character
+	of expression.
+	* sem_res.adb (Resolve_Short_Circuit): Place error on first
+	character of expression.
+
+2011-11-21  Yannick Moy  <moy@adacore.com>
+
+	* exp_util.adb (Remove_Side_Effects): Do nothing in Alfa mode.
+
+2011-11-21  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_attr.adb (Expand_N_Attribute_Reference, case
+	Max_Size_In_Storage_Elements): Account for the size of the
+	hidden list header which precedes controlled objects allocated
+	on the heap.
+	* rtsfind.ads: Add RE_Header_Size_With_Padding to the runtime
+	tables.
+	* sinfo.adb (Header_Size_Added): New routine.
+	(Set_Header_Size_Added): New routine.
+	* sinfo.ads: Add flag Controlled_Header_Added along with
+	associated comment.
+	(Header_Size_Added): New inlined routine.
+	(Set_Header_Size_Added): New inlined routine.
+	* s-stposu.adb (Allocate_Any_Controlled): Use
+	Header_Size_With_Padding to calculate the proper
+	size of the header.
+	(Deallocate_Any_Controlled): Use
+	Header_Size_With_Padding to calculate the proper size
+	of the header.	(Header_Size_With_Padding): New routine.
+	(Nearest_Multiple_Rounded_Up): Removed along with its uses.
+	* s-stposu.ads (Header_Size_With_Padding): New routine.
+
+2011-11-21  Ed Schonberg  <schonberg@adacore.com>
+
+	* aspects.adb: Aspect specifications are allowed on renaming
+	declarations
+	* par-ch6.adb (P_Subprogram): Parse aspect specifications in a
+	subprogram renaming declaration
+
 2011-11-21  Tristan Gingold  <gingold@adacore.com>
 
 	* env.c: Remove unused declaration.

gcc/ada/aspects.adb

@@ -180,6 +180,7 @@ package body Aspects is
       N_Component_Declaration                  => True,
       N_Entry_Declaration                      => True,
       N_Exception_Declaration                  => True,
+      N_Exception_Renaming_Declaration         => True,
       N_Formal_Abstract_Subprogram_Declaration => True,
       N_Formal_Concrete_Subprogram_Declaration => True,
       N_Formal_Object_Declaration              => True,
@@ -188,11 +189,14 @@ package body Aspects is
       N_Full_Type_Declaration                  => True,
       N_Function_Instantiation                 => True,
       N_Generic_Package_Declaration            => True,
+      N_Generic_Renaming_Declaration           => True,
       N_Generic_Subprogram_Declaration         => True,
       N_Object_Declaration                     => True,
+      N_Object_Renaming_Declaration            => True,
       N_Package_Declaration                    => True,
       N_Package_Instantiation                  => True,
       N_Package_Specification                  => True,
+      N_Package_Renaming_Declaration           => True,
       N_Private_Extension_Declaration          => True,
       N_Private_Type_Declaration               => True,
       N_Procedure_Instantiation                => True,
@@ -202,6 +206,7 @@ package body Aspects is
       N_Single_Task_Declaration                => True,
       N_Subprogram_Body                        => True,
       N_Subprogram_Declaration                 => True,
+      N_Subprogram_Renaming_Declaration        => True,
       N_Subtype_Declaration                    => True,
       N_Task_Body                              => True,
       N_Task_Type_Declaration                  => True,

gcc/ada/exp_attr.adb

@@ -2989,6 +2989,52 @@ package body Exp_Attr is
          Analyze_And_Resolve (N, Typ);
       end Mantissa;
 
+      ----------------------------------
+      -- Max_Size_In_Storage_Elements --
+      ----------------------------------
+
+      when Attribute_Max_Size_In_Storage_Elements =>
+         Apply_Universal_Integer_Attribute_Checks (N);
+
+         --  Heap-allocated controlled objects contain two extra pointers which
+         --  are not part of the actual type. Transform the attribute reference
+         --  into a runtime expression to add the size of the hidden header.
+
+         --  Do not perform this expansion on .NET/JVM targets because the
+         --  two pointers are already present in the type.
+
+         if VM_Target = No_VM
+           and then Nkind (N) = N_Attribute_Reference
+           and then Needs_Finalization (Ptyp)
+           and then not Header_Size_Added (N)
+         then
+            Set_Header_Size_Added (N);
+
+            --  Generate:
+            --    P'Max_Size_In_Storage_Elements +
+            --      Universal_Integer
+            --        (Header_Size_With_Padding (Ptyp'Alignment))
+
+            Rewrite (N,
+              Make_Op_Add (Loc,
+                Left_Opnd  => Relocate_Node (N),
+                Right_Opnd =>
+                  Convert_To (Universal_Integer,
+                    Make_Function_Call (Loc,
+                      Name                   =>
+                        New_Reference_To
+                          (RTE (RE_Header_Size_With_Padding), Loc),
+
+                      Parameter_Associations => New_List (
+                        Make_Attribute_Reference (Loc,
+                          Prefix         =>
+                            New_Reference_To (Ptyp, Loc),
+                          Attribute_Name => Name_Alignment))))));
+
+            Analyze (N);
+            return;
+         end if;
+
       --------------------
       -- Mechanism_Code --
       --------------------
@@ -5572,8 +5618,7 @@ package body Exp_Attr is
       --  that the result is in range.
 
       when Attribute_Aft                          |
-           Attribute_Max_Alignment_For_Allocation |
-           Attribute_Max_Size_In_Storage_Elements =>
+           Attribute_Max_Alignment_For_Allocation =>
          Apply_Universal_Integer_Attribute_Checks (N);
 
       --  The following attributes should not appear at this stage, since they

gcc/ada/exp_prag.adb

@@ -270,7 +270,7 @@ package body Exp_Prag is
 
    procedure Expand_Pragma_Check (N : Node_Id) is
       Cond : constant Node_Id    := Arg2 (N);
-      Loc  : constant Source_Ptr := Sloc (Cond);
+      Loc  : constant Source_Ptr := Sloc (First_Node (Cond));
       Nam  : constant Name_Id    := Chars (Arg1 (N));
       Msg  : Node_Id;
 

gcc/ada/exp_util.adb

@@ -6420,9 +6420,12 @@ package body Exp_Util is
    --  Start of processing for Remove_Side_Effects
 
    begin
-      --  Handle cases in which there is nothing to do
+      --  Handle cases in which there is nothing to do. In particular,
+      --  side-effects are not removed in Alfa mode for formal verification.
+      --  Instead, formal verification is performed only on those expressions
+      --  provably side-effect free.
 
-      if not Expander_Active then
+      if not Full_Expander_Active then
          return;
 
       --  Cannot generate temporaries if the invocation to remove side effects
@@ -6622,15 +6625,6 @@ package body Exp_Util is
       --  Otherwise we generate a reference to the value
 
       else
-         --  An expression which is in Alfa mode is considered side effect free
-         --  if the resulting value is captured by a variable or a constant.
-
-         if Alfa_Mode
-           and then Nkind (Parent (Exp)) = N_Object_Declaration
-         then
-            return;
-         end if;
-
          --  Special processing for function calls that return a limited type.
          --  We need to build a declaration that will enable build-in-place
          --  expansion of the call. This is not done if the context is already
@@ -6665,39 +6659,25 @@ package body Exp_Util is
          Def_Id := Make_Temporary (Loc, 'R', Exp);
          Set_Etype (Def_Id, Exp_Type);
 
-         --  The regular expansion of functions with side effects involves the
-         --  generation of an access type to capture the return value found on
-         --  the secondary stack. Since Alfa (and why) cannot process access
-         --  types, use a different approach which ignores the secondary stack
-         --  and "copies" the returned object.
-
-         if Alfa_Mode then
-            Res := New_Reference_To (Def_Id, Loc);
-            Ref_Type := Exp_Type;
-
-         --  Regular expansion utilizing an access type and 'reference
-
-         else
-            Res :=
-              Make_Explicit_Dereference (Loc,
-                Prefix => New_Reference_To (Def_Id, Loc));
+         Res :=
+           Make_Explicit_Dereference (Loc,
+             Prefix => New_Reference_To (Def_Id, Loc));
 
-            --  Generate:
-            --    type Ann is access all <Exp_Type>;
+         --  Generate:
+         --    type Ann is access all <Exp_Type>;
 
-            Ref_Type := Make_Temporary (Loc, 'A');
+         Ref_Type := Make_Temporary (Loc, 'A');
 
-            Ptr_Typ_Decl :=
-              Make_Full_Type_Declaration (Loc,
-                Defining_Identifier => Ref_Type,
-                Type_Definition     =>
-                  Make_Access_To_Object_Definition (Loc,
-                    All_Present        => True,
-                    Subtype_Indication =>
-                      New_Reference_To (Exp_Type, Loc)));
+         Ptr_Typ_Decl :=
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => Ref_Type,
+             Type_Definition     =>
+               Make_Access_To_Object_Definition (Loc,
+                 All_Present        => True,
+                 Subtype_Indication =>
+                   New_Reference_To (Exp_Type, Loc)));
 
-            Insert_Action (Exp, Ptr_Typ_Decl);
-         end if;
+         Insert_Action (Exp, Ptr_Typ_Decl);
 
          E := Exp;
          if Nkind (E) = N_Explicit_Dereference then

gcc/ada/par-ch6.adb

@@ -108,7 +108,8 @@ package body Ch6 is
    --    end [DESIGNATOR];
 
    --  SUBPROGRAM_RENAMING_DECLARATION ::=
-   --    SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
+   --    SUBPROGRAM_SPECIFICATION renames callable_entity_NAME
+   --      [ASPECT_SPECIFICATIONS];
 
    --  SUBPROGRAM_BODY_STUB ::=
    --    SUBPROGRAM_SPECIFICATION is separate;
@@ -506,6 +507,7 @@ package body Ch6 is
             Scan; -- past RENAMES
             Set_Name (Rename_Node, P_Name);
             Set_Specification (Rename_Node, Specification_Node);
+            P_Aspect_Specifications (Rename_Node);
             TF_Semicolon;
             Pop_Scope_Stack;
             return Rename_Node;

gcc/ada/rtsfind.ads

@@ -1353,6 +1353,7 @@ package Rtsfind is
 
      RE_Allocate_Any_Controlled,         -- System.Storage_Pools.Subpools
      RE_Deallocate_Any_Controlled,       -- System.Storage_Pools.Subpools
+     RE_Header_Size_With_Padding,        -- System.Storage_Pools.Subpools
      RE_Root_Storage_Pool_With_Subpools, -- System.Storage_Pools.Subpools
      RE_Root_Subpool,                    -- System.Storage_Pools.Subpools
      RE_Subpool_Handle,                  -- System.Storage_Pools.Subpools
@@ -2550,6 +2551,7 @@ package Rtsfind is
 
      RE_Allocate_Any_Controlled          => System_Storage_Pools_Subpools,
      RE_Deallocate_Any_Controlled        => System_Storage_Pools_Subpools,
+     RE_Header_Size_With_Padding         => System_Storage_Pools_Subpools,
      RE_Root_Storage_Pool_With_Subpools  => System_Storage_Pools_Subpools,
      RE_Root_Subpool                     => System_Storage_Pools_Subpools,
      RE_Subpool_Handle                   => System_Storage_Pools_Subpools,

gcc/ada/s-stposu.adb

@@ -56,12 +56,6 @@ package body System.Storage_Pools.Subpools is
    procedure Detach (N : not null SP_Node_Ptr);
    --  Unhook a subpool node from an arbitrary subpool list
 
-   function Nearest_Multiple_Rounded_Up
-     (Size      : Storage_Count;
-      Alignment : Storage_Count) return Storage_Count;
-   --  Given arbitrary values of storage size and alignment, calculate the
-   --  nearest multiple of the alignment rounded up where size can fit.
-
    --------------
    -- Allocate --
    --------------
@@ -218,10 +212,7 @@ package body System.Storage_Pools.Subpools is
          --  Account for possible padding space before the header due to a
          --  larger alignment.
 
-         Header_And_Padding :=
-           Nearest_Multiple_Rounded_Up
-             (Size      => Header_Size,
-              Alignment => Alignment);
+         Header_And_Padding := Header_Size_With_Padding (Alignment);
 
          N_Size := Storage_Size + Header_And_Padding;
 
@@ -388,10 +379,7 @@ package body System.Storage_Pools.Subpools is
          --  Account for possible padding space before the header due to a
          --  larger alignment.
 
-         Header_And_Padding :=
-           Nearest_Multiple_Rounded_Up
-             (Size      => Header_Size,
-              Alignment => Alignment);
+         Header_And_Padding := Header_Size_With_Padding (Alignment);
 
          --    N_Addr  N_Ptr           Addr (from input)
          --    |       |               |
@@ -571,6 +559,28 @@ package body System.Storage_Pools.Subpools is
       Free (Subpool.Node);
    end Finalize_Subpool;
 
+   ------------------------------
+   -- Header_Size_With_Padding --
+   ------------------------------
+
+   function Header_Size_With_Padding
+     (Alignment : System.Storage_Elements.Storage_Count)
+   return System.Storage_Elements.Storage_Count
+   is
+      Size : constant Storage_Count := Header_Size;
+
+   begin
+      if Size mod Alignment = 0 then
+         return Size;
+
+      --  Add enough padding to reach the nearest multiple of the alignment
+      --  rounding up.
+
+      else
+         return ((Size + Alignment - 1) / Alignment) * Alignment;
+      end if;
+   end Header_Size_With_Padding;
+
    ----------------
    -- Initialize --
    ----------------
@@ -592,26 +602,6 @@ package body System.Storage_Pools.Subpools is
       Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
    end Initialize_Pool;
 
-   ---------------------------------
-   -- Nearest_Multiple_Rounded_Up --
-   ---------------------------------
-
-   function Nearest_Multiple_Rounded_Up
-     (Size      : Storage_Count;
-      Alignment : Storage_Count) return Storage_Count
-   is
-   begin
-      if Size mod Alignment = 0 then
-         return Size;
-
-      --  Add enough padding to reach the nearest multiple of the alignment
-      --  rounding up.
-
-      else
-         return ((Size + Alignment - 1) / Alignment) * Alignment;
-      end if;
-   end Nearest_Multiple_Rounded_Up;
-
    ---------------------
    -- Pool_Of_Subpool --
    ---------------------

gcc/ada/s-stposu.ads

@@ -329,6 +329,13 @@ private
    --  subpool from its owner's list. Deallocate the associated doubly linked
    --  list node.
 
+   function Header_Size_With_Padding
+     (Alignment : System.Storage_Elements.Storage_Count)
+   return System.Storage_Elements.Storage_Count;
+   --  Given an arbitrary alignment, calculate the size of the header which
+   --  precedes a controlled object as the nearest multiple rounded up of the
+   --  alignment.
+
    overriding procedure Initialize (Controller : in out Pool_Controller);
    --  Buffer routine, calls Initialize_Pool
 

gcc/ada/s-taprop-irix.adb

@@ -838,7 +838,7 @@ package body System.Task_Primitives.Operations is
 
       Result :=
         pthread_create
-          (T.Common.LL.Thread'Access,
+          (T.Common.LL.Thread'Unrestricted_Access,
            Attributes'Access,
            Thread_Body_Access (Wrapper),
            To_Address (T));
@@ -867,7 +867,7 @@ package body System.Task_Primitives.Operations is
 
          Result :=
            pthread_create
-             (T.Common.LL.Thread'Access,
+             (T.Common.LL.Thread'Unrestricted_Access,
               Attributes'Access,
               Thread_Body_Access (Wrapper),
               To_Address (T));

gcc/ada/s-taprop-solaris.adb

@@ -1012,7 +1012,7 @@ package body System.Task_Primitives.Operations is
            Thread_Body_Access (Wrapper),
            To_Address (T),
            Opts,
-           T.Common.LL.Thread'Access);
+           T.Common.LL.Thread'Unrestricted_Access);
 
       Succeeded := Result = 0;
       pragma Assert

gcc/ada/sem_res.adb

@@ -8668,7 +8668,7 @@ package body Sem_Res is
                      --  this by making sure that the expanded code points to
                      --  the Sloc of the expression, not the original pragma.
 
-                     Error_Msg_N
+                     Error_Msg_F
                        ("?assertion would fail at run time!",
                         Expression
                           (First (Pragma_Argument_Associations (Orig))));
@@ -8694,7 +8694,7 @@ package body Sem_Res is
                   then
                      null;
                   else
-                     Error_Msg_N
+                     Error_Msg_F
                        ("?check would fail at run time!",
                         Expression
                           (Last (Pragma_Argument_Associations (Orig))));

gcc/ada/sinfo.adb

@@ -1573,6 +1573,14 @@ package body Sinfo is
       return Flag13 (N);
    end Has_Wide_Wide_Character;
 
+   function Header_Size_Added
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      return Flag11 (N);
+   end Header_Size_Added;
+
    function Hidden_By_Use_Clause
      (N : Node_Id) return Elist_Id is
    begin
@@ -4637,6 +4645,14 @@ package body Sinfo is
       Set_Flag13 (N, Val);
    end Set_Has_Wide_Wide_Character;
 
+   procedure Set_Header_Size_Added
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Attribute_Reference);
+      Set_Flag11 (N, Val);
+   end Set_Header_Size_Added;
+
    procedure Set_Hidden_By_Use_Clause
      (N : Node_Id; Val : Elist_Id) is
    begin

gcc/ada/sinfo.ads

@@ -1205,6 +1205,13 @@ package Sinfo is
    --    code outside the Wide_Character range) appears in the string. Used to
    --    implement pragma preference rules.
 
+   --  Header_Size_Added (Flag11-Sem)
+   --    Present in N_Attribute_Reference nodes, set only for attribute
+   --    Max_Size_In_Storage_Elements. The flag indicates that the size of the
+   --    hidden list header used by the runtime finalization support has been
+   --    added to the size of the prefix. The flag also prevents the infinite
+   --    expansion of the same attribute in the said context.
+
    --  Hidden_By_Use_Clause (Elist4-Sem)
    --     An entity list present in use clauses that appear within
    --     instantiations. For the resolution of local entities, entities
@@ -3326,6 +3333,7 @@ package Sinfo is
       --  Entity (Node4-Sem) used if the attribute yields a type
       --  Associated_Node (Node4-Sem)
       --  Do_Overflow_Check (Flag17-Sem)
+      --  Header_Size_Added (Flag11-Sem)
       --  Redundant_Use (Flag13-Sem)
       --  Must_Be_Byte_Aligned (Flag14)
       --  plus fields for expression
@@ -8555,6 +8563,9 @@ package Sinfo is
    function Has_Wide_Wide_Character
      (N : Node_Id) return Boolean;    -- Flag13
 
+   function Header_Size_Added
+     (N : Node_Id) return Boolean;    -- Flag11
+
    function Hidden_By_Use_Clause
      (N : Node_Id) return Elist_Id;   -- Elist4
 
@@ -9530,6 +9541,9 @@ package Sinfo is
    procedure Set_Has_Wide_Wide_Character
      (N : Node_Id; Val : Boolean := True);    -- Flag13
 
+   procedure Set_Header_Size_Added
+     (N : Node_Id; Val : Boolean := True);    -- Flag11
+
    procedure Set_Hidden_By_Use_Clause
      (N : Node_Id; Val : Elist_Id);           -- Elist4
 
@@ -11926,6 +11940,7 @@ package Sinfo is
    pragma Inline (Has_Task_Name_Pragma);
    pragma Inline (Has_Wide_Character);
    pragma Inline (Has_Wide_Wide_Character);
+   pragma Inline (Header_Size_Added);
    pragma Inline (Hidden_By_Use_Clause);
    pragma Inline (High_Bound);
    pragma Inline (Identifier);
@@ -12247,6 +12262,7 @@ package Sinfo is
    pragma Inline (Set_Has_Task_Name_Pragma);
    pragma Inline (Set_Has_Wide_Character);
    pragma Inline (Set_Has_Wide_Wide_Character);
+   pragma Inline (Set_Header_Size_Added);
    pragma Inline (Set_Hidden_By_Use_Clause);
    pragma Inline (Set_High_Bound);
    pragma Inline (Set_Identifier);