[COMMITTED] ada: TSS finalize address subprogram generation for constrained...

["Marc Poulhiès" <poulhies@adacore.com>]

From: Richard Wai <richard@annexi-strayline.com>

...subtypes of unconstrained synchronized private extensions should take
care to designate the corresponding record of the underlying concurrent
type.

When generating TSS finalize address subprograms for class-wide types of
constrained root types, it follows the parent chain looking for the
first "non-constrained" type. It is possible that such a type is a
private extension with the “synchronized” keyword, in which case the
underlying type is a concurrent type. When that happens, the designated
type of the finalize address subprogram should be the corresponding
record’s class-wide-type.

gcc/ada/ChangeLog:
	* exp_ch3.adb (Expand_Freeze_Class_Wide_Type): Expanded comments
	explaining why TSS Finalize_Address is not generated for
	concurrent class-wide types.
	* exp_ch7.adb (Make_Finalize_Address_Stmts): Handle cases where the
	underlying non-constrained parent type is a concurrent type, and
	adjust the designated type to be the corresponding record’s
	class-wide type.

gcc/testsuite/ChangeLog:

	* gnat.dg/sync_tag_finalize.adb: New test.

Signed-off-by: Richard Wai <richard@annexi-strayline.com>
---
 gcc/ada/exp_ch3.adb                         |  4 ++
 gcc/ada/exp_ch7.adb                         | 28 +++++++++-
 gcc/testsuite/gnat.dg/sync_tag_finalize.adb | 60 +++++++++++++++++++++
 3 files changed, 90 insertions(+), 2 deletions(-)
 create mode 100644 gcc/testsuite/gnat.dg/sync_tag_finalize.adb

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 04c3ad8c631..bb015986200 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -5000,6 +5000,10 @@ package body Exp_Ch3 is
       --  Do not create TSS routine Finalize_Address for concurrent class-wide
       --  types. Ignore C, C++, CIL and Java types since it is assumed that the
       --  non-Ada side will handle their destruction.
+      --
+      --  Concurrent Ada types are functionally represented by an associated
+      --  "corresponding record type" (typenameV), which owns the actual TSS
+      --  finalize bodies for the type (and technically class-wide type).
 
       elsif Is_Concurrent_Type (Root)
         or else Is_C_Derivation (Root)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index aa16c707887..4ea5e6ede64 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -8512,7 +8512,8 @@ package body Exp_Ch7 is
           Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
       then
          declare
-            Parent_Typ : Entity_Id;
+            Parent_Typ  : Entity_Id;
+            Parent_Utyp : Entity_Id;
 
          begin
             --  Climb the parent type chain looking for a non-constrained type
@@ -8533,7 +8534,30 @@ package body Exp_Ch7 is
                Parent_Typ := Underlying_Record_View (Parent_Typ);
             end if;
 
-            Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
+            Parent_Utyp := Underlying_Type (Parent_Typ);
+
+            --  Handle views created for a synchronized private extension with
+            --  known, non-defaulted discriminants. In that case, parent_typ
+            --  will be the private extension, as it is the first "non
+            --  -constrained" type in the parent chain. Unfortunately, the
+            --  underlying type, being a protected or task type, is not the
+            --  "real" type needing finalization. Rather, the "corresponding
+            --  record type" should be the designated type here. In fact, TSS
+            --  finalizer generation is specifically skipped for the nominal
+            --  class-wide type of (the full view of) a concurrent type (see
+            --  exp_ch7.Expand_Freeze_Class_Wide_Type). If we don't designate
+            --  the underlying record (Tprot_typeVC), we will end up trying to
+            --  dispatch to prot_typeVDF from an incorrectly designated
+            --  Tprot_typeC, which is, of course, not actually a member of
+            --  prot_typeV'Class, and thus incompatible.
+
+            if Ekind (Parent_Utyp) in Concurrent_Kind
+              and then Present (Corresponding_Record_Type (Parent_Utyp))
+            then
+               Parent_Utyp := Corresponding_Record_Type (Parent_Utyp);
+            end if;
+
+            Desig_Typ := Class_Wide_Type (Parent_Utyp);
          end;
 
       --  General case
diff --git a/gcc/testsuite/gnat.dg/sync_tag_finalize.adb b/gcc/testsuite/gnat.dg/sync_tag_finalize.adb
new file mode 100644
index 00000000000..6dffd4a102c
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/sync_tag_finalize.adb
@@ -0,0 +1,60 @@
+--  In previous versions of GNAT there was a curious bug that caused
+--  compilation to fail in the case of a synchronized private extension
+--  with non-default discriminants, where the creation of a constrained object
+--  (and thus subtype) caused the TSS deep finalize machinery of the internal
+--  class-wide constratined subtype (TConstrainedC) to construct a malformed
+--  TSS finalize address body. The issue was that the machinery climbs
+--  the type parent chain looking for a "non-constrained" type to use as a
+--  designated (class-wide) type for a dispatching call to a higher TSS DF
+--  subprogram. When there is a discriminated synchronized private extension
+--  with known, non-default discriminants (thus unconstrained/indefinite), 
+--  that search ends up at that private extension declaration. Since the
+--  underlying type is actually a concurrent type, class-wide TSS finalizers
+--  are not built for the type, but rather the corresponding record type. The
+--  TSS machinery that selects the designated type was prevsiously unaware of
+--  this caveat, and thus selected an incompatible designated type, leading to
+--  failed compilation.
+--
+--  TL;DR: When creating a constrained subtype of a synchronized private
+--  extension with known non-defaulted disciminants, the class-wide TSS
+--  address finalization body for the constrained subtype should dispatch to
+--  the corresponding record (class-wide) type deep finalize subprogram.
+
+--  { dg-do compile }
+
+procedure Sync_Tag_Finalize is
+   
+   package Ifaces is
+      
+      type Test_Interface is synchronized interface;
+      
+      procedure Interface_Action (Test: in out Test_Interface) is abstract;
+      
+   end Ifaces;
+   
+   
+   package Implementation is
+      type Test_Implementation
+        (Constraint: Positive) is
+        synchronized new Ifaces.Test_Interface with private;
+      
+   private
+      protected type Test_Implementation
+        (Constraint: Positive)
+      is new Ifaces.Test_Interface with
+      
+         overriding procedure Interface_Action;
+         
+      end Test_Implementation;
+   end Implementation;
+   
+   package body Implementation is
+      protected body Test_Implementation is
+         procedure Interface_Action is null;
+      end;
+   end Implementation;
+   
+   Constrained: Implementation.Test_Implementation(2);
+begin
+   null;
+end;
-- 
2.40.0