comperr.adb: Fix problem with suppressing warning messages from gigi

2007-08-14  Robert Dewar  <dewar@adacore.com>

	* comperr.adb: Fix problem with suppressing warning messages from gigi

	* erroutc.ads, erroutc.adb, errout.ads, 
	errout.adb (Write_Eol): Remove trailing spaces before writing the line
	(Write_Eol_Keep_Blanks): New procedure to write a line, including
	possible trailing spaces.
	(Output_Source_Line): Call Write_Eol_Keep_Blanks to output a source line
	Fix problem with suppressing warning messages from back end
	Improve handling of deleted warnings

	* gnat1drv.adb: 
	Fix problem with suppressing warning messages from back end
	Handle setting of Static_Dispatch_Tables flag.

	* prepcomp.adb: 
	Fix problem with suppressing warning messages from back end

	* exp_intr.adb: Improve handling of deleted warnings

From-SVN: r127413

gcc/ada/comperr.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -120,7 +120,7 @@ package body Comperr is
       --  Debug flag K disables this behavior (useful for debugging)
 
       if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then
-         Errout.Finalize;
+         Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
 
          Set_Standard_Error;

gcc/ada/errout.ads

@@ -204,7 +204,14 @@ package Errout is
    --
    --      By convention, the # insertion character is only used at the end of
    --      an error message, so the above strings only appear as the last
-   --      characters of an error message.
+   --      characters of an error message. The only exceptions to this rule
+   --      are that an RM reference may follow in the form (RM .....) and a
+   --      right parenthesis may immediately follow the #. In the case of
+   --      continued messages, # can only appear at the end of a group of
+   --      continuation messsages, except that \\ messages which always start
+   --      a new line end the sequence from the point of view of this rule.
+   --      The idea is that for any use of -gnatj, it will still be the case
+   --      that a location reference appears only at the end of a line.
 
    --    Insertion character } (Right brace: insert type reference)
    --      The character } is replaced by a string describing the type
@@ -244,8 +251,9 @@ package Errout is
    --      the message unconditional which means that it is output even if it
    --      would normally be suppressed. See section above for a description
    --      of the cases in which messages are normally suppressed. Note that
-   --      warnings are never suppressed, so the use of the ! character in a
-   --      warning message is never useful.
+   --      in the case of warnings, the meaning is that the warning should not
+   --      be removed in dead code (that's the only time that the use of !
+   --      has any effect for a warning).
    --
    --      Note: the presence of ! is ignored in continuation messages (i.e.
    --      messages starting with the \ insertion character). The effect of the
@@ -456,6 +464,10 @@ package Errout is
    --  used for keywords (actually the first compilation unit keyword) in the
    --  source file.
 
+   --  Note: a special exception is that RM is never treated as a keyword
+   --  but instead is copied literally into the message, this avoids the
+   --  need for writing 'R'M for all reference manual quotes.
+
    --  In the case of names, the default mode for the error text processor
    --  is to surround the name by quotation marks automatically. The case
    --  used for the identifier names is taken from the source program where
@@ -560,18 +572,23 @@ package Errout is
    --  Initializes for output of error messages. Must be called for each
    --  source file before using any of the other routines in the package.
 
-   procedure Finalize;
+   procedure Finalize (Last_Call : Boolean);
    --  Finalize processing of error message list. Includes processing for
    --  duplicated error messages, and other similar final adjustment of the
    --  list of error messages. Note that this procedure must be called before
    --  calling Compilation_Errors to determine if there were any errors. It
-   --  is perfectly fine to call Finalize more than once. Indeed this can
-   --  make good sense. For example, do some processing that may generate
-   --  messages. Call Finalize to eliminate duplicates and remove deleted
-   --  warnings. Test for compilation errors using Compilation_Errors, then
-   --  generate some more errors/warnings, call Finalize again to make sure
-   --  that all duplicates in these new messages are dealt with, then finally
-   --  call Output_Messages to output the final list of messages.
+   --  is perfectly fine to call Finalize more than once, providing that the
+   --  parameter Last_Call is set False for every call except the last call.
+
+   --  This multiple call capability is used to do some processing that may
+   --  generate messages. Call Finalize to eliminate duplicates and remove
+   --  deleted warnings. Test for compilation errors using Compilation_Errors,
+   --  then generate some more errors/warnings, call Finalize again to make
+   --  sure that all duplicates in these new messages are dealt with, then
+   --  finally call Output_Messages to output the final list of messages. The
+   --  argument Last_Call must be set False on all calls except the last call,
+   --  and must be set True on the last call (a value of True activates some
+   --  processing that must only be done after all messages are posted).
 
    procedure Output_Messages;
    --  Output list of messages, including messages giving number of detected
