-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2008, 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 Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Stringt; use Stringt;
with Table;
+with Tbuild; use Tbuild;
with Urealp; use Urealp;
package body Exp_Dbug is
Loc : constant Source_Ptr := Sloc (N);
Ent : constant Node_Id := Defining_Entity (N);
Nam : constant Node_Id := Name (N);
- Rnm : Name_Id;
Ren : Node_Id;
- Lit : Entity_Id;
Typ : Entity_Id;
+ Obj : Entity_Id;
Res : Node_Id;
- Def : Entity_Id;
function Output_Subscript (N : Node_Id; S : String) return Boolean;
-- Outputs a single subscript value as ?nnn (subscript is compile time
return Empty;
end if;
- -- Prepare entity name for type declaration
-
- Get_Name_String (Chars (Ent));
-
- case Nkind (N) is
- when N_Object_Renaming_Declaration =>
- Add_Str_To_Name_Buffer ("___XR");
-
- when N_Exception_Renaming_Declaration =>
- Add_Str_To_Name_Buffer ("___XRE");
-
- when N_Package_Renaming_Declaration =>
- Add_Str_To_Name_Buffer ("___XRP");
-
- -- If it is a child unit create a fully qualified name, to
- -- disambiguate multiple child units with the same name and
- -- different parents.
-
- if Is_Child_Unit (Ent) then
- Prepend_String_To_Buffer ("__");
- Prepend_String_To_Buffer
- (Get_Name_String (Chars (Scope (Ent))));
- end if;
-
- when others =>
- return Empty;
- end case;
-
- Rnm := Name_Find;
-
-- Get renamed entity and compute suffix
Name_Len := 0;
Prepend_String_To_Buffer ("___XE");
- -- For now, the literal name contains only the suffix. The Entity_Id
- -- value for the name is used to create a link from this literal name
- -- to the renamed entity using the Debug_Renaming_Link field. Then the
+ -- Include the designation of the form of renaming
+
+ case Nkind (N) is
+ when N_Object_Renaming_Declaration =>
+ Prepend_String_To_Buffer ("___XR");
+
+ when N_Exception_Renaming_Declaration =>
+ Prepend_String_To_Buffer ("___XRE");
+
+ when N_Package_Renaming_Declaration =>
+ Prepend_String_To_Buffer ("___XRP");
+
+ when others =>
+ return Empty;
+ end case;
+
+ -- Add the name of the renaming entity to the front
+
+ Prepend_String_To_Buffer (Get_Name_String (Chars (Ent)));
+
+ -- If it is a child unit create a fully qualified name, to disambiguate
+ -- multiple child units with the same name and different parents.
+
+ if Nkind (N) = N_Package_Renaming_Declaration
+ and then Is_Child_Unit (Ent)
+ then
+ Prepend_String_To_Buffer ("__");
+ Prepend_String_To_Buffer
+ (Get_Name_String (Chars (Scope (Ent))));
+ end if;
+
+ -- Create the special object whose name is the debug encoding for the
+ -- renaming declaration.
+
+ -- For now, the object name contains the suffix encoding for the renamed
+ -- object, but not the name of the leading entity. The object is linked
+ -- the renamed entity using the Debug_Renaming_Link field. Then the
-- Qualify_Entity_Name procedure uses this link to create the proper
-- fully qualified name.
-- qualification of the renamed entity, and it is really much easier to
-- do this after the renamed entity has itself been fully qualified.
- Lit := Make_Defining_Identifier (Loc, Chars => Name_Enter);
- Set_Debug_Renaming_Link (Lit, Entity (Ren));
+ Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter);
+ Res :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj,
+ Object_Definition => New_Reference_To
+ (Standard_Debug_Renaming_Type, Loc));
- -- Return the appropriate enumeration type
+ Set_Debug_Renaming_Link (Obj, Entity (Ren));
- Def := Make_Defining_Identifier (Loc, Chars => Rnm);
- Res :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Def,
- Type_Definition =>
- Make_Enumeration_Type_Definition (Loc,
- Literals => New_List (Lit)));
+ Set_Debug_Info_Needed (Obj);
+
+ -- Mark the object as internal so that it won't be initialized when
+ -- pragma Initialize_Scalars or Normalize_Scalars is in use.
- Set_Needs_Debug_Info (Def);
- Set_Needs_Debug_Info (Lit);
+ Set_Is_Internal (Obj);
- Set_Discard_Names (Defining_Identifier (Res));
return Res;
-- If we get an exception, just figure it is a case that we cannot
-- For all these cases, just return the name unchanged
then
- Name_Buffer (Name_Len + 1) := ASCII.Nul;
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
return;
end if;
-- If the front end has already computed a fully qualified name,
-- then it is also the case that no further qualification is
- -- required
+ -- required.
if Present (Scope (Scope (Entity)))
and then not Has_Fully_Qualified_Name (Entity)
Get_Qualified_Name_And_Append (E);
end if;
- Name_Buffer (Name_Len + 1) := ASCII.Nul;
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
end Get_External_Name;
-----------------------------------
if Has_Suffix then
Add_Str_To_Name_Buffer ("___");
Add_Str_To_Name_Buffer (Suffix);
- Name_Buffer (Name_Len + 1) := ASCII.Nul;
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
end if;
end Get_External_Name_With_Suffix;
E := Defining_Entity (Name_Qualify_Units.Table (J));
Qualify_Entity_Name (E);
- Ent := First_Entity (E);
- while Present (Ent) loop
- Qualify_Entity_Name (Ent);
- Next_Entity (Ent);
+ -- Normally entities in the qualification list are scopes, but in the
+ -- case of a library-level package renaming there is an associated
+ -- variable that encodes the debugger name and that variable is
+ -- entered in the list since it occurs in the Aux_Decls list of the
+ -- compilation and doesn't have a normal scope.
- -- There are odd cases where Last_Entity (E) = E. This happens
- -- in the case of renaming of packages. This test avoids getting
- -- stuck in such cases.
+ if Ekind (E) /= E_Variable then
+ Ent := First_Entity (E);
+ while Present (Ent) loop
+ Qualify_Entity_Name (Ent);
+ Next_Entity (Ent);
- exit when Ent = E;
- end loop;
+ -- There are odd cases where Last_Entity (E) = E. This happens
+ -- in the case of renaming of packages. This test avoids
+ -- getting stuck in such cases.
+
+ exit when Ent = E;
+ end loop;
+ end if;
end loop;
end Qualify_All_Entity_Names;
Add_Str_To_Name_Buffer ("__");
end if;
- -- Otherwise get name and note if it is a NPBE
+ -- Otherwise get name and note if it is a BNPE
Get_Name_String_And_Append (Chars (E));
if Has_Qualified_Name (Ent) then
return;
- -- Here is where we create the proper link for renaming
+ -- If the entity is a variable encoding the debug name for an object
+ -- renaming, then the qualified name of the entity associated with the
+ -- renamed object can now be incorporated in the debug name.
- elsif Ekind (Ent) = E_Enumeration_Literal
+ elsif Ekind (Ent) = E_Variable
and then Present (Debug_Renaming_Link (Ent))
then
Name_Len := 0;
Qualify_Entity_Name (Debug_Renaming_Link (Ent));
Get_Name_String (Chars (Ent));
- Prepend_String_To_Buffer
- (Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
+
+ -- Retrieve the now-qualified name of the renamed entity and insert
+ -- it in the middle of the name, just preceding the suffix encoding
+ -- describing the renamed object.
+
+ declare
+ Renamed_Id : constant String :=
+ Get_Name_String (Chars (Debug_Renaming_Link (Ent)));
+ Insert_Len : constant Integer := Renamed_Id'Length + 1;
+ Index : Natural := Name_Len - 3;
+
+ begin
+ -- Loop backwards through the name to find the start of the "___"
+ -- sequence associated with the suffix.
+
+ while Index >= Name_Buffer'First
+ and then (Name_Buffer (Index + 1) /= '_'
+ or else Name_Buffer (Index + 2) /= '_'
+ or else Name_Buffer (Index + 3) /= '_')
+ loop
+ Index := Index - 1;
+ end loop;
+
+ pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___");
+
+ -- Insert an underscore separator and the entity name just in
+ -- front of the suffix.
+
+ Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) :=
+ Name_Buffer (Index + 1 .. Name_Len);
+ Name_Buffer (Index + 1) := '_';
+ Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id;
+ Name_Len := Name_Len + Insert_Len;
+ end;
+
+ -- Reset the name of the variable to the new name that includes the
+ -- name of the renamed entity.
+
Set_Chars (Ent, Name_Enter);
+
+ -- If the entity needs qualification by its scope then develop it
+ -- here, add the variable's name, and again reset the entity name.
+
+ if Qualify_Needed (Scope (Ent)) then
+ Name_Len := 0;
+ Set_Entity_Name (Scope (Ent));
+ Add_Str_To_Name_Buffer ("__");
+
+ Get_Name_String_And_Append (Chars (Ent));
+
+ Set_Chars (Ent, Name_Enter);
+ end if;
+
Set_Has_Qualified_Name (Ent);
return;
procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
SL : Natural;
+ pragma Warnings (Off, BNPE_Suffix_Found);
+ -- Since this procedure only ever sets the flag
+
begin
-- Search for and strip BNPE suffix
OSDN Git Service
