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>
* sem_ch13.adb (Has_Good_Profile): Improvement
......
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;
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);
......
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;
......
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;
......
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;
......
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
......
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;
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
......
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)));
......
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;
---------------
......
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).
......
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;
......
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;
......
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;
---------------------
......
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)
......
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
......
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