diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/casing.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/casing.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/erroutc.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_prag.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-imagef.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 146 | ||||
| -rw-r--r-- | gcc/ada/namet.ads | 21 | ||||
| -rw-r--r-- | gcc/ada/sem_dist.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/sinput.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sinput.ads | 13 | ||||
| -rw-r--r-- | gcc/ada/treepr.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/uname.adb | 77 | ||||
| -rw-r--r-- | 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 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; |