ada: Incorrect resolution of prefixed calls with overriding private subprogram

The compiler incorrectly treats an overriding private subprogram that
should not be visible outside a package (because it only overrides in
the private part) as a possible interpretation for a call using prefixed
notation outside of the package. This can result in an ambiguity if there
is another subprogram with the same name but a different profile declared
in the visible part of the package, or can result in resolving to the
private operation in cases where it shouldn't resolve. This happens due
to the compiler improperly concluding that the private overriding subprogram
overrides an inherited subprogram in the package visible part, even though
the only inherited subprogram is in the private part, as a result of
a misuse of the Overridden_Operation field, which, contrary to what
its name suggests, actually refers to operations of the parent type,
rather than to the operations derived from the parent's operations.

gcc/ada/ChangeLog:

	* einfo.ads: Document new field Overridden_Inherited_Operation and
	list it as a field for the entity kinds that it applies to.
	* gen_il-fields.ads (type Opt_Field_Enum): Add new literal
	Overridden_Inherited_Operation to the type.
	* gen_il-gen-gen_entities.adb: Add Overridden_Inherited_Operation as
	a field of entities of kinds E_Enumeration_Literal and Subprogram_Kind.
	* sem_ch4.adb (Is_Callable_Private_Overriding): Change name (was
	Is_Private_Overriding). Replace Is_Hidden test on Overridden_Operation
	with test of Is_Hidden on the new field Overridden_Inherited_Operation.
	* sem_ch6.adb (New_Overloaded_Entity): Set the new field
	Overridden_Inherited_Operation on an operation derived from
	an interface to refer to the inherited operation of a private
	extension that's overridden by the derived operation. Also set
	that field in the more common cases of an explicit subprogram
	that overrides, to refer to the inherited subprogram that is
	overridden. (Contrary to its name, the Overridden_Operation
	field of the overriding subprogram, which is also set in these
	places, refers to the *parent* subprogram from which the inherited
	subprogram is derived.) Also, remove a redundant Present (Alias (S))
	test in an if_statement and the dead "else" part of that statement.

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index ba79fe4aa86b6d1aa17844a9d3f290a5f0ff1b78..c4aa98ee4f37a0bc7a97c7f1fd157469b0062963 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3940,9 +3940,21 @@ package Einfo is
 --       Defined in constants and variables. Set if there is an address clause
 --       that causes the entity to overlay a constant object.
 
+--    Overridden_Inherited_Operation
+--       Defined in subprograms and enumeration literals. When set on a
+--       subprogram S, indicates an inherited subprogram that S overrides.
+--       In the case of a privately declared explicit subprogram E that
+--       overrides a private inherited subprogram, and the inherited
+--       subprogram itself overrides another inherited subprogram declared
+--       for a private extension, the field on E will reference the subprogram
+--       inherited by the private extension. This field is used for properly
+--       handling visibility for such privately declared subprograms. This
+--       field is always Empty for enumeration literal entities.
+
 --    Overridden_Operation
 --       Defined in subprograms. For overriding operations, points to the
---       user-defined parent subprogram that is being overridden.
+--       user-defined parent subprogram from which the inherited subprogram
+--       that is being overridden is derived.
 
 --    Package_Instantiation
 --       Defined in packages and generic packages. When defined, this field
@@ -5413,6 +5425,7 @@ package Einfo is
    --    Enumeration_Pos
    --    Enumeration_Rep
    --    Alias
+   --    Overridden_Inherited_Operation
    --    Enumeration_Rep_Expr
    --    Interface_Name $$$
    --    Renamed_Object $$$
@@ -5502,6 +5515,7 @@ package Einfo is
    --    Subps_Index                          (non-generic case only)
    --    Interface_Alias
    --    LSP_Subprogram                       (non-generic case only)
+   --    Overridden_Inherited_Operation
    --    Overridden_Operation
    --    Wrapped_Entity                       (non-generic case only)
    --    Extra_Formals
@@ -5705,6 +5719,7 @@ package Einfo is
    --    Extra_Accessibility_Of_Result
    --    Last_Entity
    --    Subps_Index
+   --    Overridden_Inherited_Operation
    --    Overridden_Operation
    --    Linker_Section_Pragma
    --    Contract
@@ -5858,6 +5873,7 @@ package Einfo is
    --    Subps_Index                          (non-generic case only)
    --    Interface_Alias
    --    LSP_Subprogram                       (non-generic case only)
+   --    Overridden_Inherited_Operation
    --    Overridden_Operation                 (never for init proc)
    --    Wrapped_Entity                       (non-generic case only)
    --    Extra_Formals

diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 2d16e12805b38a38562a3e2a8c5552249393f875..9b4adee1d466c1bf1fd56df60e3f64114b6c36de 100644 (file)
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -850,6 +850,7 @@ package Gen_IL.Fields is
       Original_Protected_Subprogram,
       Original_Record_Component,
       Overlays_Constant,
+      Overridden_Inherited_Operation,
       Overridden_Operation,
       Package_Instantiation,
       Packed_Array_Impl_Type,

diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index 8cbed8a59890308697db11401c2c8ede50233ab3..b2970e6c2bf110a08b3d9a5d8f064a0ba3757568 100644 (file)
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -953,6 +953,7 @@ begin -- Gen_IL.Gen.Gen_Entities
         Sm (Enumeration_Rep_Expr, Node_Id),
         Sm (Esize, Uint),
         Sm (Alignment, Unat),
+        Sm (Overridden_Inherited_Operation, Node_Id),
         Sm (Interface_Name, Node_Id)));
 
    Ab (Subprogram_Kind, Overloadable_Kind,
@@ -981,6 +982,7 @@ begin -- Gen_IL.Gen.Gen_Entities
         Sm (Is_Machine_Code_Subprogram, Flag),
         Sm (Last_Entity, Node_Id),
         Sm (Linker_Section_Pragma, Node_Id),
+        Sm (Overridden_Inherited_Operation, Node_Id),
         Sm (Overridden_Operation, Node_Id),
         Sm (Protected_Body_Subprogram, Node_Id),
         Sm (No_Raise, Flag),

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 56dc7c6355c054713edd3b82bd5b143fbc715b67..22a04e3ba9b5f1fc3d0e87ebbbc701babf1e5dfe 100644 (file)
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -10406,11 +10406,14 @@ package body Sem_Ch4 is
          --  may be candidates, so that Try_Primitive_Operations can examine
          --  them if no real primitive is found.
 
-         function Is_Private_Overriding (Op : Entity_Id) return Boolean;
+         function Is_Callable_Private_Overriding
+           (Op : Entity_Id) return Boolean;
          --  An operation that overrides an inherited operation in the private
          --  part of its package may be hidden, but if the inherited operation
-         --  is visible a direct call to it will dispatch to the private one,
-         --  which is therefore a valid candidate.
+         --  that it overrides is visible, then a direct call to it will
+         --  dispatch to the private one, which is therefore a valid candidate.
+         --  Returns True if the operation can be called from outside the
+         --  enclosing package.
 
          function Names_Match
            (Obj_Type : Entity_Id;
@@ -10581,11 +10584,13 @@ package body Sem_Ch4 is
             return Op_List;
          end Extended_Primitive_Ops;
 
-         ---------------------------
-         -- Is_Private_Overriding --
-         ---------------------------
+         ------------------------------------
+         -- Is_Callable_Private_Overriding --
+         ------------------------------------
 
-         function Is_Private_Overriding (Op : Entity_Id) return Boolean is
+         function Is_Callable_Private_Overriding
+           (Op : Entity_Id) return Boolean
+         is
             Visible_Op : Entity_Id;
 
          begin
@@ -10607,7 +10612,10 @@ package body Sem_Ch4 is
                   --  have found what we're looking for.
 
                   if not Is_Hidden (Visible_Op)
-                    or else not Is_Hidden (Overridden_Operation (Op))
+                    or else
+                      (Present (Overridden_Inherited_Operation (Op))
+                        and then not Is_Hidden
+                                       (Overridden_Inherited_Operation (Op)))
                   then
                      return True;
                   end if;
@@ -10617,7 +10625,7 @@ package body Sem_Ch4 is
             end loop;
 
             return False;
-         end Is_Private_Overriding;
+         end Is_Callable_Private_Overriding;
 
          -----------------
          -- Names_Match --
@@ -10760,13 +10768,15 @@ package body Sem_Ch4 is
 
                  --  Do not consider hidden primitives unless the type is in an
                  --  open scope or we are within an instance, where visibility
-                 --  is known to be correct, or else if this is an overriding
-                 --  operation in the private part for an inherited operation.
+                 --  is known to be correct, or else if this is an operation
+                 --  declared in the private part that overrides a visible
+                 --  inherited operation.
 
                  or else (Is_Hidden (Prim_Op)
                            and then not Is_Immediately_Visible (Obj_Type)
                            and then not In_Instance
-                           and then not Is_Private_Overriding (Prim_Op))
+                           and then
+                             not Is_Callable_Private_Overriding (Prim_Op))
                then
                   goto Continue;
                end if;

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 48dcf8e4f1b178cb67f7f5c5d602c01ca2538aa4..8af980fe0c3c8d995f853a7c76edb4f5cc3783f7 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -12133,36 +12133,51 @@ package body Sem_Ch6 is
         and then Present (Find_Dispatching_Type (Alias (S)))
         and then Is_Interface (Find_Dispatching_Type (Alias (S)))
       then
-         --  For private types, when the full-view is processed we propagate to
-         --  the full view the non-overridden entities whose attribute "alias"
-         --  references an interface primitive. These entities were added by
-         --  Derive_Subprograms to ensure that interface primitives are
-         --  covered.
-
-         --  Inside_Freeze_Actions is non zero when S corresponds with an
-         --  internal entity that links an interface primitive with its
-         --  covering primitive through attribute Interface_Alias (see
-         --  Add_Internal_Interface_Entities).
-
-         if Inside_Freezing_Actions = 0
-           and then Is_Package_Or_Generic_Package (Current_Scope)
-           and then In_Private_Part (Current_Scope)
-           and then Parent_Kind (E) = N_Private_Extension_Declaration
-           and then Nkind (Parent (S)) = N_Full_Type_Declaration
-           and then Full_View (Defining_Identifier (Parent (E)))
-                      = Defining_Identifier (Parent (S))
-           and then Alias (E) = Alias (S)
-         then
-            Check_Operation_From_Private_View (S, E);
-            Set_Is_Dispatching_Operation (S);
+         declare
+            Private_Operation_Exported_By_Visible_Part : constant Boolean :=
+              Is_Package_Or_Generic_Package (Current_Scope)
+              and then In_Private_Part (Current_Scope)
+              and then Parent_Kind (E) = N_Private_Extension_Declaration
+              and then Nkind (Parent (S)) = N_Full_Type_Declaration
+              and then Full_View (Defining_Identifier (Parent (E)))
+                         = Defining_Identifier (Parent (S));
+
+         begin
+            --  For private types, when the full view is processed we propagate
+            --  to the full view the nonoverridden entities whose attribute
+            --  "alias" references an interface primitive. These entities were
+            --  added by Derive_Subprograms to ensure that interface primitives
+            --  are covered.
+
+            --  Inside_Freeze_Actions is nonzero when S corresponds to an
+            --  internal entity that links an interface primitive with its
+            --  covering primitive through attribute Interface_Alias (see
+            --  Add_Internal_Interface_Entities).
+
+            if Inside_Freezing_Actions = 0
+              and then Private_Operation_Exported_By_Visible_Part
+              and then Alias (E) = Alias (S)
+            then
+               Check_Operation_From_Private_View (S, E);
+               Set_Is_Dispatching_Operation (S);
 
-         --  Common case
+            --  Common case
 
-         else
-            Enter_Overloaded_Entity (S);
-            Check_Dispatching_Operation (S, Empty);
-            Check_For_Primitive_Subprogram (Is_Primitive_Subp);
-         end if;
+            else
+               Enter_Overloaded_Entity (S);
+               Check_Dispatching_Operation (S, Empty);
+               Check_For_Primitive_Subprogram (Is_Primitive_Subp);
+            end if;
+
+            if Private_Operation_Exported_By_Visible_Part
+              and then Type_Conformant (E, S)
+            then
+               --  Record the actual inherited subprogram that's being
+               --  overridden.
+
+               Set_Overridden_Inherited_Operation (S, E);
+            end if;
+         end;
 
          return;
       end if;
@@ -12601,6 +12616,26 @@ package body Sem_Ch6 is
                           and then not Is_Dispatch_Table_Wrapper (S)))
                   then
                      Set_Overridden_Operation    (S, Alias (E));
+
+                     --  Record the actual inherited subprogram that's being
+                     --  overridden. In the case where a subprogram declared
+                     --  in a private part overrides an inherited subprogram
+                     --  that itself is also declared in the private part,
+                     --  and that subprogram in turns overrides a subprogram
+                     --  declared in a package visible part (inherited via
+                     --  a private extension), we record the visible subprogram
+                     --  as the overridden one, so that we can determine
+                     --  visibility properly for prefixed calls to the
+                     --  subprogram made from outside the package. (See
+                     --  Try_Primitive_Operation in Sem_Ch4.)
+
+                     if Present (Overridden_Inherited_Operation (E)) then
+                        Set_Overridden_Inherited_Operation
+                          (S, Overridden_Inherited_Operation (E));
+                     else
+                        Set_Overridden_Inherited_Operation (S, E);
+                     end if;
+
                      Inherit_Subprogram_Contract (S, Alias (E));
 
                      Set_Is_Ada_2022_Only (S, Is_Ada_2022_Only (Alias (E)));