Patchwork [Ada] pragma Warnings Off (str) should delete continuations

login
register
mail settings
Submitter Arnaud Charlet
Date June 22, 2010, 5:31 p.m.
Message ID <20100622173105.GA1161@adacore.com>
Download mbox | patch
Permalink /patch/56541/
State New
Headers show

Comments

Arnaud Charlet - June 22, 2010, 5:31 p.m.
This patch improves the behavior of the form of pragma
Warnings where a string is given to match error text.
Now continuation lines preceding and following the deleted
message are also deleted (including the "in instantion" line)

These test programs should both compile without any warnings

pragma Warnings (Off, "*is an internal GNAT unit");
with System.OS_Lib;
procedure Warn2 is begin null; end;

procedure Bar4 is

   generic
      type F is (<>);
      type T is (<>);
   procedure Foo;

   procedure Foo is
      function Conv is new Unchecked_Conversion (F, T);
   begin
      null;
   end Foo;

   pragma Warnings (Off, "*types for unchecked conversion*");
   procedure Glorp is new Foo(Integer_32, Unsigned_64);
   pragma Warnings (On, "*types for unchecked conversion*");

begin
   null;
end Bar4;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-22  Robert Dewar  <dewar@adacore.com>

	* errout.adb (Finalize): Set Prev pointers.
	(Finalize): Delete continuations for deletion by warnings off(str).
	* erroutc.ads: Add Prev pointer to error message structure.
Eric Botcazou - June 22, 2010, 6:55 p.m.
> 2010-06-22  Robert Dewar  <dewar@adacore.com>
>
> 	* errout.adb (Finalize): Set Prev pointers.
> 	(Finalize): Delete continuations for deletion by warnings off(str).
> 	* erroutc.ads: Add Prev pointer to error message structure.

This apparently causes gnat.dg/not_null.adb to fail.

Patch

Index: errout.adb
===================================================================
--- errout.adb	(revision 161171)
+++ errout.adb	(working copy)
@@ -881,6 +881,7 @@  package body Errout is
       Errors.Append
         ((Text     => new String'(Msg_Buffer (1 .. Msglen)),
           Next     => No_Error_Msg,
+          Prev     => No_Error_Msg,
           Sptr     => Sptr,
           Optr     => Optr,
           Sfile    => Get_Source_File_Index (Sptr),
@@ -1215,6 +1216,16 @@  package body Errout is
       F   : Error_Msg_Id;
 
    begin
+      --  Set Prev pointers
+
+      Cur := First_Error_Msg;
+      while Cur /= No_Error_Msg loop
+         Nxt := Errors.Table (Cur).Next;
+         exit when Nxt = No_Error_Msg;
+         Errors.Table (Nxt).Prev := Cur;
+         Cur := Nxt;
+      end loop;
+
       --  Eliminate any duplicated error messages from the list. This is
       --  done after the fact to avoid problems with Change_Error_Text.
 
@@ -1239,11 +1250,28 @@  package body Errout is
       while Cur /= No_Error_Msg loop
          if not Errors.Table (Cur).Deleted
            and then Warning_Specifically_Suppressed
-                     (Errors.Table (Cur).Sptr,
-                      Errors.Table (Cur).Text)
+                      (Errors.Table (Cur).Sptr, Errors.Table (Cur).Text)
          then
             Errors.Table (Cur).Deleted := True;
             Warnings_Detected := Warnings_Detected - 1;
+
+            --  If this is a continuation, delete previous messages
+
+            F := Cur;
+            while Errors.Table (F).Msg_Cont loop
+               F := Errors.Table (F).Prev;
+               Errors.Table (F).Deleted := True;
+            end loop;
+
+            --  Delete any following continuations
+
+            F := Cur;
+            loop
+               F := Errors.Table (F).Next;
+               exit when F = No_Error_Msg;
+               exit when not Errors.Table (F).Msg_Cont;
+               Errors.Table (F).Deleted := True;
+            end loop;
          end if;
 
          Cur := Errors.Table (Cur).Next;
Index: erroutc.ads
===================================================================
--- erroutc.ads	(revision 161073)
+++ erroutc.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -147,6 +147,11 @@  package Erroutc is
       --  Pointer to next message in error chain. A value of No_Error_Msg
       --  indicates the end of the chain.
 
+      Prev : Error_Msg_Id;
+      --  Pointer to previous message in error chain. Only set during the
+      --  Finalize procedure. A value of No_Error_Msg indicates the first
+      --  message in the chain.
+
       Sfile : Source_File_Index;
       --  Source table index of source file. In the case of an error that
       --  refers to a template, always references the original template