[multiple changes]

2014-02-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb (Analyze_Iterator_Specification): Initialize
	properly the cursor type for subsequent volatile testing in SPARK
	mode, when domain is a formal container with an Iterabe aspect.

2014-02-20  Robert Dewar  <dewar@adacore.com>

	* errout.adb (Set_Warnings_Mode_Off): Add Reason argument.
	(Set_Specific_Warning_Off): Add Reason argument.
	* errout.ads (Set_Warnings_Mode_Off): Add Reason argument.
	(Set_Specific_Warning_Off): Add Reason argument.
	* erroutc.adb (Warnings_Entry): Add Reason field
	(Specific_Warning_Entry): Add Reason field.
	(Warnings_Suppressed): return String_Id for Reason.
	(Warning_Specifically_Suppressed): return String_Id for Reason.
	* erroutc.ads (Warnings_Entry): Add Reason field.
	(Specific_Warning_Entry): Add Reason field.
	(Set_Specific_Warning_Off): Add Reason argument.
	(Set_Warnings_Mode_Off): Add Reason argument.
	(Warnings_Suppressed): return String_Id for Reason.
	(Warning_Specifically_Suppressed): return String_Id for Reason.
	* errutil.adb (Warnings_Suppressed): returns String_Id for Reason
	(Warning_Specifically_Suppressed): returns String_Id for Reason
	* gnat_rm.texi: Document that Warning parameter is string literal
	or a concatenation of string literals.
	* par-prag.adb: New handling for Reason argument.
	* sem_prag.adb (Analyze_Pragma, case Warning): New handling
	for Reason argument.
	* sem_util.ads, sem_util.adb (Get_Reason_String): New procedure.
	* sem_warn.ads (Warnings_Off_Entry): Add reason field.
	* stringt.adb: Set Null_String_Id.
	* stringt.ads (Null_String_Id): New constant.

From-SVN: r207943

gcc/ada/ChangeLog

+2014-02-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch5.adb (Analyze_Iterator_Specification): Initialize
+	properly the cursor type for subsequent volatile testing in SPARK
+	mode, when domain is a formal container with an Iterabe aspect.
+
+2014-02-20  Robert Dewar  <dewar@adacore.com>
+
+	* errout.adb (Set_Warnings_Mode_Off): Add Reason argument.
+	(Set_Specific_Warning_Off): Add Reason argument.
+	* errout.ads (Set_Warnings_Mode_Off): Add Reason argument.
+	(Set_Specific_Warning_Off): Add Reason argument.
+	* erroutc.adb (Warnings_Entry): Add Reason field
+	(Specific_Warning_Entry): Add Reason field.
+	(Warnings_Suppressed): return String_Id for Reason.
+	(Warning_Specifically_Suppressed): return String_Id for Reason.
+	* erroutc.ads (Warnings_Entry): Add Reason field.
+	(Specific_Warning_Entry): Add Reason field.
+	(Set_Specific_Warning_Off): Add Reason argument.
+	(Set_Warnings_Mode_Off): Add Reason argument.
+	(Warnings_Suppressed): return String_Id for Reason.
+	(Warning_Specifically_Suppressed): return String_Id for Reason.
+	* errutil.adb (Warnings_Suppressed): returns String_Id for Reason
+	(Warning_Specifically_Suppressed): returns String_Id for Reason
+	* gnat_rm.texi: Document that Warning parameter is string literal
+	or a concatenation of string literals.
+	* par-prag.adb: New handling for Reason argument.
+	* sem_prag.adb (Analyze_Pragma, case Warning): New handling
+	for Reason argument.
+	* sem_util.ads, sem_util.adb (Get_Reason_String): New procedure.
+	* sem_warn.ads (Warnings_Off_Entry): Add reason field.
+	* stringt.adb: Set Null_String_Id.
+	* stringt.ads (Null_String_Id): New constant.
+
 2014-02-20  Robert Dewar  <dewar@adacore.com>
 
 	* einfo.ads: Minor comment addition: Etype of package is

