-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
-- the call to the cleanup routine that is made from an exception
-- handler for the abort signal is called with aborts deferred.
+ -- This expansion is only done if we have front end exception handling.
+ -- If we have back end exception handling, then the AT END handler is
+ -- left alone, and cleanups (including the exceptional case) are handled
+ -- by the back end.
+
+ -- In the front end case, the exception handler described above handles
+ -- the exceptional case. The AT END handler is left in the generated tree
+ -- and the code generator (e.g. gigi) must still handle proper generation
+ -- of cleanup calls for the non-exceptional case.
+
procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
Loc : constant Source_Ptr := Sloc (Clean);
pragma Assert (Present (Clean));
pragma Assert (No (Exception_Handlers (HSS)));
- if Restrictions (No_Exception_Handlers) then
+ -- Don't expand if back end exception handling active
+
+ if Exception_Mechanism = Back_End_ZCX_Exceptions then
+ return;
+ end if;
+
+ -- Don't expand an At End handler if we have already had configurable
+ -- run-time violations, since likely this will just be a matter of
+ -- generating useless cascaded messages
+
+ if Configurable_Run_Time_Violations > 0 then
+ return;
+ end if;
+
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- Loop through handlers
Handler := First_Non_Pragma (Handlrs);
- while Present (Handler) loop
+ Handler_Loop : while Present (Handler) loop
Loc := Sloc (Handler);
+ -- Remove source handler if gnat debug flag N is set
+
+ if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
+ declare
+ H : constant Node_Id := Handler;
+ begin
+ Next_Non_Pragma (Handler);
+ Remove (H);
+ goto Continue_Handler_Loop;
+ end;
+ end if;
+
+
-- If an exception occurrence is present, then we must declare it
-- and initialize it from the value stored in the TSD
if Hostparm.Java_VM then
declare
- Arg : Node_Id
- := Make_Function_Call (Loc,
- Name => New_Occurrence_Of
- (RTE (RE_Current_Target_Exception), Loc));
+ Arg : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Current_Target_Exception), Loc));
begin
Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
end;
end if;
Next_Non_Pragma (Handler);
- end loop;
+
+ <<Continue_Handler_Loop>>
+ null;
+ end loop Handler_Loop;
+
+ -- If all handlers got removed by gnatdN, then remove the list
+
+ if Debug_Flag_Dot_X
+ and then Is_Empty_List (Exception_Handlers (HSS))
+ then
+ Set_Exception_Handlers (HSS, No_List);
+ end if;
-- The last step for expanding exception handlers is to expand the
-- exception tables if zero cost exception handling is active.
- if Exception_Mechanism = Front_End_ZCX then
+ if Exception_Mechanism = Front_End_ZCX_Exceptions then
Expand_Exception_Handler_Tables (HSS);
end if;
end Expand_Exception_Handlers;
-- except : exception_data := (
-- Handled_By_Other => False,
-- Lang => 'A',
- -- Name_Length => exceptE'Length
- -- Full_Name => exceptE'Address
- -- HTable_Ptr => null);
+ -- Name_Length => exceptE'Length,
+ -- Full_Name => exceptE'Address,
+ -- HTable_Ptr => null,
+ -- Import_Code => 0,
+ -- Raise_Hook => null,
+ -- );
-- (protecting test only needed if not at library level)
--
Append_To (L, Make_Integer_Literal (Loc, 0));
+ -- Raise_Hook component: null
+
+ Append_To (L, Make_Null (Loc));
+
Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
Analyze_And_Resolve (Expression (N), Etype (Id));
-- Register_Exception (except'Unchecked_Access);
- if not Restrictions (No_Exception_Handlers) then
+ if not Restriction_Active (No_Exception_Handlers)
+ and then not Restriction_Active (No_Exception_Registration)
+ then
L := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
begin
if Present (Exception_Handlers (N))
- and then not Restrictions (No_Exception_Handlers)
+ and then not Restriction_Active (No_Exception_Handlers)
then
Expand_Exception_Handlers (N);
end if;
return;
end if;
+ -- Don't expand a raise statement that does not come from source
+ -- if we have already had configurable run-time violations, since
+ -- most likely it will be junk cascaded nonsense.
+
+ if Configurable_Run_Time_Violations > 0
+ and then not Comes_From_Source (N)
+ then
+ return;
+ end if;
+
-- Convert explicit raise of Program_Error, Constraint_Error, and
- -- Storage_Error into the corresponding raise node (in No_Run_Time
- -- mode all other raises will get normal expansion and be disallowed,
+ -- Storage_Error into the corresponding raise (in High_Integrity_Mode
+ -- all other raises will get normal expansion and be disallowed,
-- but this is also faster in all modes).
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
Id := Renamed_Object (Id);
end if;
- -- Build a C compatible string in case of no exception handlers,
+ -- Build a C-compatible string in case of no exception handlers,
-- since this is what the last chance handler is expecting.
- if Restrictions (No_Exception_Handlers) then
- -- Generate a C null message when Global_Discard_Names is True
- -- or when Debug_Flag_NN is set.
+ if Restriction_Active (No_Exception_Handlers) then
- if Global_Discard_Names or else Debug_Flag_NN then
- Name_Buffer (1) := ASCII.NUL;
+ -- Generate an empty message if configuration pragma
+ -- Suppress_Exception_Locations is set for this unit.
+
+ if Opt.Exception_Locations_Suppressed then
Name_Len := 1;
else
Name_Len := Name_Len + 1;
end if;
- -- Do not generate the message when Global_Discard_Names is True
- -- or when Debug_Flag_NN is set.
+ Name_Buffer (Name_Len) := ASCII.NUL;
+ end if;
+
- elsif Global_Discard_Names or else Debug_Flag_NN then
+ if Opt.Exception_Locations_Suppressed then
Name_Len := 0;
end if;
Hrc : List_Id;
begin
- if Exception_Mechanism /= Front_End_ZCX then
+ if Exception_Mechanism /= Front_End_ZCX_Exceptions then
return;
end if;
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- Suppress descriptor if we are in No_Exceptions restrictions mode,
-- since we can never propagate exceptions in any case in this mode.
-- The same consideration applies for No_Exception_Handlers (which
- -- is also set in No_Run_Time mode).
+ -- is also set in High_Integrity_Mode).
- if Restrictions (No_Exceptions)
- or Restrictions (No_Exception_Handlers)
+ if Restriction_Active (No_Exceptions)
+ or Restriction_Active (No_Exception_Handlers)
then
return;
end if;
begin
Scop := Spec;
while Scop /= Standard_Standard loop
- if Ekind (Scop) = E_Generic_Procedure
- or else
- Ekind (Scop) = E_Generic_Function
- or else
- Ekind (Scop) = E_Generic_Package
- or else
- Is_Eliminated (Scop)
- then
+ if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then
return;
end if;
-- Suppress all subprogram descriptors for the file System.Exceptions.
-- We similarly suppress subprogram descriptors for Ada.Exceptions.
- -- These are all init_proc's for types which cannot raise exceptions.
+ -- These are all init procs for types which cannot raise exceptions.
-- The reason this is done is that otherwise we get embarassing
-- elaboration dependencies.
-- Do not generate if no exceptions
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- Do not generate if no exceptions
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
begin
-- Nothing to be done if zero length exceptions not active
- if Exception_Mechanism /= Front_End_ZCX then
+ if Exception_Mechanism /= Front_End_ZCX_Exceptions then
return;
end if;
-- Nothing to do if no exceptions
- if Restrictions (No_Exception_Handlers) then
+ if Restriction_Active (No_Exception_Handlers) then
return;
end if;
-- This defines the traversal operation
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
begin
-- Start of processing for Remove_Handler_Entries
begin
- if Exception_Mechanism = Front_End_ZCX then
+ if Exception_Mechanism = Front_End_ZCX_Exceptions then
Discard := Remove_All_Handler_Entries (N);
end if;
end Remove_Handler_Entries;
OSDN Git Service
