To help the bootstrap path, we want to keep the compiler free from any
exception propagation during bootstrap. This has been broken recently in
various places.
Also introduce a way to more easily detect such breakage via the
-DNO_EXCEPTION_PROPAGATION which can now be used as part of BOOT_CFLAGS.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_imgv.adb (Build_Enumeration_Image_Tables): Also disable
perfect hash in GNAT_Mode.
* raise-gcc.c (__gnat_Unwind_RaiseException): Add support for
disabling exception propagation.
* sem_eval.adb (Compile_Time_Known_Value): Update comment and
remove wrong call to Check_Error_Detected.
* sem_prag.adb (Check_Loop_Pragma_Grouping, Analyze_Pragma):
Remove exception propagation during bootstrap.diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -289,12 +289,14 @@ package body Exp_Imgv is
-- If the unit where the type is declared is the main unit, and the
-- number of literals is greater than Threshold_For_Size when we are
-- optimizing for size, and the restriction No_Implicit_Loops is not
- -- active, and -gnatd_h is not specified, generate the hash function.
+ -- active, and -gnatd_h is not specified, and not GNAT_Mode, generate
+ -- the hash function.
if In_Main_Unit
and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size)
and then not Restriction_Active (No_Implicit_Loops)
and then not Debug_Flag_Underscore_H
+ and then not GNAT_Mode
then
declare
LB : constant Positive := 2 * Positive (Nlit) + 1;
diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c
--- a/gcc/ada/raise-gcc.c
+++ b/gcc/ada/raise-gcc.c
@@ -1377,6 +1377,10 @@ __gnat_cleanupunwind_handler (int version ATTRIBUTE_UNUSED,
_Unwind_Reason_Code
__gnat_Unwind_RaiseException (_Unwind_Exception *e)
{
+#ifdef NO_EXCEPTION_PROPAGATION
+ abort();
+#endif
+
#ifdef __USING_SJLJ_EXCEPTIONS__
return _Unwind_SjLj_RaiseException (e);
#else
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -1816,10 +1816,10 @@ package body Sem_Eval is
begin
-- Never known at compile time if bad type or raises Constraint_Error
- -- or empty (latter case occurs only as a result of a previous error).
+ -- or empty (which can occur as a result of a previous error or in the
+ -- case of e.g. an imported constant).
if No (Op) then
- Check_Error_Detected;
return False;
elsif Op = Error
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6152,15 +6152,11 @@ package body Sem_Prag is
--------------------------------
procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
- Stop_Search : exception;
- -- This exception is used to terminate the recursive descent of
- -- routine Check_Grouping.
-
- procedure Check_Grouping (L : List_Id);
+ function Check_Grouping (L : List_Id) return Boolean;
-- Find the first group of pragmas in list L and if successful,
-- ensure that the current pragma is part of that group. The
- -- routine raises Stop_Search once such a check is performed to
- -- halt the recursive descent.
+ -- routine returns True once such a check is performed to
+ -- stop the analysis.
procedure Grouping_Error (Prag : Node_Id);
pragma No_Return (Grouping_Error);
@@ -6171,7 +6167,7 @@ package body Sem_Prag is
-- Check_Grouping --
--------------------
- procedure Check_Grouping (L : List_Id) is
+ function Check_Grouping (L : List_Id) return Boolean is
HSS : Node_Id;
Stmt : Node_Id;
Prag : Node_Id := Empty; -- init to avoid warning
@@ -6219,7 +6215,7 @@ package body Sem_Prag is
-- Stop the search as the placement is legal.
if Stmt = N then
- raise Stop_Search;
+ return True;
-- Skip group members, but keep track of the
-- last pragma in the group.
@@ -6266,15 +6262,21 @@ package body Sem_Prag is
elsif Nkind (Stmt) = N_Block_Statement then
HSS := Handled_Statement_Sequence (Stmt);
- Check_Grouping (Declarations (Stmt));
+ if Check_Grouping (Declarations (Stmt)) then
+ return True;
+ end if;
if Present (HSS) then
- Check_Grouping (Statements (HSS));
+ if Check_Grouping (Statements (HSS)) then
+ return True;
+ end if;
end if;
end if;
Next (Stmt);
end loop;
+
+ return False;
end Check_Grouping;
--------------------
@@ -6287,6 +6289,8 @@ package body Sem_Prag is
Error_Pragma ("pragma% must appear next to pragma#");
end Grouping_Error;
+ Ignore : Boolean;
+
-- Start of processing for Check_Loop_Pragma_Grouping
begin
@@ -6294,10 +6298,7 @@ package body Sem_Prag is
-- within to determine whether the current pragma is part of the
-- first topmost grouping of Loop_Invariant and Loop_Variant.
- Check_Grouping (Statements (Loop_Stmt));
-
- exception
- when Stop_Search => null;
+ Ignore := Check_Grouping (Statements (Loop_Stmt));
end Check_Loop_Pragma_Grouping;
--------------------
@@ -24617,7 +24618,7 @@ package body Sem_Prag is
Check_First_Subtype (Task_Type);
if Rep_Item_Too_Late (Ent, N) then
- raise Pragma_Exit;
+ return;
end if;
end Task_Storage;
@@ -24879,7 +24880,7 @@ package body Sem_Prag is
or else
Rep_Item_Too_Late (E, N)
then
- raise Pragma_Exit;
+ return;
end if;
Set_Has_Pragma_Thread_Local_Storage (E);
@@ -25642,16 +25643,15 @@ package body Sem_Prag is
if CodePeer_Mode or GNATprove_Mode then
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
- raise Pragma_Exit;
+ return;
end if;
elsif Chars (Argx) = Name_Gnatprove then
if not GNATprove_Mode then
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
- raise Pragma_Exit;
+ return;
end if;
-
else
raise Program_Error;
end if;
@@ -25679,7 +25679,7 @@ package body Sem_Prag is
Chars => Name_Warnings,
Pragma_Argument_Associations => Shifted_Args));
Analyze (N);
- raise Pragma_Exit;
+ return;
end if;
-- One argument case