gcc/ada/errout.adb

@@ -332,7 +332,9 @@ package body Errout is
       --  that style checks are not considered warning messages for this
       --  purpose.
 
-      if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
+      if Is_Warning_Msg
+        and then Warnings_Suppressed (Orig_Loc) /= No_String
+      then
          return;
 
       --  For style messages, check too many messages so far
@@ -774,7 +776,10 @@ package body Errout is
 
          --  Immediate return if warning message and warnings are suppressed
 
-         if Warnings_Suppressed (Optr) or else Warnings_Suppressed (Sptr) then
+         if Warnings_Suppressed (Optr) /= No_String
+              or else
+            Warnings_Suppressed (Sptr) /= No_String
+         then
             Cur_Msg := No_Error_Msg;
             return;
          end if;
@@ -1321,10 +1326,11 @@ package body Errout is
 
          begin
             if (CE.Warn and not CE.Deleted)
-              and then
-                (Warning_Specifically_Suppressed (CE.Sptr, CE.Text)
-                   or else
-                 Warning_Specifically_Suppressed (CE.Optr, CE.Text))
+              and then (Warning_Specifically_Suppressed (CE.Sptr, CE.Text) /=
+                                                                   No_String
+                          or else
+                        Warning_Specifically_Suppressed (CE.Optr, CE.Text) /=
+                                                                   No_String)
             then
                Delete_Warning (Cur);
 

gcc/ada/errout.ads

@@ -806,10 +806,11 @@ package Errout is
    --  ignored. A call with To=False restores the default treatment in which
    --  error calls are treated as usual (and as described in this spec).
 
-   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr)
+   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id)
      renames Erroutc.Set_Warnings_Mode_Off;
    --  Called in response to a pragma Warnings (Off) to record the source
-   --  location from which warnings are to be turned off.
+   --  location from which warnings are to be turned off. Reason is the
+   --  Reason from the pragma, or the null string if none is given.
 
    procedure Set_Warnings_Mode_On (Loc : Source_Ptr)
      renames Erroutc.Set_Warnings_Mode_On;
@@ -819,14 +820,20 @@ package Errout is
    procedure Set_Specific_Warning_Off
      (Loc    : Source_Ptr;
       Msg    : String;
+      Reason : String_Id;
       Config : Boolean;
       Used   : Boolean := False)
      renames Erroutc.Set_Specific_Warning_Off;
    --  This is called in response to the two argument form of pragma Warnings
-   --  where the first argument is OFF, and the second argument is the prefix
-   --  of a specific warning to be suppressed. The first argument is the start
-   --  of the suppression range, and the second argument is the string from
-   --  the pragma.
+   --  where the first argument is OFF, and the second argument is a string
+   --  which identifies a specific warning to be suppressed. The first argument
+   --  is the start of the suppression range, and the second argument is the
+   --  string from the pragma. Loc is the location of the pragma (which is the
+   --  start of the range to suppress). Reason is the reason string from the
+   --  pragma, or the null string if no reason is given. Config is True for the
+   --  configuration pragma case (where there is no requirement for a matching
+   --  OFF pragma). Used is set True to disable the check that the warning
+   --  actually has has the effect of suppressing a warning.
 
    procedure Set_Specific_Warning_On
      (Loc : Source_Ptr;

gcc/ada/erroutc.adb

@@ -39,6 +39,7 @@ with Opt;      use Opt;
 with Output;   use Output;
 with Sinput;   use Sinput;
 with Snames;   use Snames;
+with Stringt;  use Stringt;
 with Targparm; use Targparm;
 with Uintp;    use Uintp;
 
@@ -1110,6 +1111,7 @@ package body Erroutc is
    procedure Set_Specific_Warning_Off
      (Loc    : Source_Ptr;
       Msg    : String;
+      Reason : String_Id;
       Config : Boolean;
       Used   : Boolean := False)
    is
@@ -1118,6 +1120,7 @@ package body Erroutc is
         ((Start      => Loc,
           Msg        => new String'(Msg),
           Stop       => Source_Last (Current_Source_File),
+          Reason     => Reason,
           Open       => True,
           Used       => Used,
           Config     => Config));
@@ -1163,7 +1166,7 @@ package body Erroutc is
    -- Set_Warnings_Mode_Off --
    ---------------------------
 
-   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
+   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id) is
    begin
       --  Don't bother with entries from instantiation copies, since we will
       --  already have a copy in the template, which is what matters.
