From 3b4ae9b98b07764b074110ba7215428df9efe320 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 10 Feb 2022 14:55:32 -0500 Subject: [PATCH] [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. --- 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 1df58779bffa..6d2f2f495030 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 24e3ef670f80..df042db48abf 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 44d461f315b1..bc7c7d32db36 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3760,7 +3760,7 @@ package body Errout is Set_Msg_Str (""); 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 d92ca334acd8..866294ee64b4 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 d4d4443e6335..eaac7dc61571 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 70b16c866d44..27ea708f64d0 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 cd0dd4950d66..e590751a15f1 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 1007adc085dc..fd8e848438ed 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 e8162e49c122..7eb2f0eeba24 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 (""); - - elsif Id = Error_Name then - Write_Str (""); - - else - Write_Str (""); - 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 (""); + + elsif Id = Error_Name then + Write_Str (""); + + else + 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 87fc65e697ad..5342e5d58261 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 (, - -- , ). 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 ea9c7ef71336..310940832ff4 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 d3b8eacadf1a..20253bd76167 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 caa28eb60157..e376c332f2bd 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 4df735c2ccf2..ccc4a7ad4fb8 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 2890563daa30..af2fec74cf4d 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 - -- and . 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 3173668d82a7..dda500dc6947 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 (""); - - elsif N = Error_Name then - Print_Str (""); - - elsif Is_Valid_Name (N) then - Get_Name_String (N); - Print_Char ('"'); - Write_Name (N); - Print_Char ('"'); - - else - Print_Str (""); - 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 82bc7dcc7cc2..60ef2b6686a3 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 3f9aabe3352a..35d62a214b85 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; -- 2.47.2