From: Richard Wai <rich...@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 <rich...@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
