-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, 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 Einfo; use Einfo;
with Elists; use Elists;
with Lib; use Lib;
-with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
+with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
+with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-- Add_Unique_Serial_Number --
------------------------------
- procedure Add_Unique_Serial_Number is
- Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+ Config_Serial_Number : Nat := 0;
+ -- Counter for use in config pragmas, see comment below
+ procedure Add_Unique_Serial_Number is
begin
- Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+ -- If we are analyzing configuration pragmas, Cunit (Main_Unit) will
+ -- not be set yet. This happens for example when analyzing static
+ -- string expressions in configuration pragmas. For this case, we
+ -- just maintain a local counter, defined above and we do not need
+ -- to add a b or s indication in this case.
- -- Add either b or s, depending on whether current unit is a spec
- -- or a body. This is needed because we may generate the same name
- -- in a spec and a body otherwise.
+ if No (Cunit (Current_Sem_Unit)) then
+ Config_Serial_Number := Config_Serial_Number + 1;
+ Add_Nat_To_Name_Buffer (Config_Serial_Number);
+ return;
- Name_Len := Name_Len + 1;
+ -- Normal case, within a unit
- if Nkind (Unit_Node) = N_Package_Declaration
- or else Nkind (Unit_Node) = N_Subprogram_Declaration
- or else Nkind (Unit_Node) in N_Generic_Declaration
- then
- Name_Buffer (Name_Len) := 's';
else
- Name_Buffer (Name_Len) := 'b';
+ declare
+ Unit_Node : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
+
+ begin
+ Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+
+ -- Add either b or s, depending on whether current unit is a spec
+ -- or a body. This is needed because we may generate the same name
+ -- in a spec and a body otherwise.
+
+ Name_Len := Name_Len + 1;
+
+ if Nkind (Unit_Node) = N_Package_Declaration
+ or else Nkind (Unit_Node) = N_Subprogram_Declaration
+ or else Nkind (Unit_Node) in N_Generic_Declaration
+ then
+ Name_Buffer (Name_Len) := 's';
+ else
+ Name_Buffer (Name_Len) := 'b';
+ end if;
+ end;
end if;
end Add_Unique_Serial_Number;
New_Reference_To (First_Tag_Component (Full_Type), Loc)));
end Make_DT_Access;
+ -------------------------------------
+ -- Make_Implicit_Exception_Handler --
+ -------------------------------------
+
+ function Make_Implicit_Exception_Handler
+ (Sloc : Source_Ptr;
+ Choice_Parameter : Node_Id := Empty;
+ Exception_Choices : List_Id;
+ Statements : List_Id) return Node_Id
+ is
+ Handler : Node_Id;
+ Loc : Source_Ptr;
+
+ begin
+ -- Set the source location only when debugging the expanded code
+
+ -- When debugging the source code directly, we do not want the compiler
+ -- to associate this implicit exception handler with any specific source
+ -- line, because it can potentially confuse the debugger. The most
+ -- damaging situation would arise when the debugger tries to insert a
+ -- breakpoint at a certain line. If the code of the associated implicit
+ -- exception handler is generated before the code of that line, then the
+ -- debugger will end up inserting the breakpoint inside the exception
+ -- handler, rather than the code the user intended to break on. As a
+ -- result, it is likely that the program will not hit the breakpoint
+ -- as expected.
+
+ if Debug_Generated_Code then
+ Loc := Sloc;
+ else
+ Loc := No_Location;
+ end if;
+
+ Handler :=
+ Make_Exception_Handler
+ (Loc, Choice_Parameter, Exception_Choices, Statements);
+ Set_Local_Raise_Statements (Handler, No_Elist);
+ return Handler;
+ end Make_Implicit_Exception_Handler;
+
--------------------------------
-- Make_Implicit_If_Statement --
--------------------------------
return LS;
end Make_Linker_Section_Pragma;
+ -----------------
+ -- Make_Pragma --
+ -----------------
+
+ function Make_Pragma
+ (Sloc : Source_Ptr;
+ Chars : Name_Id;
+ Pragma_Argument_Associations : List_Id := No_List;
+ Debug_Statement : Node_Id := Empty) return Node_Id
+ is
+ begin
+ return
+ Make_Pragma (Sloc,
+ Pragma_Argument_Associations => Pragma_Argument_Associations,
+ Debug_Statement => Debug_Statement,
+ Pragma_Identifier => Make_Identifier (Sloc, Chars));
+ end Make_Pragma;
+
---------------------------------
-- Make_Raise_Constraint_Error --
---------------------------------
Strval => End_String);
end Make_String_Literal;
+ --------------------
+ -- Make_Temporary --
+ --------------------
+
+ function Make_Temporary
+ (Loc : Source_Ptr;
+ Id : Character;
+ Related_Node : Node_Id := Empty) return Node_Id
+ is
+ Temp : constant Node_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name (Id));
+ begin
+ Set_Related_Expression (Temp, Related_Node);
+ return Temp;
+ end Make_Temporary;
+
---------------------------
-- Make_Unsuppress_Block --
---------------------------
Get_Name_String (Related_Id);
if Prefix /= ' ' then
- pragma Assert (Is_OK_Internal_Letter (Prefix));
+ pragma Assert (Is_OK_Internal_Letter (Prefix) or else Prefix = '_');
for J in reverse 1 .. Name_Len loop
Name_Buffer (J + 1) := Name_Buffer (J);
if Suffix /= ' ' then
pragma Assert (Is_OK_Internal_Letter (Suffix));
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Suffix;
+ Add_Char_To_Name_Buffer (Suffix);
end if;
if Suffix_Index /= 0 then
is
begin
Get_Name_String (Related_Id);
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := '_';
- Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
- Name_Len := Name_Len + Suffix'Length;
+ Add_Char_To_Name_Buffer ('_');
+ Add_Str_To_Name_Buffer (Suffix);
return Name_Find;
end New_Suffixed_Name;
OSDN Git Service
