Skip to content

R
riscv-gcc-1
Commit b269f477 by Bob Duff Committed by Arnaud Charlet
Options

sem_ch6.adb (Is_Inline_Pragma): The pragma argument can be a selected component... 

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.

From-SVN: r235129
parent 876f1624
Showing with 421 additions and 328 deletions
gcc/ada/ChangeLog
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> 2016-04-18 Gary Dismukes <dismukes@adacore.com>
* sem_ch13.adb (Has_Good_Profile): Improvement * sem_ch13.adb (Has_Good_Profile): Improvement
......
gcc/ada/casing.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -30,7 +30,6 @@ ...@@ -30,7 +30,6 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Csets; use Csets; with Csets; use Csets;
with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Widechar; use Widechar; with Widechar; use Widechar;
...@@ -125,7 +124,11 @@ package body Casing is ...@@ -125,7 +124,11 @@ package body Casing is
-- Set_Casing -- -- 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; Ptr : Natural;
Actual_Casing : Casing_Type; Actual_Casing : Casing_Type;
...@@ -144,7 +147,7 @@ package body Casing is ...@@ -144,7 +147,7 @@ package body Casing is
Ptr := 1; Ptr := 1;
while Ptr <= Name_Len loop while Ptr <= Buf.Length loop
-- Wide character. Note that we do nothing with casing in this case. -- Wide character. Note that we do nothing with casing in this case.
-- In Ada 2005 mode, required folding of lower case letters happened -- In Ada 2005 mode, required folding of lower case letters happened
...@@ -156,29 +159,29 @@ package body Casing is ...@@ -156,29 +159,29 @@ package body Casing is
-- the requested casing operation, beyond folding to upper case -- the requested casing operation, beyond folding to upper case
-- when it is mandatory, which does not involve underscores. -- when it is mandatory, which does not involve underscores.
if Name_Buffer (Ptr) = ASCII.ESC if Buf.Chars (Ptr) = ASCII.ESC
or else Name_Buffer (Ptr) = '[' or else Buf.Chars (Ptr) = '['
or else (Upper_Half_Encoding or else (Upper_Half_Encoding
and then Name_Buffer (Ptr) in Upper_Half_Character) and then Buf.Chars (Ptr) in Upper_Half_Character)
then then
Skip_Wide (Name_Buffer, Ptr); Skip_Wide (Buf.Chars, Ptr);
After_Und := False; After_Und := False;
-- Underscore, or non-identifer character (error case) -- Underscore, or non-identifer character (error case)
elsif Name_Buffer (Ptr) = '_' elsif Buf.Chars (Ptr) = '_'
or else not Identifier_Char (Name_Buffer (Ptr)) or else not Identifier_Char (Buf.Chars (Ptr))
then then
After_Und := True; After_Und := True;
Ptr := Ptr + 1; Ptr := Ptr + 1;
-- Lower case letter -- 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 if Actual_Casing = All_Upper_Case
or else (After_Und and then Actual_Casing = Mixed_Case) or else (After_Und and then Actual_Casing = Mixed_Case)
then then
Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr)); Buf.Chars (Ptr) := Fold_Upper (Buf.Chars (Ptr));
end if; end if;
After_Und := False; After_Und := False;
...@@ -186,11 +189,11 @@ package body Casing is ...@@ -186,11 +189,11 @@ package body Casing is
-- Upper case letter -- 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 if Actual_Casing = All_Lower_Case
or else (not After_Und and then Actual_Casing = Mixed_Case) or else (not After_Und and then Actual_Casing = Mixed_Case)
then then
Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr)); Buf.Chars (Ptr) := Fold_Lower (Buf.Chars (Ptr));
end if; end if;
After_Und := False; After_Und := False;
...@@ -205,4 +208,9 @@ package body Casing is ...@@ -205,4 +208,9 @@ package body Casing is
end loop; end loop;
end Set_Casing; 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; end Casing;
gcc/ada/casing.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,6 +29,7 @@ ...@@ -29,6 +29,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Namet; use Namet;
with Types; use Types; with Types; use Types;
package Casing is package Casing is
...@@ -68,14 +69,20 @@ package Casing is ...@@ -68,14 +69,20 @@ package Casing is
-- Case Control Subprograms -- -- 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); procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case);
-- Takes the name stored in the first Name_Len positions of Name_Buffer -- Uses Buf => Global_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).
procedure Set_All_Upper_Case; procedure Set_All_Upper_Case;
pragma Inline (Set_All_Upper_Case); pragma Inline (Set_All_Upper_Case);
......
gcc/ada/errout.adb
...@@ -2358,7 +2358,10 @@ package body Errout is ...@@ -2358,7 +2358,10 @@ package body Errout is
-- Adjust_Name_Case -- -- 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 begin
-- We have an all lower case name from Namet, and now we want to set -- 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 -- the appropriate case. If possible we copy the actual casing from
...@@ -2387,10 +2390,10 @@ package body Errout is ...@@ -2387,10 +2390,10 @@ package body Errout is
Sbuffer := Source_Text (Src_Ind); Sbuffer := Source_Text (Src_Ind);
while Ref_Ptr <= Name_Len loop while Ref_Ptr <= Buf.Length loop
exit when exit when
Fold_Lower (Sbuffer (Src_Ptr)) /= Fold_Lower (Sbuffer (Src_Ptr)) /=
Fold_Lower (Name_Buffer (Ref_Ptr)); Fold_Lower (Buf.Chars (Ref_Ptr));
Ref_Ptr := Ref_Ptr + 1; Ref_Ptr := Ref_Ptr + 1;
Src_Ptr := Src_Ptr + 1; Src_Ptr := Src_Ptr + 1;
end loop; end loop;
...@@ -2398,23 +2401,28 @@ package body Errout is ...@@ -2398,23 +2401,28 @@ package body Errout is
-- If we get through the loop without a mismatch, then output the -- If we get through the loop without a mismatch, then output the
-- name the way it is cased in the source program -- 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; Src_Ptr := Loc;
for J in 1 .. Name_Len loop for J in 1 .. Buf.Length loop
Name_Buffer (J) := Sbuffer (Src_Ptr); Buf.Chars (J) := Sbuffer (Src_Ptr);
Src_Ptr := Src_Ptr + 1; Src_Ptr := Src_Ptr + 1;
end loop; end loop;
-- Otherwise set the casing using the default identifier casing -- Otherwise set the casing using the default identifier casing
else else
Set_Casing (Identifier_Casing (Src_Ind), Mixed_Case); Set_Casing (Buf, Identifier_Casing (Src_Ind));
end if; end if;
end if; end if;
end; end;
end Adjust_Name_Case; 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 -- -- Set_Identifier_Casing --
--------------------------- ---------------------------
...@@ -2874,7 +2882,7 @@ package body Errout is ...@@ -2874,7 +2882,7 @@ package body Errout is
end if; end if;
-- Remaining step is to adjust casing and possibly add 'Class -- 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; Set_Msg_Name_Buffer;
Add_Class; Add_Class;
end Set_Msg_Node; end Set_Msg_Node;
......
gcc/ada/errout.ads
...@@ -904,11 +904,17 @@ package Errout is ...@@ -904,11 +904,17 @@ package Errout is
-- Utility Interface for Casing Control -- -- 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); procedure Adjust_Name_Case (Loc : Source_Ptr);
-- Given a name stored in Name_Buffer (1 .. Name_Len), set proper casing. -- Uses Buf => Global_Name_Buffer. There are no calls to this in the
-- Loc is an associated source position, if we can find a match between -- compiler, but it is called in SPARK2014.
-- 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.
procedure Set_Identifier_Casing procedure Set_Identifier_Casing
(Identifier_Name : System.Address; (Identifier_Name : System.Address;
......
gcc/ada/erroutc.adb
...@@ -66,7 +66,7 @@ package body Erroutc is ...@@ -66,7 +66,7 @@ package body Erroutc is
Class_Flag := False; Class_Flag := False;
Set_Msg_Char ('''); Set_Msg_Char (''');
Get_Name_String (Name_Class); Get_Name_String (Name_Class);
Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); Set_Casing (Identifier_Casing (Flag_Source));
Set_Msg_Name_Buffer; Set_Msg_Name_Buffer;
end if; end if;
end Add_Class; end Add_Class;
...@@ -1187,7 +1187,7 @@ package body Erroutc is ...@@ -1187,7 +1187,7 @@ package body Erroutc is
-- Else output with surrounding quotes in proper casing mode -- Else output with surrounding quotes in proper casing mode
else else
Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); Set_Casing (Identifier_Casing (Flag_Source));
Set_Msg_Quote; Set_Msg_Quote;
Set_Msg_Name_Buffer; Set_Msg_Name_Buffer;
Set_Msg_Quote; Set_Msg_Quote;
......
gcc/ada/exp_ch11.adb
...@@ -1565,13 +1565,15 @@ package body Exp_Ch11 is ...@@ -1565,13 +1565,15 @@ package body Exp_Ch11 is
if Prefix_Exception_Messages if Prefix_Exception_Messages
and then Nkind (Expression (N)) = N_String_Literal and then Nkind (Expression (N)) = N_String_Literal
then then
Name_Len := 0; declare
Add_Source_Info (Loc, Name_Enclosing_Entity); Buf : Bounded_String;
Add_Str_To_Name_Buffer (": "); begin
Add_String_To_Name_Buffer (Strval (Expression (N))); Add_Source_Info (Buf, Loc, Name_Enclosing_Entity);
Rewrite (Expression (N), Append (Buf, ": ");
Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len))); Append (Buf, Strval (Expression (N)));
Analyze_And_Resolve (Expression (N), Standard_String); Rewrite (Expression (N), Make_String_Literal (Loc, +Buf));
Analyze_And_Resolve (Expression (N), Standard_String);
end;
end if; end if;
-- Avoid passing exception-name'identity in runtimes in which this -- Avoid passing exception-name'identity in runtimes in which this
......
gcc/ada/exp_intr.adb
...@@ -54,7 +54,6 @@ with Sinfo; use Sinfo; ...@@ -54,7 +54,6 @@ with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp; with Uintp; use Uintp;
with Urealp; use Urealp; with Urealp; use Urealp;
...@@ -112,58 +111,51 @@ package body Exp_Intr is ...@@ -112,58 +111,51 @@ package body Exp_Intr is
-- GNAT.Source_Info; see g-souinf.ads for documentation of these -- GNAT.Source_Info; see g-souinf.ads for documentation of these
-- intrinsics. -- 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 -- Recursive procedure to construct string for qualified name of enclosing
-- program unit. The qualification stops at an enclosing scope has no -- program unit. The qualification stops at an enclosing scope has no
-- source name (block or loop). If entity is a subprogram instance, skip -- source name (block or loop). If entity is a subprogram instance, skip
-- enclosing wrapper package. The name is appended to the current contents -- enclosing wrapper package. The name is appended to Buf.
-- of Name_Buffer, incrementing Name_Len.
--------------------- ---------------------
-- Add_Source_Info -- -- Add_Source_Info --
--------------------- ---------------------
procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id) is procedure Add_Source_Info
Ent : Entity_Id; (Buf : in out Bounded_String;
Loc : Source_Ptr;
Save_NB : constant String := Name_Buffer (1 .. Name_Len); Nam : Name_Id)
Save_NL : constant Natural := Name_Len; is
-- Save current Name_Buffer contents
begin begin
Name_Len := 0;
-- Line
case Nam is case Nam is
when Name_Line => 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 => when Name_File =>
Get_Decoded_Name_String Append_Decoded (Buf, Reference_Name (Get_Source_File_Index (Loc)));
(Reference_Name (Get_Source_File_Index (Loc)));
when Name_Source_Location => when Name_Source_Location =>
Build_Location_String (Global_Name_Buffer, Loc); Build_Location_String (Buf, Loc);
when Name_Enclosing_Entity => when Name_Enclosing_Entity =>
-- Skip enclosing blocks to reach enclosing unit -- Skip enclosing blocks to reach enclosing unit
Ent := Current_Scope; declare
while Present (Ent) loop Ent : Entity_Id := Current_Scope;
exit when not Ekind_In (Ent, E_Block, E_Loop); begin
Ent := Scope (Ent); while Present (Ent) loop
end 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 => when Name_Compilation_ISO_Date =>
Name_Buffer (1 .. 10) := Opt.Compilation_Time (1 .. 10); Append (Buf, Opt.Compilation_Time (1 .. 10));
Name_Len := 10;
when Name_Compilation_Date => when Name_Compilation_Date =>
declare declare
...@@ -177,34 +169,117 @@ package body Exp_Intr is ...@@ -177,34 +169,117 @@ package body Exp_Intr is
MM : constant Natural range 1 .. 12 := MM : constant Natural range 1 .. 12 :=
(Character'Pos (M1) - Character'Pos ('0')) * 10 + (Character'Pos (M1) - Character'Pos ('0')) * 10 +
(Character'Pos (M2) - Character'Pos ('0')); (Character'Pos (M2) - Character'Pos ('0'));
begin begin
-- Reformat ISO date into MMM DD YYYY (__DATE__) format -- Reformat ISO date into MMM DD YYYY (__DATE__) format
Name_Buffer (1 .. 3) := Months (MM); Append (Buf, Months (MM));
Name_Buffer (4) := ' '; Append (Buf, ' ');
Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10); Append (Buf, Opt.Compilation_Time (9 .. 10));
Name_Buffer (7) := ' '; Append (Buf, ' ');
Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4); Append (Buf, Opt.Compilation_Time (1 .. 4));
Name_Len := 11;
end; end;
when Name_Compilation_Time => when Name_Compilation_Time =>
Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19); Append (Buf, Opt.Compilation_Time (12 .. 19));
Name_Len := 8;
when others => when others =>
raise Program_Error; raise Program_Error;
end case; end case;
end Add_Source_Info;
-- Prepend original Name_Buffer contents -----------------------
-- Append_Entity_Name --
-----------------------
Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) := procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
Name_Buffer (1 .. Name_Len); Temp : Bounded_String;
Name_Buffer (1 .. Save_NL) := Save_NB;
Name_Len := Name_Len + Save_NL; procedure Inner (E : Entity_Id);
end Add_Source_Info; -- 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 -- -- Expand_Binary_Operator_Call --
...@@ -865,12 +940,13 @@ package body Exp_Intr is ...@@ -865,12 +940,13 @@ package body Exp_Intr is
-- String cases -- String cases
else else
Name_Len := 0; declare
Add_Source_Info (Loc, Nam); Buf : Bounded_String;
Rewrite (N, begin
Make_String_Literal (Loc, Add_Source_Info (Buf, Loc, Nam);
Strval => String_From_Name_Buffer)); Rewrite (N, Make_String_Literal (Loc, Strval => +Buf));
Analyze_And_Resolve (N, Standard_String); Analyze_And_Resolve (N, Standard_String);
end;
end if; end if;
Set_Is_Static_Expression (N); Set_Is_Static_Expression (N);
...@@ -1401,109 +1477,4 @@ package body Exp_Intr is ...@@ -1401,109 +1477,4 @@ package body Exp_Intr is
Analyze (N); Analyze (N);
end Expand_To_Pointer; 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; end Exp_Intr;
gcc/ada/exp_intr.ads
...@@ -30,12 +30,14 @@ with Types; use Types; ...@@ -30,12 +30,14 @@ with Types; use Types;
package Exp_Intr is package Exp_Intr is
procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id); procedure Add_Source_Info
-- Append a string to Name_Buffer depending on Nam, which is the name of (Buf : in out Bounded_String;
-- one of the intrinsics declared in GNAT.Source_Info; see g-souinf.ads for Loc : Source_Ptr;
-- documentation of these intrinsics. The caller must set Name_Buffer and Nam : Name_Id);
-- Name_Len before the call. Loc is passed to provide location information -- Append a string to Buf depending on Nam, which is the name of one of the
-- where it is needed. -- 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); procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id);
-- N is either a function call node, a procedure call statement node, or -- N is either a function call node, a procedure call statement node, or
......
gcc/ada/lib-xref-spark_specific.adb
...@@ -261,15 +261,28 @@ package body SPARK_Specific is ...@@ -261,15 +261,28 @@ package body SPARK_Specific is
case Ekind (E) is case Ekind (E) is
when E_Entry when E_Entry
| E_Entry_Family | E_Entry_Family
| E_Function
| E_Generic_Function | E_Generic_Function
| E_Generic_Package | E_Generic_Package
| E_Generic_Procedure | E_Generic_Procedure
| E_Package | E_Package
| E_Procedure
=> =>
Typ := Xref_Entity_Letters (Ekind (E)); 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 => when E_Package_Body | E_Subprogram_Body | E_Task_Body =>
Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E))); Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
......
gcc/ada/namet.adb
...@@ -137,6 +137,11 @@ package body Namet is ...@@ -137,6 +137,11 @@ package body Namet is
end loop; end loop;
end Append; 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 procedure Append (Buf : in out Bounded_String; Id : Name_Id) is
pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
S : constant Int := Name_Entries.Table (Id).Name_Chars_Index; S : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
...@@ -154,26 +159,27 @@ package body Namet is ...@@ -154,26 +159,27 @@ package body Namet is
procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is
C : Character; C : Character;
P : Natural; P : Natural;
Temp : Bounded_String;
begin begin
Append (Buf, Id); Append (Temp, Id);
-- Skip scan if we already know there are no encodings -- Skip scan if we already know there are no encodings
if Name_Entries.Table (Id).Name_Has_No_Encodings then if Name_Entries.Table (Id).Name_Has_No_Encodings then
return; goto Done;
end if; end if;
-- Quick loop to see if there is anything special to do -- Quick loop to see if there is anything special to do
P := 1; P := 1;
loop loop
if P = Buf.Length then if P = Temp.Length then
Name_Entries.Table (Id).Name_Has_No_Encodings := True; Name_Entries.Table (Id).Name_Has_No_Encodings := True;
return; goto Done;
else else
C := Buf.Chars (P); C := Temp.Chars (P);
exit when exit when
C = 'U' or else C = 'U' or else
...@@ -190,10 +196,10 @@ package body Namet is ...@@ -190,10 +196,10 @@ package body Namet is
Decode : declare Decode : declare
New_Len : Natural; New_Len : Natural;
Old : Positive; Old : Positive;
New_Buf : String (1 .. Buf.Chars'Last); New_Buf : String (1 .. Temp.Chars'Last);
procedure Copy_One_Character; 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. -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
function Hex (N : Natural) return Word; function Hex (N : Natural) return Word;
...@@ -210,14 +216,14 @@ package body Namet is ...@@ -210,14 +216,14 @@ package body Namet is
C : Character; C : Character;
begin begin
C := Buf.Chars (Old); C := Temp.Chars (Old);
-- U (upper half insertion case) -- U (upper half insertion case)
if C = 'U' if C = 'U'
and then Old < Buf.Length and then Old < Temp.Length
and then Buf.Chars (Old + 1) not in 'A' .. 'Z' and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
and then Buf.Chars (Old + 1) /= '_' and then Temp.Chars (Old + 1) /= '_'
then then
Old := Old + 1; Old := Old + 1;
...@@ -237,8 +243,8 @@ package body Namet is ...@@ -237,8 +243,8 @@ package body Namet is
-- WW (wide wide character insertion) -- WW (wide wide character insertion)
elsif C = 'W' elsif C = 'W'
and then Old < Buf.Length and then Old < Temp.Length
and then Buf.Chars (Old + 1) = 'W' and then Temp.Chars (Old + 1) = 'W'
then then
Old := Old + 2; Old := Old + 2;
Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len); Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
...@@ -246,9 +252,9 @@ package body Namet is ...@@ -246,9 +252,9 @@ package body Namet is
-- W (wide character insertion) -- W (wide character insertion)
elsif C = 'W' elsif C = 'W'
and then Old < Buf.Length and then Old < Temp.Length
and then Buf.Chars (Old + 1) not in 'A' .. 'Z' and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
and then Buf.Chars (Old + 1) /= '_' and then Temp.Chars (Old + 1) /= '_'
then then
Old := Old + 1; Old := Old + 1;
Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len); Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
...@@ -271,7 +277,7 @@ package body Namet is ...@@ -271,7 +277,7 @@ package body Namet is
begin begin
for J in 1 .. N loop for J in 1 .. N loop
C := Buf.Chars (Old); C := Temp.Chars (Old);
Old := Old + 1; Old := Old + 1;
pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f'); pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
...@@ -304,12 +310,12 @@ package body Namet is ...@@ -304,12 +310,12 @@ package body Namet is
-- Loop through characters of name -- Loop through characters of name
while Old <= Buf.Length loop while Old <= Temp.Length loop
-- Case of character literal, put apostrophes around character -- Case of character literal, put apostrophes around character
if Buf.Chars (Old) = 'Q' if Temp.Chars (Old) = 'Q'
and then Old < Buf.Length and then Old < Temp.Length
then then
Old := Old + 1; Old := Old + 1;
Insert_Character ('''); Insert_Character (''');
...@@ -318,10 +324,10 @@ package body Namet is ...@@ -318,10 +324,10 @@ package body Namet is
-- Case of operator name -- Case of operator name
elsif Buf.Chars (Old) = 'O' elsif Temp.Chars (Old) = 'O'
and then Old < Buf.Length and then Old < Temp.Length
and then Buf.Chars (Old + 1) not in 'A' .. 'Z' and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
and then Buf.Chars (Old + 1) /= '_' and then Temp.Chars (Old + 1) /= '_'
then then
Old := Old + 1; Old := Old + 1;
...@@ -362,8 +368,8 @@ package body Namet is ...@@ -362,8 +368,8 @@ package body Namet is
J := Map'First; J := Map'First;
loop loop
exit when Buf.Chars (Old) = Map (J) exit when Temp.Chars (Old) = Map (J)
and then Buf.Chars (Old + 1) = Map (J + 1); and then Temp.Chars (Old + 1) = Map (J + 1);
J := J + 4; J := J + 4;
end loop; end loop;
...@@ -380,8 +386,8 @@ package body Namet is ...@@ -380,8 +386,8 @@ package body Namet is
-- Skip past original operator name in input -- Skip past original operator name in input
while Old <= Buf.Length while Old <= Temp.Length
and then Buf.Chars (Old) in 'a' .. 'z' and then Temp.Chars (Old) in 'a' .. 'z'
loop loop
Old := Old + 1; Old := Old + 1;
end loop; end loop;
...@@ -392,8 +398,8 @@ package body Namet is ...@@ -392,8 +398,8 @@ package body Namet is
else else
-- Copy original operator name from input to output -- Copy original operator name from input to output
while Old <= Buf.Length while Old <= Temp.Length
and then Buf.Chars (Old) in 'a' .. 'z' and then Temp.Chars (Old) in 'a' .. 'z'
loop loop
Copy_One_Character; Copy_One_Character;
end loop; end loop;
...@@ -411,9 +417,12 @@ package body Namet is ...@@ -411,9 +417,12 @@ package body Namet is
-- Copy new buffer as result -- Copy new buffer as result
Buf.Length := New_Len; Temp.Length := New_Len;
Buf.Chars (1 .. New_Len) := New_Buf (1 .. New_Len); Temp.Chars (1 .. New_Len) := New_Buf (1 .. New_Len);
end Decode; end Decode;
<<Done>>
Append (Buf, Temp);
end Append_Decoded; end Append_Decoded;
---------------------------------- ----------------------------------
...@@ -440,67 +449,73 @@ package body Namet is ...@@ -440,67 +449,73 @@ package body Namet is
-- Only remaining issue is U/W/WW sequences -- Only remaining issue is U/W/WW sequences
else else
Append (Buf, Id); declare
Temp : Bounded_String;
begin
Append (Temp, Id);
P := 1; P := 1;
while P < Buf.Length loop while P < Temp.Length loop
if Buf.Chars (P + 1) in 'A' .. 'Z' then if Temp.Chars (P + 1) in 'A' .. 'Z' then
P := P + 1; P := P + 1;
-- Uhh encoding -- Uhh encoding
elsif Buf.Chars (P) = 'U' then elsif Temp.Chars (P) = 'U' then
for J in reverse P + 3 .. P + Buf.Length loop for J in reverse P + 3 .. P + Temp.Length loop
Buf.Chars (J + 3) := Buf.Chars (J); Temp.Chars (J + 3) := Temp.Chars (J);
end loop; end loop;
Buf.Length := Buf.Length + 3; Temp.Length := Temp.Length + 3;
Buf.Chars (P + 3) := Buf.Chars (P + 2); Temp.Chars (P + 3) := Temp.Chars (P + 2);
Buf.Chars (P + 2) := Buf.Chars (P + 1); Temp.Chars (P + 2) := Temp.Chars (P + 1);
Buf.Chars (P) := '['; Temp.Chars (P) := '[';
Buf.Chars (P + 1) := '"'; Temp.Chars (P + 1) := '"';
Buf.Chars (P + 4) := '"'; Temp.Chars (P + 4) := '"';
Buf.Chars (P + 5) := ']'; Temp.Chars (P + 5) := ']';
P := P + 6; P := P + 6;
-- WWhhhhhhhh encoding -- WWhhhhhhhh encoding
elsif Buf.Chars (P) = 'W' elsif Temp.Chars (P) = 'W'
and then P + 9 <= Buf.Length and then P + 9 <= Temp.Length
and then Buf.Chars (P + 1) = 'W' and then Temp.Chars (P + 1) = 'W'
and then Buf.Chars (P + 2) not in 'A' .. 'Z' and then Temp.Chars (P + 2) not in 'A' .. 'Z'
and then Buf.Chars (P + 2) /= '_' and then Temp.Chars (P + 2) /= '_'
then then
Buf.Chars (P + 12 .. Buf.Length + 2) := Temp.Chars (P + 12 .. Temp.Length + 2) :=
Buf.Chars (P + 10 .. Buf.Length); Temp.Chars (P + 10 .. Temp.Length);
Buf.Chars (P) := '['; Temp.Chars (P) := '[';
Buf.Chars (P + 1) := '"'; Temp.Chars (P + 1) := '"';
Buf.Chars (P + 10) := '"'; Temp.Chars (P + 10) := '"';
Buf.Chars (P + 11) := ']'; Temp.Chars (P + 11) := ']';
Buf.Length := Buf.Length + 2; Temp.Length := Temp.Length + 2;
P := P + 12; P := P + 12;
-- Whhhh encoding -- Whhhh encoding
elsif Buf.Chars (P) = 'W' elsif Temp.Chars (P) = 'W'
and then P < Buf.Length and then P < Temp.Length
and then Buf.Chars (P + 1) not in 'A' .. 'Z' and then Temp.Chars (P + 1) not in 'A' .. 'Z'
and then Buf.Chars (P + 1) /= '_' and then Temp.Chars (P + 1) /= '_'
then then
Buf.Chars (P + 8 .. P + Buf.Length + 3) := Temp.Chars (P + 8 .. P + Temp.Length + 3) :=
Buf.Chars (P + 5 .. Buf.Length); Temp.Chars (P + 5 .. Temp.Length);
Buf.Chars (P + 2 .. P + 5) := Buf.Chars (P + 1 .. P + 4); Temp.Chars (P + 2 .. P + 5) := Temp.Chars (P + 1 .. P + 4);
Buf.Chars (P) := '['; Temp.Chars (P) := '[';
Buf.Chars (P + 1) := '"'; Temp.Chars (P + 1) := '"';
Buf.Chars (P + 6) := '"'; Temp.Chars (P + 6) := '"';
Buf.Chars (P + 7) := ']'; Temp.Chars (P + 7) := ']';
Buf.Length := Buf.Length + 3; Temp.Length := Temp.Length + 3;
P := P + 8; P := P + 8;
else else
P := P + 1; P := P + 1;
end if; end if;
end loop; end loop;
Append (Buf, Temp);
end;
end if; end if;
end Append_Decoded_With_Brackets; end Append_Decoded_With_Brackets;
...@@ -564,9 +579,11 @@ package body Namet is ...@@ -564,9 +579,11 @@ package body Namet is
------------------------ ------------------------
procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id) is procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id) is
Temp : Bounded_String;
begin begin
Append (Buf, Id); Append (Temp, Id);
Strip_Qualification_And_Suffixes (Buf); Strip_Qualification_And_Suffixes (Temp);
Append (Buf, Temp);
end Append_Unqualified; end Append_Unqualified;
-------------------------------- --------------------------------
...@@ -577,9 +594,11 @@ package body Namet is ...@@ -577,9 +594,11 @@ package body Namet is
(Buf : in out Bounded_String; (Buf : in out Bounded_String;
Id : Name_Id) Id : Name_Id)
is is
Temp : Bounded_String;
begin begin
Append_Decoded (Buf, Id); Append_Decoded (Temp, Id);
Strip_Qualification_And_Suffixes (Buf); Strip_Qualification_And_Suffixes (Temp);
Append (Buf, Temp);
end Append_Unqualified_Decoded; end Append_Unqualified_Decoded;
-------------- --------------
...@@ -1625,9 +1644,9 @@ package body Namet is ...@@ -1625,9 +1644,9 @@ package body Namet is
-- To_String -- -- To_String --
--------------- ---------------
function To_String (X : Bounded_String) return String is function To_String (Buf : Bounded_String) return String is
begin begin
return X.Chars (1 .. X.Length); return Buf.Chars (1 .. Buf.Length);
end To_String; end To_String;
--------------- ---------------
......
gcc/ada/namet.ads
...@@ -318,8 +318,9 @@ package Namet is ...@@ -318,8 +318,9 @@ package Namet is
-- Subprograms -- -- Subprograms --
----------------- -----------------
function To_String (X : Bounded_String) return String; function To_String (Buf : Bounded_String) return String;
function "+" (X : Bounded_String) return String renames To_String; pragma Inline (To_String);
function "+" (Buf : Bounded_String) return String renames To_String;
function Name_Find function Name_Find
(Buf : Bounded_String := Global_Name_Buffer) return Name_Id; (Buf : Bounded_String := Global_Name_Buffer) return Name_Id;
...@@ -361,6 +362,9 @@ package Namet is ...@@ -361,6 +362,9 @@ package Namet is
procedure Append (Buf : in out Bounded_String; S : String); procedure Append (Buf : in out Bounded_String; S : String);
-- Append S onto Buf -- 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); 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 -- 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). -- one of the special name Id values (No_Name or Error_Name).
......
gcc/ada/sem_ch6.adb
...@@ -2550,17 +2550,27 @@ package body Sem_Ch6 is ...@@ -2550,17 +2550,27 @@ package body Sem_Ch6 is
function Is_Inline_Pragma (N : Node_Id) return Boolean is function Is_Inline_Pragma (N : Node_Id) return Boolean is
begin begin
return if Nkind (N) = N_Pragma
Nkind (N) = N_Pragma
and then and then
(Pragma_Name (N) = Name_Inline_Always (Pragma_Name (N) = Name_Inline_Always
or else (Pragma_Name (N) = Name_Inline or else (Pragma_Name (N) = Name_Inline
and then and then
(Front_End_Inlining or else Optimization_Level > 0))) (Front_End_Inlining or else Optimization_Level > 0)))
and then then
Chars declare
(Expression (First (Pragma_Argument_Associations (N)))) = Pragma_Arg : Node_Id :=
Chars (Body_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; end Is_Inline_Pragma;
-- Start of processing for Check_Inline_Pragma -- Start of processing for Check_Inline_Pragma
...@@ -2588,7 +2598,10 @@ package body Sem_Ch6 is ...@@ -2588,7 +2598,10 @@ package body Sem_Ch6 is
if Present (Prag) then if Present (Prag) then
if Present (Spec_Id) 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); Analyze (Prag);
end if; end if;
......
gcc/ada/sem_prag.adb
...@@ -9863,7 +9863,7 @@ package body Sem_Prag is ...@@ -9863,7 +9863,7 @@ package body Sem_Prag is
begin begin
Get_Name_String (Chars (Prof_Nam)); 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_Strlen := Name_Len;
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
end Set_Error_Msg_To_Profile_Name; end Set_Error_Msg_To_Profile_Name;
......
gcc/ada/stringt.adb
...@@ -80,16 +80,16 @@ package body Stringt is ...@@ -80,16 +80,16 @@ package body Stringt is
------------------------------- -------------------------------
procedure Add_String_To_Name_Buffer (S : String_Id) 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 begin
for J in 1 .. Len loop for X in 1 .. String_Length (S) loop
Name_Buffer (Name_Len + J) := Append (Buf, Get_Character (Get_String_Char (S, X)));
Get_Character (Get_String_Char (S, Int (J)));
end loop; end loop;
end Append;
Name_Len := Name_Len + Len;
end Add_String_To_Name_Buffer;
---------------- ----------------
-- End_String -- -- End_String --
...@@ -330,12 +330,8 @@ package body Stringt is ...@@ -330,12 +330,8 @@ package body Stringt is
procedure String_To_Name_Buffer (S : String_Id) is procedure String_To_Name_Buffer (S : String_Id) is
begin begin
Name_Len := Natural (String_Length (S)); Name_Len := 0;
Append (Global_Name_Buffer, S);
for J in 1 .. Name_Len loop
Name_Buffer (J) :=
Get_Character (Get_String_Char (S, Int (J)));
end loop;
end String_To_Name_Buffer; end String_To_Name_Buffer;
--------------------- ---------------------
......
gcc/ada/stringt.ads
...@@ -124,10 +124,13 @@ package Stringt is ...@@ -124,10 +124,13 @@ package Stringt is
-- Error if any characters are out of Character range. Does not attempt -- Error if any characters are out of Character range. Does not attempt
-- to do any encoding of any characters. -- 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); procedure Add_String_To_Name_Buffer (S : String_Id);
-- Append characters of given string to Name_Buffer, updating Name_Len. -- Same as Append (Global_Name_Buffer, S)
-- Error if any characters are out of Character range. Does not attempt
-- to do any encoding of any characters.
function String_Chars_Address return System.Address; function String_Chars_Address return System.Address;
-- Return address of String_Chars table (used by Back_End call to Gigi) -- Return address of String_Chars table (used by Back_End call to Gigi)
......
gcc/ada/uname.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -429,7 +429,7 @@ package body Uname is ...@@ -429,7 +429,7 @@ package body Uname is
begin begin
Get_Decoded_Name_String (N); Get_Decoded_Name_String (N);
Unit_Is_Body := Name_Buffer (Name_Len) = 'b'; 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, -- 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 -- since it is always an error to do so. However, if we do, at this
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment