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 --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index ab8cc1012c31c3c0e07c149d6513119e94f9fe3c..0770bafd23166557b284174b81df319746c133b9 100644 (file)
--- 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 b139bd4cf4e784639ff9088b4b288a1ddda54c17..2d31c71f366e3ff15e4c37d14f53d211820d59a4 100644 (file)
--- 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)