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 7c05e532aea7a83ed82c2ec8eb446b19652e0c6d..e3fcb13b649c510c86792467f5d8615f16cef23b 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2781,6 +2781,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 0f534af8a32feb1567d5e7b9650a000f6e13d83f..ea7af3e449c2712b1134a276357f036a775f8fb4 100644 (file)
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -5598,7 +5598,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);
@@ -7906,16 +7909,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);
@@ -8480,7 +8479,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 3dcf98001ecafa179d319dea28eae9ef5d1e23de..5f644ef2503ccdfc80df20c8633e2de1956ebefc 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6079,23 +6079,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 c293e0fa63fbe3b1739b5620fe875ce0cba14462..8c37f3fefa27ff56c157ad436bdbf9b01826609b 100644 (file)
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -729,6 +729,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 37ddd851d7c3fd74ea397b4b51b3ccc5146377eb..d81ff5c024069bd00cdf73f89275c6ca10e248c2 100644 (file)
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -505,6 +505,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 794e4204d842bccba290ef0da939845d8edf1ee9..b68dcda4c54958d697b942bc50f57f6f8449e8ef 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -8387,15 +8387,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