This patch improves some debug printouts so that they avoid crashing on
invalid data.
In addition, the relevant code uses Global_Name_Buffer all over the
place. This patch cleans up some of those uses, in particular ones in
the same code as the robustness changes, and code called by that code.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* namet.ads, namet.adb (Write_Name_For_Debug): New more-robust
version of Write_Name.
(Destroy_Global_Name_Buffer): New procedure to help detect bugs
related to use of Global_Name_Buffer. Misc cleanup and comment
improvements. E.g. we don't need to document every detail of
debugging printouts, especially since they can change.
* uname.ads, uname.adb (Write_Unit_Name_For_Debug): New
more-robust version of Write_Unit_Name.
(Get_Unit_Name_String): Pass buffer in, instead of using the
global variable. Misc cleanup. Remove the "special fudge", which
is apparently not needed, and anyway the comment "the %s or %b
has already been eliminated" seems wrong.
(Write_Unit_Name): Call the new version of Get_Unit_Name_String.
* errout.adb (Set_Msg_Insertion_Unit_Name): Call the new version
of Get_Unit_Name_String. We pass the global variable here,
because it's too much trouble to disentangle such uses in
Errout.
* sem_util.ads, sem_util.adb, sem_dist.adb
(Get_Library_Unit_Name): New version of
Get_Library_Unit_Name_String that avoids usage of the global
variable.
* casing.ads, casing.adb, exp_prag.adb, exp_util.adb
(Set_All_Upper_Case): Remove. There is no need for a wrapper
here -- code is clearer without it.
* treepr.adb (Print_Name): Call Write_Name_For_Debug, which
deals with No_Name (etc), rather than duplicating that here.
Note that the call to Get_Name_String was superfluous.
(Tree_Dump): Call Write_Unit_Name_For_Debug instead of
Write_Unit_Name, which crashes if not Is_Valid_Name.
* erroutc.ads: Improve comments.
* erroutc.adb (Set_Msg_Name_Buffer): Call
Destroy_Global_Name_Buffer to detect potential bugs where it
incorrectly looks at the global variable.
* sinput.adb (Write_Location): Call Write_Name_For_Debug instead
of Write_Name, so it won't blow up on invalid data.
* sinput.ads: Improve comments; remove some verbosity.
* libgnat/s-imagef.adb: Fix typo in comment.diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb
--- a/gcc/ada/casing.adb
+++ b/gcc/ada/casing.adb
@@ -105,15 +105,6 @@ package body Casing is
end if;
end Determine_Casing;
- ------------------------
- -- Set_All_Upper_Case --
- ------------------------
-
- procedure Set_All_Upper_Case is
- begin
- Set_Casing (All_Upper_Case);
- end Set_All_Upper_Case;
-
----------------
-- Set_Casing --
----------------
diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads
--- a/gcc/ada/casing.ads
+++ b/gcc/ada/casing.ads
@@ -78,12 +78,6 @@ package Casing is
procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case);
-- Uses Buf => Global_Name_Buffer
- procedure Set_All_Upper_Case;
- pragma Inline (Set_All_Upper_Case);
- -- This procedure is called with an identifier name stored in Name_Buffer.
- -- On return, the identifier is converted to all upper case. The call is
- -- equivalent to Set_Casing (All_Upper_Case).
-
function Determine_Casing (Ident : Text_Buffer) return Casing_Type;
-- Determines the casing of the identifier/keyword string Ident. A special
-- test is made for SPARK_Mode which is considered to be mixed case, since
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -3760,7 +3760,7 @@ package body Errout is
Set_Msg_Str ("<error>");
else
- Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
+ Get_Unit_Name_String (Global_Name_Buffer, Error_Msg_Unit_1, Suffix);
Set_Msg_Blank;
Set_Msg_Quote;
Set_Msg_Name_Buffer;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -1468,6 +1468,7 @@ package body Erroutc is
procedure Set_Msg_Name_Buffer is
begin
Set_Msg_Str (Name_Buffer (1 .. Name_Len));
+ Destroy_Global_Name_Buffer;
end Set_Msg_Name_Buffer;
-------------------
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -23,7 +23,7 @@
-- --
------------------------------------------------------------------------------
--- This packages contains global variables and routines common to error
+-- This package contains global variables and routines common to error
-- reporting packages, including Errout and Prj.Err.
with Table;
@@ -617,8 +617,8 @@ package Erroutc is
-- buffer with no leading zeroes output.
procedure Set_Msg_Name_Buffer;
- -- Output name from Name_Buffer, with surrounding quotes unless manual
- -- quotation mode is in effect.
+ -- Output name from Namet.Global_Name_Buffer, with surrounding quotes
+ -- unless manual quotation mode is in effect.
procedure Set_Msg_Quote;
-- Set quote if in normal quote mode, nothing if in manual quote mode
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -605,14 +605,14 @@ package body Exp_Prag is
Get_Name_String (Chars (External));
end if;
- Set_All_Upper_Case;
+ Set_Casing (All_Upper_Case);
Psect :=
Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
else
Get_Name_String (Chars (Internal));
- Set_All_Upper_Case;
+ Set_Casing (All_Upper_Case);
Psect :=
Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
end if;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6699,7 +6699,7 @@ package body Exp_Util is
-- Generates the entity name in upper case
Get_Decoded_Name_String (Chars (Ent));
- Set_All_Upper_Case;
+ Set_Casing (All_Upper_Case);
Store_String_Chars (Name_Buffer (1 .. Name_Len));
return;
end Internal_Full_Qualified_Name;
diff --git a/gcc/ada/libgnat/s-imagef.adb b/gcc/ada/libgnat/s-imagef.adb
--- a/gcc/ada/libgnat/s-imagef.adb
+++ b/gcc/ada/libgnat/s-imagef.adb
@@ -174,7 +174,7 @@ package body System.Image_F is
-- operation are omitted here.
-- A 64-bit value can represent all integers with 18 decimal digits, but
- -- not all with 19 decimal digits. If the total number of requested ouput
+ -- not all with 19 decimal digits. If the total number of requested output
-- digits (Fore - 1) + Aft is greater than 18 then, for purposes of the
-- conversion, Aft is adjusted to 18 - (Fore - 1). In that case, trailing
-- zeros can complete the output after writing the first 18 significant
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -170,39 +170,39 @@ package body Namet is
(Buf : in out Bounded_String;
Id : Valid_Name_Id)
is
- C : Character;
- P : Natural;
Temp : Bounded_String;
+ function Has_Encodings (Temp : Bounded_String) return Boolean;
+ -- True if Temp contains encoded characters. If not, we can set
+ -- Name_Has_No_Encodings to True below, and never call this again
+ -- on the same Name_Id.
+
+ function Has_Encodings (Temp : Bounded_String) return Boolean is
+ begin
+ for J in 1 .. Temp.Length loop
+ if Temp.Chars (J) in 'U' | 'W' | 'Q' | 'O' then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Has_Encodings;
+
begin
Append (Temp, Id);
- -- Skip scan if we already know there are no encodings
+ -- Skip scan if we already know there are no encodings (i.e. the first
+ -- time this was called on Id, the Has_Encodings call below returned
+ -- False).
if Name_Entries.Table (Id).Name_Has_No_Encodings then
goto Done;
end if;
- -- Quick loop to see if there is anything special to do
-
- P := 1;
- loop
- if P = Temp.Length then
- Name_Entries.Table (Id).Name_Has_No_Encodings := True;
- goto Done;
-
- else
- C := Temp.Chars (P);
-
- exit when
- C = 'U' or else
- C = 'W' or else
- C = 'Q' or else
- C = 'O';
-
- P := P + 1;
- end if;
- end loop;
+ if not Has_Encodings (Temp) then
+ Name_Entries.Table (Id).Name_Has_No_Encodings := True;
+ goto Done;
+ end if;
-- Here we have at least some encoding that we must decode
@@ -235,8 +235,7 @@ package body Namet is
if C = 'U'
and then Old < Temp.Length
- and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
- and then Temp.Chars (Old + 1) /= '_'
+ and then Temp.Chars (Old + 1) not in 'A' .. 'Z' | '_'
then
Old := Old + 1;
@@ -274,8 +273,7 @@ package body Namet is
elsif C = 'W'
and then Old < Temp.Length
- and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
- and then Temp.Chars (Old + 1) /= '_'
+ and then Temp.Chars (Old + 1) not in 'A' .. 'Z' | '_'
then
Old := Old + 1;
Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
@@ -301,7 +299,7 @@ package body Namet is
C := Temp.Chars (Old);
Old := Old + 1;
- pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
+ pragma Assert (C in '0' .. '9' | 'a' .. 'f');
if C <= '9' then
T := 16 * T + Character'Pos (C) - Character'Pos ('0');
@@ -347,8 +345,7 @@ package body Namet is
elsif Temp.Chars (Old) = 'O'
and then Old < Temp.Length
- and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
- and then Temp.Chars (Old + 1) /= '_'
+ and then Temp.Chars (Old + 1) not in 'A' .. 'Z' | '_'
then
Old := Old + 1;
@@ -501,8 +498,7 @@ package body Namet is
elsif Temp.Chars (P) = 'W'
and then P + 9 <= Temp.Length
and then Temp.Chars (P + 1) = 'W'
- and then Temp.Chars (P + 2) not in 'A' .. 'Z'
- and then Temp.Chars (P + 2) /= '_'
+ and then Temp.Chars (P + 2) not in 'A' .. 'Z' | '_'
then
Temp.Chars (P + 12 .. Temp.Length + 2) :=
Temp.Chars (P + 10 .. Temp.Length);
@@ -517,8 +513,7 @@ package body Namet is
elsif Temp.Chars (P) = 'W'
and then P < Temp.Length
- and then Temp.Chars (P + 1) not in 'A' .. 'Z'
- and then Temp.Chars (P + 1) /= '_'
+ and then Temp.Chars (P + 1) not in 'A' .. 'Z' | '_'
then
Temp.Chars (P + 8 .. P + Temp.Length + 3) :=
Temp.Chars (P + 5 .. Temp.Length);
@@ -571,7 +566,7 @@ package body Namet is
declare
CC : constant Character := Get_Character (C);
begin
- if CC in 'a' .. 'z' or else CC in '0' .. '9' then
+ if CC in 'a' .. 'z' | '0' .. '9' then
Buf.Chars (Buf.Length) := CC;
else
Buf.Chars (Buf.Length) := 'U';
@@ -625,6 +620,25 @@ package body Namet is
Append (Buf, Temp);
end Append_Unqualified_Decoded;
+ --------------------------------
+ -- Destroy_Global_Name_Buffer --
+ --------------------------------
+
+ procedure Destroy_Global_Name_Buffer is
+ procedure Do_It;
+ -- Do the work. Needed only for "pragma Debug" below, so we don't do
+ -- anything in production mode.
+
+ procedure Do_It is
+ begin
+ Global_Name_Buffer.Length := Global_Name_Buffer.Max_Length;
+ Global_Name_Buffer.Chars := (others => '!');
+ end Do_It;
+ pragma Debug (Do_It);
+ begin
+ null;
+ end Destroy_Global_Name_Buffer;
+
--------------
-- Finalize --
--------------
@@ -990,9 +1004,7 @@ package body Namet is
begin
-- Any name starting or ending with underscore is internal
- if Buf.Chars (1) = '_'
- or else Buf.Chars (Buf.Length) = '_'
- then
+ if Buf.Chars (1) = '_' or else Buf.Chars (Buf.Length) = '_' then
return True;
-- Allow quoted character
@@ -1059,12 +1071,7 @@ package body Namet is
function Is_OK_Internal_Letter (C : Character) return Boolean is
begin
- return C in 'A' .. 'Z'
- and then C /= 'O'
- and then C /= 'Q'
- and then C /= 'U'
- and then C /= 'W'
- and then C /= 'X';
+ return C in 'A' .. 'Z' and then C not in 'O' | 'Q' | 'U' | 'W' | 'X';
end Is_OK_Internal_Letter;
----------------------
@@ -1450,9 +1457,7 @@ package body Namet is
exit;
end if;
- exit when Buf.Chars (J) /= 'b'
- and then Buf.Chars (J) /= 'n'
- and then Buf.Chars (J) /= 'p';
+ exit when Buf.Chars (J) not in 'b' | 'n' | 'p';
end loop;
-- Find rightmost __ or $ separator if one exists. First we position
@@ -1535,25 +1540,7 @@ package body Namet is
procedure wn (Id : Name_Id) is
begin
- if Is_Valid_Name (Id) then
- declare
- Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
- begin
- Append (Buf, Id);
- Write_Str (Buf.Chars (1 .. Buf.Length));
- end;
-
- elsif Id = No_Name then
- Write_Str ("<No_Name>");
-
- elsif Id = Error_Name then
- Write_Str ("<Error_Name>");
-
- else
- Write_Str ("<invalid name_id>");
- Write_Int (Int (Id));
- end if;
-
+ Write_Name_For_Debug (Id);
Write_Eol;
end wn;
@@ -1579,6 +1566,33 @@ package body Namet is
Write_Str (Buf.Chars (1 .. Buf.Length));
end Write_Name_Decoded;
+ --------------------------
+ -- Write_Name_For_Debug --
+ --------------------------
+
+ procedure Write_Name_For_Debug (Id : Name_Id) is
+ begin
+ if Is_Valid_Name (Id) then
+ declare
+ Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
+ begin
+ Append (Buf, Id);
+ Write_Str (Buf.Chars (1 .. Buf.Length));
+ end;
+
+ elsif Id = No_Name then
+ Write_Str ("<No_Name>");
+
+ elsif Id = Error_Name then
+ Write_Str ("<Error_Name>");
+
+ else
+ Write_Str ("<invalid name ");
+ Write_Int (Int (Id));
+ Write_Str (">");
+ end if;
+ end Write_Name_For_Debug;
+
-- Package initialization, initialize tables
begin
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -166,6 +166,11 @@ package Namet is
-- does a save/restore on Name_Len and Name_Buffer (1 .. Name_Len). This
-- works in part because Name_Len is default-initialized to 0.
+ procedure Destroy_Global_Name_Buffer with Inline;
+ -- Overwrites Global_Name_Buffer with meaningless data. This can be used in
+ -- the transition away from Global_Name_Buffer, in order to detect cases
+ -- where we incorrectly rely on the global.
+
-----------------------------
-- Types for Namet Package --
-----------------------------
@@ -422,12 +427,16 @@ package Namet is
-- Write_Name writes the characters of the specified name using the
-- standard output procedures in package Output. The name is written
-- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in
- -- the name table). If Id is Error_Name, or No_Name, no text is output.
+ -- the name table). If Id is Error_Name or No_Name, no text is output.
procedure Write_Name_Decoded (Id : Valid_Name_Id);
-- Like Write_Name, except that the name written is the decoded name, as
-- described for Append_Decoded.
+ procedure Write_Name_For_Debug (Id : Name_Id);
+ -- Like Write_Name, except it tries to be robust in the presence of invalid
+ -- data.
+
function Name_Entries_Count return Nat;
-- Return current number of entries in the names table
@@ -537,14 +546,8 @@ package Namet is
procedure wn (Id : Name_Id);
pragma Export (Ada, wn);
- -- This routine is intended for debugging use only (i.e. it is intended to
- -- be called from the debugger). It writes the characters of the specified
- -- name using the standard output procedures in package Output, followed by
- -- a new line. The name is written in encoded form (i.e. including Uhh,
- -- Whhh, Qx, _op as they appear in the name table). If Id is Error_Name,
- -- No_Name, or invalid an appropriate string is written (<Error_Name>,
- -- <No_Name>, <invalid name>). Unlike Write_Name, this call does not affect
- -- the contents of Name_Buffer or Name_Len.
+ -- Write Id to standard output, followed by a newline. Intended to be
+ -- called in the debugger.
private
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
--- a/gcc/ada/sem_dist.adb
+++ b/gcc/ada/sem_dist.adb
@@ -394,11 +394,10 @@ package body Sem_Dist is
(RTE (RE_Get_Local_Partition_Id), Loc);
end if;
- -- Get and store the String_Id corresponding to the name of the
- -- library unit whose Partition_Id is needed.
+ -- Get the String_Id corresponding to the name of the library unit whose
+ -- Partition_Id is needed.
- Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
- Prefix_String := String_From_Name_Buffer;
+ Prefix_String := Get_Library_Unit_Name (Unit_Declaration_Node (Ety));
-- Build the function call which will replace the attribute
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -11390,21 +11390,23 @@ package body Sem_Util is
end if;
end Get_Iterable_Type_Primitive;
- ----------------------------------
- -- Get_Library_Unit_Name_String --
- ----------------------------------
+ ---------------------------
+ -- Get_Library_Unit_Name --
+ ---------------------------
- procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
+ function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id is
Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
-
+ Buf : Bounded_String;
begin
- Get_Unit_Name_String (Unit_Name_Id);
+ Get_Unit_Name_String (Buf, Unit_Name_Id);
+
+ -- Remove the last seven characters (" (spec)" or " (body)")
- -- Remove seven last character (" (spec)" or " (body)")
+ Buf.Length := Buf.Length - 7;
+ pragma Assert (Buf.Chars (Buf.Length + 1) = ' ');
- Name_Len := Name_Len - 7;
- pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
- end Get_Library_Unit_Name_String;
+ return String_From_Name_Buffer (Buf);
+ end Get_Library_Unit_Name;
--------------------------
-- Get_Max_Queue_Length --
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1258,9 +1258,8 @@ package Sem_Util is
-- Retrieve one of the primitives First, Last, Next, Previous, Has_Element,
-- Element from the value of the Iterable aspect of a type.
- procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id);
- -- Retrieve the fully expanded name of the library unit declared by
- -- Decl_Node into the name buffer.
+ function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id;
+ -- Return the full expanded name of the library unit declared by Decl_Node
function Get_Max_Queue_Length (Id : Entity_Id) return Uint;
-- Return the argument of pragma Max_Queue_Length or zero if the annotation
diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
--- a/gcc/ada/sinput.adb
+++ b/gcc/ada/sinput.adb
@@ -1023,7 +1023,7 @@ package body Sinput is
SI : constant Source_File_Index := Get_Source_File_Index (P);
begin
- Write_Name (Debug_Source_Name (SI));
+ Write_Name_For_Debug (Debug_Source_Name (SI));
Write_Char (':');
Write_Int (Int (Get_Logical_Line_Number (P)));
Write_Char (':');
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -693,14 +693,11 @@ package Sinput is
-- names in some situations.
procedure Write_Location (P : Source_Ptr);
- -- Writes out a string of the form fff:nn:cc, where fff, nn, cc are the
- -- file name, line number and column corresponding to the given source
- -- location. No_Location and Standard_Location appear as the strings
- -- <no location> and <standard location>. If the location is within an
- -- instantiation, then the instance location is appended, enclosed in
- -- square brackets (which can nest if necessary). Note that this routine
- -- is used only for internal compiler debugging output purposes (which
- -- is why the somewhat cryptic use of brackets is acceptable).
+ -- Writes P, in the form fff:nn:cc, where fff, nn, cc are the file name,
+ -- line number and column corresponding to the given source location. If
+ -- the location is within an instantiation, then the instance location is
+ -- appended, enclosed in square brackets, which can nest if necessary. This
+ -- is used only for debugging output.
procedure wl (P : Source_Ptr);
pragma Export (Ada, wl);
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -1142,21 +1142,7 @@ package body Treepr is
procedure Print_Name (N : Name_Id) is
begin
if Phase = Printing then
- if N = No_Name then
- Print_Str ("<No_Name>");
-
- elsif N = Error_Name then
- Print_Str ("<Error_Name>");
-
- elsif Is_Valid_Name (N) then
- Get_Name_String (N);
- Print_Char ('"');
- Write_Name (N);
- Print_Char ('"');
-
- else
- Print_Str ("<invalid name>");
- end if;
+ Write_Name_For_Debug (N);
end if;
end Print_Name;
@@ -1878,7 +1864,7 @@ package body Treepr is
Write_Eol;
Write_Str ("Tree created for ");
- Write_Unit_Name (Unit_Name (Main_Unit));
+ Write_Unit_Name_For_Debug (Unit_Name (Main_Unit));
Underline;
Print_Node_Subtree (Cunit (Main_Unit));
Write_Eol;
diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb
--- a/gcc/ada/uname.adb
+++ b/gcc/ada/uname.adb
@@ -411,51 +411,42 @@ package body Uname is
--------------------------
procedure Get_Unit_Name_String
- (N : Unit_Name_Type;
+ (Buf : in out Bounded_String;
+ N : Unit_Name_Type;
Suffix : Boolean := True)
is
- Unit_Is_Body : Boolean;
-
begin
- Get_Decoded_Name_String (N);
- Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
- Set_Casing (Identifier_Casing (Source_Index (Main_Unit)));
-
- -- A special fudge, normally we don't have operator symbols present,
- -- since it is always an error to do so. However, if we do, at this
- -- stage it has the form:
+ Buf.Length := 0;
+ Append_Decoded (Buf, N);
- -- "and"
+ -- Buf always ends with "%s" or "%b", which we either remove, or replace
+ -- with " (spec)" or " (body)". Set_Casing of Buf after checking for
+ -- (lower case) 's'/'b', and before appending (lower case) "spec" or
+ -- "body".
- -- and the %s or %b has already been eliminated so put 2 chars back
+ pragma Assert (Buf.Length >= 3);
+ pragma Assert (Buf.Chars (1) /= '"');
+ pragma Assert (Buf.Chars (Buf.Length) in 's' | 'b');
- if Name_Buffer (1) = '"' then
- Name_Len := Name_Len + 2;
- end if;
-
- -- Now adjust the %s or %b to (spec) or (body)
+ declare
+ S : constant String :=
+ (if Buf.Chars (Buf.Length) = 's' then " (spec)" else " (body)");
+ begin
+ Buf.Length := Buf.Length - 1; -- remove 's' or 'b'
+ pragma Assert (Buf.Chars (Buf.Length) = '%');
+ Buf.Length := Buf.Length - 1; -- remove '%'
+ Set_Casing (Buf, Identifier_Casing (Source_Index (Main_Unit)));
- if Suffix then
- if Unit_Is_Body then
- Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
- else
- Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
+ if Suffix then
+ Append (Buf, S);
end if;
- end if;
+ end;
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '-' then
- Name_Buffer (J) := '.';
+ for J in 1 .. Buf.Length loop
+ if Buf.Chars (J) = '-' then
+ Buf.Chars (J) := '.';
end if;
end loop;
-
- -- Adjust Name_Len
-
- if Suffix then
- Name_Len := Name_Len + (7 - 2);
- else
- Name_Len := Name_Len - 2;
- end if;
end Get_Unit_Name_String;
----------------
@@ -721,9 +712,23 @@ package body Uname is
---------------------
procedure Write_Unit_Name (N : Unit_Name_Type) is
+ Buf : Bounded_String;
begin
- Get_Unit_Name_String (N);
- Write_Str (Name_Buffer (1 .. Name_Len));
+ Get_Unit_Name_String (Buf, N);
+ Write_Str (Buf.chars (1 .. Buf.Length));
end Write_Unit_Name;
+ -------------------------------
+ -- Write_Unit_Name_For_Debug --
+ -------------------------------
+
+ procedure Write_Unit_Name_For_Debug (N : Unit_Name_Type) is
+ begin
+ if Is_Valid_Name (N) then
+ Write_Unit_Name (N);
+ else
+ Write_Name_For_Debug (N);
+ end if;
+ end Write_Unit_Name_For_Debug;
+
end Uname;
diff --git a/gcc/ada/uname.ads b/gcc/ada/uname.ads
--- a/gcc/ada/uname.ads
+++ b/gcc/ada/uname.ads
@@ -57,7 +57,7 @@ package Uname is
-- For display purposes, unit names are printed out with the suffix
-- " (body)" for a body and " (spec)" for a spec. These formats are
- -- used for the Write_Unit_Name and Get_Unit_Name_String subprograms.
+ -- used for Write_Unit_Name and Get_Unit_Name_String.
-----------------
-- Subprograms --
@@ -111,13 +111,11 @@ package Uname is
-- N_Subunit
procedure Get_Unit_Name_String
- (N : Unit_Name_Type;
+ (Buf : in out Bounded_String;
+ N : Unit_Name_Type;
Suffix : Boolean := True);
- -- Places the display name of the unit in Name_Buffer and sets Name_Len to
- -- the length of the stored name, i.e. it uses the same interface as the
- -- Get_Name_String routine in the Namet package. The name is decoded and
- -- contains an indication of spec or body if Boolean parameter Suffix is
- -- True.
+ -- Puts the display name for N in Buf. The name is decoded and contains an
+ -- indication of spec or body if Suffix is True.
function Is_Body_Name (N : Unit_Name_Type) return Boolean;
-- Returns True iff the given name is the unit name of a body (i.e. if
@@ -161,7 +159,7 @@ package Uname is
-- result = A.R.C (body)
--
-- See spec of Load_Unit for extensive discussion of why this routine
- -- needs to be used (the call in the body of Load_Unit is the only one).
+ -- needs to be used (the calls in Load_Unit are the only ones).
function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean;
function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean;
@@ -175,8 +173,10 @@ package Uname is
-- are the same, they always have the same Name_Id value.
procedure Write_Unit_Name (N : Unit_Name_Type);
- -- Given a unit name, this procedure writes the display name to the
- -- standard output file. Name_Buffer and Name_Len are set as described
- -- above for the Get_Unit_Name_String call on return.
+ -- Writes the display form of N to standard output
+
+ procedure Write_Unit_Name_For_Debug (N : Unit_Name_Type);
+ -- Like Write_Unit_Name, except it tries to be robust in the presence of
+ -- invalid data.
end Uname;
