+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- E X P _ D B U G --
--- --
--- B o d y --
--- --
--- $Revision: 1.2.10.1 $
--- --
--- 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. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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_Len >= 3 and then
- Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
-
- or else (Name_Len >= 4 and then
- (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;
projects / msp430-gcc.git / blobdiff