[multiple changes]

2011-12-12  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (GNAT_Pragma): Check comes from source.

2011-12-12  Robert Dewar  <dewar@adacore.com>

	* gnatls.adb: Minor reformatting.

2011-12-12  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads (Alignment): New TSD field.
	(Max_Predef_Prims): Value lowered to 15 (or 9 in case of
	configurable runtime) Update documentation of predefined
	primitives since Alignment has been removed.
	* exp_disp.ads Update documentation of slots of dispatching
	primitives.
	* exp_disp.adb (Default_Prim_Op_Position): Update slot
	values since alignment is no longer a predefined primitive.
	(Is_Predefined_Dispatch_Operation): Remove _alignment.
	(Is_Predefined_Internal_Operation): Remove _alignment.
	(Make_DT): Update static test on the value stored in a-tags.ads
	for Max_Predef_Prims; store the value of 'alignment in the TSD.
	* exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram
	that retrieves the alignment from the TSD
	* exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation
	of class-wide types obtain the value of alignment from the TSD.
	* exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment
	applied to a class-wide type invoke Build_Get_Alignment to
	generate code which retrieves the value of the alignment from
	the TSD.
	* rtsfind.ads (RE_Alignment): New Ada.Tags entity
	* sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged
	types if the value of the alignment is bigger than the Maximum
	alignment then set the value of the alignment to the Maximum
	alignment and report a warning.
	* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate
	spec of _alignment.
	(Predefined_Primitive_Bodies): Do not generate body of _alignment.

From-SVN: r182229

gcc/ada/ChangeLog

+2011-12-12  Robert Dewar  <dewar@adacore.com>
+
+	* sem_prag.adb (GNAT_Pragma): Check comes from source.
+
+2011-12-12  Robert Dewar  <dewar@adacore.com>
+
+	* gnatls.adb: Minor reformatting.
+
+2011-12-12  Javier Miranda  <miranda@adacore.com>
+
+	* a-tags.ads (Alignment): New TSD field.
+	(Max_Predef_Prims): Value lowered to 15 (or 9 in case of
+	configurable runtime) Update documentation of predefined
+	primitives since Alignment has been removed.
+	* exp_disp.ads Update documentation of slots of dispatching
+	primitives.
+	* exp_disp.adb (Default_Prim_Op_Position): Update slot
+	values since alignment is no longer a predefined primitive.
+	(Is_Predefined_Dispatch_Operation): Remove _alignment.
+	(Is_Predefined_Internal_Operation): Remove _alignment.
+	(Make_DT): Update static test on the value stored in a-tags.ads
+	for Max_Predef_Prims; store the value of 'alignment in the TSD.
+	* exp_atag.ads, exp_atag.adb (Build_Get_Alignment): New subprogram
+	that retrieves the alignment from the TSD
+	* exp_util.adb (Build_Allocated_Deallocate_Proc): For deallocation
+	of class-wide types obtain the value of alignment from the TSD.
+	* exp_attr.adb (Expand_N_Attribute_Reference): For 'alignment
+	applied to a class-wide type invoke Build_Get_Alignment to
+	generate code which retrieves the value of the alignment from
+	the TSD.
+	* rtsfind.ads (RE_Alignment): New Ada.Tags entity
+	* sem_ch13.adb (Analyze_Attribute_Definition_Clause): For tagged
+	types if the value of the alignment is bigger than the Maximum
+	alignment then set the value of the alignment to the Maximum
+	alignment and report a warning.
+	* exp_ch3.adb (Make_Predefined_Primitive_Specs): Do not generate
+	spec of _alignment.
+	(Predefined_Primitive_Bodies): Do not generate body of _alignment.
+
 2011-12-12  Gary Dismukes  <dismukes@adacore.com>
 
 	* freeze.adb (Freeze_Expression): Allow freezing of static

gcc/ada/a-tags.ads

