-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
-with Rtsfind; use Rtsfind;
with Restrict; use Restrict;
with Rident; use Rident;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Clean, Loc)));
- -- Avoid generation of raise stmt if compiling with no exceptions
- -- propagation
+ -- Generate reraise statement as last statement of AT-END handler,
+ -- unless we are under control of No_Exception_Propagation, in which
+ -- case no exception propagation is possible anyway, so we do not need
+ -- a reraise (the AT END handler in this case is only for normal exits
+ -- not for exceptional exits). Also, we flag the Reraise statement as
+ -- being part of an AT END handler to prevent signalling this reraise
+ -- as a violation of the restriction when it is not set.
if not Restriction_Active (No_Exception_Propagation) then
- Append_To (Stmnts,
- Make_Raise_Statement (Loc));
+ declare
+ Rstm : constant Node_Id := Make_Raise_Statement (Loc);
+ begin
+ Set_From_At_End (Rstm);
+ Append_To (Stmnts, Rstm);
+ end;
end if;
Set_Exception_Handlers (HSS, New_List (
Local_Expansion_Required := True;
declare
- L : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (H),
- Chars => New_Internal_Name ('L'));
+ L : constant Entity_Id := Make_Temporary (Sloc (H), 'L');
begin
Set_Exception_Label (H, L);
Add_Label_Declaration (L);
declare
-- L3 is the label to exit the HSS
- L3_Dent : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
+ L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L');
Labl_L3 : constant Node_Id :=
Make_Label (Loc,
Rewrite (HSS,
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Blk_Stm)));
+ Statements => New_List (Blk_Stm),
+ End_Label => Relocate_Node (End_Label (HSS))));
-- Set block statement as analyzed, we don't want to actually call
-- Analyze on this block, it would cause a recursion in exception
Relmt := First_Elmt (Local_Raise_Statements (Handler));
while Present (Relmt) loop
declare
- Raise_S : constant Node_Id := Node (Relmt);
-
+ Raise_S : constant Node_Id := Node (Relmt);
+ RLoc : constant Source_Ptr := Sloc (Raise_S);
Name_L1 : constant Node_Id :=
New_Occurrence_Of (L1_Dent, Loc);
-
Goto_L1 : constant Node_Id :=
- Make_Goto_Statement (Loc,
+ Make_Goto_Statement (RLoc,
Name => Name_L1);
begin
Ent : constant Entity_Id := RTE (Proc);
begin
- -- If we have no Entity, then we are probably in no run time mode
- -- or some weird error has occured. In either case do do nothing!
+ -- If we have no Entity, then we are probably in no run time mode or
+ -- some weird error has occurred. In either case do nothing. Note use
+ -- of No_Location to hide this code from the debugger, so single
+ -- stepping doesn't jump back and forth.
if Present (Ent) then
declare
Call : constant Node_Id :=
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (Proc), Loc),
+ Make_Procedure_Call_Statement (No_Location,
+ Name => New_Occurrence_Of (RTE (Proc), No_Location),
Parameter_Associations => Args);
begin
Handler_Loop : while Present (Handler) loop
Next_Handler := Next_Non_Pragma (Handler);
- -- Remove source handler if gnat debug flag N is set
+ -- Remove source handler if gnat debug flag .x is set
if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
Remove (Handler);
-- Remove handler if no exception propagation, generating a warning
-- if a source generated handler was not the target of a local raise.
- elsif Restriction_Active (No_Exception_Propagation) then
- if not Has_Local_Raise (Handler)
+ else
+ if Restriction_Active (No_Exception_Propagation)
+ and then not Has_Local_Raise (Handler)
and then Comes_From_Source (Handler)
and then Warn_On_Non_Local_Exception
then
Handler);
end if;
- Remove (Handler);
-
- -- Exception handler is active and retained and must be processed
-
- else
- -- If an exception occurrence is present, then we must declare it
- -- and initialize it from the value stored in the TSD
-
- -- declare
- -- name : Exception_Occurrence;
- -- begin
- -- Save_Occurrence (name, Get_Current_Excep.all)
- -- ...
- -- end;
-
- if Present (Choice_Parameter (Handler)) then
- declare
- Cparm : constant Entity_Id := Choice_Parameter (Handler);
- Clc : constant Source_Ptr := Sloc (Cparm);
- Save : Node_Id;
-
- begin
- Save :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Cparm, Clc),
- Make_Explicit_Dereference (Loc,
- Make_Function_Call (Loc,
- Name => Make_Explicit_Dereference (Loc,
- New_Occurrence_Of
- (RTE (RE_Get_Current_Excep), Loc))))));
-
- Mark_Rewrite_Insertion (Save);
- Prepend (Save, Statements (Handler));
-
- Obj_Decl :=
- Make_Object_Declaration
- (Clc,
- Defining_Identifier => Cparm,
- Object_Definition =>
- New_Occurrence_Of
- (RTE (RE_Exception_Occurrence), Clc));
- Set_No_Initialization (Obj_Decl, True);
-
- Rewrite (Handler,
- Make_Implicit_Exception_Handler (Loc,
- Exception_Choices => Exception_Choices (Handler),
-
- Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => New_List (Obj_Decl),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements (Handler))))));
-
- Analyze_List (Statements (Handler), Suppress => All_Checks);
- end;
- end if;
-
- -- The processing at this point is rather different for the JVM
- -- case, so we completely separate the processing.
+ if No_Exception_Propagation_Active then
+ Remove (Handler);
- -- For the JVM case, we unconditionally call Update_Exception,
- -- passing a call to the intrinsic Current_Target_Exception (see
- -- JVM version of Ada.Exceptions in 4jexcept.adb for details).
+ -- Exception handler is active and retained and must be processed
- if VM_Target /= No_VM then
- declare
- 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;
+ else
+ -- If an exception occurrence is present, then we must declare
+ -- it and initialize it from the value stored in the TSD
- -- For the normal case, we have to worry about the state of
- -- abort deferral. Generally, we defer abort during runtime
- -- handling of exceptions. When control is passed to the
- -- handler, then in the normal case we undefer aborts. In any
- -- case this entire handling is relevant only if aborts are
- -- allowed!
+ -- declare
+ -- name : Exception_Occurrence;
+ -- begin
+ -- Save_Occurrence (name, Get_Current_Excep.all)
+ -- ...
+ -- end;
- elsif Abort_Allowed then
+ if Present (Choice_Parameter (Handler)) then
+ declare
+ Cparm : constant Entity_Id := Choice_Parameter (Handler);
+ Cloc : constant Source_Ptr := Sloc (Cparm);
+ Hloc : constant Source_Ptr := Sloc (Handler);
+ Save : Node_Id;
- -- There are some special cases in which we do not do the
- -- undefer. In particular a finalization (AT END) handler
- -- wants to operate with aborts still deferred.
+ begin
+ -- Note use of No_Location to hide this code from the
+ -- debugger, so single stepping doesn't jump back and
+ -- forth.
+
+ Save :=
+ Make_Procedure_Call_Statement (No_Location,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Save_Occurrence),
+ No_Location),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Cparm, Cloc),
+ Make_Explicit_Dereference (No_Location,
+ Make_Function_Call (No_Location,
+ Name => Make_Explicit_Dereference (No_Location,
+ New_Occurrence_Of
+ (RTE (RE_Get_Current_Excep),
+ No_Location))))));
+
+ Mark_Rewrite_Insertion (Save);
+ Prepend (Save, Statements (Handler));
+
+ Obj_Decl :=
+ Make_Object_Declaration
+ (Cloc,
+ Defining_Identifier => Cparm,
+ Object_Definition =>
+ New_Occurrence_Of
+ (RTE (RE_Exception_Occurrence), Cloc));
+ Set_No_Initialization (Obj_Decl, True);
+
+ Rewrite (Handler,
+ Make_Exception_Handler (Hloc,
+ Choice_Parameter => Empty,
+ Exception_Choices => Exception_Choices (Handler),
+
+ Statements => New_List (
+ Make_Block_Statement (Hloc,
+ Declarations => New_List (Obj_Decl),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Hloc,
+ Statements => Statements (Handler))))));
+
+ -- Local raise statements can't occur, since exception
+ -- handlers with choice parameters are not allowed when
+ -- No_Exception_Propagation applies, so set attributes
+ -- accordingly.
+
+ Set_Local_Raise_Statements (Handler, No_Elist);
+ Set_Local_Raise_Not_OK (Handler);
+
+ Analyze_List
+ (Statements (Handler), Suppress => All_Checks);
+ end;
+ end if;
- -- We also suppress the call if this is the special handler
- -- for Abort_Signal, since if we are aborting, we want to keep
- -- aborts deferred (one abort is enough).
+ -- The processing at this point is rather different for the JVM
+ -- case, so we completely separate the processing.
- -- If abort really needs to be deferred the expander must add
- -- this call explicitly, see Expand_N_Asynchronous_Select.
+ -- For the VM case, we unconditionally call Update_Exception,
+ -- passing a call to the intrinsic Current_Target_Exception
+ -- (see JVM/.NET versions of Ada.Exceptions for details).
- Others_Choice :=
- Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
+ if VM_Target /= No_VM then
+ declare
+ 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;
- if (Others_Choice
- or else Entity (First (Exception_Choices (Handler))) /=
- Stand.Abort_Signal)
- and then not
- (Others_Choice
- and then All_Others (First (Exception_Choices (Handler))))
- and then Abort_Allowed
- then
- Prepend_Call_To_Handler (RE_Abort_Undefer);
+ -- For the normal case, we have to worry about the state of
+ -- abort deferral. Generally, we defer abort during runtime
+ -- handling of exceptions. When control is passed to the
+ -- handler, then in the normal case we undefer aborts. In
+ -- any case this entire handling is relevant only if aborts
+ -- are allowed!
+
+ elsif Abort_Allowed then
+
+ -- There are some special cases in which we do not do the
+ -- undefer. In particular a finalization (AT END) handler
+ -- wants to operate with aborts still deferred.
+
+ -- We also suppress the call if this is the special handler
+ -- for Abort_Signal, since if we are aborting, we want to
+ -- keep aborts deferred (one abort is enough).
+
+ -- If abort really needs to be deferred the expander must
+ -- add this call explicitly, see
+ -- Expand_N_Asynchronous_Select.
+
+ Others_Choice :=
+ Nkind (First (Exception_Choices (Handler))) =
+ N_Others_Choice;
+
+ if (Others_Choice
+ or else Entity (First (Exception_Choices (Handler))) /=
+ Stand.Abort_Signal)
+ and then not
+ (Others_Choice
+ and then
+ All_Others (First (Exception_Choices (Handler))))
+ and then Abort_Allowed
+ then
+ Prepend_Call_To_Handler (RE_Abort_Undefer);
+ end if;
end if;
end if;
end if;
Exname : constant Node_Id :=
Make_Defining_Identifier (Loc, Name_Exname);
+ procedure Force_Static_Allocation_Of_Referenced_Objects
+ (Aggregate : Node_Id);
+ -- A specialized solution to one particular case of an ugly problem
+ --
+ -- The given aggregate includes an Unchecked_Conversion as one of the
+ -- component values. The call to Analyze_And_Resolve below ends up
+ -- calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
+ -- to introduce a (constant) temporary and then obtain the component
+ -- value by evaluating the temporary.
+ --
+ -- In the case of an exception declared within a subprogram (or any
+ -- other dynamic scope), this is a bad transformation. The exception
+ -- object is marked as being Statically_Allocated but the temporary is
+ -- not. If the initial value of a Statically_Allocated declaration
+ -- references a dynamically allocated object, this prevents static
+ -- initialization of the object.
+ --
+ -- We cope with this here by marking the temporary Statically_Allocated.
+ -- It might seem cleaner to generalize this utility and then use it to
+ -- enforce a rule that the entities referenced in the declaration of any
+ -- "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
+ -- entity must also be either Library_Level or hoisted. It turns out
+ -- that this would be incompatible with the current treatment of an
+ -- object which is local to a subprogram, subject to an Export pragma,
+ -- not subject to an address clause, and whose declaration contains
+ -- references to other local (non-hoisted) objects (e.g., in the initial
+ -- value expression).
+
+ ---------------------------------------------------
+ -- Force_Static_Allocation_Of_Referenced_Objects --
+ ---------------------------------------------------
+
+ procedure Force_Static_Allocation_Of_Referenced_Objects
+ (Aggregate : Node_Id)
+ is
+ function Fixup_Node (N : Node_Id) return Traverse_Result;
+ -- If the given node references a dynamically allocated object, then
+ -- correct the declaration of the object.
+
+ ----------------
+ -- Fixup_Node --
+ ----------------
+
+ function Fixup_Node (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) in N_Has_Entity
+ and then Present (Entity (N))
+ and then not Is_Library_Level_Entity (Entity (N))
+
+ -- Note: the following test is not needed but it seems cleaner
+ -- to do this test (this would be more important if procedure
+ -- Force_Static_Allocation_Of_Referenced_Objects recursively
+ -- traversed the declaration of an entity after marking it as
+ -- statically allocated).
+
+ and then not Is_Statically_Allocated (Entity (N))
+ then
+ Set_Is_Statically_Allocated (Entity (N));
+ end if;
+
+ return OK;
+ end Fixup_Node;
+
+ procedure Fixup_Tree is new Traverse_Proc (Fixup_Node);
+
+ -- Start of processing for Force_Static_Allocation_Of_Referenced_Objects
+
+ begin
+ Fixup_Tree (Aggregate);
+ end Force_Static_Allocation_Of_Referenced_Objects;
+
+ -- Start of processing for Expand_N_Exception_Declaration
+
begin
-- There is no expansion needed when compiling for the JVM since the
- -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
+ -- JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads
+ -- for details.
if VM_Target /= No_VM then
return;
Defining_Identifier => Exname,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
+ Expression =>
+ Make_String_Literal (Loc,
+ Strval => Fully_Qualified_Name_String (Id))));
Set_Is_Statically_Allocated (Exname);
Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
Analyze_And_Resolve (Expression (N), Etype (Id));
+ Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
+
-- Register_Exception (except'Unchecked_Access);
if not No_Exception_Handlers_Set
Insert_List_After_And_Analyze (N, L);
end if;
end if;
-
end Expand_N_Exception_Declaration;
---------------------------------------------
H : Node_Id;
begin
- -- Debug_Flag_Dot_G := True;
-
-- Processing for locally handled exception (exclude reraise case)
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
-- If a string expression is present, then the raise statement is
-- converted to a call:
-
-- Raise_Exception (exception-name'Identity, string);
-
- -- and there is nothing else to do
+ -- and there is nothing else to do.
if Present (Expression (N)) then
- Rewrite (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Name (N),
- Attribute_Name => Name_Identity),
- Expression (N))));
+
+ -- Avoid passing exception-name'identity in runtimes in which this
+ -- argument is not used. This avoids generating undefined references
+ -- to these exceptions when compiling with no optimization
+
+ if Configurable_Run_Time_On_Target
+ and then (Restriction_Active (No_Exception_Handlers)
+ or else
+ Restriction_Active (No_Exception_Propagation))
+ then
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (RTE (RE_Null_Id), Loc),
+ Expression (N))));
+ else
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Name (N),
+ Attribute_Name => Name_Identity),
+ Expression (N))));
+ end if;
+
Analyze (N);
return;
end if;
-- Remaining processing is for the case where no string expression
-- is present.
- -- There is no expansion needed for statement "raise <exception>;" when
- -- compiling for the JVM since the JVM has a built-in exception
- -- mechanism. However we need to keep the expansion for "raise;"
- -- statements. See 4jexcept.ads for details.
-
- if Present (Name (N)) and then VM_Target /= No_VM then
- 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.
Id : Entity_Id := Entity (Name (N));
begin
+ Name_Len := 0;
Build_Location_String (Loc);
-- If the exception is a renaming, use the exception that it
-- be referencing this entity by normal visibility methods.
if No (Choice_Parameter (Ehand)) then
- E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ E := Make_Temporary (Loc, 'E');
Set_Choice_Parameter (Ehand, E);
Set_Ekind (E, E_Variable);
Set_Etype (E, RTE (RE_Exception_Occurrence));
procedure Warn_If_No_Propagation (N : Node_Id) is
begin
- if Restriction_Active (No_Exception_Propagation)
+ if Restriction_Check_Required (No_Exception_Propagation)
and then Warn_On_Non_Local_Exception
then
Warn_No_Exception_Propagation_Active (N);
OSDN Git Service