@@ -1197,10 +1200,10 @@ package body Erroutc is
       --  source file. This ending point will be adjusted by a subsequent
       --  corresponding pragma Warnings (On).
 
-      Warnings.Increment_Last;
-      Warnings.Table (Warnings.Last).Start := Loc;
-      Warnings.Table (Warnings.Last).Stop :=
-        Source_Last (Current_Source_File);
+      Warnings.Append
+        ((Start  => Loc,
+          Stop   => Source_Last (Current_Source_File),
+          Reason => Reason));
    end Set_Warnings_Mode_Off;
 
    --------------------------
@@ -1342,7 +1345,7 @@ package body Erroutc is
 
    function Warning_Specifically_Suppressed
      (Loc : Source_Ptr;
-      Msg : String_Ptr) return Boolean
+      Msg : String_Ptr) return String_Id
    is
       function Matches (S : String; P : String) return Boolean;
       --  Returns true if the String S patches the pattern P, which can contain
@@ -1429,36 +1432,36 @@ package body Erroutc is
             then
                if Matches (Msg.all, SWE.Msg.all) then
                   SWE.Used := True;
-                  return True;
+                  return SWE.Reason;
                end if;
             end if;
          end;
       end loop;
 
-      return False;
+      return No_String;
    end Warning_Specifically_Suppressed;
 
    -------------------------
    -- Warnings_Suppressed --
    -------------------------
 
-   function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
+   function Warnings_Suppressed (Loc : Source_Ptr) return String_Id is
    begin
-      if Warning_Mode = Suppress then
-         return True;
-      end if;
-
       --  Loop through table of ON/OFF warnings
 
       for J in Warnings.First .. Warnings.Last loop
          if Warnings.Table (J).Start <= Loc
            and then Loc <= Warnings.Table (J).Stop
          then
-            return True;
+            return Warnings.Table (J).Reason;
          end if;
       end loop;
 
-      return False;
+      if Warning_Mode = Suppress then
+         return Null_String_Id;
+      else
+         return No_String;
+      end if;
    end Warnings_Suppressed;
 
 end Erroutc;

gcc/ada/erroutc.ads

@@ -267,9 +267,13 @@ package Erroutc is
    --  values in this table always reference the original template, not an
    --  instantiation copy, in the generic case.
 
+   --  Reason is the reason from the pragma Warnings (Off,..) or the null
+   --  string if no reason parameter is given.
+
    type Warnings_Entry is record
