From: Ghjuvan Lacambre <lacambre@adacore.com>
Date: Wed, 28 Oct 2020 10:03:16 +0000 (+0100)
Subject: [Ada] Emit error messages for null/generic nonreturning procedures
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=bf85ff03b3e6a17da5bee164114721ea076e33ad;p=gcc.git

[Ada] Emit error messages for null/generic nonreturning procedures

gcc/ada/

	* sem_prag.adb (Analyze_Pragma): declare new Check_No_Return
	function and call it.
---

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 05ff5114ac7..bb891326b33 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -19670,7 +19670,59 @@ package body Sem_Prag is
 
          --  pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
 
-         when Pragma_No_Return => No_Return : declare
+         when Pragma_No_Return => Prag_No_Return : declare
+
+            function Check_No_Return
+               (E : Entity_Id;
+                N : Node_Id) return Boolean;
+            --  Check rule 6.5.1 4/3 of the Ada Ref Manual. If the rule is
+            --  violated, emit an error message and return False, otherwise
+            --  return True.
+            --  6.5.1 Nonreturning procedures:
+            --  4/3 "Aspect No_Return shall not be specified for a null
+            --  procedure nor an instance of a generic unit."
+
+            ---------------------
+            -- Check_No_Return --
+            ---------------------
+
+            function Check_No_Return
+               (E : Entity_Id;
+                N : Node_Id) return Boolean
+            is
+               Ok : Boolean := True;
+            begin
+               if Ekind (E) = E_Procedure then
+
+                  --  If E is a generic instance, marking it with No_Return is
+                  --  forbidden, but having it inherit the No_Return of the
+                  --  generic is allowed. We check if E is inheriting its
+                  --  No_Return flag from the generic by checking if No_Return
+                  --  is already set.
+
+                  if Is_Generic_Instance (E) and then not No_Return (E) then
+                     Error_Msg_NE
+                       ("generic instance & is marked as No_Return", N, E);
+                     Error_Msg_NE
+                       ("\generic procedure & must be marked No_Return",
+                        N,
+                        Generic_Parent (Parent (E)));
+                     Ok := False;
+
+                  else
+                     if Null_Present (Subprogram_Specification (E)) then
+                        Error_Msg_NE
+                          ("null procedure & cannot be marked No_Return",
+                           N,
+                           E);
+                        Ok := False;
+                     end if;
+                  end if;
+               end if;
+
+               return Ok;
+            end Check_No_Return;
+
             Arg   : Node_Id;
             E     : Entity_Id;
             Found : Boolean;
@@ -19742,7 +19794,9 @@ package body Sem_Prag is
                         end if;
                      end if;
 
-                     Set_No_Return (E);
+                     if Check_No_Return (E, N) then
+                        Set_No_Return (E);
+                     end if;
 
                      --  A pragma that applies to a Ghost entity becomes Ghost
                      --  for the purposes of legality checks and removal of
@@ -19781,7 +19835,10 @@ package body Sem_Prag is
 
                      --  Set flag on any alias as well
 
-                     if Is_Overloadable (E) and then Present (Alias (E)) then
+                     if Is_Overloadable (E)
+                       and then Present (Alias (E))
+                       and then Check_No_Return (Alias (E), N)
+                     then
                         Set_No_Return (Alias (E));
                      end if;
 
@@ -19798,6 +19855,7 @@ package body Sem_Prag is
                if not Found then
                   if Entity (Id) = Current_Scope
                     and then From_Aspect_Specification (N)
+                    and then Check_No_Return (Entity (Id), N)
                   then
                      Set_No_Return (Entity (Id));
 
@@ -19812,7 +19870,7 @@ package body Sem_Prag is
 
                Next (Arg);
             end loop;
-         end No_Return;
+         end Prag_No_Return;
 
          -----------------
          -- No_Run_Time --