ada: Fix selection of Finalize subprogram in untagged case

The newly introduced Finalizable aspect makes it possible to derive from
a type that is not tagged but has a Finalize primitive. This patch fixes
problems where overridings of the Finalize primitive were ignored.

gcc/ada/ChangeLog:

	* exp_ch7.adb (Make_Final_Call): Tweak search of Finalize primitive.
	* exp_util.adb (Finalize_Address): Likewise.

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 41438f40a8880eaa835946d93d730628d3aabd2a..0f534af8a32feb1567d5e7b9650a000f6e13d83f 100644 (file)
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -7906,12 +7906,16 @@ 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)));
-         else
-            Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
 
-            if Is_Protected_Type (Utyp) then
-               Utyp := Corresponding_Record_Type (Utyp);
-            end if;
+         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;
          end if;
 
          Ref := Unchecked_Convert_To (Utyp, Ref);

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f225e179b2347d86cabd766dc8514deb4b32651c..90de6962a1bc5dbe013ac35acd7980a1c0b3d2a4 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6080,11 +6080,17 @@ package body Exp_Util is
             Utyp := Corresponding_Record_Type (Root_Type (Btyp));
 
          else
-            Utyp := Underlying_Type (Root_Type (Btyp));
-
-            if Is_Protected_Type (Utyp) then
-               Utyp := Corresponding_Record_Type (Utyp);
-            end if;
+            declare
+               Root : constant Entity_Id := Underlying_Type (Root_Type (Btyp));
+            begin
+               if Is_Protected_Type (Root) then
+                  Utyp := Corresponding_Record_Type (Root);
+               else
+                  while No (TSS (Utyp, TSS_Finalize_Address)) loop
+                     Utyp := Underlying_Type (Base_Type (Etype (Utyp)));
+                  end loop;
+               end if;
+            end;
          end if;
       end if;