1754 lines
55 KiB
Ada
1754 lines
55 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
-- --
|
||
|
-- GNAT COMPILER COMPONENTS --
|
||
|
-- --
|
||
|
-- E X P _ D B U G --
|
||
|
-- --
|
||
|
-- B o d y --
|
||
|
-- --
|
||
|
-- $Revision: 1.56 $
|
||
|
-- --
|
||
|
-- Copyright (C) 1996-2001 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- --
|
||
|
-- 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. --
|
||
|
-- --
|
||
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
||
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||
|
-- --
|
||
|
------------------------------------------------------------------------------
|
||
|
|
||
|
with Alloc; use Alloc;
|
||
|
with Atree; use Atree;
|
||
|
with Debug; use Debug;
|
||
|
with Einfo; use Einfo;
|
||
|
with Exp_Util; use Exp_Util;
|
||
|
with Freeze; use Freeze;
|
||
|
with Lib; use Lib;
|
||
|
with Hostparm; use Hostparm;
|
||
|
with Namet; use Namet;
|
||
|
with Nlists; use Nlists;
|
||
|
with Nmake; use Nmake;
|
||
|
with Opt; use Opt;
|
||
|
with Output; use Output;
|
||
|
with Sem_Eval; use Sem_Eval;
|
||
|
with Sem_Util; use Sem_Util;
|
||
|
with Sinput; use Sinput;
|
||
|
with Snames; use Snames;
|
||
|
with Stand; use Stand;
|
||
|
with Stringt; use Stringt;
|
||
|
with Table;
|
||
|
with Urealp; use Urealp;
|
||
|
|
||
|
with GNAT.HTable;
|
||
|
|
||
|
package body Exp_Dbug is
|
||
|
|
||
|
-- The following table is used to queue up the entities passed as
|
||
|
-- arguments to Qualify_Entity_Names for later processing when
|
||
|
-- Qualify_All_Entity_Names is called.
|
||
|
|
||
|
package Name_Qualify_Units is new Table.Table (
|
||
|
Table_Component_Type => Node_Id,
|
||
|
Table_Index_Type => Nat,
|
||
|
Table_Low_Bound => 1,
|
||
|
Table_Initial => Alloc.Name_Qualify_Units_Initial,
|
||
|
Table_Increment => Alloc.Name_Qualify_Units_Increment,
|
||
|
Table_Name => "Name_Qualify_Units");
|
||
|
|
||
|
-- Define hash table for compressed debug names
|
||
|
|
||
|
-- This hash table keeps track of qualification prefix strings
|
||
|
-- that have been compressed. The element is the corresponding
|
||
|
-- hash value used in the compressed symbol.
|
||
|
|
||
|
type Hindex is range 0 .. 4096;
|
||
|
-- Type to define range of headers
|
||
|
|
||
|
function SHash (S : String_Ptr) return Hindex;
|
||
|
-- Hash function for this table
|
||
|
|
||
|
function SEq (F1, F2 : String_Ptr) return Boolean;
|
||
|
-- Equality function for this table
|
||
|
|
||
|
type Elmt is record
|
||
|
W : Word;
|
||
|
S : String_Ptr;
|
||
|
end record;
|
||
|
|
||
|
No_Elmt : Elmt := (0, null);
|
||
|
|
||
|
package CDN is new GNAT.HTable.Simple_HTable (
|
||
|
Header_Num => Hindex,
|
||
|
Element => Elmt,
|
||
|
No_Element => No_Elmt,
|
||
|
Key => String_Ptr,
|
||
|
Hash => SHash,
|
||
|
Equal => SEq);
|
||
|
|
||
|
--------------------------------
|
||
|
-- Use of Qualification Flags --
|
||
|
--------------------------------
|
||
|
|
||
|
-- There are two flags used to keep track of qualification of entities
|
||
|
|
||
|
-- Has_Fully_Qualified_Name
|
||
|
-- Has_Qualified_Name
|
||
|
|
||
|
-- The difference between these is as follows. Has_Qualified_Name is
|
||
|
-- set to indicate that the name has been qualified as required by the
|
||
|
-- spec of this package. As described there, this may involve the full
|
||
|
-- qualification for the name, but for some entities, notably procedure
|
||
|
-- local variables, this full qualification is not required.
|
||
|
|
||
|
-- The flag Has_Fully_Qualified_Name is set if indeed the name has been
|
||
|
-- fully qualified in the Ada sense. If Has_Fully_Qualified_Name is set,
|
||
|
-- then Has_Qualified_Name is also set, but the other way round is not
|
||
|
-- the case.
|
||
|
|
||
|
-- Consider the following example:
|
||
|
|
||
|
-- with ...
|
||
|
-- procedure X is
|
||
|
-- B : Ddd.Ttt;
|
||
|
-- procedure Y is ..
|
||
|
|
||
|
-- Here B is a procedure local variable, so it does not need fully
|
||
|
-- qualification. The flag Has_Qualified_Name will be set on the
|
||
|
-- first attempt to qualify B, to indicate that the job is done
|
||
|
-- and need not be redone.
|
||
|
|
||
|
-- But Y is qualified as x__y, since procedures are always fully
|
||
|
-- qualified, so the first time that an attempt is made to qualify
|
||
|
-- the name y, it will be replaced by x__y, and both flags are set.
|
||
|
|
||
|
-- Why the two flags? Well there are cases where we derive type names
|
||
|
-- from object names. As noted in the spec, type names are always
|
||
|
-- fully qualified. Suppose for example that the backend has to build
|
||
|
-- a padded type for variable B. then it will construct the PAD name
|
||
|
-- from B, but it requires full qualification, so the fully qualified
|
||
|
-- type name will be x__b___PAD. The two flags allow the circuit for
|
||
|
-- building this name to realize efficiently that b needs further
|
||
|
-- qualification.
|
||
|
|
||
|
----------------------
|
||
|
-- Local Procedures --
|
||
|
----------------------
|
||
|
|
||
|
procedure Add_Uint_To_Buffer (U : Uint);
|
||
|
-- Add image of universal integer to Name_Buffer, updating Name_Len
|
||
|
|
||
|
procedure Add_Real_To_Buffer (U : Ureal);
|
||
|
-- Add nnn_ddd to Name_Buffer, where nnn and ddd are integer values of
|
||
|
-- the normalized numerator and denominator of the given real value.
|
||
|
|
||
|
function Bounds_Match_Size (E : Entity_Id) return Boolean;
|
||
|
-- Determine whether the bounds of E match the size of the type. This is
|
||
|
-- used to determine whether encoding is required for a discrete type.
|
||
|
|
||
|
function CDN_Hash (S : String) return Word;
|
||
|
-- This is the hash function used to compress debug symbols. The string
|
||
|
-- S is the prefix which is a list of qualified names separated by double
|
||
|
-- underscore (no trailing double underscore). The returned value is the
|
||
|
-- hash value used in the compressed names. It is also used for the hash
|
||
|
-- table used to keep track of what prefixes have been compressed so far.
|
||
|
|
||
|
procedure Compress_Debug_Name (E : Entity_Id);
|
||
|
-- If the name of the entity E is too long, or compression is to be
|
||
|
-- attempted on all names (Compress_Debug_Names set), then an attempt
|
||
|
-- is made to compress the name of the entity.
|
||
|
|
||
|
function Double_Underscore (S : String; J : Natural) return Boolean;
|
||
|
-- Returns True if J is the start of a double underscore
|
||
|
-- sequence in the string S (defined as two underscores
|
||
|
-- which are preceded and followed by a non-underscore)
|
||
|
|
||
|
procedure Prepend_String_To_Buffer (S : String);
|
||
|
-- Prepend given string to the contents of the string buffer, updating
|
||
|
-- the value in Name_Len (i.e. string is added at start of buffer).
|
||
|
|
||
|
procedure Prepend_Uint_To_Buffer (U : Uint);
|
||
|
-- Prepend image of universal integer to Name_Buffer, updating Name_Len
|
||
|
|
||
|
procedure Put_Hex (W : Word; N : Natural);
|
||
|
-- Output W as 8 hex digits (0-9, a-f) in Name_Buffer (N .. N + 7)
|
||
|
|
||
|
procedure Qualify_Entity_Name (Ent : Entity_Id);
|
||
|
-- If not already done, replaces the Chars field of the given entity
|
||
|
-- with the appropriate fully qualified name.
|
||
|
|
||
|
procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean);
|
||
|
-- Given an qualified entity name in Name_Buffer, remove any plain X or
|
||
|
-- X{nb} qualification suffix. The contents of Name_Buffer is not changed
|
||
|
-- but Name_Len may be adjusted on return to remove the suffix. If a
|
||
|
-- suffix is found and stripped, then Suffix_Found is set to True. If
|
||
|
-- no suffix is found, then Suffix_Found is not modified.
|
||
|
|
||
|
------------------------
|
||
|
-- Add_Real_To_Buffer --
|
||
|
------------------------
|
||
|
|
||
|
procedure Add_Real_To_Buffer (U : Ureal) is
|
||
|
begin
|
||
|
Add_Uint_To_Buffer (Norm_Num (U));
|
||
|
Add_Str_To_Name_Buffer ("_");
|
||
|
Add_Uint_To_Buffer (Norm_Den (U));
|
||
|
end Add_Real_To_Buffer;
|
||
|
|
||
|
------------------------
|
||
|
-- Add_Uint_To_Buffer --
|
||
|
------------------------
|
||
|
|
||
|
procedure Add_Uint_To_Buffer (U : Uint) is
|
||
|
begin
|
||
|
if U < 0 then
|
||
|
Add_Uint_To_Buffer (-U);
|
||
|
Add_Char_To_Name_Buffer ('m');
|
||
|
else
|
||
|
UI_Image (U, Decimal);
|
||
|
Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
|
||
|
end if;
|
||
|
end Add_Uint_To_Buffer;
|
||
|
|
||
|
-----------------------
|
||
|
-- Bounds_Match_Size --
|
||
|
-----------------------
|
||
|
|
||
|
function Bounds_Match_Size (E : Entity_Id) return Boolean is
|
||
|
Siz : Uint;
|
||
|
|
||
|
begin
|
||
|
if not Is_OK_Static_Subtype (E) then
|
||
|
return False;
|
||
|
|
||
|
elsif Is_Integer_Type (E)
|
||
|
and then Subtypes_Statically_Match (E, Base_Type (E))
|
||
|
then
|
||
|
return True;
|
||
|
|
||
|
-- Here we check if the static bounds match the natural size, which
|
||
|
-- is the size passed through with the debugging information. This
|
||
|
-- is the Esize rounded up to 8, 16, 32 or 64 as appropriate.
|
||
|
|
||
|
else
|
||
|
declare
|
||
|
Umark : constant Uintp.Save_Mark := Uintp.Mark;
|
||
|
Result : Boolean;
|
||
|
|
||
|
begin
|
||
|
if Esize (E) <= 8 then
|
||
|
Siz := Uint_8;
|
||
|
elsif Esize (E) <= 16 then
|
||
|
Siz := Uint_16;
|
||
|
elsif Esize (E) <= 32 then
|
||
|
Siz := Uint_32;
|
||
|
else
|
||
|
Siz := Uint_64;
|
||
|
end if;
|
||
|
|
||
|
if Is_Modular_Integer_Type (E) or else Is_Enumeration_Type (E) then
|
||
|
Result :=
|
||
|
Expr_Rep_Value (Type_Low_Bound (E)) = 0
|
||
|
and then
|
||
|
2 ** Siz - Expr_Rep_Value (Type_High_Bound (E)) = 1;
|
||
|
|
||
|
else
|
||
|
Result :=
|
||
|
Expr_Rep_Value (Type_Low_Bound (E)) + 2 ** (Siz - 1) = 0
|
||
|
and then
|
||
|
2 ** (Siz - 1) - Expr_Rep_Value (Type_High_Bound (E)) = 1;
|
||
|
end if;
|
||
|
|
||
|
Release (Umark);
|
||
|
return Result;
|
||
|
end;
|
||
|
end if;
|
||
|
end Bounds_Match_Size;
|
||
|
|
||
|
--------------
|
||
|
-- CDN_Hash --
|
||
|
--------------
|
||
|
|
||
|
function CDN_Hash (S : String) return Word is
|
||
|
H : Word;
|
||
|
|
||
|
function Rotate_Left (Value : Word; Amount : Natural) return Word;
|
||
|
pragma Import (Intrinsic, Rotate_Left);
|
||
|
|
||
|
begin
|
||
|
H := 0;
|
||
|
for J in S'Range loop
|
||
|
H := Rotate_Left (H, 3) + Character'Pos (S (J));
|
||
|
end loop;
|
||
|
|
||
|
return H;
|
||
|
end CDN_Hash;
|
||
|
|
||
|
-------------------------
|
||
|
-- Compress_Debug_Name --
|
||
|
-------------------------
|
||
|
|
||
|
procedure Compress_Debug_Name (E : Entity_Id) is
|
||
|
Ptr : Natural;
|
||
|
Sptr : String_Ptr;
|
||
|
Cod : Word;
|
||
|
|
||
|
begin
|
||
|
if not Compress_Debug_Names
|
||
|
and then Length_Of_Name (Chars (E)) <= Max_Debug_Name_Length
|
||
|
then
|
||
|
return;
|
||
|
end if;
|
||
|
|
||
|
Get_Name_String (Chars (E));
|
||
|
|
||
|
-- Find rightmost double underscore
|
||
|
|
||
|
Ptr := Name_Len - 2;
|
||
|
loop
|
||
|
exit when Double_Underscore (Name_Buffer, Ptr);
|
||
|
|
||
|
-- Cannot compress if no double underscore anywhere
|
||
|
|
||
|
if Ptr < 2 then
|
||
|
return;
|
||
|
end if;
|
||
|
|
||
|
Ptr := Ptr - 1;
|
||
|
end loop;
|
||
|
|
||
|
-- At this stage we have
|
||
|
|
||
|
-- Name_Buffer (1 .. Ptr - 1) string to compress
|
||
|
-- Name_Buffer (Ptr) underscore
|
||
|
-- Name_Buffer (Ptr + 1) underscore
|
||
|
-- Name_Buffer (Ptr + 2 .. Name_Len) simple name to retain
|
||
|
|
||
|
-- See if we already have an entry for the compression string
|
||
|
|
||
|
-- No point in compressing if it does not make things shorter
|
||
|
|
||
|
if Name_Len <= (2 + 8 + 1) + (Name_Len - (Ptr + 1)) then
|
||
|
return;
|
||
|
end if;
|
||
|
|
||
|
-- Do not compress any reference to entity in internal file
|
||
|
|
||
|
if Name_Buffer (1 .. 5) = "ada__"
|
||
|
or else
|
||
|
Name_Buffer (1 .. 8) = "system__"
|
||
|
or else
|
||
|
Name_Buffer (1 .. 6) = "gnat__"
|
||
|
or else
|
||
|
Name_Buffer (1 .. 12) = "interfaces__"
|
||
|
or else
|
||
|
(OpenVMS and then Name_Buffer (1 .. 5) = "dec__")
|
||
|
then
|
||
|
return;
|
||
|
end if;
|
||
|
|
||
|
Sptr := Name_Buffer (1 .. Ptr - 1)'Unrestricted_Access;
|
||
|
Cod := CDN.Get (Sptr).W;
|
||
|
|
||
|
if Cod = 0 then
|
||
|
Cod := CDN_Hash (Sptr.all);
|
||
|
Sptr := new String'(Sptr.all);
|
||
|
CDN.Set (Sptr, (Cod, Sptr));
|
||
|
end if;
|
||
|
|
||
|
Name_Buffer (1) := 'X';
|
||
|
Name_Buffer (2) := 'C';
|
||
|
Put_Hex (Cod, 3);
|
||
|
Name_Buffer (11) := '_';
|
||
|
Name_Buffer (12 .. Name_Len - Ptr + 10) :=
|
||
|
Name_Buffer (Ptr + 2 .. Name_Len);
|
||
|
Name_Len := Name_Len - Ptr + 10;
|
||
|
|
||
|
Set_Chars (E, Name_Enter);
|
||
|
end Compress_Debug_Name;
|
||
|
|
||
|
--------------------------------
|
||
|
-- Debug_Renaming_Declaration --
|
||
|
--------------------------------
|
||
|
|
||
|
function Debug_Renaming_Declaration (N : Node_Id) return Node_Id 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;
|
||
|
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 known value with value nnn) or as ?e (subscript is local
|
||
|
-- constant with name e), where S supplies the proper string to
|
||
|
-- use for ?. Returns False if the subscript is not of an appropriate
|
||
|
-- type to output in one of these two forms. The result is prepended
|
||
|
-- to the name stored in Name_Buffer.
|
||
|
|
||
|
----------------------
|
||
|
-- Output_Subscript --
|
||
|
----------------------
|
||
|
|
||
|
function Output_Subscript (N : Node_Id; S : String) return Boolean is
|
||
|
begin
|
||
|
if Compile_Time_Known_Value (N) then
|
||
|
Prepend_Uint_To_Buffer (Expr_Value (N));
|
||
|
|
||
|
elsif Nkind (N) = N_Identifier
|
||
|
and then Scope (Entity (N)) = Scope (Ent)
|
||
|
and then Ekind (Entity (N)) = E_Constant
|
||
|
then
|
||
|
Prepend_String_To_Buffer (Get_Name_String (Chars (Entity (N))));
|
||
|
|
||
|
else
|
||
|
return False;
|
||
|
end if;
|
||
|
|
||
|
Prepend_String_To_Buffer (S);
|
||
|
return True;
|
||
|
end Output_Subscript;
|
||
|
|
||
|
-- Start of processing for Debug_Renaming_Declaration
|
||
|
|
||
|
begin
|
||
|
if not Comes_From_Source (N) then
|
||
|
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");
|
||
|
|
||
|
when others =>
|
||
|
return Empty;
|
||
|
end case;
|
||
|
|
||
|
Rnm := Name_Find;
|
||
|
|
||
|
-- Get renamed entity and compute suffix
|
||
|
|
||
|
Name_Len := 0;
|
||
|
Ren := Nam;
|
||
|
loop
|
||
|
case Nkind (Ren) is
|
||
|
|
||
|
when N_Identifier =>
|
||
|
exit;
|
||
|
|
||
|
when N_Expanded_Name =>
|
||
|
|
||
|
-- The entity field for an N_Expanded_Name is on the
|
||
|
-- expanded name node itself, so we are done here too.
|
||
|
|
||
|
exit;
|
||
|
|
||
|
when N_Selected_Component =>
|
||
|
Prepend_String_To_Buffer
|
||
|
(Get_Name_String (Chars (Selector_Name (Ren))));
|
||
|
Prepend_String_To_Buffer ("XR");
|
||
|
Ren := Prefix (Ren);
|
||
|
|
||
|
when N_Indexed_Component =>
|
||
|
declare
|
||
|
X : Node_Id := Last (Expressions (Ren));
|
||
|
|
||
|
begin
|
||
|
while Present (X) loop
|
||
|
if not Output_Subscript (X, "XS") then
|
||
|
Set_Materialize_Entity (Ent);
|
||
|
return Empty;
|
||
|
end if;
|
||
|
|
||
|
Prev (X);
|
||
|
end loop;
|
||
|
end;
|
||
|
|
||
|
Ren := Prefix (Ren);
|
||
|
|
||
|
when N_Slice =>
|
||
|
|
||
|
Typ := Etype (First_Index (Etype (Nam)));
|
||
|
|
||
|
if not Output_Subscript (Type_High_Bound (Typ), "XS") then
|
||
|
Set_Materialize_Entity (Ent);
|
||
|
return Empty;
|
||
|
end if;
|
||
|
|
||
|
if not Output_Subscript (Type_Low_Bound (Typ), "XL") then
|
||
|
Set_Materialize_Entity (Ent);
|
||
|
return Empty;
|
||
|
end if;
|
||
|
|
||
|
Ren := Prefix (Ren);
|
||
|
|
||
|
when N_Explicit_Dereference =>
|
||
|
Prepend_String_To_Buffer ("XA");
|
||
|
Ren := Prefix (Ren);
|
||
|
|
||
|
-- For now, anything else simply results in no translation
|
||
|
|
||
|
when others =>
|
||
|
Set_Materialize_Entity (Ent);
|
||
|
return Empty;
|
||
|
end case;
|
||
|
end loop;
|
||
|
|
||
|
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
|
||
|
-- Qualify_Entity_Name procedure uses this link to create the proper
|
||
|
-- fully qualified name.
|
||
|
|
||
|
-- The reason we do things this way is that we really need to copy the
|
||
|
-- 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));
|
||
|
|
||
|
-- Return the appropriate enumeration type
|
||
|
|
||
|
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_Needs_Debug_Info (Def);
|
||
|
Set_Needs_Debug_Info (Lit);
|
||
|
|
||
|
Set_Discard_Names (Defining_Identifier (Res));
|
||
|
return Res;
|
||
|
|
||
|
-- If we get an exception, just figure it is a case that we cannot
|
||
|
-- successfully handle using our current approach, since this is
|
||
|
-- only for debugging, no need to take the compilation with us!
|
||
|
|
||
|
exception
|
||
|
when others =>
|
||
|
return Make_Null_Statement (Loc);
|
||
|
end Debug_Renaming_Declaration;
|
||
|
|
||
|
-----------------------
|
||
|
-- Double_Underscore --
|
||
|
-----------------------
|
||
|
|
||
|
function Double_Underscore (S : String; J : Natural) return Boolean is
|
||
|
begin
|
||
|
if J = S'First or else J > S'Last - 2 then
|
||
|
return False;
|
||
|
|
||
|
else
|
||
|
return S (J) = '_'
|
||
|
and then S (J + 1) = '_'
|
||
|
and then S (J - 1) /= '_'
|
||
|
and then S (J + 2) /= '_';
|
||
|
end if;
|
||
|
end Double_Underscore;
|
||
|
|
||
|
------------------------------
|
||
|
-- Generate_Auxiliary_Types --
|
||
|
------------------------------
|
||
|
|
||
|
-- Note: right now there is only one auxiliary type to be generated,
|
||
|
-- namely the enumeration type for the compression sequences if used.
|
||
|
|
||
|
procedure Generate_Auxiliary_Types is
|
||
|
Loc : constant Source_Ptr := Sloc (Cunit (Current_Sem_Unit));
|
||
|
E : Elmt;
|
||
|
Code : Entity_Id;
|
||
|
Lit : Entity_Id;
|
||
|
Start : Natural;
|
||
|
Ptr : Natural;
|
||
|
Discard : List_Id;
|
||
|
|
||
|
Literal_List : List_Id := New_List;
|
||
|
-- Gathers the list of literals for the declaration
|
||
|
|
||
|
procedure Output_Literal;
|
||
|
-- Adds suffix of form Xnnn to name in Name_Buffer, where nnn is
|
||
|
-- a serial number that is one greater on each call, and then
|
||
|
-- builds an enumeration literal and adds it to the literal list.
|
||
|
|
||
|
Serial : Nat := 0;
|
||
|
-- Current serial number
|
||
|
|
||
|
procedure Output_Literal is
|
||
|
begin
|
||
|
Serial := Serial + 1;
|
||
|
Add_Char_To_Name_Buffer ('X');
|
||
|
Add_Nat_To_Name_Buffer (Serial);
|
||
|
|
||
|
Lit :=
|
||
|
Make_Defining_Identifier (Loc,
|
||
|
Chars => Name_Find);
|
||
|
Set_Has_Qualified_Name (Lit, True);
|
||
|
Append (Lit, Literal_List);
|
||
|
end Output_Literal;
|
||
|
|
||
|
-- Start of processing for Auxiliary_Types
|
||
|
|
||
|
begin
|
||
|
E := CDN.Get_First;
|
||
|
if E.S /= null then
|
||
|
while E.S /= null loop
|
||
|
|
||
|
-- We have E.S a String_Ptr that contains a string of the form:
|
||
|
|
||
|
-- b__c__d
|
||
|
|
||
|
-- In E.W is a 32-bit word representing the hash value
|
||
|
|
||
|
-- Our mission is to construct a type
|
||
|
|
||
|
-- type XChhhhhhhh is (b,c,d);
|
||
|
|
||
|
-- where hhhhhhhh is the 8 hex digits of the E.W value.
|
||
|
-- and append this type declaration to the result list
|
||
|
|
||
|
Name_Buffer (1) := 'X';
|
||
|
Name_Buffer (2) := 'C';
|
||
|
Put_Hex (E.W, 3);
|
||
|
Name_Len := 10;
|
||
|
Output_Literal;
|
||
|
|
||
|
Start := E.S'First;
|
||
|
Ptr := E.S'First;
|
||
|
while Ptr <= E.S'Last loop
|
||
|
if Ptr = E.S'Last
|
||
|
or else Double_Underscore (E.S.all, Ptr + 1)
|
||
|
then
|
||
|
Name_Len := Ptr - Start + 1;
|
||
|
Name_Buffer (1 .. Name_Len) := E.S (Start .. Ptr);
|
||
|
Output_Literal;
|
||
|
Start := Ptr + 3;
|
||
|
Ptr := Start;
|
||
|
else
|
||
|
Ptr := Ptr + 1;
|
||
|
end if;
|
||
|
end loop;
|
||
|
|
||
|
E := CDN.Get_Next;
|
||
|
end loop;
|
||
|
|
||
|
Name_Buffer (1) := 'X';
|
||
|
Name_Buffer (2) := 'C';
|
||
|
Name_Len := 2;
|
||
|
|
||
|
Code :=
|
||
|
Make_Defining_Identifier (Loc,
|
||
|
Chars => Name_Find);
|
||
|
Set_Has_Qualified_Name (Code, True);
|
||
|
|
||
|
Insert_Library_Level_Action (
|
||
|
Make_Full_Type_Declaration (Loc,
|
||
|
Defining_Identifier => Code,
|
||
|
Type_Definition =>
|
||
|
Make_Enumeration_Type_Definition (Loc,
|
||
|
Literals => Literal_List)));
|
||
|
|
||
|
-- We have to manually freeze this entity, since it is inserted
|
||
|
-- very late on into the tree, and otherwise will not be frozen.
|
||
|
-- No freeze actions are generated, so we can discard the result.
|
||
|
|
||
|
Discard := Freeze_Entity (Code, Loc);
|
||
|
end if;
|
||
|
end Generate_Auxiliary_Types;
|
||
|
|
||
|
----------------------
|
||
|
-- Get_Encoded_Name --
|
||
|
----------------------
|
||
|
|
||
|
-- Note: see spec for details on encodings
|
||
|
|
||
|
procedure Get_Encoded_Name (E : Entity_Id) is
|
||
|
Has_Suffix : Boolean;
|
||
|
|
||
|
begin
|
||
|
Get_Name_String (Chars (E));
|
||
|
|
||
|
-- Nothing to do if we do not have a type
|
||
|
|
||
|
if not Is_Type (E)
|
||
|
|
||
|
-- Or if this is an enumeration base type
|
||
|
|
||
|
or else (Is_Enumeration_Type (E)
|
||
|
and then E = Base_Type (E))
|
||
|
|
||
|
-- Or if this is a dummy type for a renaming
|
||
|
|
||
|
or else Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR"
|
||
|
or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
|
||
|
or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"
|
||
|
|
||
|
-- For all these cases, just return the name unchanged
|
||
|
|
||
|
then
|
||
|
Name_Buffer (Name_Len + 1) := ASCII.Nul;
|
||
|
return;
|
||
|
end if;
|
||
|
|
||
|
Has_Suffix := True;
|
||
|
|
||
|
-- Fixed-point case
|
||
|
|
||
|
if Is_Fixed_Point_Type (E) then
|
||
|
Get_External_Name_With_Suffix (E, "XF_");
|
||
|
Add_Real_To_Buffer (Delta_Value (E));
|
||
|
|
||
|
if Small_Value (E) /= Delta_Value (E) then
|
||
|
Add_Str_To_Name_Buffer ("_");
|
||
|
Add_Real_To_Buffer (Small_Value (E));
|
||
|
end if;
|
||
|
|
||
|
-- Vax floating-point case
|
||
|
|
||
|
elsif Vax_Float (E) then
|
||
|
|
||
|
if Digits_Value (Base_Type (E)) = 6 then
|
||
|
Get_External_Name_With_Suffix (E, "XFF");
|
||
|
|
||
|
elsif Digits_Value (Base_Type (E)) = 9 then
|
||
|
Get_External_Name_With_Suffix (E, "XFF");
|
||
|
|
||
|
else
|
||
|
pragma Assert (Digits_Value (Base_Type (E)) = 15);
|
||
|
Get_External_Name_With_Suffix (E, "XFG");
|
||
|
end if;
|
||
|
|
||
|
-- Discrete case where bounds do not match size
|
||
|
|
||
|
elsif Is_Discrete_Type (E)
|
||
|
and then not Bounds_Match_Size (E)
|
||
|
then
|
||
|
if Has_Biased_Representation (E) then
|
||
|
Get_External_Name_With_Suffix (E, "XB");
|
||
|
else
|
||
|
Get_External_Name_With_Suffix (E, "XD");
|
||
|
end if;
|
||
|
|
||
|
declare
|
||
|
Lo : constant Node_Id := Type_Low_Bound (E);
|
||
|
Hi : constant Node_Id := Type_High_Bound (E);
|
||
|
|
||
|
Lo_Stat : constant Boolean := Is_OK_Static_Expression (Lo);
|
||
|
Hi_Stat : constant Boolean := Is_OK_Static_Expression (Hi);
|
||
|
|
||
|
Lo_Discr : constant Boolean :=
|
||
|
Nkind (Lo) = N_Identifier
|
||
|
and then
|
||
|
Ekind (Entity (Lo)) = E_Discriminant;
|
||
|
|
||
|
Hi_Discr : constant Boolean :=
|
||
|
Nkind (Hi) = N_Identifier
|
||
|
and then
|
||
|
Ekind (Entity (Hi)) = E_Discriminant;
|
||
|
|
||
|
Lo_Encode : constant Boolean := Lo_Stat or Lo_Discr;
|
||
|
Hi_Encode : constant Boolean := Hi_Stat or Hi_Discr;
|
||
|
|
||
|
begin
|
||
|
if Lo_Encode or Hi_Encode then
|
||
|
if Lo_Encode then
|
||
|
if Hi_Encode then
|
||
|
Add_Str_To_Name_Buffer ("LU_");
|
||
|
else
|
||
|
Add_Str_To_Name_Buffer ("L_");
|
||
|
end if;
|
||
|
else
|
||
|
Add_Str_To_Name_Buffer ("U_");
|
||
|
end if;
|
||
|
|
||
|
if Lo_Stat then
|
||
|
Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
|
||
|
elsif Lo_Discr then
|
||
|
Get_Name_String_And_Append (Chars (Entity (Lo)));
|
||
|
end if;
|
||
|
|
||
|
if Lo_Encode and Hi_Encode then
|
||
|
Add_Str_To_Name_Buffer ("__");
|
||
|
end if;
|
||
|
|
||
|
if Hi_Stat then
|
||
|
Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
|
||
|
elsif Hi_Discr then
|
||
|
Get_Name_String_And_Append (Chars (Entity (Hi)));
|
||
|
end if;
|
||
|
end if;
|
||
|
end;
|
||
|
|
||
|
-- For all other cases, the encoded name is the normal type name
|
||
|
|
||
|
else
|
||
|
Has_Suffix := False;
|
||
|
Get_External_Name (E, Has_Suffix);
|
||
|
end if;
|
||
|
|
||
|
if Debug_Flag_B and then Has_Suffix then
|
||
|
Write_Str ("**** type ");
|
||
|
Write_Name (Chars (E));
|
||
|
Write_Str (" is encoded as ");
|
||
|
Write_Str (Name_Buffer (1 .. Name_Len));
|
||
|
Write_Eol;
|
||
|
end if;
|
||
|
|
||
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
||
|
end Get_Encoded_Name;
|
||
|
|
||
|
-------------------
|
||
|
-- Get_Entity_Id --
|
||
|
-------------------
|
||
|
|
||
|
function Get_Entity_Id (External_Name : String) return Entity_Id is
|
||
|
begin
|
||
|
return Empty;
|
||
|
end Get_Entity_Id;
|
||
|
|
||
|
-----------------------
|
||
|
-- Get_External_Name --
|
||
|
-----------------------
|
||
|
|
||
|
procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean)
|
||
|
is
|
||
|
E : Entity_Id := Entity;
|
||
|
Kind : Entity_Kind;
|
||
|
|
||
|
procedure Get_Qualified_Name_And_Append (Entity : Entity_Id);
|
||
|
-- Appends fully qualified name of given entity to Name_Buffer
|
||
|
|
||
|
-----------------------------------
|
||
|
-- Get_Qualified_Name_And_Append --
|
||
|
-----------------------------------
|
||
|
|
||
|
procedure Get_Qualified_Name_And_Append (Entity : Entity_Id) is
|
||
|
begin
|
||
|
-- If the entity is a compilation unit, its scope is Standard,
|
||
|
-- there is no outer scope, and the no further qualification
|
||
|
-- is required.
|
||
|
|
||
|
-- If the front end has already computed a fully qualified name,
|
||
|
-- then it is also the case that no further qualification is
|
||
|
-- required
|
||
|
|
||
|
if Present (Scope (Scope (Entity)))
|
||
|
and then not Has_Fully_Qualified_Name (Entity)
|
||
|
then
|
||
|
Get_Qualified_Name_And_Append (Scope (Entity));
|
||
|
Add_Str_To_Name_Buffer ("__");
|
||
|
end if;
|
||
|
|
||
|
Get_Name_String_And_Append (Chars (Entity));
|
||
|
end Get_Qualified_Name_And_Append;
|
||
|
|
||
|
-- Start of processing for Get_External_Name
|
||
|
|
||
|
begin
|
||
|
Name_Len := 0;
|
||
|
|
||
|
-- If this is a child unit, we want the child
|
||
|
|
||
|
if Nkind (E) = N_Defining_Program_Unit_Name then
|
||
|
E := Defining_Identifier (Entity);
|
||
|
end if;
|
||
|
|
||
|
Kind := Ekind (E);
|
||
|
|
||
|
-- Case of interface name being used
|
||
|
|
||
|
if (Kind = E_Procedure or else
|
||
|
Kind = E_Function or else
|
||
|
Kind = E_Constant or else
|
||
|
Kind = E_Variable or else
|
||
|
Kind = E_Exception)
|
||
|
and then Present (Interface_Name (E))
|
||
|
and then No (Address_Clause (E))
|
||
|
and then not Has_Suffix
|
||
|
then
|
||
|
-- The following code needs explanation ???
|
||
|
|
||
|
if Convention (E) = Convention_Stdcall
|
||
|
and then Ekind (E) = E_Variable
|
||
|
then
|
||
|
Add_Str_To_Name_Buffer ("_imp__");
|
||
|
end if;
|
||
|
|
||
|
Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
|
||
|
|
||
|
-- All other cases besides the interface name case
|
||
|
|
||
|
else
|
||
|
-- If this is a library level subprogram (i.e. a subprogram that is a
|
||
|
-- compilation unit other than a subunit), then we prepend _ada_ to
|
||
|
-- ensure distinctions required as described in the spec.
|
||
|
-- Check explicitly for child units, because those are not flagged
|
||
|
-- as Compilation_Units by lib. Should they be ???
|
||
|
|
||
|
if Is_Subprogram (E)
|
||
|
and then (Is_Compilation_Unit (E) or Is_Child_Unit (E))
|
||
|
and then not Has_Suffix
|
||
|
then
|
||
|
Add_Str_To_Name_Buffer ("_ada_");
|
||
|
end if;
|
||
|
|
||
|
-- If the entity is a subprogram instance that is not a compilation
|
||
|
-- unit, generate the name of the original Ada entity, which is the
|
||
|
-- one gdb needs.
|
||
|
|
||
|
if Is_Generic_Instance (E)
|
||
|
and then Is_Subprogram (E)
|
||
|
and then not Is_Compilation_Unit (Scope (E))
|
||
|
then
|
||
|
E := Related_Instance (Scope (E));
|
||
|
end if;
|
||
|
|
||
|
Get_Qualified_Name_And_Append (E);
|
||
|
|
||
|
if Has_Homonym (E) then
|
||
|
declare
|
||
|
H : Entity_Id := Homonym (E);
|
||
|
Nr : Nat := 1;
|
||
|
|
||
|
begin
|
||
|
while Present (H) loop
|
||
|
if (Scope (H) = Scope (E)) then
|
||
|
Nr := Nr + 1;
|
||
|
end if;
|
||
|
|
||
|
H := Homonym (H);
|
||
|
end loop;
|
||
|
|
||
|
if Nr > 1 then
|
||
|
if No_Dollar_In_Label then
|
||
|
Add_Str_To_Name_Buffer ("__");
|
||
|
else
|
||
|
Add_Char_To_Name_Buffer ('$');
|
||
|
end if;
|
||
|
|
||
|
Add_Nat_To_Name_Buffer (Nr);
|
||
|
end if;
|
||
|
end;
|
||
|
end if;
|
||
|
end if;
|
||
|
|
||
|
Name_Buffer (Name_Len + 1) := ASCII.Nul;
|
||
|
end Get_External_Name;
|
||
|
|
||
|
-----------------------------------
|
||
|
-- Get_External_Name_With_Suffix --
|
||
|
-----------------------------------
|
||
|
|
||
|
procedure Get_External_Name_With_Suffix
|
||
|
(Entity : Entity_Id;
|
||
|
Suffix : String)
|
||
|
is
|
||
|
Has_Suffix : constant Boolean := (Suffix /= "");
|
||
|
begin
|
||
|
Get_External_Name (Entity, Has_Suffix);
|
||
|
|
||
|
if Has_Suffix then
|
||
|
Add_Str_To_Name_Buffer ("___");
|
||
|
Add_Str_To_Name_Buffer (Suffix);
|
||
|
|
||
|
Name_Buffer (Name_Len + 1) := ASCII.Nul;
|
||
|
end if;
|
||
|
end Get_External_Name_With_Suffix;
|
||
|
|
||
|
--------------------------
|
||
|
-- Get_Variant_Encoding --
|
||
|
--------------------------
|
||
|
|
||
|
procedure Get_Variant_Encoding (V : Node_Id) is
|
||
|
Choice : Node_Id;
|
||
|
|
||
|
procedure Choice_Val (Typ : Character; Choice : Node_Id);
|
||
|
-- Output encoded value for a single choice value. Typ is the key
|
||
|
-- character ('S', 'F', or 'T') that precedes the choice value.
|
||
|
|
||
|
----------------
|
||
|
-- Choice_Val --
|
||
|
----------------
|
||
|
|
||
|
procedure Choice_Val (Typ : Character; Choice : Node_Id) is
|
||
|
begin
|
||
|
Add_Char_To_Name_Buffer (Typ);
|
||
|
|
||
|
if Nkind (Choice) = N_Integer_Literal then
|
||
|
Add_Uint_To_Buffer (Intval (Choice));
|
||
|
|
||
|
-- Character literal with no entity present (this is the case
|
||
|
-- Standard.Character or Standard.Wide_Character as root type)
|
||
|
|
||
|
elsif Nkind (Choice) = N_Character_Literal
|
||
|
and then No (Entity (Choice))
|
||
|
then
|
||
|
Add_Uint_To_Buffer
|
||
|
(UI_From_Int (Int (Char_Literal_Value (Choice))));
|
||
|
|
||
|
else
|
||
|
declare
|
||
|
Ent : constant Entity_Id := Entity (Choice);
|
||
|
|
||
|
begin
|
||
|
if Ekind (Ent) = E_Enumeration_Literal then
|
||
|
Add_Uint_To_Buffer (Enumeration_Rep (Ent));
|
||
|
|
||
|
else
|
||
|
pragma Assert (Ekind (Ent) = E_Constant);
|
||
|
Choice_Val (Typ, Constant_Value (Ent));
|
||
|
end if;
|
||
|
end;
|
||
|
end if;
|
||
|
end Choice_Val;
|
||
|
|
||
|
-- Start of processing for Get_Variant_Encoding
|
||
|
|
||
|
begin
|
||
|
Name_Len := 0;
|
||
|
|
||
|
Choice := First (Discrete_Choices (V));
|
||
|
while Present (Choice) loop
|
||
|
if Nkind (Choice) = N_Others_Choice then
|
||
|
Add_Char_To_Name_Buffer ('O');
|
||
|
|
||
|
elsif Nkind (Choice) = N_Range then
|
||
|
Choice_Val ('R', Low_Bound (Choice));
|
||
|
Choice_Val ('T', High_Bound (Choice));
|
||
|
|
||
|
elsif Is_Entity_Name (Choice)
|
||
|
and then Is_Type (Entity (Choice))
|
||
|
then
|
||
|
Choice_Val ('R', Type_Low_Bound (Entity (Choice)));
|
||
|
Choice_Val ('T', Type_High_Bound (Entity (Choice)));
|
||
|
|
||
|
elsif Nkind (Choice) = N_Subtype_Indication then
|
||
|
declare
|
||
|
Rang : constant Node_Id :=
|
||
|
Range_Expression (Constraint (Choice));
|
||
|
begin
|
||
|
Choice_Val ('R', Low_Bound (Rang));
|
||
|
Choice_Val ('T', High_Bound (Rang));
|
||
|
end;
|
||
|
|
||
|
else
|
||
|
Choice_Val ('S', Choice);
|
||
|
end if;
|
||
|
|
||
|
Next (Choice);
|
||
|
end loop;
|
||
|
|
||
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
||
|
|
||
|
if Debug_Flag_B then
|
||
|
declare
|
||
|
VP : constant Node_Id := Parent (V); -- Variant_Part
|
||
|
CL : constant Node_Id := Parent (VP); -- Component_List
|
||
|
RD : constant Node_Id := Parent (CL); -- Record_Definition
|
||
|
FT : constant Node_Id := Parent (RD); -- Full_Type_Declaration
|
||
|
|
||
|
begin
|
||
|
Write_Str ("**** variant for type ");
|
||
|
Write_Name (Chars (Defining_Identifier (FT)));
|
||
|
Write_Str (" is encoded as ");
|
||
|
Write_Str (Name_Buffer (1 .. Name_Len));
|
||
|
Write_Eol;
|
||
|
end;
|
||
|
end if;
|
||
|
end Get_Variant_Encoding;
|
||
|
|
||
|
---------------------------------
|
||
|
-- Make_Packed_Array_Type_Name --
|
||
|
---------------------------------
|
||
|
|
||
|
function Make_Packed_Array_Type_Name
|
||
|
(Typ : Entity_Id;
|
||
|
Csize : Uint)
|
||
|
return Name_Id
|
||
|
is
|
||
|
begin
|
||
|
Get_Name_String (Chars (Typ));
|
||
|
Add_Str_To_Name_Buffer ("___XP");
|
||
|
Add_Uint_To_Buffer (Csize);
|
||
|
return Name_Find;
|
||
|
end Make_Packed_Array_Type_Name;
|
||
|
|
||
|
------------------------------
|
||
|
-- Prepend_String_To_Buffer --
|
||
|
------------------------------
|
||
|
|
||
|
procedure Prepend_String_To_Buffer (S : String) is
|
||
|
N : constant Integer := S'Length;
|
||
|
|
||
|
begin
|
||
|
Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
|
||
|
Name_Buffer (1 .. N) := S;
|
||
|
Name_Len := Name_Len + N;
|
||
|
end Prepend_String_To_Buffer;
|
||
|
|
||
|
----------------------------
|
||
|
-- Prepend_Uint_To_Buffer --
|
||
|
----------------------------
|
||
|
|
||
|
procedure Prepend_Uint_To_Buffer (U : Uint) is
|
||
|
begin
|
||
|
if U < 0 then
|
||
|
Prepend_String_To_Buffer ("m");
|
||
|
Prepend_Uint_To_Buffer (-U);
|
||
|
else
|
||
|
UI_Image (U, Decimal);
|
||
|
Prepend_String_To_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
|
||
|
end if;
|
||
|
end Prepend_Uint_To_Buffer;
|
||
|
|
||
|
-------------
|
||
|
-- Put_Hex --
|
||
|
-------------
|
||
|
|
||
|
procedure Put_Hex (W : Word; N : Natural) is
|
||
|
Hex : constant array (Word range 0 .. 15) of Character :=
|
||
|
"0123456789abcdef";
|
||
|
|
||
|
Cod : Word;
|
||
|
|
||
|
begin
|
||
|
Cod := W;
|
||
|
for J in reverse N .. N + 7 loop
|
||
|
Name_Buffer (J) := Hex (Cod and 16#F#);
|
||
|
Cod := Cod / 16;
|
||
|
end loop;
|
||
|
end Put_Hex;
|
||
|
|
||
|
------------------------------
|
||
|
-- Qualify_All_Entity_Names --
|
||
|
------------------------------
|
||
|
|
||
|
procedure Qualify_All_Entity_Names is
|
||
|
E : Entity_Id;
|
||
|
Ent : Entity_Id;
|
||
|
|
||
|
begin
|
||
|
for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
|
||
|
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);
|
||
|
|
||
|
-- 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 loop;
|
||
|
|
||
|
-- Second loop compresses any names that need compressing
|
||
|
|
||
|
for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
|
||
|
E := Defining_Entity (Name_Qualify_Units.Table (J));
|
||
|
Compress_Debug_Name (E);
|
||
|
|
||
|
Ent := First_Entity (E);
|
||
|
while Present (Ent) loop
|
||
|
Compress_Debug_Name (Ent);
|
||
|
Next_Entity (Ent);
|
||
|
exit when Ent = E;
|
||
|
end loop;
|
||
|
end loop;
|
||
|
end Qualify_All_Entity_Names;
|
||
|
|
||
|
-------------------------
|
||
|
-- Qualify_Entity_Name --
|
||
|
-------------------------
|
||
|
|
||
|
procedure Qualify_Entity_Name (Ent : Entity_Id) is
|
||
|
|
||
|
Full_Qualify_Name : String (1 .. Name_Buffer'Length);
|
||
|
Full_Qualify_Len : Natural := 0;
|
||
|
-- Used to accumulate fully qualified name of subprogram
|
||
|
|
||
|
procedure Fully_Qualify_Name (E : Entity_Id);
|
||
|
-- Used to qualify a subprogram or type name, where full
|
||
|
-- qualification up to Standard is always used. Name is set
|
||
|
-- in Full_Qualify_Name with the length in Full_Qualify_Len.
|
||
|
-- Note that this routine does not prepend the _ada_ string
|
||
|
-- required for library subprograms (this is done in the back end).
|
||
|
|
||
|
function Is_BNPE (S : Entity_Id) return Boolean;
|
||
|
-- Determines if S is a BNPE, i.e. Body-Nested Package Entity, which
|
||
|
-- is defined to be a package which is immediately nested within a
|
||
|
-- package body.
|
||
|
|
||
|
function Qualify_Needed (S : Entity_Id) return Boolean;
|
||
|
-- Given a scope, determines if the scope is to be included in the
|
||
|
-- fully qualified name, True if so, False if not.
|
||
|
|
||
|
procedure Set_BNPE_Suffix (E : Entity_Id);
|
||
|
-- Recursive routine to append the BNPE qualification suffix. Works
|
||
|
-- from right to left with E being the current entity in the list.
|
||
|
-- The result does NOT have the trailing n's and trailing b stripped.
|
||
|
-- The caller must do this required stripping.
|
||
|
|
||
|
procedure Set_Entity_Name (E : Entity_Id);
|
||
|
-- Internal recursive routine that does most of the work. This routine
|
||
|
-- leaves the result sitting in Name_Buffer and Name_Len.
|
||
|
|
||
|
BNPE_Suffix_Needed : Boolean := False;
|
||
|
-- Set true if a body-nested package entity suffix is required
|
||
|
|
||
|
Save_Chars : constant Name_Id := Chars (Ent);
|
||
|
-- Save original name
|
||
|
|
||
|
------------------------
|
||
|
-- Fully_Qualify_Name --
|
||
|
------------------------
|
||
|
|
||
|
procedure Fully_Qualify_Name (E : Entity_Id) is
|
||
|
Discard : Boolean := False;
|
||
|
|
||
|
begin
|
||
|
-- If this we are qualifying entities local to a generic
|
||
|
-- instance, use the name of the original instantiation,
|
||
|
-- not that of the anonymous subprogram in the wrapper
|
||
|
-- package, so that gdb doesn't have to know about these.
|
||
|
|
||
|
if Is_Generic_Instance (E)
|
||
|
and then Is_Subprogram (E)
|
||
|
and then not Comes_From_Source (E)
|
||
|
and then not Is_Compilation_Unit (Scope (E))
|
||
|
then
|
||
|
Fully_Qualify_Name (Related_Instance (Scope (E)));
|
||
|
return;
|
||
|
end if;
|
||
|
|
||
|
-- If we reached fully qualified name, then just copy it
|
||
|
|
||
|
if Has_Fully_Qualified_Name (E) then
|
||
|
Get_Name_String (Chars (E));
|
||
|
Strip_BNPE_Suffix (Discard);
|
||
|
Full_Qualify_Name (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
|
||
|
Full_Qualify_Len := Name_Len;
|
||
|
Set_Has_Fully_Qualified_Name (Ent);
|
||
|
|
||
|
-- Case of non-fully qualified name
|
||
|
|
||
|
else
|
||
|
if Scope (E) = Standard_Standard then
|
||
|
Set_Has_Fully_Qualified_Name (Ent);
|
||
|
else
|
||
|
Fully_Qualify_Name (Scope (E));
|
||
|
Full_Qualify_Name (Full_Qualify_Len + 1) := '_';
|
||
|
Full_Qualify_Name (Full_Qualify_Len + 2) := '_';
|
||
|
Full_Qualify_Len := Full_Qualify_Len + 2;
|
||
|
end if;
|
||
|
|
||
|
if Has_Qualified_Name (E) then
|
||
|
Get_Unqualified_Name_String (Chars (E));
|
||
|
else
|
||
|
Get_Name_String (Chars (E));
|
||
|
end if;
|
||
|
|
||
|
Full_Qualify_Name
|
||
|
(Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
|
||
|
Name_Buffer (1 .. Name_Len);
|
||
|
Full_Qualify_Len := Full_Qualify_Len + Name_Len;
|
||
|
end if;
|
||
|
|
||
|
if Is_BNPE (E) then
|
||
|
BNPE_Suffix_Needed := True;
|
||
|
end if;
|
||
|
end Fully_Qualify_Name;
|
||
|
|
||
|
-------------
|
||
|
-- Is_BNPE --
|
||
|
-------------
|
||
|
|
||
|
function Is_BNPE (S : Entity_Id) return Boolean is
|
||
|
begin
|
||
|
return
|
||
|
Ekind (S) = E_Package
|
||
|
and then Is_Package_Body_Entity (S);
|
||
|
end Is_BNPE;
|
||
|
|
||
|
--------------------
|
||
|
-- Qualify_Needed --
|
||
|
--------------------
|
||
|
|
||
|
function Qualify_Needed (S : Entity_Id) return Boolean is
|
||
|
begin
|
||
|
-- If we got all the way to Standard, then we have certainly
|
||
|
-- fully qualified the name, so set the flag appropriately,
|
||
|
-- and then return False, since we are most certainly done!
|
||
|
|
||
|
if S = Standard_Standard then
|
||
|
Set_Has_Fully_Qualified_Name (Ent, True);
|
||
|
return False;
|
||
|
|
||
|
-- Otherwise figure out if further qualification is required
|
||
|
|
||
|
else
|
||
|
return
|
||
|
Is_Subprogram (Ent)
|
||
|
or else
|
||
|
Ekind (Ent) = E_Subprogram_Body
|
||
|
or else
|
||
|
(Ekind (S) /= E_Block
|
||
|
and then not Is_Dynamic_Scope (S));
|
||
|
end if;
|
||
|
end Qualify_Needed;
|
||
|
|
||
|
---------------------
|
||
|
-- Set_BNPE_Suffix --
|
||
|
---------------------
|
||
|
|
||
|
procedure Set_BNPE_Suffix (E : Entity_Id) is
|
||
|
S : constant Entity_Id := Scope (E);
|
||
|
|
||
|
begin
|
||
|
if Qualify_Needed (S) then
|
||
|
Set_BNPE_Suffix (S);
|
||
|
|
||
|
if Is_BNPE (E) then
|
||
|
Add_Char_To_Name_Buffer ('b');
|
||
|
else
|
||
|
Add_Char_To_Name_Buffer ('n');
|
||
|
end if;
|
||
|
|
||
|
else
|
||
|
Add_Char_To_Name_Buffer ('X');
|
||
|
end if;
|
||
|
|
||
|
end Set_BNPE_Suffix;
|
||
|
|
||
|
---------------------
|
||
|
-- Set_Entity_Name --
|
||
|
---------------------
|
||
|
|
||
|
procedure Set_Entity_Name (E : Entity_Id) is
|
||
|
S : constant Entity_Id := Scope (E);
|
||
|
|
||
|
begin
|
||
|
-- If we reach an already qualified name, just take the encoding
|
||
|
-- except that we strip the package body suffixes, since these
|
||
|
-- will be separately put on later.
|
||
|
|
||
|
if Has_Qualified_Name (E) then
|
||
|
Get_Name_String_And_Append (Chars (E));
|
||
|
Strip_BNPE_Suffix (BNPE_Suffix_Needed);
|
||
|
|
||
|
-- If the top level name we are adding is itself fully
|
||
|
-- qualified, then that means that the name that we are
|
||
|
-- preparing for the Fully_Qualify_Name call will also
|
||
|
-- generate a fully qualified name.
|
||
|
|
||
|
if Has_Fully_Qualified_Name (E) then
|
||
|
Set_Has_Fully_Qualified_Name (Ent);
|
||
|
end if;
|
||
|
|
||
|
-- Case where upper level name is not encoded yet
|
||
|
|
||
|
else
|
||
|
-- Recurse if further qualification required
|
||
|
|
||
|
if Qualify_Needed (S) then
|
||
|
Set_Entity_Name (S);
|
||
|
Add_Str_To_Name_Buffer ("__");
|
||
|
end if;
|
||
|
|
||
|
-- Otherwise get name and note if it is a NPBE
|
||
|
|
||
|
Get_Name_String_And_Append (Chars (E));
|
||
|
|
||
|
if Is_BNPE (E) then
|
||
|
BNPE_Suffix_Needed := True;
|
||
|
end if;
|
||
|
end if;
|
||
|
end Set_Entity_Name;
|
||
|
|
||
|
-- Start of processing for Qualify_Entity_Name
|
||
|
|
||
|
begin
|
||
|
if Has_Qualified_Name (Ent) then
|
||
|
return;
|
||
|
|
||
|
-- Here is where we create the proper link for renaming
|
||
|
|
||
|
elsif Ekind (Ent) = E_Enumeration_Literal
|
||
|
and then Present (Debug_Renaming_Link (Ent))
|
||
|
then
|
||
|
Set_Entity_Name (Debug_Renaming_Link (Ent));
|
||
|
Get_Name_String (Chars (Ent));
|
||
|
Prepend_String_To_Buffer
|
||
|
(Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
|
||
|
Set_Chars (Ent, Name_Enter);
|
||
|
Set_Has_Qualified_Name (Ent);
|
||
|
return;
|
||
|
|
||
|
elsif Is_Subprogram (Ent)
|
||
|
or else Ekind (Ent) = E_Subprogram_Body
|
||
|
or else Is_Type (Ent)
|
||
|
then
|
||
|
Fully_Qualify_Name (Ent);
|
||
|
Name_Len := Full_Qualify_Len;
|
||
|
Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
|
||
|
|
||
|
elsif Qualify_Needed (Scope (Ent)) then
|
||
|
Name_Len := 0;
|
||
|
Set_Entity_Name (Ent);
|
||
|
|
||
|
else
|
||
|
Set_Has_Qualified_Name (Ent);
|
||
|
return;
|
||
|
end if;
|
||
|
|
||
|
-- Fall through with a fully qualified name in Name_Buffer/Name_Len
|
||
|
|
||
|
-- Add body-nested package suffix if required
|
||
|
|
||
|
if BNPE_Suffix_Needed
|
||
|
and then Ekind (Ent) /= E_Enumeration_Literal
|
||
|
then
|
||
|
Set_BNPE_Suffix (Ent);
|
||
|
|
||
|
-- Strip trailing n's and last trailing b as required. note that
|
||
|
-- we know there is at least one b, or no suffix would be generated.
|
||
|
|
||
|
while Name_Buffer (Name_Len) = 'n' loop
|
||
|
Name_Len := Name_Len - 1;
|
||
|
end loop;
|
||
|
|
||
|
Name_Len := Name_Len - 1;
|
||
|
end if;
|
||
|
|
||
|
Set_Chars (Ent, Name_Enter);
|
||
|
Set_Has_Qualified_Name (Ent);
|
||
|
|
||
|
if Debug_Flag_BB then
|
||
|
Write_Str ("*** ");
|
||
|
Write_Name (Save_Chars);
|
||
|
Write_Str (" qualified as ");
|
||
|
Write_Name (Chars (Ent));
|
||
|
Write_Eol;
|
||
|
end if;
|
||
|
end Qualify_Entity_Name;
|
||
|
|
||
|
--------------------------
|
||
|
-- Qualify_Entity_Names --
|
||
|
--------------------------
|
||
|
|
||
|
procedure Qualify_Entity_Names (N : Node_Id) is
|
||
|
begin
|
||
|
Name_Qualify_Units.Append (N);
|
||
|
end Qualify_Entity_Names;
|
||
|
|
||
|
--------------------------------
|
||
|
-- Save_Unitname_And_Use_List --
|
||
|
--------------------------------
|
||
|
|
||
|
procedure Save_Unitname_And_Use_List
|
||
|
(Main_Unit_Node : Node_Id;
|
||
|
Main_Kind : Node_Kind)
|
||
|
is
|
||
|
INITIAL_NAME_LENGTH : constant := 1024;
|
||
|
|
||
|
Item : Node_Id;
|
||
|
Pack_Name : Node_Id;
|
||
|
|
||
|
Unit_Spec : Node_Id := 0;
|
||
|
Unit_Body : Node_Id := 0;
|
||
|
|
||
|
Main_Name : String_Id;
|
||
|
-- Fully qualified name of Main Unit
|
||
|
|
||
|
Unit_Name : String_Id;
|
||
|
-- Name of unit specified in a Use clause
|
||
|
|
||
|
Spec_Unit_Index : Source_File_Index;
|
||
|
Spec_File_Name : File_Name_Type := No_File;
|
||
|
|
||
|
Body_Unit_Index : Source_File_Index;
|
||
|
Body_File_Name : File_Name_Type := No_File;
|
||
|
|
||
|
type String_Ptr is access all String;
|
||
|
|
||
|
Spec_File_Name_Str : String_Ptr;
|
||
|
Body_File_Name_Str : String_Ptr;
|
||
|
|
||
|
type Label is record
|
||
|
Label_Name : String_Ptr;
|
||
|
Name_Length : Integer;
|
||
|
Pos : Integer;
|
||
|
end record;
|
||
|
|
||
|
Spec_Label : Label;
|
||
|
Body_Label : Label;
|
||
|
|
||
|
procedure Initialize (L : out Label);
|
||
|
-- Initialize label
|
||
|
|
||
|
procedure Append (L : in out Label; Ch : Character);
|
||
|
-- Append character to label
|
||
|
|
||
|
procedure Append (L : in out Label; Str : String);
|
||
|
-- Append string to label
|
||
|
|
||
|
procedure Append_Name (L : in out Label; Unit_Name : String_Id);
|
||
|
-- Append name to label
|
||
|
|
||
|
function Sufficient_Space
|
||
|
(L : Label;
|
||
|
Unit_Name : String_Id)
|
||
|
return Boolean;
|
||
|
-- Does sufficient space exist to append another name?
|
||
|
|
||
|
procedure Append (L : in out Label; Str : String) is
|
||
|
begin
|
||
|
L.Label_Name (L.Pos + 1 .. L.Pos + Str'Length) := Str;
|
||
|
L.Pos := L.Pos + Str'Length;
|
||
|
end Append;
|
||
|
|
||
|
procedure Append (L : in out Label; Ch : Character) is
|
||
|
begin
|
||
|
L.Pos := L.Pos + 1;
|
||
|
L.Label_Name (L.Pos) := Ch;
|
||
|
end Append;
|
||
|
|
||
|
procedure Append_Name (L : in out Label; Unit_Name : String_Id) is
|
||
|
Char : Char_Code;
|
||
|
Upper_Offset : constant := Character'Pos ('a') - Character'Pos ('A');
|
||
|
|
||
|
begin
|
||
|
for J in 1 .. String_Length (Unit_Name) loop
|
||
|
Char := Get_String_Char (Unit_Name, J);
|
||
|
|
||
|
if Character'Val (Char) = '.' then
|
||
|
Append (L, "__");
|
||
|
elsif Character'Val (Char) in 'A' .. 'Z' then
|
||
|
Append (L, Character'Val (Char + Upper_Offset));
|
||
|
elsif Char /= 0 then
|
||
|
Append (L, Character'Val (Char));
|
||
|
end if;
|
||
|
end loop;
|
||
|
end Append_Name;
|
||
|
|
||
|
procedure Initialize (L : out Label) is
|
||
|
begin
|
||
|
L.Name_Length := INITIAL_NAME_LENGTH;
|
||
|
L.Pos := 0;
|
||
|
L.Label_Name := new String (1 .. L.Name_Length);
|
||
|
end Initialize;
|
||
|
|
||
|
function Sufficient_Space
|
||
|
(L : Label;
|
||
|
Unit_Name : String_Id)
|
||
|
return Boolean
|
||
|
is
|
||
|
Len : Integer := Integer (String_Length (Unit_Name)) + 1;
|
||
|
|
||
|
begin
|
||
|
for J in 1 .. String_Length (Unit_Name) loop
|
||
|
if Character'Val (Get_String_Char (Unit_Name, J)) = '.' then
|
||
|
Len := Len + 1;
|
||
|
end if;
|
||
|
end loop;
|
||
|
|
||
|
return L.Pos + Len < L.Name_Length;
|
||
|
end Sufficient_Space;
|
||
|
|
||
|
-- Start of processing for Save_Unitname_And_Use_List
|
||
|
|
||
|
begin
|
||
|
Initialize (Spec_Label);
|
||
|
Initialize (Body_Label);
|
||
|
|
||
|
case Main_Kind is
|
||
|
when N_Package_Declaration =>
|
||
|
Main_Name := Full_Qualified_Name
|
||
|
(Defining_Unit_Name (Specification (Unit (Main_Unit_Node))));
|
||
|
Unit_Spec := Main_Unit_Node;
|
||
|
Append (Spec_Label, "_LPS__");
|
||
|
Append (Body_Label, "_LPB__");
|
||
|
|
||
|
when N_Package_Body =>
|
||
|
Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node));
|
||
|
Unit_Body := Main_Unit_Node;
|
||
|
Main_Name := Full_Qualified_Name (Unit_Spec);
|
||
|
Append (Spec_Label, "_LPS__");
|
||
|
Append (Body_Label, "_LPB__");
|
||
|
|
||
|
when N_Subprogram_Body =>
|
||
|
Unit_Body := Main_Unit_Node;
|
||
|
|
||
|
if Present (Corresponding_Spec (Unit (Main_Unit_Node))) then
|
||
|
Unit_Spec := Corresponding_Spec (Unit (Main_Unit_Node));
|
||
|
Main_Name := Full_Qualified_Name
|
||
|
(Corresponding_Spec (Unit (Main_Unit_Node)));
|
||
|
else
|
||
|
Main_Name := Full_Qualified_Name
|
||
|
(Defining_Unit_Name (Specification (Unit (Main_Unit_Node))));
|
||
|
end if;
|
||
|
|
||
|
Append (Spec_Label, "_LSS__");
|
||
|
Append (Body_Label, "_LSB__");
|
||
|
|
||
|
when others =>
|
||
|
return;
|
||
|
end case;
|
||
|
|
||
|
Append_Name (Spec_Label, Main_Name);
|
||
|
Append_Name (Body_Label, Main_Name);
|
||
|
|
||
|
-- If we have a body, process it first
|
||
|
|
||
|
if Present (Unit_Body) then
|
||
|
|
||
|
Item := First (Context_Items (Unit_Body));
|
||
|
|
||
|
while Present (Item) loop
|
||
|
if Nkind (Item) = N_Use_Package_Clause then
|
||
|
Pack_Name := First (Names (Item));
|
||
|
while Present (Pack_Name) loop
|
||
|
Unit_Name := Full_Qualified_Name (Entity (Pack_Name));
|
||
|
|
||
|
if Sufficient_Space (Body_Label, Unit_Name) then
|
||
|
Append (Body_Label, '$');
|
||
|
Append_Name (Body_Label, Unit_Name);
|
||
|
end if;
|
||
|
|
||
|
Pack_Name := Next (Pack_Name);
|
||
|
end loop;
|
||
|
end if;
|
||
|
|
||
|
Item := Next (Item);
|
||
|
end loop;
|
||
|
end if;
|
||
|
|
||
|
while Present (Unit_Spec) and then
|
||
|
Nkind (Unit_Spec) /= N_Compilation_Unit
|
||
|
loop
|
||
|
Unit_Spec := Parent (Unit_Spec);
|
||
|
end loop;
|
||
|
|
||
|
if Present (Unit_Spec) then
|
||
|
|
||
|
Item := First (Context_Items (Unit_Spec));
|
||
|
|
||
|
while Present (Item) loop
|
||
|
if Nkind (Item) = N_Use_Package_Clause then
|
||
|
Pack_Name := First (Names (Item));
|
||
|
while Present (Pack_Name) loop
|
||
|
Unit_Name := Full_Qualified_Name (Entity (Pack_Name));
|
||
|
|
||
|
if Sufficient_Space (Spec_Label, Unit_Name) then
|
||
|
Append (Spec_Label, '$');
|
||
|
Append_Name (Spec_Label, Unit_Name);
|
||
|
end if;
|
||
|
|
||
|
if Sufficient_Space (Body_Label, Unit_Name) then
|
||
|
Append (Body_Label, '$');
|
||
|
Append_Name (Body_Label, Unit_Name);
|
||
|
end if;
|
||
|
|
||
|
Pack_Name := Next (Pack_Name);
|
||
|
end loop;
|
||
|
end if;
|
||
|
|
||
|
Item := Next (Item);
|
||
|
end loop;
|
||
|
end if;
|
||
|
|
||
|
if Present (Unit_Spec) then
|
||
|
Append (Spec_Label, Character'Val (0));
|
||
|
Spec_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Spec));
|
||
|
Spec_File_Name := Full_File_Name (Spec_Unit_Index);
|
||
|
Get_Name_String (Spec_File_Name);
|
||
|
Spec_File_Name_Str := new String (1 .. Name_Len + 1);
|
||
|
Spec_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
|
||
|
Spec_File_Name_Str (Name_Len + 1) := Character'Val (0);
|
||
|
Spec_Filename := Spec_File_Name_Str (1)'Unrestricted_Access;
|
||
|
Spec_Context_List :=
|
||
|
Spec_Label.Label_Name.all (1)'Unrestricted_Access;
|
||
|
end if;
|
||
|
|
||
|
if Present (Unit_Body) then
|
||
|
Append (Body_Label, Character'Val (0));
|
||
|
Body_Unit_Index := Source_Index (Get_Cunit_Unit_Number (Unit_Body));
|
||
|
Body_File_Name := Full_File_Name (Body_Unit_Index);
|
||
|
Get_Name_String (Body_File_Name);
|
||
|
Body_File_Name_Str := new String (1 .. Name_Len + 1);
|
||
|
Body_File_Name_Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
|
||
|
Body_File_Name_Str (Name_Len + 1) := Character'Val (0);
|
||
|
Body_Filename := Body_File_Name_Str (1)'Unrestricted_Access;
|
||
|
Body_Context_List :=
|
||
|
Body_Label.Label_Name.all (1)'Unrestricted_Access;
|
||
|
end if;
|
||
|
|
||
|
end Save_Unitname_And_Use_List;
|
||
|
|
||
|
---------
|
||
|
-- SEq --
|
||
|
---------
|
||
|
|
||
|
function SEq (F1, F2 : String_Ptr) return Boolean is
|
||
|
begin
|
||
|
return F1.all = F2.all;
|
||
|
end SEq;
|
||
|
|
||
|
-----------
|
||
|
-- SHash --
|
||
|
-----------
|
||
|
|
||
|
function SHash (S : String_Ptr) return Hindex is
|
||
|
begin
|
||
|
return Hindex
|
||
|
(Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length));
|
||
|
end SHash;
|
||
|
|
||
|
-----------------------
|
||
|
-- Strip_BNPE_Suffix --
|
||
|
-----------------------
|
||
|
|
||
|
procedure Strip_BNPE_Suffix (Suffix_Found : in out Boolean) is
|
||
|
begin
|
||
|
for J in reverse 2 .. Name_Len loop
|
||
|
if Name_Buffer (J) = 'X' then
|
||
|
Name_Len := J - 1;
|
||
|
Suffix_Found := True;
|
||
|
exit;
|
||
|
end if;
|
||
|
|
||
|
exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n';
|
||
|
end loop;
|
||
|
end Strip_BNPE_Suffix;
|
||
|
|
||
|
end Exp_Dbug;
|