2011-08-01 Javier Miranda <miranda@adacore.com>

	* sem_ch7.adb (Uninstall_Declarations): Remove useless code.
	* einfo.ads (Access_Disp_Table): Fix documentation.
	(Dispatch_Table_Wrappers): Fix documentation.
	* einfo.adb (Access_Disp_Table, Dispatch_Table_Wrappers,
	Set_Access_Disp_Table, Set_Dispatch_Table_Wrappers): Fix the assertions
	to enforce the documentation of this attribute.
	(Set_Is_Interface): Cleanup the assertion.
	* exp_ch4.adb (Expand_Allocator_Expression, Tagged_Membership): Locate
	the Underlying_Type entity before reading attribute Access_Disp_Table.
	* exp_disp.adb (Expand_Dispatching_Call, Expand_Interface_Conversion):
	Locate the Underlying_Type before reading attribute Access_Disp_Table.
	* exp_aggr.adb (Build_Array_Aggr_Code, Build_Record_Aggr_Code): Locate
	the Underlying_Type entity before reading attribute Access_Disp_Table.
	* exp_ch3.adb (Build_Record_Init_Proc, Expand_N_Object_Declaration):
	Locate the Underlying_Type entity before reading attribute
	Access_Disp_Table.

2011-08-01  Ed Schonberg  <schonberg@adacore.com>

	* s-poosiz.ads: Additional overriding indicators.

2011-08-01  Yannick Moy  <moy@adacore.com>

	* sem_ch5.adb (Analyze_Exit_Statement): add return after error in
	formal mode.
	(Analyze_Iteration_Scheme): issue error in formal mode when loop
	parameter specification does not include a subtype mark.
	* sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): issue error in
	formal mode on abstract subprogram.
	(Analyze_Subprogram_Specification): issue error in formal mode on
	user-defined operator.
	(Process_Formals): issue error in formal mode on access parameter and
	default expression.
	* sem_ch9.adb (Analyze_Abort_Statement,
	Analyze_Accept_Statement, Analyze_Asynchronous_Select,
	Analyze_Conditional_Entry_Call, Analyze_Delay_Relative,
	Analyze_Delay_Until, Analyze_Entry_Call_Alternative,
	Analyze_Requeue, Analyze_Selective_Accept,
	Analyze_Timed_Entry_Call): issue error in formal mode on such constructs
	* sem_ch11.adb (Analyze_Raise_Statement, Analyze_Raise_xxx_Error):
	issue error in formal mode on user-defined raise statement.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177047 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 26 insertions, 18 deletions

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 2213ec5840b..34e49247835 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -874,19 +874,23 @@ package body Exp_Ch4 is
          end if;
 
          if Present (TagT) then
-            Tag_Assign :=
-              Make_Assignment_Statement (Loc,
-                Name =>
-                  Make_Selected_Component (Loc,
-                    Prefix => TagR,
-                    Selector_Name =>
-                      New_Reference_To (First_Tag_Component (TagT), Loc)),
+            declare
+               Full_T : constant Entity_Id := Underlying_Type (TagT);
 
-                Expression =>
-                  Unchecked_Convert_To (RTE (RE_Tag),
-                    New_Reference_To
-                      (Elists.Node (First_Elmt (Access_Disp_Table (TagT))),
-                       Loc)));
+            begin
+               Tag_Assign :=
+                 Make_Assignment_Statement (Loc,
+                   Name =>
+                     Make_Selected_Component (Loc,
+                       Prefix => TagR,
+                       Selector_Name =>
+                         New_Reference_To (First_Tag_Component (Full_T), Loc)),
+                   Expression =>
+                     Unchecked_Convert_To (RTE (RE_Tag),
+                       New_Reference_To
+                         (Elists.Node
+                           (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
+            end;
 
             --  The previous assignment has to be done in any case
 
@@ -10397,6 +10401,7 @@ package body Exp_Ch4 is
       Right : constant Node_Id    := Right_Opnd (N);
       Loc   : constant Source_Ptr := Sloc (N);
 
+      Full_R_Typ : Entity_Id;
       Left_Type  : Entity_Id;
       New_Node   : Node_Id;
       Right_Type : Entity_Id;
@@ -10414,6 +10419,12 @@ package body Exp_Ch4 is
          Left_Type := Root_Type (Left_Type);
       end if;
 
+      if Is_Class_Wide_Type (Right_Type) then
+         Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
+      else
+         Full_R_Typ := Underlying_Type (Right_Type);
+      end if;
+
       Obj_Tag :=
         Make_Selected_Component (Loc,
           Prefix        => Relocate_Node (Left),
@@ -10482,8 +10493,7 @@ package body Exp_Ch4 is
                      Prefix => Obj_Tag,
                      Attribute_Name => Name_Address),
                    New_Reference_To (
-                     Node (First_Elmt
-                            (Access_Disp_Table (Root_Type (Right_Type)))),
+                     Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
                      Loc)));
 
          --  Ada 95: Normal case
@@ -10493,9 +10503,7 @@ package body Exp_Ch4 is
               Obj_Tag_Node => Obj_Tag,
               Typ_Tag_Node =>
                  New_Reference_To (
-                   Node (First_Elmt
-                          (Access_Disp_Table (Root_Type (Right_Type)))),
-                   Loc),
+                   Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),  Loc),
               Related_Nod => N,
               New_Node    => New_Node);
 
@@ -10526,7 +10534,7 @@ package body Exp_Ch4 is
                 Left_Opnd  => Obj_Tag,
                 Right_Opnd =>
                   New_Reference_To
-                    (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
+                    (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
          end if;
       end if;
    end Tagged_Membership;