diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 41 | ||||
| -rw-r--r-- | gcc/ada/casing.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/casing.ads | 23 | ||||
| -rw-r--r-- | gcc/ada/errout.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/errout.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/erroutc.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 281 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/lib-xref-spark_specific.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 207 | ||||
| -rw-r--r-- | gcc/ada/namet.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/stringt.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/stringt.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/uname.adb | 4 |
17 files changed, 421 insertions, 328 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a8a6f5c..4dd3d36 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2016-04-18 Bob Duff <duff@adacore.com> + + * sem_ch6.adb (Is_Inline_Pragma): The pragma + argument can be a selected component, which has no Chars field, + so we need to deal with that case (use the Selector_Name). + (Check_Inline_Pragma): We need to test Is_List_Member before + calling In_Same_List, because in case of a library unit, they're + not in lists, so In_Same_List fails an assertion. + +2016-04-18 Bob Duff <duff@adacore.com> + + * namet.ads, namet.adb: Add an Append that appends a + Bounded_String onto a Bounded_String. Probably a little more + efficient than "Append(X, +Y);". Also minor cleanup. + (Append_Decoded, Append_Decoded_With_Brackets, Append_Unqualified, + Append_Unqualified_Decoded): Make sure these work with non-empty + buffers. + * casing.ads, casing.adb (Set_Casing): Pass a Bounded_String + parameter, defaulting to Global_Name_Buffer. + * errout.ads, errout.adb (Adjust_Name_Case): Pass a + Bounded_String parameter, no default. + * exp_ch11.adb (Expand_N_Raise_Statement): Use local + Bounded_String instead of Global_Name_Buffer. + * exp_intr.ads, exp_intr.adb (Write_Entity_Name): Rename it + to Append_Entity_Name, and pass a Bounded_String parameter, + instead of using globals. + (Add_Source_Info): Pass a Bounded_String parameter, instead of + using globals. + (Expand_Source_Info): Use local instead of globals. + * stringt.ads, stringt.adb (Append): Add an Append procedure + for appending a String_Id onto a Bounded_String. + (String_To_Name_Buffer, Add_String_To_Name_Buffer): Rewrite in + terms of Append. + * sem_prag.adb (Set_Error_Msg_To_Profile_Name): Adjust for new + Adjust_Name_Case parameter. + * erroutc.adb, uname.adb: Don't pass D => Mixed_Case to + Set_Casing; that's the default. + * lib-xref-spark_specific.adb (Add_SPARK_Scope): Pretend that calls to + protected subprograms are entry calls; otherwise it is not possible to + distinguish them from regular subprogram calls. + 2016-04-18 Gary Dismukes <dismukes@adacore.com> * sem_ch13.adb (Has_Good_Profile): Improvement diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb index 5ed97be..d61112e 100644 --- a/gcc/ada/casing.adb +++ b/gcc/ada/casing.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,7 +30,6 @@ ------------------------------------------------------------------------------ with Csets; use Csets; -with Namet; use Namet; with Opt; use Opt; with Widechar; use Widechar; @@ -125,7 +124,11 @@ package body Casing is -- Set_Casing -- ---------------- - procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is + procedure Set_Casing + (Buf : in out Bounded_String; + C : Casing_Type; + D : Casing_Type := Mixed_Case) + is Ptr : Natural; Actual_Casing : Casing_Type; @@ -144,7 +147,7 @@ package body Casing is Ptr := 1; - while Ptr <= Name_Len loop + while Ptr <= Buf.Length loop -- Wide character. Note that we do nothing with casing in this case. -- In Ada 2005 mode, required folding of lower case letters happened @@ -156,29 +159,29 @@ package body Casing is -- the requested casing operation, beyond folding to upper case -- when it is mandatory, which does not involve underscores. - if Name_Buffer (Ptr) = ASCII.ESC - or else Name_Buffer (Ptr) = '[' + if Buf.Chars (Ptr) = ASCII.ESC + or else Buf.Chars (Ptr) = '[' or else (Upper_Half_Encoding - and then Name_Buffer (Ptr) in Upper_Half_Character) + and then Buf.Chars (Ptr) in Upper_Half_Character) then - Skip_Wide (Name_Buffer, Ptr); + Skip_Wide (Buf.Chars, Ptr); After_Und := False; -- Underscore, or non-identifer character (error case) - elsif Name_Buffer (Ptr) = '_' - or else not Identifier_Char (Name_Buffer (Ptr)) + elsif Buf.Chars (Ptr) = '_' + or else not Identifier_Char (Buf.Chars (Ptr)) then After_Und := True; Ptr := Ptr + 1; -- Lower case letter - elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then + elsif Is_Lower_Case_Letter (Buf.Chars (Ptr)) then if Actual_Casing = All_Upper_Case or else (After_Und and then Actual_Casing = Mixed_Case) then - Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr)); + Buf.Chars (Ptr) := Fold_Upper (Buf.Chars (Ptr)); end if; After_Und := False; @@ -186,11 +189,11 @@ package body Casing is -- Upper case letter - elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then + elsif Is_Upper_Case_Letter (Buf.Chars (Ptr)) then if Actual_Casing = All_Lower_Case or else (not After_Und and then Actual_Casing = Mixed_Case) then - Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr)); + Buf.Chars (Ptr) := Fold_Lower (Buf.Chars (Ptr)); end if; After_Und := False; @@ -205,4 +208,9 @@ package body Casing is end loop; end Set_Casing; + procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is + begin + Set_Casing (Global_Name_Buffer, C, D); + end Set_Casing; + end Casing; diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads index dec27ee..e3f7a3a 100644 --- a/gcc/ada/casing.ads +++ b/gcc/ada/casing.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with Namet; use Namet; with Types; use Types; package Casing is @@ -68,14 +69,20 @@ package Casing is -- Case Control Subprograms -- ------------------------------ + procedure Set_Casing + (Buf : in out Bounded_String; + C : Casing_Type; + D : Casing_Type := Mixed_Case); + -- Takes the name stored in Buf and modifies it to be consistent with the + -- casing given by C, or if C = Unknown, then with the casing given by + -- D. The name is basically treated as an identifier, except that special + -- separator characters other than underline are permitted and treated like + -- underlines (this handles cases like minus and period in unit names, + -- apostrophes in error messages, angle brackets in names like <any_type>, + -- etc). + procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case); - -- Takes the name stored in the first Name_Len positions of Name_Buffer - -- and modifies it to be consistent with the casing given by C, or if - -- C = Unknown, then with the casing given by D. The name is basically - -- treated as an identifier, except that special separator characters - -- other than underline are permitted and treated like underlines (this - -- handles cases like minus and period in unit names, apostrophes in error - -- messages, angle brackets in names like <any_type>, etc). + -- Uses Buf => Global_Name_Buffer procedure Set_All_Upper_Case; pragma Inline (Set_All_Upper_Case); diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 7c2a097..db558eb 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2358,7 +2358,10 @@ package body Errout is -- Adjust_Name_Case -- ---------------------- - procedure Adjust_Name_Case (Loc : Source_Ptr) is + procedure Adjust_Name_Case + (Buf : in out Bounded_String; + Loc : Source_Ptr) + is begin -- We have an all lower case name from Namet, and now we want to set -- the appropriate case. If possible we copy the actual casing from @@ -2387,10 +2390,10 @@ package body Errout is Sbuffer := Source_Text (Src_Ind); - while Ref_Ptr <= Name_Len loop + while Ref_Ptr <= Buf.Length loop exit when Fold_Lower (Sbuffer (Src_Ptr)) /= - Fold_Lower (Name_Buffer (Ref_Ptr)); + Fold_Lower (Buf.Chars (Ref_Ptr)); Ref_Ptr := Ref_Ptr + 1; Src_Ptr := Src_Ptr + 1; end loop; @@ -2398,23 +2401,28 @@ package body Errout is -- If we get through the loop without a mismatch, then output the -- name the way it is cased in the source program - if Ref_Ptr > Name_Len then + if Ref_Ptr > Buf.Length then Src_Ptr := Loc; - for J in 1 .. Name_Len loop - Name_Buffer (J) := Sbuffer (Src_Ptr); + for J in 1 .. Buf.Length loop + Buf.Chars (J) := Sbuffer (Src_Ptr); Src_Ptr := Src_Ptr + 1; end loop; -- Otherwise set the casing using the default identifier casing else - Set_Casing (Identifier_Casing (Src_Ind), Mixed_Case); + Set_Casing (Buf, Identifier_Casing (Src_Ind)); end if; end if; end; end Adjust_Name_Case; + procedure Adjust_Name_Case (Loc : Source_Ptr) is + begin + Adjust_Name_Case (Global_Name_Buffer, Loc); + end Adjust_Name_Case; + --------------------------- -- Set_Identifier_Casing -- --------------------------- @@ -2874,7 +2882,7 @@ package body Errout is end if; -- Remaining step is to adjust casing and possibly add 'Class - Adjust_Name_Case (Loc); + Adjust_Name_Case (Global_Name_Buffer, Loc); Set_Msg_Name_Buffer; Add_Class; end Set_Msg_Node; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 7066914..70988b9 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -904,11 +904,17 @@ package Errout is -- Utility Interface for Casing Control -- ------------------------------------------ + procedure Adjust_Name_Case + (Buf : in out Bounded_String; + Loc : Source_Ptr); + -- Given a name stored in Buf, set proper casing. Loc is an associated + -- source position, if we can find a match between the name in Buf and the + -- name at that source location, we copy the casing from the source, + -- otherwise we set appropriate default casing. + procedure Adjust_Name_Case (Loc : Source_Ptr); - -- Given a name stored in Name_Buffer (1 .. Name_Len), set proper casing. - -- Loc is an associated source position, if we can find a match between - -- the name in Name_Buffer and the name at that source location, we copy - -- the casing from the source, otherwise we set appropriate default casing. + -- Uses Buf => Global_Name_Buffer. There are no calls to this in the + -- compiler, but it is called in SPARK2014. procedure Set_Identifier_Casing (Identifier_Name : System.Address; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index d74a3ee..5376aec 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -66,7 +66,7 @@ package body Erroutc is Class_Flag := False; Set_Msg_Char ('''); Get_Name_String (Name_Class); - Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Casing (Identifier_Casing (Flag_Source)); Set_Msg_Name_Buffer; end if; end Add_Class; @@ -1187,7 +1187,7 @@ package body Erroutc is -- Else output with surrounding quotes in proper casing mode else - Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); + Set_Casing (Identifier_Casing (Flag_Source)); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 653007c..0c788de 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1565,13 +1565,15 @@ package body Exp_Ch11 is if Prefix_Exception_Messages and then Nkind (Expression (N)) = N_String_Literal then - Name_Len := 0; - Add_Source_Info (Loc, Name_Enclosing_Entity); - Add_Str_To_Name_Buffer (": "); - Add_String_To_Name_Buffer (Strval (Expression (N))); - Rewrite (Expression (N), - Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len))); - Analyze_And_Resolve (Expression (N), Standard_String); + declare + Buf : Bounded_String; + begin + Add_Source_Info (Buf, Loc, Name_Enclosing_Entity); + Append (Buf, ": "); + Append (Buf, Strval (Expression (N))); + Rewrite (Expression (N), Make_String_Literal (Loc, +Buf)); + Analyze_And_Resolve (Expression (N), Standard_String); + end; end if; -- Avoid passing exception-name'identity in runtimes in which this diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 8b2d1f2..63f6ccb 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -54,7 +54,6 @@ with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; -with Stringt; use Stringt; with Tbuild; use Tbuild; with Uintp; use Uintp; with Urealp; use Urealp; @@ -112,58 +111,51 @@ package body Exp_Intr is -- GNAT.Source_Info; see g-souinf.ads for documentation of these -- intrinsics. - procedure Write_Entity_Name (E : Entity_Id); + procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id); -- Recursive procedure to construct string for qualified name of enclosing -- program unit. The qualification stops at an enclosing scope has no -- source name (block or loop). If entity is a subprogram instance, skip - -- enclosing wrapper package. The name is appended to the current contents - -- of Name_Buffer, incrementing Name_Len. + -- enclosing wrapper package. The name is appended to Buf. --------------------- -- Add_Source_Info -- --------------------- - procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id) is - Ent : Entity_Id; - - Save_NB : constant String := Name_Buffer (1 .. Name_Len); - Save_NL : constant Natural := Name_Len; - -- Save current Name_Buffer contents - + procedure Add_Source_Info + (Buf : in out Bounded_String; + Loc : Source_Ptr; + Nam : Name_Id) + is begin - Name_Len := 0; - - -- Line - case Nam is - when Name_Line => - Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Loc))); + Append (Buf, Nat (Get_Logical_Line_Number (Loc))); when Name_File => - Get_Decoded_Name_String - (Reference_Name (Get_Source_File_Index (Loc))); + Append_Decoded (Buf, Reference_Name (Get_Source_File_Index (Loc))); when Name_Source_Location => - Build_Location_String (Global_Name_Buffer, Loc); + Build_Location_String (Buf, Loc); when Name_Enclosing_Entity => -- Skip enclosing blocks to reach enclosing unit - Ent := Current_Scope; - while Present (Ent) loop - exit when not Ekind_In (Ent, E_Block, E_Loop); - Ent := Scope (Ent); - end loop; + declare + Ent : Entity_Id := Current_Scope; + begin + while Present (Ent) loop + exit when not Ekind_In (Ent, E_Block, E_Loop); + Ent := Scope (Ent); + end loop; - -- Ent now points to the relevant defining entity + -- Ent now points to the relevant defining entity - Write_Entity_Name (Ent); + Append_Entity_Name (Buf, Ent); + end; when Name_Compilation_ISO_Date => - Name_Buffer (1 .. 10) := Opt.Compilation_Time (1 .. 10); - Name_Len := 10; + Append (Buf, Opt.Compilation_Time (1 .. 10)); when Name_Compilation_Date => declare @@ -177,34 +169,117 @@ package body Exp_Intr is MM : constant Natural range 1 .. 12 := (Character'Pos (M1) - Character'Pos ('0')) * 10 + - (Character'Pos (M2) - Character'Pos ('0')); + (Character'Pos (M2) - Character'Pos ('0')); begin -- Reformat ISO date into MMM DD YYYY (__DATE__) format - Name_Buffer (1 .. 3) := Months (MM); - Name_Buffer (4) := ' '; - Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10); - Name_Buffer (7) := ' '; - Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4); - Name_Len := 11; + Append (Buf, Months (MM)); + Append (Buf, ' '); + Append (Buf, Opt.Compilation_Time (9 .. 10)); + Append (Buf, ' '); + Append (Buf, Opt.Compilation_Time (1 .. 4)); end; when Name_Compilation_Time => - Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19); - Name_Len := 8; + Append (Buf, Opt.Compilation_Time (12 .. 19)); when others => raise Program_Error; end case; + end Add_Source_Info; - -- Prepend original Name_Buffer contents + ----------------------- + -- Append_Entity_Name -- + ----------------------- - Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) := - Name_Buffer (1 .. Name_Len); - Name_Buffer (1 .. Save_NL) := Save_NB; - Name_Len := Name_Len + Save_NL; - end Add_Source_Info; + procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is + Temp : Bounded_String; + + procedure Inner (E : Entity_Id); + -- Inner recursive routine, keep outer routine non-recursive to ease + -- debugging when we get strange results from this routine. + + ----------- + -- Inner -- + ----------- + + procedure Inner (E : Entity_Id) is + begin + -- If entity has an internal name, skip by it, and print its scope. + -- Note that we strip a final R from the name before the test, this + -- is needed for some cases of instantiations. + + declare + E_Name : Bounded_String; + + begin + Append (E_Name, Chars (E)); + + if E_Name.Chars (E_Name.Length) = 'R' then + E_Name.Length := E_Name.Length - 1; + end if; + + if Is_Internal_Name (E_Name) then + Inner (Scope (E)); + return; + end if; + end; + + -- Just print entity name if its scope is at the outer level + + if Scope (E) = Standard_Standard then + null; + + -- If scope comes from source, write scope and entity + + elsif Comes_From_Source (Scope (E)) then + Append_Entity_Name (Temp, Scope (E)); + Append (Temp, '.'); + + -- If in wrapper package skip past it + + elsif Is_Wrapper_Package (Scope (E)) then + Append_Entity_Name (Temp, Scope (Scope (E))); + Append (Temp, '.'); + + -- Otherwise nothing to output (happens in unnamed block statements) + + else + null; + end if; + + -- Output the name + + declare + E_Name : Bounded_String; + + begin + Append_Unqualified_Decoded (E_Name, Chars (E)); + + -- Remove trailing upper case letters from the name (useful for + -- dealing with some cases of internal names generated in the case + -- of references from within a generic. + + while E_Name.Length > 1 + and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z' + loop + E_Name.Length := E_Name.Length - 1; + end loop; + + -- Adjust casing appropriately (gets name from source if possible) + + Adjust_Name_Case (E_Name, Sloc (E)); + Append (Temp, E_Name); + end; + end Inner; + + -- Start of processing for Append_Entity_Name + + begin + Inner (E); + Append (Buf, Temp); + end Append_Entity_Name; --------------------------------- -- Expand_Binary_Operator_Call -- @@ -865,12 +940,13 @@ package body Exp_Intr is -- String cases else - Name_Len := 0; - Add_Source_Info (Loc, Nam); - Rewrite (N, - Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); - Analyze_And_Resolve (N, Standard_String); + declare + Buf : Bounded_String; + begin + Add_Source_Info (Buf, Loc, Nam); + Rewrite (N, Make_String_Literal (Loc, Strval => +Buf)); + Analyze_And_Resolve (N, Standard_String); + end; end if; Set_Is_Static_Expression (N); @@ -1401,109 +1477,4 @@ package body Exp_Intr is Analyze (N); end Expand_To_Pointer; - ----------------------- - -- Write_Entity_Name -- - ----------------------- - - procedure Write_Entity_Name (E : Entity_Id) is - - procedure Write_Entity_Name_Inner (E : Entity_Id); - -- Inner recursive routine, keep outer routine non-recursive to ease - -- debugging when we get strange results from this routine. - - ----------------------------- - -- Write_Entity_Name_Inner -- - ----------------------------- - - procedure Write_Entity_Name_Inner (E : Entity_Id) is - begin - -- If entity has an internal name, skip by it, and print its scope. - -- Note that Is_Internal_Name destroys Name_Buffer, hence the save - -- and restore since we depend on its current contents. Note that - -- we strip a final R from the name before the test, this is needed - -- for some cases of instantiations. - - declare - Save_NB : constant String := Name_Buffer (1 .. Name_Len); - Save_NL : constant Natural := Name_Len; - Iname : Boolean; - - begin - Get_Name_String (Chars (E)); - - if Name_Buffer (Name_Len) = 'R' then - Name_Len := Name_Len - 1; - end if; - - Iname := Is_Internal_Name; - - Name_Buffer (1 .. Save_NL) := Save_NB; - Name_Len := Save_NL; - - if Iname then - Write_Entity_Name_Inner (Scope (E)); - return; - end if; - end; - - -- Just print entity name if its scope is at the outer level - - if Scope (E) = Standard_Standard then - null; - - -- If scope comes from source, write scope and entity - - elsif Comes_From_Source (Scope (E)) then - Write_Entity_Name (Scope (E)); - Add_Char_To_Name_Buffer ('.'); - - -- If in wrapper package skip past it - - elsif Is_Wrapper_Package (Scope (E)) then - Write_Entity_Name (Scope (Scope (E))); - Add_Char_To_Name_Buffer ('.'); - - -- Otherwise nothing to output (happens in unnamed block statements) - - else - null; - end if; - - -- Output the name - - declare - Save_NB : constant String := Name_Buffer (1 .. Name_Len); - Save_NL : constant Natural := Name_Len; - - begin - Get_Unqualified_Decoded_Name_String (Chars (E)); - - -- Remove trailing upper case letters from the name (useful for - -- dealing with some cases of internal names generated in the case - -- of references from within a generic. - - while Name_Len > 1 - and then Name_Buffer (Name_Len) in 'A' .. 'Z' - loop - Name_Len := Name_Len - 1; - end loop; - - -- Adjust casing appropriately (gets name from source if possible) - - Adjust_Name_Case (Sloc (E)); - - -- Append to original entry value of Name_Buffer - - Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) := - Name_Buffer (1 .. Name_Len); - Name_Buffer (1 .. Save_NL) := Save_NB; - Name_Len := Save_NL + Name_Len; - end; - end Write_Entity_Name_Inner; - - -- Start of processing for Write_Entity_Name - - begin - Write_Entity_Name_Inner (E); - end Write_Entity_Name; end Exp_Intr; diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads index 5ba0769..693ed5f 100644 --- a/gcc/ada/exp_intr.ads +++ b/gcc/ada/exp_intr.ads @@ -30,12 +30,14 @@ with Types; use Types; package Exp_Intr is - procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id); - -- Append a string to Name_Buffer depending on Nam, which is the name of - -- one of the intrinsics declared in GNAT.Source_Info; see g-souinf.ads for - -- documentation of these intrinsics. The caller must set Name_Buffer and - -- Name_Len before the call. Loc is passed to provide location information - -- where it is needed. + procedure Add_Source_Info + (Buf : in out Bounded_String; + Loc : Source_Ptr; + Nam : Name_Id); + -- Append a string to Buf depending on Nam, which is the name of one of the + -- intrinsics declared in GNAT.Source_Info; see g-souinf.ads for + -- documentation of these intrinsics. Loc is passed to provide location + -- information where it is needed. procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id); -- N is either a function call node, a procedure call statement node, or diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index c857b0f..67e0879 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -261,15 +261,28 @@ package body SPARK_Specific is case Ekind (E) is when E_Entry | E_Entry_Family - | E_Function | E_Generic_Function | E_Generic_Package | E_Generic_Procedure | E_Package - | E_Procedure => Typ := Xref_Entity_Letters (Ekind (E)); + when E_Function + | E_Procedure + => + -- In in SPARK we need to distinguish protected functions and + -- procedures from ordinary subprograms, but there are no special + -- Xref letters for them. Since this distiction is only needed + -- to detect protected calls we pretent that such calls are entry + -- calls. + + if Ekind (Scope (E)) = E_Protected_Type then + Typ := Xref_Entity_Letters (E_Entry); + else + Typ := Xref_Entity_Letters (Ekind (E)); + end if; + when E_Package_Body | E_Subprogram_Body | E_Task_Body => Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E))); diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 4ba68df..9972aa9 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -137,6 +137,11 @@ package body Namet is end loop; end Append; + procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String) is + begin + Append (Buf, Buf2.Chars (1 .. Buf2.Length)); + end Append; + procedure Append (Buf : in out Bounded_String; Id : Name_Id) is pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S : constant Int := Name_Entries.Table (Id).Name_Chars_Index; @@ -154,26 +159,27 @@ package body Namet is procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is C : Character; P : Natural; + Temp : Bounded_String; begin - Append (Buf, Id); + Append (Temp, Id); -- Skip scan if we already know there are no encodings if Name_Entries.Table (Id).Name_Has_No_Encodings then - return; + goto Done; end if; -- Quick loop to see if there is anything special to do P := 1; loop - if P = Buf.Length then + if P = Temp.Length then Name_Entries.Table (Id).Name_Has_No_Encodings := True; - return; + goto Done; else - C := Buf.Chars (P); + C := Temp.Chars (P); exit when C = 'U' or else @@ -190,10 +196,10 @@ package body Namet is Decode : declare New_Len : Natural; Old : Positive; - New_Buf : String (1 .. Buf.Chars'Last); + New_Buf : String (1 .. Temp.Chars'Last); procedure Copy_One_Character; - -- Copy a character from Buf.Chars to New_Buf. Includes case + -- Copy a character from Temp.Chars to New_Buf. Includes case -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it. function Hex (N : Natural) return Word; @@ -210,14 +216,14 @@ package body Namet is C : Character; begin - C := Buf.Chars (Old); + C := Temp.Chars (Old); -- U (upper half insertion case) if C = 'U' - and then Old < Buf.Length - and then Buf.Chars (Old + 1) not in 'A' .. 'Z' - and then Buf.Chars (Old + 1) /= '_' + and then Old < Temp.Length + and then Temp.Chars (Old + 1) not in 'A' .. 'Z' + and then Temp.Chars (Old + 1) /= '_' then Old := Old + 1; @@ -237,8 +243,8 @@ package body Namet is -- WW (wide wide character insertion) elsif C = 'W' - and then Old < Buf.Length - and then Buf.Chars (Old + 1) = 'W' + and then Old < Temp.Length + and then Temp.Chars (Old + 1) = 'W' then Old := Old + 2; Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len); @@ -246,9 +252,9 @@ package body Namet is -- W (wide character insertion) elsif C = 'W' - and then Old < Buf.Length - and then Buf.Chars (Old + 1) not in 'A' .. 'Z' - and then Buf.Chars (Old + 1) /= '_' + and then Old < Temp.Length + and then Temp.Chars (Old + 1) not in 'A' .. 'Z' + and then Temp.Chars (Old + 1) /= '_' then Old := Old + 1; Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len); @@ -271,7 +277,7 @@ package body Namet is begin for J in 1 .. N loop - C := Buf.Chars (Old); + C := Temp.Chars (Old); Old := Old + 1; pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f'); @@ -304,12 +310,12 @@ package body Namet is -- Loop through characters of name - while Old <= Buf.Length loop + while Old <= Temp.Length loop -- Case of character literal, put apostrophes around character - if Buf.Chars (Old) = 'Q' - and then Old < Buf.Length + if Temp.Chars (Old) = 'Q' + and then Old < Temp.Length then Old := Old + 1; Insert_Character ('''); @@ -318,10 +324,10 @@ package body Namet is -- Case of operator name - elsif Buf.Chars (Old) = 'O' - and then Old < Buf.Length - and then Buf.Chars (Old + 1) not in 'A' .. 'Z' - and then Buf.Chars (Old + 1) /= '_' + 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) /= '_' then Old := Old + 1; @@ -362,8 +368,8 @@ package body Namet is J := Map'First; loop - exit when Buf.Chars (Old) = Map (J) - and then Buf.Chars (Old + 1) = Map (J + 1); + exit when Temp.Chars (Old) = Map (J) + and then Temp.Chars (Old + 1) = Map (J + 1); J := J + 4; end loop; @@ -380,8 +386,8 @@ package body Namet is -- Skip past original operator name in input - while Old <= Buf.Length - and then Buf.Chars (Old) in 'a' .. 'z' + while Old <= Temp.Length + and then Temp.Chars (Old) in 'a' .. 'z' loop Old := Old + 1; end loop; @@ -392,8 +398,8 @@ package body Namet is else -- Copy original operator name from input to output - while Old <= Buf.Length - and then Buf.Chars (Old) in 'a' .. 'z' + while Old <= Temp.Length + and then Temp.Chars (Old) in 'a' .. 'z' loop Copy_One_Character; end loop; @@ -411,9 +417,12 @@ package body Namet is -- Copy new buffer as result - Buf.Length := New_Len; - Buf.Chars (1 .. New_Len) := New_Buf (1 .. New_Len); + Temp.Length := New_Len; + Temp.Chars (1 .. New_Len) := New_Buf (1 .. New_Len); end Decode; + + <<Done>> + Append (Buf, Temp); end Append_Decoded; ---------------------------------- @@ -440,67 +449,73 @@ package body Namet is -- Only remaining issue is U/W/WW sequences else - Append (Buf, Id); + declare + Temp : Bounded_String; + begin + Append (Temp, Id); - P := 1; - while P < Buf.Length loop - if Buf.Chars (P + 1) in 'A' .. 'Z' then - P := P + 1; + P := 1; + while P < Temp.Length loop + if Temp.Chars (P + 1) in 'A' .. 'Z' then + P := P + 1; - -- Uhh encoding + -- Uhh encoding - elsif Buf.Chars (P) = 'U' then - for J in reverse P + 3 .. P + Buf.Length loop - Buf.Chars (J + 3) := Buf.Chars (J); - end loop; + elsif Temp.Chars (P) = 'U' then + for J in reverse P + 3 .. P + Temp.Length loop + Temp.Chars (J + 3) := Temp.Chars (J); + end loop; - Buf.Length := Buf.Length + 3; - Buf.Chars (P + 3) := Buf.Chars (P + 2); - Buf.Chars (P + 2) := Buf.Chars (P + 1); - Buf.Chars (P) := '['; - Buf.Chars (P + 1) := '"'; - Buf.Chars (P + 4) := '"'; - Buf.Chars (P + 5) := ']'; - P := P + 6; - - -- WWhhhhhhhh encoding - - elsif Buf.Chars (P) = 'W' - and then P + 9 <= Buf.Length - and then Buf.Chars (P + 1) = 'W' - and then Buf.Chars (P + 2) not in 'A' .. 'Z' - and then Buf.Chars (P + 2) /= '_' - then - Buf.Chars (P + 12 .. Buf.Length + 2) := - Buf.Chars (P + 10 .. Buf.Length); - Buf.Chars (P) := '['; - Buf.Chars (P + 1) := '"'; - Buf.Chars (P + 10) := '"'; - Buf.Chars (P + 11) := ']'; - Buf.Length := Buf.Length + 2; - P := P + 12; - - -- Whhhh encoding - - elsif Buf.Chars (P) = 'W' - and then P < Buf.Length - and then Buf.Chars (P + 1) not in 'A' .. 'Z' - and then Buf.Chars (P + 1) /= '_' - then - Buf.Chars (P + 8 .. P + Buf.Length + 3) := - Buf.Chars (P + 5 .. Buf.Length); - Buf.Chars (P + 2 .. P + 5) := Buf.Chars (P + 1 .. P + 4); - Buf.Chars (P) := '['; - Buf.Chars (P + 1) := '"'; - Buf.Chars (P + 6) := '"'; - Buf.Chars (P + 7) := ']'; - Buf.Length := Buf.Length + 3; - P := P + 8; + Temp.Length := Temp.Length + 3; + Temp.Chars (P + 3) := Temp.Chars (P + 2); + Temp.Chars (P + 2) := Temp.Chars (P + 1); + Temp.Chars (P) := '['; + Temp.Chars (P + 1) := '"'; + Temp.Chars (P + 4) := '"'; + Temp.Chars (P + 5) := ']'; + P := P + 6; + + -- WWhhhhhhhh encoding + + 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) /= '_' + then + Temp.Chars (P + 12 .. Temp.Length + 2) := + Temp.Chars (P + 10 .. Temp.Length); + Temp.Chars (P) := '['; + Temp.Chars (P + 1) := '"'; + Temp.Chars (P + 10) := '"'; + Temp.Chars (P + 11) := ']'; + Temp.Length := Temp.Length + 2; + P := P + 12; + + -- Whhhh encoding + + 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) /= '_' + then + Temp.Chars (P + 8 .. P + Temp.Length + 3) := + Temp.Chars (P + 5 .. Temp.Length); + Temp.Chars (P + 2 .. P + 5) := Temp.Chars (P + 1 .. P + 4); + Temp.Chars (P) := '['; + Temp.Chars (P + 1) := '"'; + Temp.Chars (P + 6) := '"'; + Temp.Chars (P + 7) := ']'; + Temp.Length := Temp.Length + 3; + P := P + 8; - else - P := P + 1; - end if; - end loop; + else + P := P + 1; + end if; + end loop; + + Append (Buf, Temp); + end; end if; end Append_Decoded_With_Brackets; @@ -564,9 +579,11 @@ package body Namet is ------------------------ procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id) is + Temp : Bounded_String; begin - Append (Buf, Id); - Strip_Qualification_And_Suffixes (Buf); + Append (Temp, Id); + Strip_Qualification_And_Suffixes (Temp); + Append (Buf, Temp); end Append_Unqualified; -------------------------------- @@ -577,9 +594,11 @@ package body Namet is (Buf : in out Bounded_String; Id : Name_Id) is + Temp : Bounded_String; begin - Append_Decoded (Buf, Id); - Strip_Qualification_And_Suffixes (Buf); + Append_Decoded (Temp, Id); + Strip_Qualification_And_Suffixes (Temp); + Append (Buf, Temp); end Append_Unqualified_Decoded; -------------- @@ -1625,9 +1644,9 @@ package body Namet is -- To_String -- --------------- - function To_String (X : Bounded_String) return String is + function To_String (Buf : Bounded_String) return String is begin - return X.Chars (1 .. X.Length); + return Buf.Chars (1 .. Buf.Length); end To_String; --------------- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 1d00ee0c..8806364 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -318,8 +318,9 @@ package Namet is -- Subprograms -- ----------------- - function To_String (X : Bounded_String) return String; - function "+" (X : Bounded_String) return String renames To_String; + function To_String (Buf : Bounded_String) return String; + pragma Inline (To_String); + function "+" (Buf : Bounded_String) return String renames To_String; function Name_Find (Buf : Bounded_String := Global_Name_Buffer) return Name_Id; @@ -361,6 +362,9 @@ package Namet is procedure Append (Buf : in out Bounded_String; S : String); -- Append S onto Buf + procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String); + -- Append Buf2 onto Buf + procedure Append (Buf : in out Bounded_String; Id : Name_Id); -- Append the characters of Id onto Buf. It is an error to call this with -- one of the special name Id values (No_Name or Error_Name). diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 343fbe6..6f086bf 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2550,17 +2550,27 @@ package body Sem_Ch6 is function Is_Inline_Pragma (N : Node_Id) return Boolean is begin - return - Nkind (N) = N_Pragma + if Nkind (N) = N_Pragma and then (Pragma_Name (N) = Name_Inline_Always or else (Pragma_Name (N) = Name_Inline and then (Front_End_Inlining or else Optimization_Level > 0))) - and then - Chars - (Expression (First (Pragma_Argument_Associations (N)))) = - Chars (Body_Id); + then + declare + Pragma_Arg : Node_Id := + Expression (First (Pragma_Argument_Associations (N))); + begin + if Nkind (Pragma_Arg) = N_Selected_Component then + Pragma_Arg := Selector_Name (Pragma_Arg); + end if; + + return Chars (Pragma_Arg) = Chars (Body_Id); + end; + + else + return False; + end if; end Is_Inline_Pragma; -- Start of processing for Check_Inline_Pragma @@ -2588,7 +2598,10 @@ package body Sem_Ch6 is if Present (Prag) then if Present (Spec_Id) then - if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then + if Is_List_Member (N) + and then Is_List_Member (Unit_Declaration_Node (Spec_Id)) + and then In_Same_List (N, Unit_Declaration_Node (Spec_Id)) + then Analyze (Prag); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index aae3d7ce..52c73c3 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9863,7 +9863,7 @@ package body Sem_Prag is begin Get_Name_String (Chars (Prof_Nam)); - Adjust_Name_Case (Sloc (Prof_Nam)); + Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam)); Error_Msg_Strlen := Name_Len; Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); end Set_Error_Msg_To_Profile_Name; diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb index e59881a..5be7873 100644 --- a/gcc/ada/stringt.adb +++ b/gcc/ada/stringt.adb @@ -80,16 +80,16 @@ package body Stringt is ------------------------------- procedure Add_String_To_Name_Buffer (S : String_Id) is - Len : constant Natural := Natural (String_Length (S)); + begin + Append (Global_Name_Buffer, S); + end Add_String_To_Name_Buffer; + procedure Append (Buf : in out Bounded_String; S : String_Id) is begin - for J in 1 .. Len loop - Name_Buffer (Name_Len + J) := - Get_Character (Get_String_Char (S, Int (J))); + for X in 1 .. String_Length (S) loop + Append (Buf, Get_Character (Get_String_Char (S, X))); end loop; - - Name_Len := Name_Len + Len; - end Add_String_To_Name_Buffer; + end Append; ---------------- -- End_String -- @@ -330,12 +330,8 @@ package body Stringt is procedure String_To_Name_Buffer (S : String_Id) is begin - Name_Len := Natural (String_Length (S)); - - for J in 1 .. Name_Len loop - Name_Buffer (J) := - Get_Character (Get_String_Char (S, Int (J))); - end loop; + Name_Len := 0; + Append (Global_Name_Buffer, S); end String_To_Name_Buffer; --------------------- diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads index c48f2b9..4b7c0e5 100644 --- a/gcc/ada/stringt.ads +++ b/gcc/ada/stringt.ads @@ -124,10 +124,13 @@ package Stringt is -- Error if any characters are out of Character range. Does not attempt -- to do any encoding of any characters. + procedure Append (Buf : in out Bounded_String; S : String_Id); + -- Append characters of given string to Buf. Error if any characters are + -- out of Character range. Does not attempt to do any encoding of any + -- characters. + procedure Add_String_To_Name_Buffer (S : String_Id); - -- Append characters of given string to Name_Buffer, updating Name_Len. - -- Error if any characters are out of Character range. Does not attempt - -- to do any encoding of any characters. + -- Same as Append (Global_Name_Buffer, S) function String_Chars_Address return System.Address; -- Return address of String_Chars table (used by Back_End call to Gigi) diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb index e0a1e72..8451801 100644 --- a/gcc/ada/uname.adb +++ b/gcc/ada/uname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -429,7 +429,7 @@ package body Uname is begin Get_Decoded_Name_String (N); Unit_Is_Body := Name_Buffer (Name_Len) = 'b'; - Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case); + 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 |