@@ -676,10 +693,14 @@ package Errout is
 
    procedure Remove_Warning_Messages (N : Node_Id);
    --  Remove any warning messages corresponding to the Sloc of N or any
-   --  of its descendent nodes. No effect if no such warnings.
+   --  of its descendent nodes. No effect if no such warnings. Note that
+   --  style messages (identified by the fact that they start with "(style)"
+   --  are not removed by this call. Basically the idea behind this procedure
+   --  is to remove warnings about execution conditions from known dead code.
 
    procedure Remove_Warning_Messages (L : List_Id);
-   --  Remove warnings on all elements of a list
+   --  Remove warnings on all elements of a list (Calls Remove_Warning_Messages
+   --  on each element of the list, see above).
 
    procedure Set_Ignore_Errors (To : Boolean);
    --  Following a call to this procedure with To=True, all error calls are
@@ -696,7 +717,10 @@ package Errout is
    --  Called in response to a pragma Warnings (On) to record the source
    --  location from which warnings are to be turned back on.
 
-   procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String)
+   procedure Set_Specific_Warning_Off
+     (Loc    : Source_Ptr;
+      Msg    : String;
+      Config : Boolean)
      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

gcc/ada/erroutc.adb

@@ -924,10 +924,19 @@ package body Erroutc is
          J := J + 1;
       end loop;
 
-      Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
-      Set_Msg_Quote;
-      Set_Msg_Name_Buffer;
-      Set_Msg_Quote;
+      --  Here is where we make the special exception for RM
+
+      if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
+         Set_Msg_Name_Buffer;
+
+      --  Not RM: case appropriately and add surrounding quotes
+
+      else
+         Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
+         Set_Msg_Quote;
+         Set_Msg_Name_Buffer;
+         Set_Msg_Quote;
+      end if;
    end Set_Msg_Insertion_Reserved_Word;
 
    -------------------------------------
@@ -1038,7 +1047,11 @@ package body Erroutc is
    -- Set_Specific_Warning_Off --
    ------------------------------
 
