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

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.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.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