ada: Fix generation of Initialize and Adjust calls

Before this patch, Make_Init_Call and Make_Adjust_Call made the
assumption that if the type they were called with was untagged and a
derived type, it was the untagged private view of a tagged type. That
assumption made it possible to inspect the root type's primitives to
handle the case where the underlying type was implicitly generated by
the compiler without all inherited primitives.

The introduction of the Finalizable aspect broke that assumption, so
this patch adds a new field to type entities that make the generated
full view stand out, and updates Make_Init_Call and Make_Adjust_Call to
only jump to the root type when they're passed one of those generated
types.

Make_Final_Call and Finalize_Address are two other subprograms that
perform the same test on the types they're passed. They did not suffer
from the same bug as Make_Init_Call and Make_Adjust_Call because of an
earlier, more ad hoc fix, but this patch switches them over to the newly
introduced mechanism for the sake of consistency.

gcc/ada/ChangeLog:

	* gen_il-fields.ads (Is_Implicit_Full_View): New field.
	* gen_il-gen-gen_entities.adb (Type_Kind): Use new field.
	* einfo.ads (Is_Implicit_Full_View): Document new field.
	* exp_ch7.adb (Make_Adjust_Call, Make_Init_Call, Make_Final_Call): Use
	new field.
	* exp_util.adb (Finalize_Address): Likewise.
	* sem_ch3.adb (Copy_And_Build): Set new field.

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 11e3dd0254e474d577c7802c4f8a51bc064def3c..b23cd9e8c27c1a21b1e7e90378ad727deb06687b 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2787,6 +2787,10 @@ package Einfo is
 --       identifiers in standard library packages, and to implement the
 --       restriction No_Implementation_Identifiers.
 
+--    Is_Implicit_Full_View
+--       Defined in types. Set on types that the compiler generates to act as
+--       full views of types that are derivations of private types.
+
 --    Is_Imported
 --       Defined in all entities. Set if the entity is imported. For now we
 --       only allow the import of exceptions, functions, procedures, packages,

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 5d406a3416a2e7c999f9fb32d8ae52ada4eaad69..9b88491d58f1d7999c93de9dfc625664f8f1042e 100644 (file)
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -5601,7 +5601,10 @@ package body Exp_Ch7 is
 
       --  Deal with untagged derivation of private views
 
-      if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
+      if Present (Utyp)
+        and then Is_Untagged_Derivation (Typ)
+        and then Is_Implicit_Full_View (Utyp)
+      then
          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
          Ref  := Unchecked_Convert_To (Utyp, Ref);
          Set_Assignment_OK (Ref);
@@ -7909,16 +7912,12 @@ package body Exp_Ch7 is
       if Is_Untagged_Derivation (Typ) then
          if Is_Protected_Type (Typ) then
             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+         elsif Is_Implicit_Full_View (Utyp) then
+            Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
 
-         else
-            declare
-               Root : constant Entity_Id :=
-                 Underlying_Type (Root_Type (Base_Type (Typ)));
-            begin
-               if Is_Protected_Type (Root) then
-                  Utyp := Corresponding_Record_Type (Root);
-               end if;
-            end;
+            if Is_Protected_Type (Utyp) then
+               Utyp := Corresponding_Record_Type (Utyp);
+            end if;
          end if;
 
          Ref := Unchecked_Convert_To (Utyp, Ref);
@@ -8483,7 +8482,10 @@ package body Exp_Ch7 is
 
       --  Deal with untagged derivation of private views
 
-      if Is_Untagged_Derivation (Typ) and then not Is_Conc then
+      if Is_Untagged_Derivation (Typ)
+        and then not Is_Conc
+        and then Is_Implicit_Full_View (Utyp)
+      then
          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
          Ref  := Unchecked_Convert_To (Utyp, Ref);
 

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 769e0c01c243d02fab0cbe2182fad92101e163d8..5a6fca081a694c67ad90486937557917e4014ea9 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6189,23 +6189,12 @@ package body Exp_Util is
          if Is_Protected_Type (Btyp) then
             Utyp := Corresponding_Record_Type (Root_Type (Btyp));
 
