ada: Fix support of Default_Component_Value aspect on derived types

The support of the Default_Component_Value aspect on derived constrained
array types is broken because of a couple of issues: 1) the derived types
incorrectly inherit the initialization procedure of the ancestor types
and 2) the propagation of the aspect does not work for constrained array
types (unlike for unconstrained array types).

gcc/ada/

	* exp_tss.adb (Base_Init_Proc): Do not return the Init_Proc of the
	ancestor type for a derived array type.
	* sem_ch13.adb (Inherit_Aspects_At_Freeze_Point): Factor out the
	common processing done on representation items.
	For Default_Component_Value and Default_Value, look into the first
	subtype to find out the representation items.

2 files changed, 133 insertions, 77 deletions

diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
index 09bb133..23ee349 100644
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -78,8 +78,11 @@ package body Exp_Tss is
       else
          Proc := Init_Proc (Base_Type (Full_Type), Ref);
 
+         --  For derived record types, if the base type does not have one,
+         --  we use the Init_Proc of the ancestor type.
+
          if No (Proc)
-           and then Is_Composite_Type (Full_Type)
+           and then Is_Record_Type (Full_Type)
            and then Is_Derived_Type (Full_Type)
          then
             return Init_Proc (Root_Type (Full_Type), Ref);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 618f935..e5f0ebc 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -13493,12 +13493,68 @@ package body Sem_Ch13 is
    -------------------------------------
 
    procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
+      function Get_Inherited_Rep_Item
+        (E   : Entity_Id;
+         Nam : Name_Id) return Node_Id;
+      --  Search the Rep_Item chain of entity E for an instance of a rep item
+      --  (pragma, attribute definition clause, or aspect specification) whose
+      --  name matches the given name Nam, and that has been inherited from its
+      --  parent, i.e. that has not been directly specified for E . If one is
+      --  found, it is returned, otherwise Empty is returned.
+
+      function Get_Inherited_Rep_Item
+        (E    : Entity_Id;
+         Nam1 : Name_Id;
+         Nam2 : Name_Id) return Node_Id;
+      --  Search the Rep_Item chain of entity E for an instance of a rep item
+      --  (pragma, attribute definition clause, or aspect specification) whose
+      --  name matches one of the given names Nam1 or Nam2, and that has been
+      --  inherited from its parent, i.e. that has not been directly specified
+      --  for E . If one is found, it is returned, otherwise Empty is returned.
+
       function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
         (Rep_Item : Node_Id) return Boolean;
       --  This routine checks if Rep_Item is either a pragma or an aspect
       --  specification node whose corresponding pragma (if any) is present in
       --  the Rep Item chain of the entity it has been specified to.
 
+      ----------------------------
+      -- Get_Inherited_Rep_Item --
+      ----------------------------
+
+      function Get_Inherited_Rep_Item
+        (E   : Entity_Id;
+         Nam : Name_Id) return Node_Id
+      is
+         Rep : constant Node_Id
+                 := Get_Rep_Item (E, Nam, Check_Parents => True);
+      begin
+         if Present (Rep)
+           and then not Has_Rep_Item (E, Nam, Check_Parents => False)
+         then
+            return Rep;
+         else
+            return Empty;
+         end if;
+      end Get_Inherited_Rep_Item;
+
+      function Get_Inherited_Rep_Item
+        (E    : Entity_Id;
+         Nam1 : Name_Id;
+         Nam2 : Name_Id) return Node_Id
+      is
+         Rep : constant Node_Id
+                 := Get_Rep_Item (E, Nam1, Nam2, Check_Parents => True);
+      begin
+         if Present (Rep)
+           and then not Has_Rep_Item (E, Nam1, Nam2, Check_Parents => False)
+         then
+            return Rep;
+         else
+            return Empty;
+         end if;
+      end Get_Inherited_Rep_Item;
+
       --------------------------------------------------
       -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
       --------------------------------------------------
@@ -13513,6 +13569,8 @@ package body Sem_Ch13 is
            Present_In_Rep_Item (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
       end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
 
+      Rep : Node_Id;
+
    --  Start of processing for Inherit_Aspects_At_Freeze_Point
 
    begin
@@ -13543,40 +13601,36 @@ package body Sem_Ch13 is
 
       --  Ada_05/Ada_2005
 
-      if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False)
-        and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)
-        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005))
+      Rep := Get_Inherited_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005);
+      if Present (Rep)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
       then
          Set_Is_Ada_2005_Only (Typ);
       end if;
 
       --  Ada_12/Ada_2012
 