-      Start : Source_Ptr;
-      Stop  : Source_Ptr;
+      Start  : Source_Ptr;
+      Stop   : Source_Ptr;
+      Reason : String_Id;
    end record;
 
    package Warnings is new Table.Table (
@@ -282,7 +286,7 @@ package Erroutc is
 
    --  The second table is used for the specific forms of the pragma, where
    --  the first argument is ON or OFF, and the second parameter is a string
-   --  which is the entire message to suppress, or a prefix of it.
+   --  which is the pattern to match for suppressing a warning.
 
    type Specific_Warning_Entry is record
       Start : Source_Ptr;
@@ -290,6 +294,9 @@ package Erroutc is
       --  Starting and ending source pointers for the range. These are always
       --  from the same source file.
 
+      Reason : String_Id;
+      --  Reason string from pragma Warnings, or null string if none
+
       Msg : String_Ptr;
       --  Message from pragma Warnings (Off, string)
 
@@ -466,6 +473,7 @@ package Erroutc is
    procedure Set_Specific_Warning_Off
      (Loc    : Source_Ptr;
       Msg    : String;
+      Reason : String_Id;
       Config : Boolean;
       Used   : Boolean := False);
    --  This is called in response to the two argument form of pragma Warnings
@@ -473,10 +481,11 @@ package Erroutc is
    --  which identifies a specific warning to be suppressed. The first argument
    --  is the start of the suppression range, and the second argument is the
    --  string from the pragma. Loc is the location of the pragma (which is the
-   --  start of the range to suppress). Config is True for the configuration
-   --  pragma case (where there is no requirement for a matching OFF pragma).
-   --  Used is set True to disable the check that the warning actually has
-   --  has the effect of suppressing a warning.
+   --  start of the range to suppress). Reason is the reason string from the
+   --  pragma, or the null string if no reason is given. Config is True for the
+   --  configuration pragma case (where there is no requirement for a matching
+   --  OFF pragma). Used is set True to disable the check that the warning
+   --  actually has has the effect of suppressing a warning.
 
    procedure Set_Specific_Warning_On
      (Loc : Source_Ptr;
@@ -489,9 +498,10 @@ package Erroutc is
    --  string from the pragma. Err is set to True on return to report the error
    --  of no matching Warnings Off pragma preceding this one.
 
-   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr);
+   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr; Reason : String_Id);
    --  Called in response to a pragma Warnings (Off) to record the source
-   --  location from which warnings are to be turned off.
+   --  location from which warnings are to be turned off. Reason is the
+   --  Reason from the pragma, or the null string if none is given.
 
    procedure Set_Warnings_Mode_On (Loc : Source_Ptr);
    --  Called in response to a pragma Warnings (On) to record the source
@@ -518,18 +528,24 @@ package Erroutc is
    --  Note that the call has no effect for continuation messages (those whose
    --  first character is '\'), and all variables are left unchanged.
 
-   function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
+   function Warnings_Suppressed (Loc : Source_Ptr) return String_Id;
    --  Determines if given location is covered by a warnings off suppression
    --  range in the warnings table (or is suppressed by compilation option,
    --  which generates a warning range for the whole source file). This routine
-   --  only deals with the general ON/OFF case, not specific warnings. True
-   --  is also returned if warnings are globally suppressed.
+   --  only deals with the general ON/OFF case, not specific warnings. The
+   --  returned result is No_String if warnings are not suppressed. If warnings
+   --  are suppressed for the given location, then then corresponding Reason
+   --  parameter from the pragma is returned (or the null string if no Reason
+   --  parameter was present).
 
    function Warning_Specifically_Suppressed
      (Loc : Source_Ptr;
-      Msg : String_Ptr) return Boolean;
+      Msg : String_Ptr) return String_Id;
    --  Determines if given message to be posted at given location is suppressed
    --  by specific ON/OFF Warnings pragmas specifying this particular message.
+   --  If the warning is not suppressed then No_String is returned, otherwise
+   --  the corresponding warning string is returned (or the null string if no
+   --  Warning argument was present in the pragma).
 
    type Error_Msg_Proc is
      access procedure (Msg : String; Flag_Location : Source_Ptr);

gcc/ada/errutil.adb

@@ -193,7 +193,7 @@ package body Errutil is
       --  Immediate return if warning message and warnings are suppressed.
       --  Note that style messages are not warnings for this purpose.
 
-      if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then
+      if Is_Warning_Msg and then Warnings_Suppressed (Sptr) /= No_String then
          Cur_Msg := No_Error_Msg;
          return;
       end if;

gcc/ada/gnat_rm.texi

