ada: TSS finalize address subprogram generation for constrained...

...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>

3 files changed, 90 insertions, 2 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 04c3ad8..bb01598 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 aa16c70..4ea5e6e 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 0000000..6dffd4a
--- /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;