2013-01-04 Ed Schonberg <schonberg@adacore.com>

	* sem_ch3.adb (Build_Private_Derived_Type): Set
	Has_Private_Ancestor on type derived from an untagged private
	type whose full view has discriminants
	* sem_aggr.adb (Resolve_Record_Aggregate): Reject non-extension
	aggregate for untagged record type with private ancestor.

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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d907d88..fe3d351 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2013-01-04  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch3.adb (Build_Private_Derived_Type): Set
+       Has_Private_Ancestor on type derived from an untagged private
+       type whose full view has discriminants
+       * sem_aggr.adb (Resolve_Record_Aggregate): Reject non-extension
+       aggregate for untagged record type with private ancestor.
+
 2013-01-04  Thomas Quinot  <quinot@adacore.com>
 
        * sem_elab.adb, sem_ch3.adb: Minor reformatting.

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 7458324..5e3278a 100644 (file)
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -3560,7 +3560,7 @@ package body Sem_Aggr is
          end if;
 
          --  AI05-0115: if the ancestor part is a subtype mark, the ancestor
-         --  must npt have unknown discriminants.
+         --  must not have unknown discriminants.
 
          if Is_Derived_Type (Typ)
            and then Has_Unknown_Discriminants (Root_Type (Typ))
@@ -3886,7 +3886,24 @@ package body Sem_Aggr is
                Next_Elmt (Parent_Elmt);
             end loop;
 
+         --  Typ is not a derived tagged type
+
          else
+            --  A type derived from an untagged private type whose full view
+            --  has discriminants is constructed as a record type but there
+            --  are no legal aggregates for it.
+
+            if Is_Derived_Type (Typ)
+              and then Has_Private_Ancestor (Typ)
+              and then Nkind (N) /= N_Extension_Aggregate
+            then
+               Error_Msg_Node_2 := Base_Type (Etype (Typ));
+               Error_Msg_NE
+                 ("no aggregate available for type& derived from "
+                  & "private type&", N, Typ);
+               return;
+            end if;
+
             Record_Def := Type_Definition (Parent (Base_Type (Typ)));
 
             if Null_Present (Record_Def) then

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index f61990e..ccbd511 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6417,8 +6417,9 @@ package body Sem_Ch3 is
            and then (In_Open_Scopes (Scope (Parent_Type)))
          then
             Full_Der :=
-              Make_Defining_Identifier
-                (Sloc (Derived_Type), Chars (Derived_Type));
+              Make_Defining_Identifier (Sloc (Derived_Type),
+                Chars => Chars (Derived_Type));
+
             Set_Is_Itype (Full_Der);
             Set_Has_Private_Declaration (Full_Der);
             Set_Has_Private_Declaration (Derived_Type);
@@ -6434,7 +6435,12 @@ package body Sem_Ch3 is
          else
             Build_Derived_Record_Type
               (N, Full_View (Parent_Type), Derived_Type,
-                Derive_Subps => False);
+               Derive_Subps => False);
+
+            --  Except in the context of the full view of the parent, there
+            --  are no non-extension aggregates for the derived type.
+
+            Set_Has_Private_Ancestor (Derived_Type);
          end if;
 
          --  In any case, the primitive operations are inherited from the