From: Richard Wai <rich...@annexi-strayline.com>
GNAT was relying on synchronized private type extensions deriving from a
concurrent interface to determine its limitedness. This does not cover the case
where such an extension derives a limited interface. RM-7.6(6/2) makes is clear
that "synchronized" in a private extension implies the derived type is limited.
GNAT should explicitly check for the presence of "synchronized" in a private
extension declaration, and it should have the same effect as the presence of
“limited”.
gcc/ada/ChangeLog:
* sem_ch3.adb (Build_Derived_Record_Type): Treat presence of
keyword "synchronized" the same as "limited" when determining if a
private extension is limited.
gcc/testsuite/ChangeLog:
* gnat.dg/sync_tag_discriminals.adb: New test.
* gnat.dg/sync_tag_limited.adb: New test.
Signed-off-by: Richard Wai <rich...@annexi-strayline.com>
---
gcc/ada/sem_ch3.adb | 12 +++--
.../gnat.dg/sync_tag_discriminals.adb | 51 +++++++++++++++++++
gcc/testsuite/gnat.dg/sync_tag_limited.adb | 50 ++++++++++++++++++
3 files changed, 110 insertions(+), 3 deletions(-)
create mode 100644 gcc/testsuite/gnat.dg/sync_tag_discriminals.adb
create mode 100644 gcc/testsuite/gnat.dg/sync_tag_limited.adb
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 3262236dd14..92902a7debb 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -9599,9 +9599,15 @@ package body Sem_Ch3 is
-- AI-419: Limitedness is not inherited from an interface parent, so to
-- be limited in that case the type must be explicitly declared as
- -- limited. However, task and protected interfaces are always limited.
-
- if Limited_Present (Type_Def) then
+ -- limited, or synchronized. While task and protected interfaces are
+ -- always limited, a synchronized private extension might not inherit
+ -- from such interfaces, and so we also need to recognize the
+ -- explicit limitedness implied by a synchronized private extension
+ -- that does not derive from a synchronized interface (see RM-7.3(6/2)).
+
+ if Limited_Present (Type_Def)
+ or else Synchronized_Present (Type_Def)
+ then
Set_Is_Limited_Record (Derived_Type);
elsif Is_Limited_Record (Parent_Type)
diff --git a/gcc/testsuite/gnat.dg/sync_tag_discriminals.adb
b/gcc/testsuite/gnat.dg/sync_tag_discriminals.adb
new file mode 100644
index 00000000000..b105acf6e98
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/sync_tag_discriminals.adb
@@ -0,0 +1,51 @@
+-- This test is related to sync_tag_limited in that previous versions of GNAT
+-- failed to consider a synchronized private extension as limited if it was
+-- not derrived from a synchronized interface (i.e. a limited interface). Since
+-- such a private type would not be considered limited, GNAT would fail to
+-- correctly build the expected discriminals later needed by the creation of
+-- the concurrent type's "corresponding record type", leading to a compilation
+-- error where the discriminants of the corresponding record type had no
+-- identifiers.
+--
+-- This test is in addition to sync_tag_limited because the sync_tag_limited
+-- would fail for "legality" reasons (default discriminants not allowed for
+-- a non-limited taged type). It is also an opportunity to ensure that non-
+-- defaulted discriminated synchronized private extensions work as expected.
+
+-- { dg-do compile }
+
+procedure Sync_Tag_Discriminals is
+
+ package Ifaces is
+
+ type Test_Interface is limited 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;
+
+begin
+ null;
+end Sync_Tag_Discriminals;
diff --git a/gcc/testsuite/gnat.dg/sync_tag_limited.adb
b/gcc/testsuite/gnat.dg/sync_tag_limited.adb
new file mode 100644
index 00000000000..608f10662a3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/sync_tag_limited.adb
@@ -0,0 +1,50 @@
+-- Synchronized tagged types created by a private extension with the keyword
+-- 'synchronized' shall be seen as an (immutably) limited tagged type, and
+-- should therefore accept default disciminant spectifications.
+-- This was a bug in earlier versions of GNAT, whereby GNAT erroneously
+-- relied on a parent synchronized interface to determine limitedness
+-- of a synchronized private extension. The problem being that a synchronized
+-- private extension can derive a non-synchronized interface (specifically a
+-- limited interface), Yet the RM makes it clear (7.3(6/2)) that such
+-- synchronized private extensions are always limited.
+--
+-- Ergo: Default discriminants are of course legal on any synchronized private
+-- extension.
+
+-- { dg-do compile }
+
+procedure Sync_Tag_Limited is
+
+ package Ifaces is
+
+ type Test_Interface is limited interface;
+
+ procedure Interface_Action (Test: in out Test_Interface) is abstract;
+
+ end Ifaces;
+
+
+ package Implementation is
+ type Test_Implementation
+ (Constraint: Positive := 1) is
+ synchronized new Ifaces.Test_Interface with private;
+
+ private
+ protected type Test_Implementation
+ (Constraint: Positive := 1)
+ 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;
+
+begin
+ null;
+end Sync_Tag_Limited;
--
2.40.0
