[Ada] Implement AI12-0269 No_Return for functions

2020-06-12  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* einfo.ads (No_Return): Document it for all subprograms.
	* einfo.adb (Set_No_Return): Adjust assertion accordingly.
	* sem_ch3.adb (Check_Abstract_Overriding): Implement the
	check prescribed by RM 6.5.1(6/2) here instead of...
	(Derive_Subprogram): Adjust comment accordingly.
	* sem_disp.adb (Override_Dispatching_Operation): ...here.
	Remove superfluous return statement.
	* sem_ch6.adb (Check_No_Return_Expression): New procedure.
	(Analyze_Function_Return): Call it to implement the check
	prescribed by AI12-0269 for simple return statements of
	No_Return functions, and also checks extended statements.
	(Analyze_Return_Statement): Only give an error on a return
	statement in No_Return procedures.  Use idiomatic form.
	* sem_ch8.adb (Analyze_Subprogram_Renaming): Adjust error
	message for No_Return renaming subprogram.
	* sem_prag.adb (Analyze_Pragma) <Pragma_No_Return>: Accept
	it on functions and generic functions in Ada 2020.

7 files changed, 101 insertions, 25 deletions

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 83beff6..9176f4a 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -6180,8 +6180,7 @@ package body Einfo is
 
    procedure Set_No_Return (Id : E; V : B := True) is
    begin
-      pragma Assert
-        (V = False or else Ekind_In (Id, E_Procedure, E_Generic_Procedure));
+      pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
       Set_Flag113 (Id, V);
    end Set_No_Return;
 
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 75474cd..a1cfd7d 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3720,8 +3720,8 @@ package Einfo is
 --       pragma No_Component_Reordering applies.
 
 --    No_Return (Flag113)
---       Defined in all entities. Always false except in the case of procedures
---       and generic procedures for which a pragma No_Return is given.
+--       Defined in all entities. Set for subprograms and generic subprograms
+--       to which a valid aspect or pragma No_Return applies.
 
 --    No_Strict_Aliasing (Flag136) [base type only]
 --       Defined in access types. Set to direct the backend to avoid any
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 538796e..ff1f6db 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -10868,6 +10868,20 @@ package body Sem_Ch3 is
             end if;
          end if;
 
+         --  Ada 2005 (AI95-0414) and Ada 2020 (AI12-0269): Diagnose failure to
+         --  match No_Return in parent, but do it unconditionally in Ada 95 too
+         --  for procedures, since this is our pragma.
+
+         if Present (Overridden_Operation (Subp))
+           and then No_Return (Overridden_Operation (Subp))
+           and then not No_Return (Subp)
+         then
+            Error_Msg_N ("overriding subprogram & must be No_Return", Subp);
+            Error_Msg_N
+              ("\since overridden subprogram is No_Return (RM 6.5.1(6/2))",
+               Subp);
+         end if;
+
          --  If the operation is a wrapper for a synchronized primitive, it
          --  may be called indirectly through a dispatching select. We assume
          --  that it will be referenced elsewhere indirectly, and suppress
@@ -15450,9 +15464,9 @@ package body Sem_Ch3 is
       end if;
 
       --  No_Return must be inherited properly. If this is overridden in the
-      --  case of a dispatching operation, then a check is made in Sem_Disp
-      --  that the overriding operation is also No_Return (no such check is
-      --  required for the case of non-dispatching operation.
+      --  case of a dispatching operation, then the check is made later in
+      --  Check_Abstract_Overriding that the overriding operation is also
+      --  No_Return (no such check is required for the nondispatching case).
 
       Set_No_Return (New_Subp, No_Return (Parent_Subp));
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 576e33e..456bd97 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -676,6 +676,10 @@ package body Sem_Ch6 is
       R_Type : constant Entity_Id := Etype (Scope_Id);
       --  Function result subtype
 
+      procedure Check_No_Return_Expression (Return_Expr : Node_Id);
+      --  Ada 2020: Check that the return expression in a No_Return function
+      --  meets the conditions specified by RM 6.5.1(5.1/5).
+
       procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id);
       --  Apply legality rule of 6.5 (5.9) to the access discriminants of an
       --  aggregate in a return statement.
@@ -684,6 +688,34 @@ package body Sem_Ch6 is
       --  Check that the return_subtype_indication properly matches the result
       --  subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
 
+      --------------------------------
+      -- Check_No_Return_Expression --
+      --------------------------------
+
+      procedure Check_No_Return_Expression (Return_Expr : Node_Id) is
+         Kind : constant Node_Kind := Nkind (Return_Expr);
+
+      begin
+         if Kind = N_Raise_Expression then
+            return;
+
+         elsif Kind = N_Function_Call
+           and then Is_Entity_Name (Name (Return_Expr))
+           and then Ekind_In (Entity (Name (Return_Expr)), E_Function,
+                                                           E_Generic_Function)
+           and then No_Return (Entity (Name (Return_Expr)))
+         then
+            return;
+         end if;
+
+         Error_Msg_N
+           ("illegal expression in RETURN statement of No_Return function",
+            Return_Expr);
+         Error_Msg_N
+           ("\must be raise expression or call to No_Return (RM 6.5.1(5.1/5))",
+            Return_Expr);
+      end Check_No_Return_Expression;
+
       ------------------------------------------
       -- Check_Return_Construct_Accessibility --
       ------------------------------------------
@@ -1101,6 +1133,19 @@ package body Sem_Ch6 is
             Check_Limited_Return (N, Expr, R_Type);
 
             Check_Return_Construct_Accessibility (N);