-   procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String) is
+   procedure Set_Specific_Warning_Off
+     (Loc    : Source_Ptr;
+      Msg    : String;
+      Config : Boolean)
+   is
       pragma Assert (Msg'First = 1);
 
       Pattern : String  := Msg;
@@ -1063,17 +1076,17 @@ package body Erroutc is
          Star_End := False;
       end if;
 
-      Specific_Warnings.Increment_Last;
-      Specific_Warnings.Table (Specific_Warnings.Last) :=
-        (Start      => Loc,
-         Msg        => new String'(Msg),
-         Pattern    => new String'(Pattern (1 .. Patlen)),
-         Patlen     => Patlen,
-         Stop       => Source_Last (Current_Source_File),
-         Open       => True,
-         Used       => False,
-         Star_Start => Star_Start,
-         Star_End   => Star_End);
+      Specific_Warnings.Append
+        ((Start      => Loc,
+          Msg        => new String'(Msg),
+          Pattern    => new String'(Pattern (1 .. Patlen)),
+          Patlen     => Patlen,
+          Stop       => Source_Last (Current_Source_File),
+          Open       => True,
+          Used       => False,
+          Star_Start => Star_Start,
+          Star_End   => Star_End,
+          Config     => Config));
    end Set_Specific_Warning_Off;
 
    -----------------------------
@@ -1099,6 +1112,11 @@ package body Erroutc is
                SWE.Stop := Loc;
                SWE.Open := False;
                Err := False;
+
+               --  If a config pragma is specifically cancelled, consider
+               --  that it is no longer active as a configuration pragma.
+
+               SWE.Config := False;
                return;
             end if;
          end;
@@ -1218,7 +1236,7 @@ package body Erroutc is
          declare
             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
          begin
-            if SWE.Start /= No_Location then
+            if not SWE.Config then
                if SWE.Open then
                   Eproc.all
                     ("?pragma Warnings Off with no matching Warnings On",
@@ -1265,11 +1283,14 @@ package body Erroutc is
             SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
 
          begin
-            --  See if location is in range
+            --  Pragma applies if it is a configuration pragma, or if the
+            --  location is in range of a specific non-configuration pragma.
 
-            if SWE.Start = No_Location
+            if SWE.Config
               or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
             then
+               --  Check if message matches, dealing with * patterns
+
                Patlen     := SWE.Patlen;
                Pattern    := SWE.Pattern;
                Star_Start := SWE.Star_Start;

gcc/ada/erroutc.ads

@@ -263,8 +263,7 @@ package Erroutc is
       Start : Source_Ptr;
       Stop  : Source_Ptr;
       --  Starting and ending source pointers for the range. These are always
-      --  from the same source file. Start is set to No_Location for the case
-      --  of a configuration pragma.
+      --  from the same source file.
 
       Msg : String_Ptr;
       --  Message from pragma Warnings (Off, string)
@@ -277,7 +276,7 @@ package Erroutc is
       --  Length of pattern string (excluding initial/final asterisks)
 
       Open : Boolean;
-      --  Set to True if OFF has been encountered with no matchin ON
+      --  Set to True if OFF has been encountered with no matching ON
 
       Used : Boolean;
       --  Set to True if entry has been used to suppress a warning
@@ -288,6 +287,10 @@ package Erroutc is
       Star_End : Boolean;
       --  True if given pattern had * at end
 
+      Config : Boolean;
+      --  True if pragma is configuration pragma (in which case no matching
+      --  Off pragma is required, and it is not required that a specific
+      --  warning be suppressed).
    end record;
 
    package Specific_Warnings is new Table.Table (
@@ -298,6 +301,23 @@ package Erroutc is
      Table_Increment      => 200,
      Table_Name           => "Specific_Warnings");
 
+   --  Note on handling configuration case versus specific case. A complication
+   --  arises from this example:
+
+   --     pragma Warnings (Off, "not referenced*");
+   --     procedure Mumble (X : Integer) is
+   --     pragma Warnings (On, "not referenced*");
+   --     begin
+   --        null;
+   --     end Mumble;
+
+   --  The trouble is that the first pragma is technically a configuration
+   --  pragma, and yet it is clearly being used in the context of thinking
+   --  of it as a specific case. To deal with this, what we do is that the
+   --  On entry can match a configuration pragma from the same file, and if
+   --  we find such an On entry, we cancel the indication of it being the
+   --  configuration case. This seems to handle all cases we run into ok.
+
    -----------------
    -- Subprograms --
    -----------------
@@ -430,23 +450,28 @@ package Erroutc is
    --  the input value of E was either already No_Error_Msg, or was the
    --  last non-deleted message.
 
-   procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String);
+   procedure Set_Specific_Warning_Off
+     (Loc    : Source_Ptr;
+      Msg    : String;
+      Config : Boolean);
    --  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. Loc is set to No_Location for the configuration pragma case.
+   --  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). Config is True for the configuration
+   --  pragma case (where there is no requirement for a matching OFF pragma).
 
    procedure Set_Specific_Warning_On
      (Loc : Source_Ptr;
       Msg : String;
       Err : out Boolean);
    --  This is called in response to the two argument form of pragma Warnings
-   --  where the first argument is ON, and the second argument is the prefix
-   --  of a specific warning to be suppressed. The first argument is the end
-   --  of the suppression range, and the second argument is the string from
-   --  the pragma. Err is set to True on return to report the error of no
-   --  matching Warnings Off pragma preceding this one.
+   --  where the first argument is ON, and the second argument is a string
+   --  which identifies a specific warning to be suppressed. The first argument
+   --  is the end of the suppression range, and the second argument is the
+   --  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);
    --  Called in response to a pragma Warnings (Off) to record the source

gcc/ada/exp_intr.adb

@@ -770,7 +770,7 @@ package body Exp_Intr is
 
    begin
       if No_Pool_Assigned (Rtyp) then
-         Error_Msg_N ("?deallocation from empty storage pool", N);
+         Error_Msg_N ("?deallocation from empty storage pool!", N);
       end if;
 
       --  Nothing to do if we know the argument is null