@@ -98,6 +98,8 @@ private
    --           :   primitive ops    :   +-------------------+
    --           |      pointers      |   |   access level    |
    --           +--------------------+   +-------------------+
+   --                                    |     alignment     |
+   --                                    +-------------------+
    --                                    |   expanded name   |
    --                                    +-------------------+
    --                                    |   external tag    |
@@ -269,6 +271,7 @@ private
       --  function return, and class-wide stream I/O, the danger of objects
       --  outliving their type declaration can be eliminated (Ada 2005: AI-344)
 
+      Alignment     : Natural;
       Expanded_Name : Cstring_Ptr;
       External_Tag  : Cstring_Ptr;
       HT_Link       : Tag_Ptr;
@@ -545,25 +548,24 @@ private
    procedure Unregister_Tag (T : Tag);
    --  Remove a particular tag from the external tag hash table
 
-   Max_Predef_Prims : constant Positive := 16;
+   Max_Predef_Prims : constant Positive := 15;
    --  Number of reserved slots for the following predefined ada primitives:
    --
    --    1. Size
-   --    2. Alignment,
-   --    3. Read
-   --    4. Write
-   --    5. Input
-   --    6. Output
-   --    7. "="
-   --    8. assignment
-   --    9. deep adjust
-   --   10. deep finalize
-   --   11. async select
-   --   12. conditional select
-   --   13. prim_op kind
-   --   14. task_id
-   --   15. dispatching requeue
-   --   16. timed select
+   --    2. Read
+   --    3. Write
+   --    4. Input
+   --    5. Output
+   --    6. "="
+   --    7. assignment
+   --    8. deep adjust
+   --    9. deep finalize
+   --   10. async select
+   --   11. conditional select
+   --   12. prim_op kind
+   --   13. task_id
+   --   14. dispatching requeue
+   --   15. timed select
    --
    --  The compiler checks that the value here is correct
 

gcc/ada/exp_atag.adb

@@ -289,6 +289,25 @@ package body Exp_Atag is
               (RTE_Record_Component (RE_Access_Level), Loc));
    end Build_Get_Access_Level;
 
