https://gcc.gnu.org/g:356536a4e6bce777e9f150e0bdcd627cd73068cd
commit r15-3566-g356536a4e6bce777e9f150e0bdcd627cd73068cd
Author: Javier Miranda <mira...@adacore.com>
Date: Mon Aug 26 18:56:37 2024 +0000
ada: First controlling parameter: report error without Extensions allowed
Enable reporting an error when this new aspect/pragma is set to
True, and the sources are compiled without language extensions
allowed.
gcc/ada/
* sem_ch13.adb (Analyze_One_Aspect): Call
Error_Msg_GNAT_Extension() to report an error when the aspect
First_Controlling_Parameter is set to True and the sources are
compiled without Core_Extensions_ Allowed.
* sem_prag.adb (Pragma_First_Controlling_Parameter): Call
subprogram Error_Msg_GNAT_Extension() to report an error when the
aspect First_Controlling_Parameter is set to True and the sources
are compiled without Core_Extensions_Allowed. Report an error when
the aspect pragma does not confirm an inherited True value.
Diff:
---
gcc/ada/sem_ch13.adb | 28 +++++++++++++++++----------
gcc/ada/sem_prag.adb | 53 ++++++++++++++++++++++++++++++++++++++++++----------
2 files changed, 61 insertions(+), 20 deletions(-)
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index ab8cc1012c31..0770bafd2316 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -4530,6 +4530,9 @@ package body Sem_Ch13 is
if (No (Expr) or else Entity (Expr) = Standard_True)
and then not Core_Extensions_Allowed
then
+ Error_Msg_GNAT_Extension
+ ("'First_'Controlling_'Parameter", Sloc (Aspect),
+ Is_Core_Extension => True);
goto Continue;
end if;
@@ -4545,19 +4548,24 @@ package body Sem_Ch13 is
goto Continue;
end if;
- -- If the aspect is specified for a derived type, the
- -- specified value shall be confirming.
-
if Present (Expr)
- and then Is_Derived_Type (E)
- and then
- Has_First_Controlling_Parameter_Aspect (Etype (E))
and then Entity (Expr) = Standard_False
then
- Error_Msg_Name_1 := Nam;
- Error_Msg_N
- ("specification of inherited aspect% can only "
- & "confirm parent value", Id);
+ -- If the aspect is specified for a derived type,
+ -- the specified value shall be confirming.
+
+ if Is_Derived_Type (E)
+ and then Has_First_Controlling_Parameter_Aspect
+ (Etype (E))
+ then
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_N
+ ("specification of inherited True value for "
+ & "aspect% can only confirm parent value",
+ Id);
+ end if;
+
+ goto Continue;
end if;
-- Given that the aspect has been explicitly given,
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index b139bd4cf4e7..2d31c71f366e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -17761,22 +17761,55 @@ package body Sem_Prag is
----------------------------------------
when Pragma_First_Controlling_Parameter => First_Ctrl_Param : declare
- Arg : Node_Id;
- E : Entity_Id := Empty;
+ Arg : Node_Id;
+ E : Entity_Id := Empty;
+ Expr : Node_Id := Empty;
begin
- if not Core_Extensions_Allowed then
- return;
- end if;
-
GNAT_Pragma;
- Check_Arg_Count (1);
+ Check_At_Least_N_Arguments (1);
+ Check_At_Most_N_Arguments (2);
Arg := Get_Pragma_Arg (Arg1);
+ Check_Arg_Is_Identifier (Arg);
- if Nkind (Arg) = N_Identifier then
- Analyze (Arg);
- E := Entity (Arg);
+ Analyze (Arg);
+ E := Entity (Arg);
+
+ if Present (Arg2) then
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_Boolean);
+ Expr := Get_Pragma_Arg (Arg2);
+ Analyze_And_Resolve (Expr, Standard_Boolean);
+ end if;
+
+ if not Core_Extensions_Allowed then
+ if No (Expr)
+ or else
+ (Present (Expr)
+ and then Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_True)
+ then
+ Error_Msg_GNAT_Extension
+ ("'First_'Controlling_'Parameter", Sloc (N),
+ Is_Core_Extension => True);
+ end if;
+
+ return;
+
+ elsif Present (Expr)
+ and then Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_False
+ then
+ if Is_Derived_Type (E)
+ and then Has_First_Controlling_Parameter_Aspect (Etype (E))
+ then
+ Error_Msg_Name_1 := Name_First_Controlling_Parameter;
+ Error_Msg_N
+ ("specification of inherited True value for aspect% can "
+ & "only confirm parent value", Pragma_Identifier (N));
+ end if;
+
+ return;
end if;
if No (E)
