[multiple changes]

2010-06-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (Mark_Coextensions): If the expression in the allocator
	for a coextension in an object declaration is a concatenation, treat
	coextension as dynamic.

2010-06-23  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Ensure that the
	internal entities are added to the scope of the tagged type.
	(Derive_Subprograms): Do not stop derivation when we find the first
	internal entity that has attribute Interface_Alias. After the change
	done to Override_Dispatching_Operations it is no longer true that
	these primirives are always located at the end of the list of
	primitives.
	* einfo.ads (Primitive_Operations): Add documentation.
	* exp_disp.adb (Write_DT): Improve output adding to the name of the
	primitive a prefix indicating its corresponding tagged type.
	* sem_disp.adb (Override_Dispatching_Operations): If the overridden
	entity covers the primitive of an interface that is not an ancestor of
	this tagged type then the new primitive is added at the end of the list
	of primitives.  Required to fulfill the C++ ABI.

From-SVN: r161253

gcc/ada/ChangeLog

+2010-06-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_util.adb (Mark_Coextensions): If the expression in the allocator
+	for a coextension in an object declaration is a concatenation, treat
+	coextension as dynamic.
+
+2010-06-23  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch3.adb (Add_Internal_Interface_Entities): Ensure that the
+	internal entities are added to the scope of the tagged type.
+	(Derive_Subprograms): Do not stop derivation when we find the first
+	internal entity that has attribute Interface_Alias. After the change
+	done to Override_Dispatching_Operations it is no longer true that
+	these primirives are always located at the end of the list of
+	primitives.
+	* einfo.ads (Primitive_Operations): Add documentation.
+	* exp_disp.adb (Write_DT): Improve output adding to the name of the
+	primitive a prefix indicating its corresponding tagged type.
+	* sem_disp.adb (Override_Dispatching_Operations): If the overridden
+	entity covers the primitive of an interface that is not an ancestor of
+	this tagged type then the new primitive is added at the end of the list
+	of primitives.  Required to fulfill the C++ ABI.
+
 2010-06-23  Javier Miranda  <miranda@adacore.com>
 
 	* atree.ads (Set_Reporting_Proc): New subprogram.

gcc/ada/einfo.ads

@@ -3152,7 +3152,9 @@ package Einfo is
 --       types. Points to an element list of entities for primitive operations
 --       for the tagged type. Not present (and not set) in untagged types (it
 --       is an error to reference the primitive operations field of a type
---       that is not tagged).
+--       that is not tagged). In order to fulfill the C++ ABI, entities of
+--       primitives that come from source must be stored in this list following
+--       their order of occurrence in the sources.
 
 --    Prival (Node17)
 --       Present in private components of protected types. Refers to the entity

gcc/ada/exp_disp.adb

@@ -7127,7 +7127,7 @@ package body Exp_Disp is
             Next_Elmt (Prim_Elmt);
          end loop;
 
-         --  Third stage: Fix the position of all the new primitives
+         --  Third stage: Fix the position of all the new primitives.
          --  Entries associated with primitives covering interfaces
          --  are handled in a latter round.
 
@@ -7515,6 +7515,17 @@ package body Exp_Disp is
             Write_Str ("(predefined) ");
          end if;
 
