ada: Incorrect error message on use of 'Result with wrong prefix

gcc/ada/ChangeLog:

	* sem_util.ads (Is_Access_Subprogram_Wrapper): Renamed as
	Is_Access_To_Subprogram_Wrapper.
	* sem_util.adb (Is_Access_Subprogram_Wrapper): Ditto plus add
	assertion.
	* sem_disp.adb (Is_Access_To_Subprogram_Wrapper): Removed.
	* sem_prag.adb (Find_Related_Declaration_Or_Body): Replace call to
	Is_Access_Subprogram_Wrapper by call to Is_Access_To_Subprogram_Wrapper.
	* exp_ch6.adb (Expand_Call): Ditto.
	* sem_attr.adb (Analyze_Attribute [Attribute_Result]): For access to
	subprogram wrappers, report that the expected prefix is the name of
	the access type.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 7a6f9567f874d2ed4ef7c8c4c999ef0a452be7a8..5ae609c47e489df2cbde910f69de14e65c1ba450 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -2812,10 +2812,10 @@ package body Exp_Ch6 is
 
       if Must_Rewrite_Indirect_Call
         and then (not Is_Overloadable (Current_Scope)
-             or else not (Is_Access_Subprogram_Wrapper (Current_Scope)
+             or else not (Is_Access_To_Subprogram_Wrapper (Current_Scope)
                            or else
                              (Chars (Current_Scope) = Name_uWrapped_Statements
-                               and then Is_Access_Subprogram_Wrapper
+                               and then Is_Access_To_Subprogram_Wrapper
                                           (Scope (Current_Scope)))))
       then
          declare

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2dd502f21bc2e8befb15b6ce3220dba3956ae2b7..8033506108a8603fc69c18634881e88d7d8759a9 100644 (file)
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6176,7 +6176,13 @@ package body Sem_Attr is
                   --  Otherwise the prefix denotes some unrelated function
 
                   else
-                     Error_Msg_Name_2 := Chars (Spec_Id);
+                     if Is_Access_To_Subprogram_Wrapper (Spec_Id) then
+                        Error_Msg_Name_2 :=
+                          Chars (Etype (Last_Formal (Spec_Id)));
+                     else
+                        Error_Msg_Name_2 := Chars (Spec_Id);
+                     end if;
+
                      Error_Attr
                        ("incorrect prefix for attribute %, expected %", P);
                   end if;
@@ -6187,8 +6193,17 @@ package body Sem_Attr is
                elsif Is_Access_Subprogram_Type (Pref_Id) then
                   if Pref_Id = Spec_Id then
                      Set_Etype (N, Etype (Designated_Type (Spec_Id)));
+
+                  --  Otherwise the prefix denotes some unrelated function
+
                   else
-                     Error_Msg_Name_2 := Chars (Spec_Id);
+                     if Is_Access_To_Subprogram_Wrapper (Spec_Id) then
+                        Error_Msg_Name_2 :=
+                          Chars (Etype (Last_Formal (Spec_Id)));
+                     else
+                        Error_Msg_Name_2 := Chars (Spec_Id);
+                     end if;
+
                      Error_Attr
                        ("incorrect prefix for attribute %, expected %", P);
                   end if;

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index ac9042ccc58e7c5dfc84c9d8f1cb50fa0f876277..dfcf384c7dae8a21f3e380f2e706a624b7052d45 100644 (file)
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1199,8 +1199,6 @@ package body Sem_Disp is
    ---------------------------------
 
    procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
-      function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean;
-      --  Return True if E is an access to subprogram wrapper
 
       procedure Warn_On_Late_Primitive_After_Private_Extension
         (Typ  : Entity_Id;
@@ -1209,22 +1207,6 @@ package body Sem_Disp is
       --  if it is a public primitive defined after some private extension of
       --  the tagged type.
 
-      -------------------------------------
-      -- Is_Access_To_Subprogram_Wrapper --
-      -------------------------------------
-
-      function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean
-      is
-         Decl_N : constant Node_Id := Unit_Declaration_Node (E);
-         Par_N  : constant Node_Id := Parent (List_Containing (Decl_N));
-
-      begin
-         --  Access to subprogram wrappers are declared in the freezing actions
-
-         return Nkind (Par_N) = N_Freeze_Entity
-           and then Ekind (Entity (Par_N)) = E_Access_Subprogram_Type;
-      end Is_Access_To_Subprogram_Wrapper;
-
       ----------------------------------------------------
       -- Warn_On_Late_Primitive_After_Private_Extension --
       ----------------------------------------------------
@@ -1298,9 +1280,7 @@ package body Sem_Disp is
 
       --  Wrappers of access to subprograms are not primitive subprograms.
 
-      elsif Is_Wrapper (Subp)
-        and then Is_Access_To_Subprogram_Wrapper (Subp)
-      then
+      elsif Is_Access_To_Subprogram_Wrapper (Subp) then
          return;
       end if;
 

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 3519f9166e616e83defb4842e092d810f0ef9b17..e3f1ed0e08567aef447e004bccef51876849dba7 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -34170,7 +34170,7 @@ package body Sem_Prag is
                then
                   return Stmt;
 
-               elsif Is_Access_Subprogram_Wrapper (Defining_Entity (Stmt))
+               elsif Is_Access_To_Subprogram_Wrapper (Defining_Entity (Stmt))
                  and then Ada_Version >= Ada_2022
                then
                   return Stmt;

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 8119fa43d64f9a25ed3ef057b837cd0ee63bcc3f..7d6e0fc7d8ac9892be5527a4c2b1a3cec236fa7c 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12747,18 +12747,28 @@ package body Sem_Util is
       return False;
    end Has_Non_Null_Statements;
 
-   ----------------------------------
-   -- Is_Access_Subprogram_Wrapper --
-   ----------------------------------
+   -------------------------------------
+   -- Is_Access_To_Subprogram_Wrapper --
+   -------------------------------------
+
+   function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean is
+      Formal : Entity_Id;
 
-   function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
-      Formal : constant Entity_Id := Last_Formal (E);
    begin
-      return Present (Formal)
-        and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
-        and then Access_Subprogram_Wrapper
-           (Directly_Designated_Type (Etype (Formal))) = E;
-   end Is_Access_Subprogram_Wrapper;
+      if not Is_Wrapper (E)
+        or else not Can_Have_Formals (E)
+        or else No (Last_Formal (E))
+      then
+         return False;
+
+      else
+         Formal := Last_Formal (E);
+
+         return Ekind (Etype (Formal)) in Access_Subprogram_Kind
+           and then Access_Subprogram_Wrapper
+              (Directly_Designated_Type (Etype (Formal))) = E;
+      end if;
+   end Is_Access_To_Subprogram_Wrapper;
 
    ---------------------------
    -- Is_Explicitly_Aliased --

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 6118e27bc2defe5f4e2b3ae1bc514179bb96f481..fc1845e0b4908d6b96ad28b7d49f32eb63e354c2 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1881,7 +1881,7 @@ package Sem_Util is
    --  pragma Initialize_Scalars or by the binder. Return an expression created
    --  at source location Loc, which denotes the invalid value.
 
-   function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean;
+   function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean;
    --  True if E is the constructed wrapper for an access_to_subprogram
    --  type with Pre/Postconditions.