diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/exp_dbug.adb')
-rw-r--r-- | gcc-4.4.3/gcc/ada/exp_dbug.adb | 1436 |
1 files changed, 0 insertions, 1436 deletions
diff --git a/gcc-4.4.3/gcc/ada/exp_dbug.adb b/gcc-4.4.3/gcc/ada/exp_dbug.adb deleted file mode 100644 index 0a48868b3..000000000 --- a/gcc-4.4.3/gcc/ada/exp_dbug.adb +++ /dev/null @@ -1,1436 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ D B U G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Alloc; use Alloc; -with Atree; use Atree; -with Debug; use Debug; -with Einfo; use Einfo; -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 Sinfo; use Sinfo; -with Stand; use Stand; -with Stringt; use Stringt; -with Table; -with Tbuild; use Tbuild; -with Urealp; use Urealp; - -package body Exp_Dbug is - - -- 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"); - - -------------------------------- - -- 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. - - -------------------- - -- Homonym_Suffix -- - -------------------- - - -- The string defined here (and its associated length) is used to - -- gather the homonym string that will be appended to Name_Buffer - -- when the name is complete. Strip_Suffixes appends to this string - -- as does Append_Homonym_Number, and Output_Homonym_Numbers_Suffix - -- appends the string to the end of Name_Buffer. - - Homonym_Numbers : String (1 .. 256); - Homonym_Len : Natural := 0; - - ---------------------- - -- 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. - - procedure Append_Homonym_Number (E : Entity_Id); - -- If the entity E has homonyms in the same scope, then make an entry - -- in the Homonym_Numbers array, bumping Homonym_Count accordingly. - - 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. - - procedure Output_Homonym_Numbers_Suffix; - -- If homonym numbers are stored, then output them into Name_Buffer - - 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 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_Suffixes (BNPE_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 - -- BNPE suffix is found and stripped, then BNPE_Suffix_Found is set to - -- True. If no suffix is found, then BNPE_Suffix_Found is not modified. - -- This routine also searches for a homonym suffix, and if one is found - -- it is also stripped, and the entries are added to the global homonym - -- list (Homonym_Numbers) so that they can later be put back. - - ------------------------ - -- 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; - - --------------------------- - -- Append_Homonym_Number -- - --------------------------- - - procedure Append_Homonym_Number (E : Entity_Id) is - - procedure Add_Nat_To_H (Nr : Nat); - -- Little procedure to append Nr to Homonym_Numbers - - ------------------ - -- Add_Nat_To_H -- - ------------------ - - procedure Add_Nat_To_H (Nr : Nat) is - begin - if Nr >= 10 then - Add_Nat_To_H (Nr / 10); - end if; - - Homonym_Len := Homonym_Len + 1; - Homonym_Numbers (Homonym_Len) := - Character'Val (Nr mod 10 + Character'Pos ('0')); - end Add_Nat_To_H; - - -- Start of processing for Append_Homonym_Number - - begin - 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 Homonym_Len > 0 then - Homonym_Len := Homonym_Len + 1; - Homonym_Numbers (Homonym_Len) := '_'; - end if; - - Add_Nat_To_H (Nr); - end; - end if; - end Append_Homonym_Number; - - ----------------------- - -- 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; - - -------------------------------- - -- 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); - Ren : Node_Id; - Typ : Entity_Id; - Obj : Entity_Id; - Res : Node_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) - and then not Needs_Debug_Info (Ent) - then - return Empty; - end if; - - -- 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 => - Set_Materialize_Entity (Ent); - 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"); - - -- Include the designation of the form of renaming - - case Nkind (N) is - when N_Object_Renaming_Declaration => - Prepend_String_To_Buffer ("___XR"); - - when N_Exception_Renaming_Declaration => - Prepend_String_To_Buffer ("___XRE"); - - when N_Package_Renaming_Declaration => - Prepend_String_To_Buffer ("___XRP"); - - when others => - return Empty; - end case; - - -- Add the name of the renaming entity to the front - - Prepend_String_To_Buffer (Get_Name_String (Chars (Ent))); - - -- If it is a child unit create a fully qualified name, to disambiguate - -- multiple child units with the same name and different parents. - - if Nkind (N) = N_Package_Renaming_Declaration - and then Is_Child_Unit (Ent) - then - Prepend_String_To_Buffer ("__"); - Prepend_String_To_Buffer - (Get_Name_String (Chars (Scope (Ent)))); - end if; - - -- Create the special object whose name is the debug encoding for the - -- renaming declaration. - - -- For now, the object name contains the suffix encoding for the renamed - -- object, but not the name of the leading entity. The object is linked - -- the renamed entity using the Debug_Renaming_Link field. Then the - -- Qualify_Entity_Name procedure uses this link to create the proper - -- fully qualified name. - - -- 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. - - Obj := Make_Defining_Identifier (Loc, Chars => Name_Enter); - Res := - Make_Object_Declaration (Loc, - Defining_Identifier => Obj, - Object_Definition => New_Reference_To - (Standard_Debug_Renaming_Type, Loc)); - - Set_Debug_Renaming_Link (Obj, Entity (Ren)); - - Set_Debug_Info_Needed (Obj); - - -- Mark the object as internal so that it won't be initialized when - -- pragma Initialize_Scalars or Normalize_Scalars is in use. - - Set_Is_Internal (Obj); - - 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; - - ---------------------- - -- Get_Encoded_Name -- - ---------------------- - - -- Note: see spec for details on encodings - - procedure Get_Encoded_Name (E : Entity_Id) is - Has_Suffix : Boolean; - - begin - -- If not generating code, there is no need to create encoded names, and - -- problems when the back-end is called to annotate types without full - -- code generation. See comments in Get_External_Name_With_Suffix for - -- additional details. - - -- However we do create encoded names if the back end is active, even - -- if Operating_Mode got reset. Otherwise any serious error reported - -- by the backend calling Error_Msg changes the Compilation_Mode to - -- Check_Semantics, which disables the functionality of this routine, - -- causing the generation of spurious additional errors. - - -- Couldn't we just test Original_Operating_Mode here? ??? - - if Operating_Mode /= Generate_Code - and then not Generating_Code - then - return; - end if; - - 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 - declare - Lo : constant Node_Id := Type_Low_Bound (E); - Hi : constant Node_Id := Type_High_Bound (E); - - Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo); - Hi_Con : constant Boolean := Compile_Time_Known_Value (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_Con or Lo_Discr; - Hi_Encode : constant Boolean := Hi_Con or Hi_Discr; - - Biased : constant Boolean := Has_Biased_Representation (E); - - begin - if Biased then - Get_External_Name_With_Suffix (E, "XB"); - else - Get_External_Name_With_Suffix (E, "XD"); - end if; - - if Lo_Encode or Hi_Encode then - if Biased then - Add_Str_To_Name_Buffer ("_"); - else - 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; - end if; - - if Lo_Con 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_Con 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_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 ("__"); - Get_Name_String_And_Append (Chars (Entity)); - Append_Homonym_Number (Entity); - - else - Get_Name_String_And_Append (Chars (Entity)); - end if; - end Get_Qualified_Name_And_Append; - - -- Start of processing for Get_External_Name - - begin - Name_Len := 0; - Homonym_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 - 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)) - and then (Ekind (Scope (E)) = E_Package - or else - Ekind (Scope (E)) = E_Package_Body) - and then Present (Related_Instance (Scope (E))) - then - E := Related_Instance (Scope (E)); - end if; - - Get_Qualified_Name_And_Append (E); - 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 - -- If we are not in code generation mode, this procedure may still be - -- called from Back_End (more specifically - from gigi for doing type - -- representation annotation or some representation-specific checks). - -- But in this mode there is no need to mess with external names. - - -- Furthermore, the call causes difficulties in this case because the - -- string representing the homonym number is not correctly reset as a - -- part of the call to Output_Homonym_Numbers_Suffix (which is not - -- called in gigi). - - if Operating_Mode /= Generate_Code then - return; - end if; - - 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 - if Nkind (Choice) = N_Integer_Literal then - Add_Char_To_Name_Buffer (Typ); - 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_Char_To_Name_Buffer (Typ); - Add_Uint_To_Buffer (Char_Literal_Value (Choice)); - - else - declare - Ent : constant Entity_Id := Entity (Choice); - - begin - if Ekind (Ent) = E_Enumeration_Literal then - Add_Char_To_Name_Buffer (Typ); - 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; - - ------------------------------------ - -- Get_Secondary_DT_External_Name -- - ------------------------------------ - - procedure Get_Secondary_DT_External_Name - (Typ : Entity_Id; - Ancestor_Typ : Entity_Id; - Suffix_Index : Int) - is - begin - Get_External_Name (Typ, Has_Suffix => False); - - if Ancestor_Typ /= Typ then - declare - Len : constant Natural := Name_Len; - Save_Str : constant String (1 .. Name_Len) - := Name_Buffer (1 .. Name_Len); - begin - Get_External_Name (Ancestor_Typ, Has_Suffix => False); - - -- Append the extended name of the ancestor to the - -- extended name of Typ - - Name_Buffer (Len + 2 .. Len + Name_Len + 1) := - Name_Buffer (1 .. Name_Len); - Name_Buffer (1 .. Len) := Save_Str; - Name_Buffer (Len + 1) := '_'; - Name_Len := Len + Name_Len + 1; - end; - end if; - - Add_Nat_To_Name_Buffer (Suffix_Index); - end Get_Secondary_DT_External_Name; - - --------------------------------- - -- 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; - - ----------------------------------- - -- Output_Homonym_Numbers_Suffix -- - ----------------------------------- - - procedure Output_Homonym_Numbers_Suffix is - J : Natural; - - begin - if Homonym_Len > 0 then - - -- Check for all 1's, in which case we do not output - - J := 1; - loop - exit when Homonym_Numbers (J) /= '1'; - - -- If we reached end of string we do not output - - if J = Homonym_Len then - Homonym_Len := 0; - return; - end if; - - exit when Homonym_Numbers (J + 1) /= '_'; - J := J + 2; - end loop; - - -- If we exit the loop then suffix must be output - - Add_Str_To_Name_Buffer ("__"); - Add_Str_To_Name_Buffer (Homonym_Numbers (1 .. Homonym_Len)); - Homonym_Len := 0; - end if; - end Output_Homonym_Numbers_Suffix; - - ------------------------------ - -- 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; - - ------------------------------ - -- 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); - - -- Normally entities in the qualification list are scopes, but in the - -- case of a library-level package renaming there is an associated - -- variable that encodes the debugger name and that variable is - -- entered in the list since it occurs in the Aux_Decls list of the - -- compilation and doesn't have a normal scope. - - if Ekind (E) /= E_Variable then - 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 if; - 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 - -- Ignore empty entry (can happen in error cases) - - if No (E) then - return; - - -- 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. - - elsif 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_Suffixes (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; - - -- Here we do one step of the qualification - - 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; - Append_Homonym_Number (E); - 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_Suffixes (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 BNPE - - Get_Name_String_And_Append (Chars (E)); - - if Is_BNPE (E) then - BNPE_Suffix_Needed := True; - end if; - - Append_Homonym_Number (E); - end if; - end Set_Entity_Name; - - -- Start of processing for Qualify_Entity_Name - - begin - if Has_Qualified_Name (Ent) then - return; - - -- If the entity is a variable encoding the debug name for an object - -- renaming, then the qualified name of the entity associated with the - -- renamed object can now be incorporated in the debug name. - - elsif Ekind (Ent) = E_Variable - and then Present (Debug_Renaming_Link (Ent)) - then - Name_Len := 0; - Qualify_Entity_Name (Debug_Renaming_Link (Ent)); - Get_Name_String (Chars (Ent)); - - -- Retrieve the now-qualified name of the renamed entity and insert - -- it in the middle of the name, just preceding the suffix encoding - -- describing the renamed object. - - declare - Renamed_Id : constant String := - Get_Name_String (Chars (Debug_Renaming_Link (Ent))); - Insert_Len : constant Integer := Renamed_Id'Length + 1; - Index : Natural := Name_Len - 3; - - begin - -- Loop backwards through the name to find the start of the "___" - -- sequence associated with the suffix. - - while Index >= Name_Buffer'First - and then (Name_Buffer (Index + 1) /= '_' - or else Name_Buffer (Index + 2) /= '_' - or else Name_Buffer (Index + 3) /= '_') - loop - Index := Index - 1; - end loop; - - pragma Assert (Name_Buffer (Index + 1 .. Index + 3) = "___"); - - -- Insert an underscore separator and the entity name just in - -- front of the suffix. - - Name_Buffer (Index + 1 + Insert_Len .. Name_Len + Insert_Len) := - Name_Buffer (Index + 1 .. Name_Len); - Name_Buffer (Index + 1) := '_'; - Name_Buffer (Index + 2 .. Index + Insert_Len) := Renamed_Id; - Name_Len := Name_Len + Insert_Len; - end; - - -- Reset the name of the variable to the new name that includes the - -- name of the renamed entity. - - Set_Chars (Ent, Name_Enter); - - -- If the entity needs qualification by its scope then develop it - -- here, add the variable's name, and again reset the entity name. - - if Qualify_Needed (Scope (Ent)) then - Name_Len := 0; - Set_Entity_Name (Scope (Ent)); - Add_Str_To_Name_Buffer ("__"); - - Get_Name_String_And_Append (Chars (Ent)); - - Set_Chars (Ent, Name_Enter); - end if; - - Set_Has_Qualified_Name (Ent); - return; - - 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 - - Output_Homonym_Numbers_Suffix; - - -- 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; - - -------------------- - -- Strip_Suffixes -- - -------------------- - - procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is - SL : Natural; - - pragma Warnings (Off, BNPE_Suffix_Found); - -- Since this procedure only ever sets the flag - - begin - -- Search for and strip BNPE suffix - - for J in reverse 2 .. Name_Len loop - if Name_Buffer (J) = 'X' then - Name_Len := J - 1; - BNPE_Suffix_Found := True; - exit; - end if; - - exit when Name_Buffer (J) /= 'b' and then Name_Buffer (J) /= 'n'; - end loop; - - -- Search for and strip homonym numbers suffix - - for J in reverse 2 .. Name_Len - 2 loop - if Name_Buffer (J) = '_' - and then Name_Buffer (J + 1) = '_' - then - if Name_Buffer (J + 2) in '0' .. '9' then - if Homonym_Len > 0 then - Homonym_Len := Homonym_Len + 1; - Homonym_Numbers (Homonym_Len) := '-'; - end if; - - SL := Name_Len - (J + 1); - - Homonym_Numbers (Homonym_Len + 1 .. Homonym_Len + SL) := - Name_Buffer (J + 2 .. Name_Len); - Name_Len := J - 1; - Homonym_Len := Homonym_Len + SL; - end if; - - exit; - end if; - end loop; - end Strip_Suffixes; - -end Exp_Dbug; |