+         --  Prefix the name of the primitive with its corresponding tagged
+         --  type to facilitate seeing inherited primitives.
+
+         if Present (Alias (Prim)) then
+            Write_Name
+              (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
+         else
+            Write_Name (Chars (Typ));
+         end if;
+
+         Write_Str (".");
          Write_Name (Chars (Prim));
 
          --  Indicate if this primitive has an aliased primitive

gcc/ada/sem_ch3.adb

@@ -1517,13 +1517,14 @@ package body Sem_Ch3 is
    -------------------------------------
 
    procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
-      Elmt        : Elmt_Id;
-      Iface       : Entity_Id;
-      Iface_Elmt  : Elmt_Id;
-      Iface_Prim  : Entity_Id;
-      Ifaces_List : Elist_Id;
-      New_Subp    : Entity_Id := Empty;
-      Prim        : Entity_Id;
+      Elmt          : Elmt_Id;
+      Iface         : Entity_Id;
+      Iface_Elmt    : Elmt_Id;
+      Iface_Prim    : Entity_Id;
+      Ifaces_List   : Elist_Id;
+      New_Subp      : Entity_Id := Empty;
+      Prim          : Entity_Id;
+      Restore_Scope : Boolean := False;
 
    begin
       pragma Assert (Ada_Version >= Ada_05
@@ -1532,6 +1533,13 @@ package body Sem_Ch3 is
         and then Has_Interfaces (Tagged_Type)
         and then not Is_Interface (Tagged_Type));
 
+      --  Ensure that the internal entities are added to the scope of the type
+
+      if Scope (Tagged_Type) /= Current_Scope then
+         Push_Scope (Scope (Tagged_Type));
+         Restore_Scope := True;
+      end if;
+
       Collect_Interfaces (Tagged_Type, Ifaces_List);
 
       Iface_Elmt := First_Elmt (Ifaces_List);
@@ -1556,32 +1564,47 @@ package body Sem_Ch3 is
                    (Tagged_Type => Tagged_Type,
                     Iface_Prim  => Iface_Prim);
 
+               --  Handle cases where the type has no primitive covering this
+               --  interface primitive.
+
                if No (Prim) then
 
-                  --  In some rare cases, a name conflict may have kept the
-                  --  operation completely hidden. Look for it in the list
-                  --  of primitive operations of the type.
+                  --  if the tagged type is defined at library level then we
+                  --  invoke Check_Abstract_Overriding to report the error
+                  --  and thus avoid generating the dispatch tables.
 
-                  declare
-                     El : Elmt_Id;
+                  if Is_Library_Level_Tagged_Type (Tagged_Type) then
+                     Check_Abstract_Overriding (Tagged_Type);
+                     pragma Assert (Serious_Errors_Detected > 0);
+                     return;
 
-                  begin
-                     El := First_Elmt (Primitive_Operations (Tagged_Type));
-                     while Present (El) loop
-                        Prim := Node (El);
-                        exit when Is_Subprogram (Prim)
-                          and then Alias (Prim) = Iface_Prim;
-                        Next_Elmt (El);
-                     end loop;
+                  --  For tagged types defined in nested scopes it is still
+                  --  possible to cover this interface primitive by means of
+                  --  late overriding (see Override_Dispatching_Operation).
 
-                     --  If the operation was not explicitly overridden, it
-                     --  should have been inherited as an abstract operation
-                     --  so Prim can not be Empty at this stage.
+                  --  Search in the list of primitives of the type for the
+                  --  entity that will be overridden in such case to reference
+                  --  it in the internal entity that we build here. If the
+                  --  primitive is not overridden then the error will be
+                  --  reported later as part of the analysis of entities
+                  --  defined in the enclosing scope.
 
-                     if No (El) then
-                        raise Program_Error;
-                     end if;
-                  end;
+                  else
+                     declare
+                        El : Elmt_Id;
+
+                     begin
+                        El := First_Elmt (Primitive_Operations (Tagged_Type));
+                        while Present (El)
+                          and then Alias (Node (El)) /= Iface_Prim
+                        loop
+                           Next_Elmt (El);
+                        end loop;
+
+                        pragma Assert (Present (El));
+                        Prim := Node (El);
+                     end;
+                  end if;
                end if;
 
                Derive_Subprogram
@@ -1627,6 +1650,10 @@ package body Sem_Ch3 is
 
          Next_Elmt (Iface_Elmt);
       end loop;
+
+      if Restore_Scope then
+         Pop_Scope;
+      end if;
    end Add_Internal_Interface_Entities;
 
    -----------------------------------
@@ -12827,13 +12854,13 @@ package body Sem_Ch3 is
             Subp       := Node (Elmt);
             Alias_Subp := Ultimate_Alias (Subp);
 
-            --  At this early stage Derived_Type has no entities with attribute
-            --  Interface_Alias. In addition, such primitives are always
-            --  located at the end of the list of primitives of Parent_Type.
-            --  Therefore, if found we can safely stop processing pending
-            --  entities.
+            --  Do not derive internal entities of the parent that link
+            --  interface primitives and its covering primitive. These
+            --  entities will be added to this type when frozen.
 
-            exit when Present (Interface_Alias (Subp));
+            if Present (Interface_Alias (Subp)) then
+               goto Continue;
+            end if;
 
             --  If the generic actual is present find the corresponding
             --  operation in the generic actual. If the parent type is a
@@ -13008,6 +13035,7 @@ package body Sem_Ch3 is
                Act_Subp := Node (Act_Elmt);
             end if;
 
+            <<Continue>>
             Next_Elmt (Elmt);
          end loop;
 

gcc/ada/sem_disp.adb

@@ -784,7 +784,7 @@ package body Sem_Disp is
         and then not Comes_From_Source (Subp)
         and then not Has_Dispatching_Parent
       then
-         --  Complete decoration if internally built subprograms that override
+         --  Complete decoration of internally built subprograms that override
          --  a dispatching primitive. These entities correspond with the
          --  following cases:
 
@@ -1709,7 +1709,28 @@ package body Sem_Disp is
          return;
       end if;
 
-      Replace_Elmt (Elmt, New_Op);
+      --  The location of entities that come from source in the list of
+      --  primitives of the tagged type must follow their order of occurrence
+      --  in the sources to fulfill the C++ ABI. If the overriden entity is a
+      --  primitive of an interface that is not an ancestor of this tagged
+      --  type (that is, it is an entity added to the list of primitives by
+      --  Derive_Interface_Progenitors), then we must append the new entity
+      --  at the end of the list of primitives.
+
+      if Present (Alias (Prev_Op))
+        and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op)))
+        and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)),
+                                  Tagged_Type)
+      then
+         Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt);
+         Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
+
+      --  The new primitive replaces the overriden entity. Required to ensure
+      --  that overriding primitive is assigned the same dispatch table slot.
+
+      else
+         Replace_Elmt (Elmt, New_Op);
+      end if;
 
       if Ada_Version >= Ada_05
         and then Has_Interfaces (Tagged_Type)

gcc/ada/sem_util.adb

@@ -7948,6 +7948,16 @@ package body Sem_Util is
             if Is_Dynamic then
                Set_Is_Dynamic_Coextension (N);
 
+            --  If the allocator expression is potentially dynamic, it may
+            --  be expanded out of order and require dynamic allocation
+            --  anyway, so we treat the coextension itself as dynamic.
+            --  Potential optimization ???
+
+            elsif Nkind (Expression (N)) = N_Qualified_Expression
+              and then Nkind (Expression (Expression (N))) = N_Op_Concat
+            then
+               Set_Is_Dynamic_Coextension (N);
+
             else
                Set_Is_Static_Coextension (N);
             end if;