public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-361] [Ada] Make debug printouts more robust
@ 2022-05-12 12:41 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-12 12:41 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:3b4ae9b98b07764b074110ba7215428df9efe320
commit r13-361-g3b4ae9b98b07764b074110ba7215428df9efe320
Author: Bob Duff <duff@adacore.com>
Date: Thu Feb 10 14:55:32 2022 -0500
[Ada] Make debug printouts more robust
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.
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:
---
gcc/ada/casing.adb | 9 ---
gcc/ada/casing.ads | 6 --
gcc/ada/errout.adb | 2 +-
gcc/ada/erroutc.adb | 1 +
gcc/ada/erroutc.ads | 6 +-
gcc/ada/exp_prag.adb | 4 +-
gcc/ada/exp_util.adb | 2 +-
gcc/ada/libgnat/s-imagef.adb | 2 +-
gcc/ada/namet.adb | 146 ++++++++++++++++++++++++-------------------
gcc/ada/namet.ads | 21 ++++---
gcc/ada/sem_dist.adb | 7 +--
gcc/ada/sem_util.adb | 22 ++++---
gcc/ada/sem_util.ads | 5 +-
gcc/ada/sinput.adb | 2 +-
gcc/ada/sinput.ads | 13 ++--
gcc/ada/treepr.adb | 18 +-----
gcc/ada/uname.adb | 77 ++++++++++++-----------
gcc/ada/uname.ads | 22 +++----
18 files changed, 178 insertions(+), 187 deletions(-)
diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb
index 1df58779bff..6d2f2f49503 100644
--- 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
index 24e3ef670f8..df042db48ab 100644
--- 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
index 44d461f315b..bc7c7d32db3 100644
--- 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
index d92ca334acd..866294ee64b 100644
--- 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
index d4d4443e633..eaac7dc6157 100644
--- 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
index 70b16c866d4..27ea708f64d 100644
--- 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
index cd0dd4950d6..e590751a15f 100644
--- 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
index 1007adc085d..fd8e848438e 100644
--- 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
index e8162e49c12..7eb2f0eeba2 100644
--- 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
index 87fc65e697a..5342e5d5826 100644
--- 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
index ea9c7ef7133..310940832ff 100644
--- 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
index d3b8eacadf1..20253bd7616 100644
--- 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
index caa28eb6015..e376c332f2b 100644
--- 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
index 4df735c2ccf..ccc4a7ad4fb 100644
--- 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
index 2890563daa3..af2fec74cf4 100644
--- 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
index 3173668d82a..dda500dc694 100644
--- 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
index 82bc7dcc7cc..60ef2b6686a 100644
--- 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
index 3f9aabe3352..35d62a214b8 100644
--- 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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-12 12:41 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-12 12:41 [gcc r13-361] [Ada] Make debug printouts more robust Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).