-- --
-- 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- --
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;
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
if Present (Choice_Parameter (Handler)) then
declare
Cparm : constant Entity_Id := Choice_Parameter (Handler);
- Clc : constant Source_Ptr := Sloc (Cparm);
+ Cloc : constant Source_Ptr := Sloc (Cparm);
+ Hloc : constant Source_Ptr := Sloc (Handler);
Save : Node_Id;
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 (Loc,
+ Make_Procedure_Call_Statement (No_Location,
Name =>
- New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
+ New_Occurrence_Of (RTE (RE_Save_Occurrence),
+ No_Location),
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 (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), Loc))))));
+ (RTE (RE_Get_Current_Excep),
+ No_Location))))));
Mark_Rewrite_Insertion (Save);
Prepend (Save, Statements (Handler));
Obj_Decl :=
Make_Object_Declaration
- (Clc,
+ (Cloc,
Defining_Identifier => Cparm,
Object_Definition =>
New_Occurrence_Of
- (RTE (RE_Exception_Occurrence), Clc));
+ (RTE (RE_Exception_Occurrence), Cloc));
Set_No_Initialization (Obj_Decl, True);
Rewrite (Handler,
- Make_Implicit_Exception_Handler (Loc,
+ Make_Exception_Handler (Hloc,
+ Choice_Parameter => Empty,
Exception_Choices => Exception_Choices (Handler),
Statements => New_List (
- Make_Block_Statement (Loc,
+ Make_Block_Statement (Hloc,
Declarations => New_List (Obj_Decl),
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
+ 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;
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
-- 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