-      if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False)
-        and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)
-        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012))
+      Rep := Get_Inherited_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012);
+      if Present (Rep)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
       then
          Set_Is_Ada_2012_Only (Typ);
       end if;
 
       --  Ada_2022
 
-      if not Has_Rep_Item (Typ, Name_Ada_2022, False)
-        and then Has_Rep_Item (Typ, Name_Ada_2022)
-        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Ada_2022))
+      Rep := Get_Inherited_Rep_Item (Typ, Name_Ada_2022);
+      if Present (Rep)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
       then
          Set_Is_Ada_2022_Only (Typ);
       end if;
 
       --  Atomic/Shared
 
-      if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False)
-        and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared)
-        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Atomic, Name_Shared))
+      Rep := Get_Inherited_Rep_Item (Typ,  Name_Atomic, Name_Shared);
+      if Present (Rep)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
       then
          Set_Is_Atomic (Typ);
          Set_Is_Volatile (Typ);
@@ -13591,74 +13645,80 @@ package body Sem_Ch13 is
          Set_Convention (Typ, Convention (Base_Type (Typ)));
       end if;
 
-      --  Default_Component_Value
+      --  Default_Component_Value (for base types only)
 
-      --  Verify that there is no rep_item declared for the type, and there
-      --  is one coming from an ancestor.
+      --  Note that we need to look into the first subtype because the base
+      --  type may be the implicit base type built by the compiler for the
+      --  declaration of a constrained subtype with the aspect.
 
-      if Is_Array_Type (Typ)
-        and then Is_Base_Type (Typ)
-        and then not Has_Rep_Item (Typ, Name_Default_Component_Value, False)
-        and then Has_Rep_Item (Typ, Name_Default_Component_Value)
-      then
+      if Is_Array_Type (Typ) and then Is_Base_Type (Typ) then
          declare
+            F_Typ : constant Entity_Id := First_Subtype (Typ);
+
             E : Entity_Id;
 
          begin
-            E := Entity (Get_Rep_Item (Typ, Name_Default_Component_Value));
+            Rep :=
+              Get_Inherited_Rep_Item (F_Typ, Name_Default_Component_Value);
+            if Present (Rep) then
+               E := Entity (Rep);
 
-            --  Deal with private types
+               --  Deal with private types
 
-            if Is_Private_Type (E) then
-               E := Full_View (E);
-            end if;
+               if Is_Private_Type (E) then
+                  E := Full_View (E);
+               end if;
 
-            Set_Default_Aspect_Component_Value (Typ,
-              Default_Aspect_Component_Value (E));
+               Set_Default_Aspect_Component_Value
+                 (Typ, Default_Aspect_Component_Value (E));
+               Set_Has_Default_Aspect (Typ);
+            end if;
          end;
       end if;
 
-      --  Default_Value
+      --  Default_Value (for base types only)
 
-      if Is_Scalar_Type (Typ)
-        and then Is_Base_Type (Typ)
-        and then not Has_Rep_Item (Typ, Name_Default_Value, False)
-        and then Has_Rep_Item (Typ, Name_Default_Value)
-      then
-         Set_Has_Default_Aspect (Typ);
+      --  Note that we need to look into the first subtype because the base
+      --  type may be the implicit base type built by the compiler for the
+      --  declaration of a constrained subtype with the aspect.
 
+      if Is_Scalar_Type (Typ) and then Is_Base_Type (Typ) then
          declare
+            F_Typ : constant Entity_Id := First_Subtype (Typ);
+
             E : Entity_Id;
 
          begin
-            E := Entity (Get_Rep_Item (Typ, Name_Default_Value));
+            Rep := Get_Inherited_Rep_Item (F_Typ, Name_Default_Value);
+            if Present (Rep) then
+               E := Entity (Rep);
 
-            --  Deal with private types
+               --  Deal with private types
 
-            if Is_Private_Type (E) then
-               E := Full_View (E);
-            end if;
+               if Is_Private_Type (E) then
+                  E := Full_View (E);
+               end if;
 