+
+            --  Ada 2020 (AI12-0269): Any return statement that applies to a
+            --  nonreturning function shall be a simple_return_statement with
+            --  an expression that is a raise_expression, or else a call on a
+            --  nonreturning function, or else a parenthesized expression of
+            --  one of these.
+
+            if Ada_Version >= Ada_2020
+              and then No_Return (Scope_Id)
+              and then Comes_From_Source (N)
+            then
+               Check_No_Return_Expression (Original_Node (Expr));
+            end if;
          end if;
       else
          Obj_Decl := Last (Return_Object_Declarations (N));
@@ -1162,6 +1207,18 @@ package body Sem_Ch6 is
                     ("aliased only allowed for limited return objects", N);
                end if;
             end if;
+
+            --  Ada 2020 (AI12-0269): Any return statement that applies to a
+            --  nonreturning function shall be a simple_return_statement.
+
+            if Ada_Version >= Ada_2020
+              and then No_Return (Scope_Id)
+              and then Comes_From_Source (N)
+            then
+               Error_Msg_N
+                 ("extended RETURN statement not allowed in No_Return "
+                  & "function", N);
+            end if;
          end;
       end if;
 
@@ -2091,8 +2148,12 @@ package body Sem_Ch6 is
       --  Check that pragma No_Return is obeyed. Don't complain about the
       --  implicitly-generated return that is placed at the end.
 
-      if No_Return (Scope_Id) and then Comes_From_Source (N) then
-         Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
+      if No_Return (Scope_Id)
+        and then Ekind_In (Kind, E_Procedure, E_Generic_Procedure)
+        and then Comes_From_Source (N)
+      then
+         Error_Msg_N
+           ("RETURN statement not allowed in No_Return procedure", N);
       end if;
 
       --  Warn on any unassigned OUT parameters if in procedure
@@ -2103,17 +2164,17 @@ package body Sem_Ch6 is
 
       --  Check that functions return objects, and other things do not
 
-      if Kind = E_Function or else Kind = E_Generic_Function then
+      if Ekind_In (Kind, E_Function, E_Generic_Function) then
          if not Returns_Object then
             Error_Msg_N ("missing expression in return from function", N);
          end if;
 
-      elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
+      elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
          if Returns_Object then
             Error_Msg_N ("procedure cannot return value (use function)", N);
          end if;
 
-      elsif Kind = E_Entry or else Kind = E_Entry_Family then
+      elsif Ekind_In (Kind, E_Entry, E_Entry_Family) then
          if Returns_Object then
             if Is_Protected_Type (Scope (Scope_Id)) then
                Error_Msg_N ("entry body cannot return value", N);
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index e62be559..8a63831 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -3106,9 +3106,10 @@ package body Sem_Ch8 is
          if No_Return (Rename_Spec)
            and then not No_Return (Entity (Nam))
          then
-            Error_Msg_N ("renaming completes a No_Return procedure", N);
+            Error_Msg_NE
+              ("renamed subprogram & must be No_Return", N, Entity (Nam));
             Error_Msg_N
-              ("\renamed procedure must be nonreturning (RM 6.5.1 (7/2))", N);
+              ("\since renaming subprogram is No_Return (RM 6.5.1(7/2))", N);
          end if;
 
          --  The specification does not introduce new formals, but only
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index a2fbcfc..3b40f4c 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -2548,14 +2548,6 @@ package body Sem_Disp is
       Prim : Node_Id;
 
    begin
-      --  Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
-      --  we do it unconditionally in Ada 95 now, since this is our pragma).
-
-      if No_Return (Prev_Op) and then not No_Return (New_Op) then
-         Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
-         Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
-      end if;
-
       --  If there is no previous operation to override, the type declaration
       --  was malformed, and an error must have been emitted already.
 
@@ -2666,7 +2658,6 @@ package body Sem_Disp is
          Set_Alias (Prev_Op, New_Op);
          Set_DTC_Entity (Prev_Op, Empty);
          Set_Has_Controlling_Result (New_Op, Has_Controlling_Result (Prev_Op));
-         return;
       end if;
    end Override_Dispatching_Operation;
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 05171d4..75d5b0e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -19814,7 +19814,7 @@ package body Sem_Prag is
                   raise Pragma_Exit;
                end if;
 
-               --  Loop to find matching procedures
+               --  Loop to find matching procedures or functions (Ada 2020)
 
                E := Entity (Id);
 
@@ -19822,8 +19822,13 @@ package body Sem_Prag is
                while Present (E)
                  and then Scope (E) = Current_Scope
                loop
-                  if Ekind_In (E, E_Generic_Procedure, E_Procedure) then
+                  --  Ada 2020 (AI12-0269): A function can be No_Return
 
+                  if Ekind_In (E, E_Generic_Procedure, E_Procedure)
+                    or else (Ada_Version >= Ada_2020
+                              and then
+                             Ekind_In (E, E_Generic_Function, E_Function))
+                  then
                      --  Check that the pragma is not applied to a body.
                      --  First check the specless body case, to give a
                      --  different error message. These checks do not apply
@@ -19905,6 +19910,11 @@ package body Sem_Prag is
                     and then From_Aspect_Specification (N)
                   then
                      Set_No_Return (Entity (Id));
+
+                  elsif Ada_Version >= Ada_2020 then
+                     Error_Pragma_Arg
+                       ("no subprogram& found for pragma%", Arg);
+
                   else
                      Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
                   end if;