From: Eric Botcazou Date: Fri, 20 Mar 2026 21:18:54 +0000 (+0100) Subject: Ada: Fix interaction between overloading and types with implicit dereference X-Git-Tag: basepoints/gcc-17~568 X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=d4bcf46e0504a688b2c8f5125cf555f63ebeeb98;p=thirdparty%2Fgcc.git Ada: Fix interaction between overloading and types with implicit dereference The overall strategy for types declared with implicit dereference is to add two interpretations for every name, the direct one and the one corresponding to the generalized reference. But the two interpretations are not always preserved through the analysis and, more importantly, the resolution stops at the first couple of interpretations for such a name, disregarding more traditional overloading of specific names. The change makes sure that the two interpretation are preserved through the analysis, and implements the proper resolution of traditionally overloaded names in the presence of types with implicit dereference. It also performs some streamlining in the common processing of overloaded nodes in Resolve. gcc/ada/ PR ada/120669 * sem_ch4.adb (Analyze_Explicit_Dereference): Remove interpretations of the prefix only if they are of access types. (Analyze_One_Call.Indicate_Name_And_Type): Check for an implicit dereference only after indicating the name and type of the call. * sem_ch5.adb (Analyze_Assignment): Do not remove interpretations for the LHS if they are for a type with implicit dereference. * sem_res.adb (Resolve): Streamline the processing of overloaded nodes once an interpretation is picked for them. Add a specific handling for additional interpretations for generalized references. (Resolve_Explicit_Dereference): Remove interpretations of the prefix only if they are of access types. (Is_Ambiguous_Operand): Skip the direct interpretation for a limited type that has implicit dereference. * sem_type.adb (Add_One_Interp): Set the name of the first entry of the table of interpretations in more cases. gcc/testsuite/ * gnat.dg/implicit_deref1.adb: New test. * gnat.dg/implicit_deref2.adb: Likewise. * gnat.dg/implicit_deref3.adb: Likewise. --- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 6f5cebf73dd..81b9458d554 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2335,12 +2335,12 @@ package body Sem_Ch4 is while Present (It.Nam) loop T := It.Typ; - if Is_Access_Type (T) - and then No (First_Formal (Base_Type (Designated_Type (T)))) - then - Set_Etype (P, T); - else - Remove_Interp (I); + if Is_Access_Type (T) then + if No (First_Formal (Base_Type (Designated_Type (T)))) then + Set_Etype (P, T); + else + Remove_Interp (I); + end if; end if; Get_Next_Interp (I, It); @@ -3843,11 +3843,9 @@ package body Sem_Ch4 is procedure Indicate_Name_And_Type is begin Add_One_Interp (N, Nam, Etype (Nam)); - Check_Implicit_Dereference (N, Etype (Nam)); - Success := True; - -- If the prefix of the call is a name, indicate the entity - -- being called. If it is not a name, it is an expression that + -- If the prefix of the call is an entity name, indicate the entity + -- being called. If it is not such a name, it is an expression that -- denotes an access to subprogram or else an entry or family. In -- the latter case, the name is a selected component, and the entity -- being called is noted on the selector. @@ -3862,6 +3860,11 @@ package body Sem_Ch4 is end if; end if; + -- Now add an interpretation for the implicit dereference, if any + + Check_Implicit_Dereference (N, Etype (Nam)); + Success := True; + if Debug_Flag_E and not Report then Write_Str (" Overloaded call "); Write_Int (Int (N)); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 171731f1d30..30cdaeb4a7e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -455,8 +455,14 @@ package body Sem_Ch5 is Get_First_Interp (Lhs, I, It); while Present (It.Typ) loop + -- AI22-0112 restores the Ada 95 rule that excludes limited + -- types from consideration during resolution of the target + -- variable in assignment statements. + if Is_Limited_Type (It.Typ) then - Remove_Interp (I); + if not Has_Implicit_Dereference (It.Typ) then + Remove_Interp (I); + end if; elsif T1 = Any_Type then T1 := It.Typ; end if; @@ -505,7 +511,9 @@ package body Sem_Ch5 is -- variable in assignment statements. if Is_Limited_Type (It.Typ) then - Remove_Interp (I); + if not Has_Implicit_Dereference (It.Typ) then + Remove_Interp (I); + end if; elsif Has_Compatible_Type (Rhs, It.Typ) then if T1 = Any_Type then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 688347ba1aa..7f168499426 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2287,6 +2287,7 @@ package body Sem_Res is I1 : Interp_Index := 0; -- prevent junk warning It : Interp; It1 : Interp; + Prev_It : Interp := No_Interp; Seen : Entity_Id := Empty; -- prevent junk warning function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; @@ -2858,86 +2859,59 @@ package body Sem_Res is -- We have a matching interpretation, Expr_Type is the type -- from this interpretation, and Seen is the entity. - -- For an operator, just set the entity name. The type will be - -- set by the specific operator resolution routine. - - if Nkind (N) in N_Op then - Set_Entity (N, Seen); - Generate_Reference (Seen, N); + -- If this is an additional interpretation introduced by + -- Check_Implicit_Dereference, the actual interpretation + -- for N was the previous one. Resolve N and insert the + -- explicit dereference. - elsif Nkind (N) in N_Case_Expression - | N_Character_Literal - | N_Delta_Aggregate - | N_If_Expression + if Present (It.Nam) + and then Ekind (It.Nam) = E_Discriminant + and then Has_Implicit_Dereference (It.Nam) + and then (Nkind (N) /= N_Indexed_Component + or else No (Generalized_Indexing (N))) then - Set_Etype (N, Expr_Type); - - -- AI05-0139-2: Expression is overloaded because type has - -- implicit dereference. The context may be the one that - -- requires implicit dereferemce. + pragma Assert (Prev_It /= No_Interp); - elsif Has_Implicit_Dereference (Expr_Type) then - Set_Etype (N, Expr_Type); - Set_Is_Overloaded (N, False); + if Is_Entity_Name (N) then + Set_Etype (N, Prev_It.Typ); + Set_Entity (N, Prev_It.Nam); + Generate_Reference (Prev_It.Nam, N); - -- If the expression is an entity, generate a reference - -- to it, as this is not done for an overloaded construct - -- during analysis. - - if Is_Entity_Name (N) - and then Comes_From_Source (N) + elsif Nkind (N) in N_Subprogram_Call + and then Is_Entity_Name (Name (N)) then - Generate_Reference (Entity (N), N); - - -- Examine access discriminants of entity type, - -- to check whether one of them yields the - -- expected type. - - declare - Disc : Entity_Id := - First_Discriminant (Etype (Entity (N))); - - begin - while Present (Disc) loop - exit when Is_Access_Type (Etype (Disc)) - and then Has_Implicit_Dereference (Disc) - and then Designated_Type (Etype (Disc)) = Typ; + Set_Etype (Name (N), Prev_It.Typ); + Set_Entity (Name (N), Prev_It.Nam); + Generate_Reference (Prev_It.Nam, Name (N)); + Set_Is_Overloaded (Name (N), False); + end if; - Next_Discriminant (Disc); - end loop; + Build_Explicit_Dereference (N, It.Nam); - if Present (Disc) then - Build_Explicit_Dereference (N, Disc); - end if; - end; - end if; + -- For an operator, just set the entity. The type will be + -- set by the specific operator resolution routine. - exit Interp_Loop; + elsif Nkind (N) in N_Op then + Set_Entity (N, Seen); + Generate_Reference (Seen, N); - elsif Is_Overloaded (N) - and then Present (It.Nam) - and then Ekind (It.Nam) = E_Discriminant - and then Has_Implicit_Dereference (It.Nam) - then - -- If the node is a general indexing, the dereference is - -- is inserted when resolving the rewritten form, else - -- insert it now. + -- For an entity name, set both the type and the entity - if Nkind (N) /= N_Indexed_Component - or else No (Generalized_Indexing (N)) - then - Build_Explicit_Dereference (N, It.Nam); - end if; + elsif Is_Entity_Name (N) then + Set_Etype (N, Expr_Type); + Set_Entity (N, Seen); + Generate_Reference (Seen, N); - -- For an explicit dereference, attribute reference, range, - -- short-circuit form (which is not an operator node), or call - -- with a name that is an explicit dereference, there is - -- nothing to be done at this point. + -- For nodes other than calls, or calls with a name that is an + -- explicit dereference, there is nothing to be done. elsif Nkind (N) in N_Attribute_Reference | N_And_Then + | N_Case_Expression + | N_Character_Literal + | N_Delta_Aggregate | N_Explicit_Dereference - | N_Identifier + | N_If_Expression | N_Indexed_Component | N_Or_Else | N_Range @@ -2947,29 +2921,23 @@ package body Sem_Res is then null; - -- For procedure or function calls, set the type of the name, - -- and also the entity pointer for the prefix. + -- For some calls, set the type and entity of the name - elsif Nkind (N) in N_Subprogram_Call - and then Is_Entity_Name (Name (N)) - then + elsif Is_Entity_Name (Name (N)) then Set_Etype (Name (N), Expr_Type); Set_Entity (Name (N), Seen); Generate_Reference (Seen, Name (N)); - elsif Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Selected_Component - then + elsif Nkind (Name (N)) = N_Selected_Component then Set_Etype (Name (N), Expr_Type); Set_Entity (Selector_Name (Name (N)), Seen); Generate_Reference (Seen, Selector_Name (Name (N))); - -- For all other cases, just set the type of the Name + -- For other calls, just set the type of the Name else Set_Etype (Name (N), Expr_Type); end if; - end if; <> @@ -2978,6 +2946,8 @@ package body Sem_Res is exit Interp_Loop when No (It.Typ); + Prev_It := It; + Get_Next_Interp (I, It); end loop Interp_Loop; end if; @@ -9324,19 +9294,19 @@ package body Sem_Res is Get_First_Interp (P, I, It); while Present (It.Typ) loop - if Is_Access_Type (It.Typ) - and then Covers (Typ, Designated_Type (It.Typ)) - then - if No (P_Typ) then - P_Typ := It.Typ; - end if; + if Is_Access_Type (It.Typ) then + if Covers (Typ, Designated_Type (It.Typ)) then + if No (P_Typ) then + P_Typ := It.Typ; + end if; - -- Remove access types that do not match, but preserve access - -- to subprogram interpretations, in case a further dereference - -- is needed (see below). + -- Remove access types that do not match, but preserve access + -- to subprogram interpretations, in case a further dereference + -- is needed (see below). - elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then - Remove_Interp (I); + elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then + Remove_Interp (I); + end if; end if; Get_Next_Interp (I, It); @@ -13769,6 +13739,17 @@ package body Sem_Res is return True; end if; + -- Skip the direct interpretation for a limited type that has implicit + -- dereference, since it cannot be used for operands of an assignment, + -- per AI22-0112 which restores the Ada 95 rule for all versions. + + if Present (It.Typ) + and then Is_Limited_Type (It.Typ) + and then Has_Implicit_Dereference (It.Typ) + then + Get_Next_Interp (I, It); + end if; + I1 := I; It1 := It; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index d4e7569c543..0f8e7cb66cd 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -476,13 +476,19 @@ package body Sem_Type is then Add_Entry (Entity (Name (N)), Etype (N)); + elsif Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Selected_Component + and then Is_Entity_Name (Selector_Name (Name (N))) + then + Add_Entry (Entity (Selector_Name (Name (N))), Etype (N)); + -- If this is an indirect call there will be no name associated -- with the previous entry. To make diagnostics clearer, save -- Subprogram_Type of first interpretation, so that the error will -- point to the anonymous access to subprogram, not to the result -- type of the call itself. - elsif (Nkind (N)) = N_Function_Call + elsif Nkind (N) = N_Function_Call and then Nkind (Name (N)) = N_Explicit_Dereference and then Is_Overloaded (Name (N)) then @@ -497,10 +503,17 @@ package body Sem_Type is Add_Entry (It.Nam, Etype (N)); end; - else - -- Overloaded prefix in indexed or selected component, or call - -- whose name is an expression or another call. + -- If this is a generalized indexing, treat it as a function call + elsif Nkind (N) = N_Indexed_Component + and then Present (Generalized_Indexing (N)) + then + Add_Entry (Entity (Name (Generalized_Indexing (N))), Etype (N)); + + -- An overloaded prefix in indexed or selected component, or a call + -- whose name is an expression or another call. + + else Add_Entry (Etype (N), Etype (N)); end if; diff --git a/gcc/testsuite/gnat.dg/implicit_deref1.adb b/gcc/testsuite/gnat.dg/implicit_deref1.adb new file mode 100644 index 00000000000..eb3a1085187 --- /dev/null +++ b/gcc/testsuite/gnat.dg/implicit_deref1.adb @@ -0,0 +1,50 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with Ada.Containers.Indefinite_Ordered_Maps; +with Ada.Strings.Unbounded; + +procedure Implicit_Deref1 is + use Ada.Strings.Unbounded; + + package Reproduce_Pkg is + type Person_Type is tagged private; + + type Person_Ref (Data : not null access Person_Type) is + limited null record + with Implicit_Dereference => Data; + + type Person_Handler_Ptr is access procedure (Person : Person_Type); + + function New_Person (Name : Unbounded_String) return Person_Ref; + + function New_Person + (Person : aliased in out Person_Type; Name : Unbounded_String) + return Person_Ref; + + private + + type Person_Type is tagged record + Name : Unbounded_String; + end record; + end Reproduce_Pkg; + + package body Reproduce_Pkg is + function New_Person (Name : Unbounded_String) return Person_Ref is + begin + return (Data => new Person_Type'(Name => Name)); + end New_Person; + + function New_Person + (Person : aliased in out Person_Type; Name : Unbounded_String) + return Person_Ref is + begin + return (Data => new Person_Type'(Name => Name)); + end New_Person; + end Reproduce_Pkg; + + App : Reproduce_Pkg.Person_Type := + Reproduce_Pkg.New_Person (Name => To_Unbounded_String ("hello")); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/implicit_deref2.adb b/gcc/testsuite/gnat.dg/implicit_deref2.adb new file mode 100644 index 00000000000..e0a0ae4dc66 --- /dev/null +++ b/gcc/testsuite/gnat.dg/implicit_deref2.adb @@ -0,0 +1,74 @@ +-- { dg-do compile } + +with Ada.Text_IO; +with System.Address_To_Access_Conversions; + +procedure Implicit_Deref2 is + + package Test is + + type Any is + tagged limited + record + Address : System.Address; + end record; + + type Any_Ptr is access Any; + + generic + type T (<>) is limited private; + type T_Ptr is access T; + function Make (P : T_Ptr) return Any_Ptr; + + generic + type T (<>) is limited private; + type T_Ref (Data : not null access constant T) is limited private; + with function Make_T_Ref (Data : not null access constant T) return T_Ref; + function Get (P : Any_Ptr) return T_Ref; + + end Test; + + package body Test is + + function Make (P : T_Ptr) return Any_Ptr is + package Convert is new System.Address_To_Access_Conversions (T); + begin + return new Any'(Address => Convert.To_Address (Convert.Object_Pointer (P))); + end Make; + + function Get (P : Any_Ptr) return T_Ref is + package Convert is new System.Address_To_Access_Conversions (T); + begin + return Make_T_Ref (Convert.To_Pointer (P.Address)); + end Get; + + end Test; + + type Integer_Ptr is access Integer; + type Integer_Ref (Data : not null access constant Integer) is limited null record + with Implicit_Dereference => Data; + function Make_Integer_Ref (Data : not null access constant Integer) return Integer_Ref is + (Data => Data); + + function Make is new Test.Make (Integer, Integer_Ptr); + function Get is new Test.Get (Integer, Integer_Ref, Make_Integer_Ref); + + type Float_Ptr is access Float; + type Float_Ref (Data : not null access constant Float) is limited null record + with Implicit_Dereference => Data; + function Make_Float_Ref (Data : not null access constant Float) return Float_Ref is + (Data => Data); + + function Make is new Test.Make (Float, Float_Ptr); + function Get is new Test.Get (Float, Float_Ref, Make_Float_Ref); + + A1 : Test.Any_Ptr := Make (new Integer'(42)); + A2 : Integer := Get (A1); + + B1 : Test.Any_Ptr := Make (new Float'(43.0)); + B2 : Float := Get (B1); + +begin + Ada.Text_IO.Put_Line (A2'Image); + Ada.Text_IO.Put_Line (B2'Image); +end; diff --git a/gcc/testsuite/gnat.dg/implicit_deref3.adb b/gcc/testsuite/gnat.dg/implicit_deref3.adb new file mode 100644 index 00000000000..7476064ee33 --- /dev/null +++ b/gcc/testsuite/gnat.dg/implicit_deref3.adb @@ -0,0 +1,52 @@ +-- { dg-do compile } + +procedure Implicit_Deref3 is + + package P is + type Root is tagged null record; + + type Access_Root_Class is access Root'Class; + + type Root_Ref is tagged record + Block : Access_Root_Class; + end record; + + function Create (Value : Root'Class) return Root_Ref + is (Block => new Root'Class'(Value)); + end P; + + use P; + + generic + type T (<>) is abstract new Root with private; + type Parent_Ref is new Root_Ref with private; + package Pointers is + type Ref is new Parent_Ref with null record; + + not overriding + function Create (Value : T) return Ref + is (Parent_Ref'(Create (Value)) with null record); + + type Reference_Type (Data : access T) is limited null record + with Implicit_Dereference => Data; + + function Get (This : Ref) return Reference_Type + is (Data => T (This.Block.all)'Access); + end Pointers; + + type Derived_A is abstract new Root with null record; + + type Derived_B is new Derived_A with record + I : Integer; + end record; + + package A_Pointers is new Pointers (Derived_A, Root_Ref); + package B_Pointers is new Pointers (Derived_B, A_Pointers.Ref); + + X : B_Pointers.Ref; + Y : Integer := X.Get.Data.I; + Z : Integer := B_Pointers.Get (X).Data.I; + +begin + null; +end;