@@ -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,
@@ -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)
From: Javier Miranda <miranda@adacore.com> 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. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_ch13.adb | 28 ++++++++++++++--------- gcc/ada/sem_prag.adb | 53 +++++++++++++++++++++++++++++++++++--------- 2 files changed, 61 insertions(+), 20 deletions(-)