[gcc r13-7886] ada: Fix exception raised on invalid contract in generic package

[gcc r13-7886] ada: Fix exception raised on invalid contract in generic package

[Eric Botcazou]

https://gcc.gnu.org/g:a28d0a363e95b70a856763562072ff5153c0e7ab

commit r13-7886-ga28d0a363e95b70a856763562072ff5153c0e7ab
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Mon Apr 24 11:07:38 2023 +0200

    ada: Fix exception raised on invalid contract in generic package
    
    This lets the compiler give a proper error message instead.
    
    gcc/ada/
    
            * contracts.adb (Contract_Error): New exception.
            (Add_Contract_Item): Raise Contract_Error instead of Program_Error.
            (Add_Generic_Contract_Pragma): Deal with Contract_Error.

Diff:
---
 gcc/ada/contracts.adb | 31 +++++++++++++++++++++----------
 1 file changed, 21 insertions(+), 10 deletions(-)

diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 39c067300d6..3a7d6028a73 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -62,6 +62,11 @@ with Warnsw;         use Warnsw;
 
 package body Contracts is
 
+   Contract_Error : exception;
+   --  This exception is raised by Add_Contract_Item when it is invoked on an
+   --  invalid pragma. Note that clients of the package must filter them out
+   --  before invoking Add_Contract_Item, so it should not escape the package.
+
    procedure Analyze_Package_Instantiation_Contract (Inst_Id : Entity_Id);
    --  Analyze all delayed pragmas chained on the contract of package
    --  instantiation Inst_Id as if they appear at the end of a declarative
@@ -197,7 +202,7 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       --  Entry bodies, the applicable pragmas are:
@@ -215,7 +220,7 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       --  Entry or subprogram declarations, the applicable pragmas are:
@@ -264,7 +269,7 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       --  Packages or instantiations, the applicable pragmas are:
@@ -288,7 +293,7 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       --  Package bodies, the applicable pragmas are:
@@ -301,7 +306,7 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       --  The four volatility refinement pragmas are ok for all types.
@@ -329,7 +334,7 @@ package body Contracts is
 
                --  The pragma is not a proper contract item
 
-               raise Program_Error;
+               raise Contract_Error;
             end if;
          end;
 
@@ -353,7 +358,7 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       --  Task bodies, the applicable pragmas are:
@@ -367,7 +372,7 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       --  Task units, the applicable pragmas are:
@@ -402,11 +407,11 @@ package body Contracts is
          --  The pragma is not a proper contract item
 
          else
-            raise Program_Error;
+            raise Contract_Error;
          end if;
 
       else
-         raise Program_Error;
+         raise Contract_Error;
       end if;
    end Add_Contract_Item;
 
@@ -2196,6 +2201,12 @@ package body Contracts is
          else
             Add_Contract_Item (Prag, Templ_Id);
          end if;
+
+      exception
+         --  We do not stop the compilation at this point in the case of an
+         --  invalid pragma because it will be properly diagnosed afterward.
+
+         when Contract_Error => null;
       end Add_Generic_Contract_Pragma;
 
       --  Local variables