https://gcc.gnu.org/g:e51e2c59cbc9249fc9d9094e266499cf3f2cdeff
commit r15-10761-ge51e2c59cbc9249fc9d9094e266499cf3f2cdeff Author: Eric Botcazou <[email protected]> Date: Sun Feb 1 20:31:41 2026 +0100 Ada: Fix prefixed-view notation rejected for discriminated private type The problem comes from an oversight in Analyze_Selected_Component. gcc/ada/ PR ada/123902 * sem_ch4.adb (Analyze_Selected_Component): Also test Core_Extensions_Allowed for discriminated private types. Rework and augment commentary throughout the procedure. gcc/testsuite/ * gnat.dg/prefix4.adb: New test. * gnat.dg/prefix4_pkg.ads: New helper. Co-authored-by: Liam Powell <[email protected]> Diff: --- gcc/ada/sem_ch4.adb | 33 ++++++++++++++++++++------------- gcc/testsuite/gnat.dg/prefix4.adb | 14 ++++++++++++++ gcc/testsuite/gnat.dg/prefix4_pkg.ads | 13 +++++++++++++ 3 files changed, 47 insertions(+), 13 deletions(-) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 6dd4891ff517..81d4d20aaeb3 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5683,12 +5683,12 @@ package body Sem_Ch4 is -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the -- selected component should resolve to a name. - -- Extension feature: Also support calls with prefixed views for - -- untagged record types. + -- GNAT extension: Accept calls with prefixed view for untagged + -- record types. if Ada_Version >= Ada_2005 and then (Is_Tagged_Type (Prefix_Type) - or else Core_Extensions_Allowed) + or else Core_Extensions_Allowed) and then not Is_Concurrent_Type (Prefix_Type) then if Nkind (Parent (N)) = N_Generic_Association @@ -5758,8 +5758,12 @@ package body Sem_Ch4 is -- Before declaring an error, check whether this is tagged -- private type and a call to a primitive operation. + -- GNAT extension: Accept calls with prefixed view for + -- untagged private types + elsif Ada_Version >= Ada_2005 - and then Is_Tagged_Type (Prefix_Type) + and then (Is_Tagged_Type (Prefix_Type) + or else Core_Extensions_Allowed) and then Try_Object_Operation (N) then return; @@ -5777,8 +5781,8 @@ package body Sem_Ch4 is Next_Entity (Comp); end loop; - -- Extension feature: Also support calls with prefixed views for - -- untagged private types. + -- GNAT extension: Accept calls with prefixed view for untagged + -- private types. if Core_Extensions_Allowed then if Try_Object_Operation (N) then @@ -5960,9 +5964,13 @@ package body Sem_Ch4 is -- visible entities are plausible interpretations, check whether -- there is some other primitive operation with that name. + -- Note that, unlike for other types, we do not accept calls with + -- prefixed view for untagged concurrent types with -gnatX, since + -- this would require associated legality rules to avoid conflict + -- with protected operations or entries of the concurrent types. + if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) then - if (Etype (N) = Any_Type - or else not Has_Candidate) + if (Etype (N) = Any_Type or else not Has_Candidate) and then Try_Object_Operation (N) then return; @@ -6038,8 +6046,7 @@ package body Sem_Ch4 is Set_Is_Overloaded (N, Is_Overloaded (Sel)); - -- Extension feature: Also support calls with prefixed views for - -- untagged types. + -- GNAT extension: Accept calls with prefixed view for untagged types elsif Core_Extensions_Allowed and then Try_Object_Operation (N) @@ -10282,8 +10289,8 @@ package body Sem_Ch4 is -- type, this is not a prefixed call. Restore the previous type as -- the current one is not a legal candidate. - -- Extension feature: Calls with prefixed views are also supported - -- for untagged types, so skip the early return when extensions are + -- GNAT extension: Given that calls with prefixed view are accepted + -- for untagged types, skip the early return when extensions are -- enabled, unless the type doesn't have a primitive operations list -- (such as in the case of predefined types). @@ -10309,7 +10316,7 @@ package body Sem_Ch4 is (Call_Node => New_Call_Node, Node_To_Replace => Node_To_Replace); - -- Extension feature: In the case where the prefix is of an + -- GNAT extension: In the case where the prefix is of an -- access type, and a primitive wasn't found for the designated -- type, then if the access type has primitives we attempt a -- prefixed call using one of its primitives. (It seems that diff --git a/gcc/testsuite/gnat.dg/prefix4.adb b/gcc/testsuite/gnat.dg/prefix4.adb new file mode 100644 index 000000000000..e22d7f79927e --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix4.adb @@ -0,0 +1,14 @@ +-- { dg-do run } +-- { dg-options "-gnatX" } + +with Prefix4_Pkg; use Prefix4_Pkg; + +procedure Prefix4 is + + Val : T (1); + +begin + if not Val.F then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/prefix4_pkg.ads b/gcc/testsuite/gnat.dg/prefix4_pkg.ads new file mode 100644 index 000000000000..3c692add576b --- /dev/null +++ b/gcc/testsuite/gnat.dg/prefix4_pkg.ads @@ -0,0 +1,13 @@ +package Prefix4_Pkg is + + type T (D : Integer) is private; + + function F (X : T) return Boolean is (True); + +private + + type T (D : Integer) is record + F : Boolean := False; + end record; + +end Prefix4_Pkg;
