+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
-- --
-- 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- --
------------------------------------------------------------------------------
with Csets; use Csets;
-with Namet; use Namet;
with Opt; use Opt;
with Widechar; use Widechar;
-- 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;
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
-- 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;
-- 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;
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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Types; use Types;
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);
-- 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
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;
-- 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 --
---------------------------
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;
-- 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;
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;
-- 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;
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
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;
-- 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
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 --
-- 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);
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;
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
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)));
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;
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
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;
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;
-- 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);
-- 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);
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');
-- 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 (''');
-- 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;
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;
-- 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;
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;
-- 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;
----------------------------------
-- 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;
------------------------
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;
--------------------------------
(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;
--------------
-- 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;
---------------
-- 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;
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).
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
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;
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;
-------------------------------
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 --
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;
---------------------
-- 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)
-- --
-- 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- --
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
projects / thirdparty / gcc.git / commitdiff