-         else
-            declare
-               Root      : constant Entity_Id :=
-                 Underlying_Type (Root_Type (Btyp));
-               Prev_Utyp : Entity_Id := Empty;
-            begin
-               if Is_Protected_Type (Root) then
-                  Utyp := Corresponding_Record_Type (Root);
-               else
-                  while No (TSS (Utyp, TSS_Finalize_Address))
-                    and then Utyp /= Prev_Utyp
-                  loop
-                     Prev_Utyp := Utyp;
-                     Utyp := Underlying_Type (Base_Type (Etype (Utyp)));
-                  end loop;
-               end if;
-            end;
+         elsif Is_Implicit_Full_View (Utyp) then
+            Utyp := Underlying_Type (Root_Type (Btyp));
+
+            if Is_Protected_Type (Utyp) then
+               Utyp := Corresponding_Record_Type (Utyp);
+            end if;
          end if;
       end if;
 

diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 18edec26742cfe167d68b312d1418146d78264ea..dd4b1a081b301d553eaf08111261843d4e7b9a0f 100644 (file)
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -733,6 +733,7 @@ package Gen_IL.Fields is
       Is_Ignored_Ghost_Entity,
       Is_Immediately_Visible,
       Is_Implementation_Defined,
+      Is_Implicit_Full_View,
       Is_Imported,
       Is_Independent,
       Is_Initial_Condition_Procedure,

diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index 44995452b10a98770157719bfb527b2176c15455..e05d8b50430b202b4e8b3474879a639f857a5724 100644 (file)
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -502,6 +502,7 @@ begin -- Gen_IL.Gen.Gen_Entities
         Sm (Is_Fixed_Lower_Bound_Array_Subtype, Flag),
         Sm (Is_Fixed_Lower_Bound_Index_Subtype, Flag),
         Sm (Is_Generic_Actual_Type, Flag),
+        Sm (Is_Implicit_Full_View, Flag),
         Sm (Is_Mutably_Tagged_Type, Flag),
         Sm (Is_Non_Static_Subtype, Flag),
         Sm (Is_Private_Composite, Flag),

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 227dda25d042d336d07e393abe8cee797da21d60..55d2795f2b12ec99065264535c723306c14bb2d9 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -8452,15 +8452,17 @@ package body Sem_Ch3 is
          Set_Has_Private_Declaration (Full_Der);
          Set_Has_Private_Declaration (Derived_Type);
 
-         Set_Scope                (Full_Der, Scope (Derived_Type));
-         Set_Is_First_Subtype     (Full_Der, Is_First_Subtype (Derived_Type));
-         Set_Has_Size_Clause      (Full_Der, False);
-         Set_Has_Alignment_Clause (Full_Der, False);
-         Set_Has_Delayed_Freeze   (Full_Der);
-         Set_Is_Frozen            (Full_Der, False);
-         Set_Freeze_Node          (Full_Der, Empty);
-         Set_Depends_On_Private   (Full_Der, Has_Private_Component (Full_Der));
-         Set_Is_Public            (Full_Der, Is_Public (Derived_Type));
+         Set_Scope                 (Full_Der, Scope (Derived_Type));
+         Set_Is_First_Subtype      (Full_Der, Is_First_Subtype (Derived_Type));
+         Set_Has_Size_Clause       (Full_Der, False);
+         Set_Has_Alignment_Clause  (Full_Der, False);
+         Set_Has_Delayed_Freeze    (Full_Der);
+         Set_Is_Frozen             (Full_Der, False);
+         Set_Freeze_Node           (Full_Der, Empty);
+         Set_Depends_On_Private
+           (Full_Der, Has_Private_Component (Full_Der));
+         Set_Is_Public             (Full_Der, Is_Public (Derived_Type));
+         Set_Is_Implicit_Full_View (Full_Der);
 
          --  The convention on the base type may be set in the private part
          --  and not propagated to the subtype until later, so we obtain the