-            Set_Default_Aspect_Value (Typ, Default_Aspect_Value (E));
+               Set_Default_Aspect_Value (Typ, Default_Aspect_Value (E));
+               Set_Has_Default_Aspect (Typ);
+            end if;
          end;
       end if;
 
       --  Discard_Names
 
-      if not Has_Rep_Item (Typ, Name_Discard_Names, False)
-        and then Has_Rep_Item (Typ, Name_Discard_Names)
-        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Discard_Names))
+      Rep := Get_Inherited_Rep_Item (Typ, Name_Discard_Names);
+      if Present (Rep)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
       then
          Set_Discard_Names (Typ);
       end if;
 
       --  Volatile
 
-      if not Has_Rep_Item (Typ, Name_Volatile, False)
-        and then Has_Rep_Item (Typ, Name_Volatile)
-        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Volatile))
+      Rep := Get_Inherited_Rep_Item (Typ, Name_Volatile);
+      if Present (Rep)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
       then
          Set_Is_Volatile (Typ);
          Set_Treat_As_Volatile (Typ);
@@ -13666,12 +13726,10 @@ package body Sem_Ch13 is
 
       --  Volatile_Full_Access and Full_Access_Only
 
-      if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False)
-        and then not Has_Rep_Item (Typ, Name_Full_Access_Only, False)
-        and then (Has_Rep_Item (Typ, Name_Volatile_Full_Access)
-                    or else Has_Rep_Item (Typ, Name_Full_Access_Only))
-        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Volatile_Full_Access))
+      Rep := Get_Inherited_Rep_Item
+               (Typ, Name_Volatile_Full_Access, Name_Full_Access_Only);
+      if Present (Rep)
+        and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
       then
          Set_Is_Volatile_Full_Access (Typ);
          Set_Is_Volatile (Typ);
@@ -13688,38 +13746,34 @@ package body Sem_Ch13 is
          begin
             --  Atomic_Components
 
-            if not Has_Rep_Item (Typ, Name_Atomic_Components, False)
-              and then Has_Rep_Item (Typ, Name_Atomic_Components)
-              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Atomic_Components))
+            Rep := Get_Inherited_Rep_Item (Typ, Name_Atomic_Components);
+            if Present (Rep)
+              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
             then
                Set_Has_Atomic_Components (Imp_Bas_Typ);
             end if;
 
             --  Volatile_Components
 
-            if not Has_Rep_Item (Typ, Name_Volatile_Components, False)
-              and then Has_Rep_Item (Typ, Name_Volatile_Components)
-              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Volatile_Components))
+            Rep := Get_Inherited_Rep_Item (Typ, Name_Volatile_Components);
+            if Present (Rep)
+              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
             then
                Set_Has_Volatile_Components (Imp_Bas_Typ);
             end if;
 
             --  Finalize_Storage_Only
 
-            if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
-              and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
-            then
+            Rep := Get_Inherited_Rep_Item (Typ, Name_Finalize_Storage_Only);
+            if Present (Rep) then
                Set_Finalize_Storage_Only (Bas_Typ);
             end if;
 
             --  Universal_Aliasing
 
-            if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False)
-              and then Has_Rep_Item (Typ, Name_Universal_Aliasing)
-              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
-                   (Get_Rep_Item (Typ, Name_Universal_Aliasing))
+            Rep := Get_Inherited_Rep_Item (Typ, Name_Universal_Aliasing);
+            if Present (Rep)
+              and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep)
             then
                Set_Universal_Aliasing (Imp_Bas_Typ);
             end if;
@@ -13727,9 +13781,8 @@ package body Sem_Ch13 is
             --  Bit_Order
 
             if Is_Record_Type (Typ) and then Typ = Bas_Typ then
-               if not Has_Rep_Item (Typ, Name_Bit_Order, False)
-                 and then Has_Rep_Item (Typ, Name_Bit_Order)
-               then
+               Rep := Get_Inherited_Rep_Item (Typ, Name_Bit_Order);
+               if Present (Rep) then
                   Set_Reverse_Bit_Order (Bas_Typ,
                     Reverse_Bit_Order
                       (Implementation_Base_Type (Etype (Bas_Typ))));