From: Javier Miranda <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch6.adb | 4 ++--
gcc/ada/sem_attr.adb | 19 +++++++++++++++++--
gcc/ada/sem_disp.adb | 22 +---------------------
gcc/ada/sem_prag.adb | 2 +-
gcc/ada/sem_util.adb | 30 ++++++++++++++++++++----------
gcc/ada/sem_util.ads | 2 +-
6 files changed, 42 insertions(+), 37 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 7a6f9567f87..5ae609c47e4 100644
--- 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 2dd502f21bc..8033506108a 100644
--- 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 ac9042ccc58..dfcf384c7da 100644
--- 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 3519f9166e6..e3f1ed0e085 100644
--- 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 8119fa43d64..7d6e0fc7d8a 100644
--- 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 6118e27bc2d..fc1845e0b49 100644
--- 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.
--
2.53.0