@@ -7381,7 +7381,7 @@ pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
 pragma Warnings (static_string_EXPRESSION [,REASON]);
 pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
 
-REASON ::= Reason => static_string_EXPRESSION
+REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
 @end smallexample
 
 @noindent

gcc/ada/par-prag.adb

@@ -1018,10 +1018,10 @@ begin
       -- Warnings (GNAT) --
       ---------------------
 
-      --  pragma Warnings (On | Off);
-      --  pragma Warnings (On | Off, LOCAL_NAME);
-      --  pragma Warnings (static_string_EXPRESSION);
-      --  pragma Warnings (On | Off, static_string_EXPRESSION);
+      --  pragma Warnings (On | Off [,REASON]);
+      --  pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
+      --  pragma Warnings (static_string_EXPRESSION [,REASON]);
+      --  pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
 
       --  The one argument ON/OFF case is processed by the parser, since it may
       --  control parser warnings as well as semantic warnings, and in any case
@@ -1042,12 +1042,33 @@ begin
 
             declare
                Argx : constant Node_Id := Expression (Arg1);
+
+               function Get_Reason return String_Id;
+               --  Analyzes Reason argument and returns corresponding String_Id
+               --  value, or null if there is no Reason argument, or if the
+               --  argument is not of the required form.
+
+               ----------------
+               -- Get_Reason --
+               ----------------
+
+               function Get_Reason return String_Id is
+               begin
+                  if Arg_Count = 1 then
+                     return Null_String_Id;
+                  else
+                     Start_String;
+                     Get_Reason_String (Expression (Arg2));
+                     return End_String;
+                  end if;
+               end Get_Reason;
+
             begin
                if Nkind (Argx) = N_Identifier then
                   if Chars (Argx) = Name_On then
                      Set_Warnings_Mode_On (Pragma_Sloc);
                   elsif Chars (Argx) = Name_Off then
-                     Set_Warnings_Mode_Off (Pragma_Sloc);
+                     Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason);
                   end if;
                end if;
             end;

gcc/ada/sem_ch5.adb

@@ -1931,6 +1931,7 @@ package body Sem_Ch5 is
                Set_Etype (Def_Id,
                  Get_Cursor_Type
                   (Parent (Find_Value_Of_Aspect (Typ, Aspect_Iterable)), Typ));
+               Ent := Etype (Def_Id);
 
             else
                Ent := First_Entity (Scope (Typ));

gcc/ada/sem_prag.adb

@@ -20815,14 +20815,17 @@ package body Sem_Prag is
 
          --  REASON ::= Reason => Static_String_Expression
 
-         when Pragma_Warnings => Warnings : begin
+         when Pragma_Warnings => Warnings : declare
+            Reason : String_Id;
+
+         begin
             GNAT_Pragma;
             Check_At_Least_N_Arguments (1);
 
             --  See if last argument is labeled Reason. If so, make sure we
-            --  have a static string expression, but otherwise just ignore
-            --  the REASON argument by decreasing Num_Args by 1 (all the
-            --  remaining tests look only at the first Num_Args arguments).
+            --  have a static string expression, and acquire the REASON string.
+            --  Then remove the REASON argument by decreasing Num_Args by one;
+            --  Remaining processing looks only at first Num_Args arguments).
 
             declare
                Last_Arg : constant Node_Id :=
@@ -20831,12 +20834,19 @@ package body Sem_Prag is
                if Nkind (Last_Arg) = N_Pragma_Argument_Association
                  and then Chars (Last_Arg) = Name_Reason
                then
-                  Check_Arg_Is_Static_Expression (Last_Arg, Standard_String);
+                  Start_String;
+                  Get_Reason_String (Get_Pragma_Arg (Last_Arg));
+                  Reason := End_String;
                   Arg_Count := Arg_Count - 1;
 
                   --  Not allowed in compiler units (bootstrap issues)
 
                   Check_Compiler_Unit (N);
