diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 3262236dd1482d5c7afeceb6d3e62dced44ce127..92902a7debb53f6242363a2c2c90f1db548c6a4b 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 0000000000000000000000000000000000000000..b105acf6e9841b25dd055e6293f8a90fb3d7d6e0 --- /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 0000000000000000000000000000000000000000..608f10662a311e629211cb17f14fa98b9a805211 --- /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;