[gcc r14-4132] ada: Private extensions with the keyword "synchronized" are always limited.

[gcc r14-4132] ada: Private extensions with the keyword "synchronized" are always limited.

[Marc Poulhi?s]

https://gcc.gnu.org/g:eceb45bb2e0bf5518d9bd873e25a498456af8e1f

commit r14-4132-geceb45bb2e0bf5518d9bd873e25a498456af8e1f
Author: Richard Wai <richard@annexi-strayline.com>
Date:   Wed Aug 9 01:54:48 2023 -0400

    ada: Private extensions with the keyword "synchronized" are always limited.
    
    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 <richard@annexi-strayline.com>

Diff:
---
 gcc/ada/sem_ch3.adb                             | 12 ++++--
 gcc/testsuite/gnat.dg/sync_tag_discriminals.adb | 51 +++++++++++++++++++++++++
 gcc/testsuite/gnat.dg/sync_tag_limited.adb      | 50 ++++++++++++++++++++++++
 3 files changed, 110 insertions(+), 3 deletions(-)

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;