[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.

18 files changed, 178 insertions, 187 deletions

diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb
index 1df5877..6d2f2f4 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 24e3ef6..df042db 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 44d461f..bc7c7d3 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 d92ca33..866294e 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 d4d4443..eaac7dc 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 70b16c8..27ea708 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 cd0dd49..e590751 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 1007adc..fd8e848 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 e8162e4..7eb2f0e 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 87fc65e..5342e5d 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 ea9c7ef..3109408 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 d3b8eac..20253bd 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 caa28eb..e376c33 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 4df735c..ccc4a7a 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 2890563..af2fec7 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 3173668..dda500d 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 82bc7dc..60ef2b6 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 3f9aabe..35d62a2 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;