gcc/ada/gnat1drv.adb

@@ -171,7 +171,7 @@ procedure Gnat1drv is
            and then not Source_File_Is_Subunit (Src_Ind)
            and then not Source_File_Is_No_Body (Src_Ind)
          then
-            Errout.Finalize;
+            Errout.Finalize (Last_Call => False);
 
             Error_Msg_Unit_1 := Sname;
 
@@ -338,6 +338,16 @@ begin
          List_Representation_Info_Mechanisms := True;
       end if;
 
+      --  Disable static allocation of dispatch tables if -gnatd.t or if layout
+      --  is enabled. The front end's layout phase currently treats types that
+      --  have discriminant-dependent arrays as not being static even when a
+      --  discriminant constraint on the type is static, and this leads to
+      --  problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ???
+
+      if Debug_Flag_Dot_T or else Frontend_Layout_On_Target then
+         Static_Dispatch_Tables := False;
+      end if;
+
       --  Output copyright notice if full list mode unless we have a list
       --  file, in which case we defer this so that it is output in the file
 
@@ -417,7 +427,7 @@ begin
       --  Exit with errors if the main source could not be parsed
 
       if Sinput.Main_Source_File = No_Source_File then
-         Errout.Finalize;
+         Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Exit_Program (E_Errors);
       end if;
@@ -428,7 +438,7 @@ begin
 
       --  Exit if compilation errors detected
 
-      Errout.Finalize;
+      Errout.Finalize (Last_Call => False);
 
       if Compilation_Errors then
          Treepr.Tree_Dump;
@@ -443,6 +453,7 @@ begin
             Tree_Gen;
          end if;
 
+         Errout.Finalize (Last_Call => True);
          Exit_Program (E_Errors);
       end if;
 
@@ -466,7 +477,7 @@ begin
 
       if Original_Operating_Mode = Check_Syntax then
          Treepr.Tree_Dump;
-         Errout.Finalize;
+         Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Tree_Gen;
          Namet.Finalize;
@@ -612,7 +623,7 @@ begin
          Write_Eol;
 
          Sem_Ch13.Validate_Unchecked_Conversions;
-         Errout.Finalize;
+         Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Treepr.Tree_Dump;
          Tree_Gen;
@@ -644,7 +655,7 @@ begin
                    or else Targparm.VM_Target /= No_VM)
       then
          Sem_Ch13.Validate_Unchecked_Conversions;
-         Errout.Finalize;
+         Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Write_ALI (Object => False);
          Tree_Dump;
@@ -700,7 +711,7 @@ begin
       --  indicating that elaboration is required, and also to back annotate
       --  representation information for List_Rep_Info.
 
-      Errout.Finalize;
+      Errout.Finalize (Last_Call => True);
       Errout.Output_Messages;
       List_Rep_Info;
 
@@ -758,7 +769,7 @@ begin
 
 exception
    when Unrecoverable_Error =>
-      Errout.Finalize;
+      Errout.Finalize (Last_Call => True);
       Errout.Output_Messages;
 
       Set_Standard_Error;

gcc/ada/prepcomp.adb

@@ -41,7 +41,7 @@ with Types;    use Types;
 package body Prepcomp is
 
    No_Preprocessing : Boolean := True;
-   --  Set to True if there is at least one source that needs to be
+   --  Set to False if there is at least one source that needs to be
    --  preprocessed.
 
    Source_Index_Of_Preproc_Data_File : Source_File_Index := No_Source_File;
@@ -560,7 +560,7 @@ package body Prepcomp is
       --  Fail if there were errors in the preprocessing data file
 
       if Total_Errors_Detected > T then
-         Errout.Finalize;
+         Errout.Finalize (Last_Call => True);
          Errout.Output_Messages;
          Fail ("errors found in preprocessing data file """,
                Get_Name_String (N),
@@ -687,7 +687,7 @@ package body Prepcomp is
             --  Fail if errors were found while processing the definition file
 
             if T /= Total_Errors_Detected then
-               Errout.Finalize;
+               Errout.Finalize (Last_Call => True);
                Errout.Output_Messages;
                Fail ("errors found in definition file """,
                      Get_Name_String (N),