+
+               --  No REASON string, set null string as reason
+
+               else
+                  Reason := Null_String_Id;
                end if;
             end;
 
@@ -20986,7 +20996,7 @@ package body Sem_Prag is
                                 and then Warn_On_Warnings_Off
                                 and then not In_Instance
                               then
-                                 Warnings_Off_Pragmas.Append ((N, E));
+                                 Warnings_Off_Pragmas.Append ((N, E, Reason));
                               end if;
 
                               if Is_Enumeration_Type (E) then
@@ -21040,7 +21050,7 @@ package body Sem_Prag is
 
                         if Chars (Argx) = Name_Off then
                            Set_Specific_Warning_Off
-                             (Loc, Name_Buffer (1 .. Name_Len),
+                             (Loc, Name_Buffer (1 .. Name_Len), Reason,
                               Config => Is_Configuration_Pragma,
                               Used   => Inside_A_Generic or else In_Instance);
 

gcc/ada/sem_util.adb

@@ -6767,6 +6767,30 @@ package body Sem_Util is
       return Get_Pragma_Id (Pragma_Name (N));
    end Get_Pragma_Id;
 
+   -----------------------
+   -- Get_Reason_String --
+   -----------------------
+
+   procedure Get_Reason_String (N : Node_Id) is
+   begin
+      if Nkind (N) = N_String_Literal then
+         Store_String_Chars (Strval (N));
+
+      elsif Nkind (N) = N_Op_Concat then
+         Get_Reason_String (Left_Opnd (N));
+         Get_Reason_String (Right_Opnd (N));
+
+      --  If not of required form, error
+
+      else
+         Error_Msg_N
+           ("Reason for pragma Warnings has wrong form", N);
+         Error_Msg_N
+           ("\must be string literal or concatenation of string literals", N);
+         return;
+      end if;
+   end Get_Reason_String;
+
    ---------------------------
    -- Get_Referenced_Object --
    ---------------------------

gcc/ada/sem_util.ads

@@ -851,6 +851,13 @@ package Sem_Util is
    pragma Inline (Get_Pragma_Id);
    --  Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
 
+   procedure Get_Reason_String (N : Node_Id);
+   --  Recursive routine to analyze reason argument for pragma Warnings. The
+   --  value of the reason argument is appended to the current string using
+   --  Store_String_Chars. The reason argument is expected to be a string
+   --  literal or concatenation of string literals. An error is given for
+   --  any other form.
+
    function Get_Referenced_Object (N : Node_Id) return Node_Id;
    --  Given a node, return the renamed object if the node represents a renamed
    --  object, otherwise return the node unchanged. The node may represent an

gcc/ada/sem_warn.ads

@@ -39,10 +39,13 @@ package Sem_Warn is
 
    type Warnings_Off_Entry is record
       N : Node_Id;
-      --  A pragma Warnings (Off, ent) node
+      --  A pragma Warnings (Off, ent [,Reason]) node
 
       E : Entity_Id;
       --  The entity involved
+
+      R : String_Id;
+      --  Warning reason if present, or null if not (not currently used)
    end record;
 
    --  An entry is made in the following table for any valid Pragma Warnings

gcc/ada/stringt.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, 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- --
@@ -472,4 +472,12 @@ package body Stringt is
       end if;
    end Write_String_Table_Entry;
 
+--  Setup the null string
+
+pragma Warnings (Off); -- kill strange warning from code below ???
+
+begin
+   Start_String;
+   Null_String_Id := End_String;
+
 end Stringt;

gcc/ada/stringt.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, 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- --
@@ -48,6 +48,9 @@ package Stringt is
 --  value for two identical strings stored separately and also cannot count on
 --  the two Id values being different.
 
+   Null_String_Id : String_Id;
+   --  Gets set to a null string with length zero
+
    --------------------------------------
    -- String Table Access Subprograms --
    --------------------------------------