+   -------------------------
+   -- Build_Get_Alignment --
+   -------------------------
+
+   function Build_Get_Alignment
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id
+   is
+   begin
+      return
+        Make_Selected_Component (Loc,
+          Prefix =>
+            Build_TSD (Loc,
+              Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
+          Selector_Name =>
+            New_Reference_To
+              (RTE_Record_Component (RE_Alignment), Loc));
+   end Build_Get_Alignment;
+
    ------------------------------------------
    -- Build_Get_Predefined_Prim_Op_Address --
    ------------------------------------------

gcc/ada/exp_atag.ads

@@ -66,6 +66,13 @@ package Exp_Atag is
    --
    --  Generates: TSD (Tag).Access_Level
 
+   function Build_Get_Alignment
+     (Loc      : Source_Ptr;
+      Tag_Node : Node_Id) return Node_Id;
+   --  Build code that retrieves the alignment of the tagged type.
+   --
+   --  Generates: TSD (Tag).Alignment
+
    procedure Build_Get_Predefined_Prim_Op_Address
      (Loc      : Source_Ptr;
       Position : Uint;

gcc/ada/exp_attr.adb

@@ -1120,19 +1120,11 @@ package body Exp_Attr is
 
          elsif Is_Class_Wide_Type (Ptyp) then
 
-            --  No need to do anything else compiling under restriction
-            --  No_Dispatching_Calls. During the semantic analysis we
-            --  already notified such violation.
-
-            if Restriction_Active (No_Dispatching_Calls) then
-               return;
-            end if;
-
             New_Node :=
-              Make_Function_Call (Loc,
-                Name => New_Reference_To
-                  (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
-                Parameter_Associations => New_List (Pref));
+              Build_Get_Alignment (Loc,
+                Make_Attribute_Reference (Loc,
+                  Prefix => Pref,
+                  Attribute_Name => Name_Tag));
 
             if Typ /= Standard_Integer then
 

gcc/ada/exp_ch3.adb

@@ -250,7 +250,6 @@ package body Exp_Ch3 is
    --  Dispatching is required in general, since the result of the attribute
    --  will vary with the actual object subtype.
    --
-   --     _alignment     provides result of 'Alignment attribute
    --     _size          provides result of 'Size attribute
    --     typSR          provides result of 'Read attribute
    --     typSW          provides result of 'Write attribute
@@ -8156,18 +8155,6 @@ package body Exp_Ch3 is
 
         Ret_Type => Standard_Long_Long_Integer));
 
-      --  Spec of _Alignment
-
-      Append_To (Res, Predef_Spec_Or_Body (Loc,
-        Tag_Typ => Tag_Typ,
-        Name    => Name_uAlignment,
-        Profile => New_List (
-          Make_Parameter_Specification (Loc,
-            Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
-            Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
-
-        Ret_Type => Standard_Integer));
-
       --  Specs for dispatching stream attributes
 
       declare
@@ -8740,29 +8727,6 @@ package body Exp_Ch3 is
          end loop;
       end if;
 
-      --  Body of _Alignment
-
-      Decl := Predef_Spec_Or_Body (Loc,
-        Tag_Typ => Tag_Typ,
-        Name    => Name_uAlignment,
-        Profile => New_List (
-          Make_Parameter_Specification (Loc,
-            Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
-            Parameter_Type      => New_Reference_To (Tag_Typ, Loc))),
-
-        Ret_Type => Standard_Integer,
-        For_Body => True);
-
-      Set_Handled_Statement_Sequence (Decl,
-        Make_Handled_Sequence_Of_Statements (Loc, New_List (
-          Make_Simple_Return_Statement (Loc,
-            Expression =>
-              Make_Attribute_Reference (Loc,
-                Prefix          => Make_Identifier (Loc, Name_X),
-                Attribute_Name  => Name_Alignment)))));
-
-      Append_To (Res, Decl);
-
       --  Body of _Size
 
       Decl := Predef_Spec_Or_Body (Loc,

gcc/ada/exp_disp.adb

@@ -579,32 +579,29 @@ package body Exp_Disp is
       if Chars (E) = Name_uSize then
          return Uint_1;
 
-      elsif Chars (E) = Name_uAlignment then
-         return Uint_2;
-
       elsif TSS_Name = TSS_Stream_Read then
-         return Uint_3;
+         return Uint_2;
 
       elsif TSS_Name = TSS_Stream_Write then
-         return Uint_4;
+         return Uint_3;
 
       elsif TSS_Name = TSS_Stream_Input then
-         return Uint_5;
+         return Uint_4;
 
       elsif TSS_Name = TSS_Stream_Output then
-         return Uint_6;
+         return Uint_5;
 
       elsif Chars (E) = Name_Op_Eq then
-         return Uint_7;
+         return Uint_6;
 
       elsif Chars (E) = Name_uAssign then
-         return Uint_8;
+         return Uint_7;
 
       elsif TSS_Name = TSS_Deep_Adjust then
-         return Uint_9;
+         return Uint_8;
 
       elsif TSS_Name = TSS_Deep_Finalize then
-         return Uint_10;
+         return Uint_9;
 
       --  In VM targets unconditionally allow obtaining the position associated
       --  with predefined interface primitives since in these platforms any
@@ -612,22 +609,22 @@ package body Exp_Disp is
 
       elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
          if Chars (E) = Name_uDisp_Asynchronous_Select then
-            return Uint_11;
+            return Uint_10;
 
          elsif Chars (E) = Name_uDisp_Conditional_Select then
-            return Uint_12;
+            return Uint_11;
 
          elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
-            return Uint_13;
+            return Uint_12;
 
          elsif Chars (E) = Name_uDisp_Get_Task_Id then
-            return Uint_14;
+            return Uint_13;
 
          elsif Chars (E) = Name_uDisp_Requeue then
-            return Uint_15;
+            return Uint_14;
 
          elsif Chars (E) = Name_uDisp_Timed_Select then
-            return Uint_16;
+            return Uint_15;
          end if;
       end if;
 
@@ -1945,7 +1942,6 @@ package body Exp_Disp is
          TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
                                      .. Name_Len));
          if        Chars (E) = Name_uSize
-           or else Chars (E) = Name_uAlignment
            or else TSS_Name  = TSS_Stream_Read
            or else TSS_Name  = TSS_Stream_Write
            or else TSS_Name  = TSS_Stream_Input
@@ -1991,7 +1987,6 @@ package body Exp_Disp is
              (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
 
          if        Chars (E) = Name_uSize
-           or else Chars (E) = Name_uAlignment
            or else
              (Chars (E) = Name_Op_Eq
                 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
@@ -4513,16 +4508,16 @@ package body Exp_Disp is
       end if;
 
       --  Ensure that the value of Max_Predef_Prims defined in a-tags is
-      --  correct. Valid values are 10 under configurable runtime or 16
+      --  correct. Valid values are 9 under configurable runtime or 15
       --  with full runtime.
 
       if RTE_Available (RE_Interface_Data) then
-         if Max_Predef_Prims /= 16 then
+         if Max_Predef_Prims /= 15 then
             Error_Msg_N ("run-time library configuration error", Typ);
             return Result;
          end if;
       else
-         if Max_Predef_Prims /= 10 then
+         if Max_Predef_Prims /= 9 then
             Error_Msg_N ("run-time library configuration error", Typ);
             Error_Msg_CRT ("tagged types", Typ);
             return Result;
@@ -4846,6 +4841,7 @@ package body Exp_Disp is
       --   TSD : Type_Specific_Data (I_Depth) :=
       --           (Idepth             => I_Depth,
       --            Access_Level       => Type_Access_Level (Typ),
+      --            Alignment          => Typ'Alignment,
       --            Expanded_Name      => Cstring_Ptr!(Exname'Address))
       --            External_Tag       => Cstring_Ptr!(Exname'Address))
       --            HT_Link            => HT_Link'Address,
@@ -4895,6 +4891,23 @@ package body Exp_Disp is
       Append_To (TSD_Aggr_List,
         Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
 
+      --  Alignment
+
+      --  For CPP types we cannot rely on the value of 'Alignment provided
+      --  by the backend to initialize this TSD field.
+
+      if Convention (Typ) = Convention_CPP
+        or else Is_CPP_Class (Root_Type (Typ))
+      then
+         Append_To (TSD_Aggr_List,
+           Make_Integer_Literal (Loc, 0));
+      else
+         Append_To (TSD_Aggr_List,
+           Make_Attribute_Reference (Loc,
+             Prefix => New_Reference_To (Typ, Loc),
+             Attribute_Name => Name_Alignment));
+      end if;
+
       --  Expanded_Name
 
       Append_To (TSD_Aggr_List,

gcc/ada/exp_disp.ads

@@ -52,65 +52,61 @@ package Exp_Disp is
    --      type. Constructs of the form Prefix'Size are converted into
    --      Prefix._Size.
 
-   --      _Alignment (2) - implementation of the attribute 'Alignment for
-   --      any tagged type. Constructs of the form Prefix'Alignment are
-   --      converted into Prefix._Alignment.
-
-   --      TSS_Stream_Read (3) - implementation of the stream attribute Read
+   --      TSS_Stream_Read (2) - implementation of the stream attribute Read
    --      for any tagged type.
 
-   --      TSS_Stream_Write (4) - implementation of the stream attribute Write
+   --      TSS_Stream_Write (3) - implementation of the stream attribute Write
    --      for any tagged type.
 
-   --      TSS_Stream_Input (5) - implementation of the stream attribute Input
+   --      TSS_Stream_Input (4) - implementation of the stream attribute Input
    --      for any tagged type.
 
-   --      TSS_Stream_Output (6) - implementation of the stream attribute
+   --      TSS_Stream_Output (5) - implementation of the stream attribute
    --      Output for any tagged type.
 
-   --      Op_Eq (7) - implementation of the equality operator for any non-
+   --      Op_Eq (6) - implementation of the equality operator for any non-
    --      limited tagged type.
 
-   --      _Assign (8) - implementation of the assignment operator for any
+   --      _Assign (7) - implementation of the assignment operator for any
    --      non-limited tagged type.
 
-   --      TSS_Deep_Adjust (9) - implementation of the finalization operation
+   --      TSS_Deep_Adjust (8) - implementation of the finalization operation
    --      Adjust for any non-limited tagged type.
 
-   --      TSS_Deep_Finalize (10) - implementation of the finalization
+   --      TSS_Deep_Finalize (9) - implementation of the finalization
    --      operation Finalize for any non-limited tagged type.
 
-   --      _Disp_Asynchronous_Select (11) - used in the expansion of ATC with
+   --      _Disp_Asynchronous_Select (10) - used in the expansion of ATC with
    --      dispatching triggers. Null implementation for limited interfaces,
    --      full body generation for types that implement limited interfaces,
    --      not generated for the rest of the cases. See Expand_N_Asynchronous_
    --      Select in Exp_Ch9 for more information.
 
-   --      _Disp_Conditional_Select (12) - used in the expansion of conditional
+   --      _Disp_Conditional_Select (11) - used in the expansion of conditional
    --      selects with dispatching triggers. Null implementation for limited
    --      interfaces, full body generation for types that implement limited
    --      interfaces, not generated for the rest of the cases. See Expand_N_
    --      Conditional_Entry_Call in Exp_Ch9 for more information.
 
-   --      _Disp_Get_Prim_Op_Kind (13) - helper routine used in the expansion
+   --      _Disp_Get_Prim_Op_Kind (12) - helper routine used in the expansion
    --      of ATC with dispatching triggers. Null implementation for limited
    --      interfaces, full body generation for types that implement limited
    --      interfaces, not generated for the rest of the cases.
 
-   --      _Disp_Get_Task_Id (14) - helper routine used in the expansion of
+   --      _Disp_Get_Task_Id (13) - helper routine used in the expansion of
    --      Abort, attributes 'Callable and 'Terminated for task interface
    --      class-wide types. Full body generation for task types, null
    --      implementation for limited interfaces, not generated for the rest
    --      of the cases. See Expand_N_Attribute_Reference in Exp_Attr and
    --      Expand_N_Abort_Statement in Exp_Ch9 for more information.
 
-   --      _Disp_Requeue (15) - used in the expansion of dispatching requeue
+   --      _Disp_Requeue (14) - used in the expansion of dispatching requeue
    --      statements. Null implementation is provided for protected, task
    --      and synchronized interfaces. Protected and task types implementing
    --      concurrent interfaces receive full bodies. See Expand_N_Requeue_
    --      Statement in Exp_Ch9 for more information.
 
-   --      _Disp_Timed_Select (16) - used in the expansion of timed selects
+   --      _Disp_Timed_Select (15) - used in the expansion of timed selects
    --      with dispatching triggers. Null implementation for limited
    --      interfaces, full body generation for types that implement limited
    --      interfaces, not generated for the rest of the cases. See Expand_N_

gcc/ada/exp_util.adb

@@ -755,7 +755,32 @@ package body Exp_Util is
 
          Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
          Append_To (Actuals, New_Reference_To (Size_Id, Loc));
-         Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+
+         if Is_Allocate
+           or else not Is_Class_Wide_Type (Desig_Typ)
+         then
+            Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
+
+         --  For deallocation of class wide types we obtain the value of
+         --  alignment from the Type Specific Record of the deallocated object.
+         --  This is needed because the frontend expansion of class-wide types
+         --  into equivalent types confuses the backend.
+
+         else
+            --  Generate:
+            --     Obj.all'Alignment
+
+            --  ... because 'Alignment applied to class-wide types is expanded
+            --  into the code that reads the value of alignment from the TSD
+            --  (see Expand_N_Attribute_Reference)
+
+            Append_To (Actuals,
+              Unchecked_Convert_To (RTE (RE_Storage_Offset),
+                Make_Attribute_Reference (Loc,
+                  Prefix =>
+                    Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
+                  Attribute_Name => Name_Alignment)));
+         end if;
 
          --  h) Is_Controlled
 

gcc/ada/gnatls.adb

@@ -1221,8 +1221,8 @@ procedure Gnatls is
 
       if Rts_Full_Path /= null then
 
-         --  Directory name was found on the project path.  Look for the
-         --  include subdir(s).
+         --  Directory name was found on the project path. Look for the
+         --  include subdirectory(s).
 
          Src_Path := Get_RTS_Search_Dir (Rts_Full_Path.all, Include);
 

gcc/ada/rtsfind.ads

@@ -570,6 +570,7 @@ package Rtsfind is
      RE_Unbounded_String,                -- Ada.Strings.Unbounded
 
      RE_Access_Level,                    -- Ada.Tags
+     RE_Alignment,                       -- Ada.Tags
      RE_Address_Array,                   -- Ada.Tags
      RE_Addr_Ptr,                        -- Ada.Tags
      RE_Base_Address,                    -- Ada.Tags
@@ -1768,6 +1769,7 @@ package Rtsfind is
      RE_Unbounded_String                 => Ada_Strings_Unbounded,
 
      RE_Access_Level                     => Ada_Tags,
+     RE_Alignment                        => Ada_Tags,
      RE_Address_Array                    => Ada_Tags,
      RE_Addr_Ptr                         => Ada_Tags,
      RE_Base_Address                     => Ada_Tags,

gcc/ada/sem_ch13.adb

@@ -2495,8 +2495,8 @@ package body Sem_Ch13 is
          --  Alignment attribute definition clause
 
          when Attribute_Alignment => Alignment : declare
-            Align : constant Uint := Get_Alignment_Value (Expr);
-
+            Align     : constant Uint := Get_Alignment_Value (Expr);
+            Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
          begin
             FOnly := True;
 
@@ -2511,7 +2511,16 @@ package body Sem_Ch13 is
 
             elsif Align /= No_Uint then
                Set_Has_Alignment_Clause (U_Ent);
-               Set_Alignment            (U_Ent, Align);
+
+               if Is_Tagged_Type (U_Ent)
+                 and then Align > Max_Align
+               then
+                  Error_Msg_N
+                    ("?alignment for & set to Maximum_Aligment", Nam);
+                  Set_Alignment (U_Ent, Max_Align);
+               else
+                  Set_Alignment (U_Ent, Align);
+               end if;
 
                --  For an array type, U_Ent is the first subtype. In that case,
                --  also set the alignment of the anonymous base type so that

gcc/ada/sem_prag.adb

@@ -2709,7 +2709,14 @@ package body Sem_Prag is
 
       procedure GNAT_Pragma is
       begin
-         Check_Restriction (No_Implementation_Pragmas, N);
+         --  We need to check the No_Implementation_Pragmas restriction for
+         --  the case of a pragma from source. Note that the case of aspects
+         --  generating corresponding pragmas marks these pragmas as not being
+         --  from source, so this test also catches that case.
+
+         if Comes_From_Source (N) then
+            Check_Restriction (No_Implementation_Pragmas, N);
+         end if;
       end GNAT_Pragma;
 
       --------------------------