[Bug ada/25838] New: Assert Failure with Bug Box

["anhvofrcaus at gmail dot com" <gcc-bugzilla at gcc dot gnu dot org>]

gnatmake -c -u -P/home/voax/gps-prj/ada-2005/bugs/assert_failure.gpr
bugs_test.adb -d
gcc -c -gnat05 -I- -gnatA /home/voax/gps-prj/ada-2005/bugs/bugs_test.adb
+===========================GNAT BUG DETECTED==============================+
| 4.1.0 20060106 (prerelease) (i686-pc-linux-gnu) Assert_Failure einfo.adb:507|
| Error detected at bugs_test.adb:23:9                                     |
| Please submit a bug report; see http://gcc.gnu.org/bugs.html.            |
| Use a subject line meaningful to you and us to track the bug.            |
| Include the entire contents of this bug box in the report.               |
| Include the exact gcc or gnatmake command that you entered.              |
| Also include sources listed below in gnatchop format                     |
| (concatenated together with no headers between files).                   |
+==========================================================================+
Please include these source files with error report
Note that list may not be accurate in some cases,
so please double check that the problem can still
be reproduced with the set of files listed.
/home/voax/gps-prj/ada-2005/bugs/bugs_test.adb
/home/voax/gps-prj/ada-2005/bugs/implementing_interface.ads
/home/voax/gps-prj/ada-2005/bugs/abstract_interface.ads
compilation abandoned
gnatmake: "/home/voax/gps-prj/ada-2005/bugs/bugs_test.adb" compilation error
process exited with status 4

Here are the source files shown above

package Abstract_Interface is

   type Base is interface;


--     type Task_Base is task interface;
   type Mutex is task interface;
   procedure Wait (Object : in out Mutex) is abstract;
   procedure Signal (Object : in out Mutex) is abstract;


   --     type Protected_Base is protected interface;
   type Buffer is protected interface;
   procedure Put (Object : in out Buffer;
                  Data : in Integer) is abstract;
   procedure Get (Object : in out Buffer;
                  Data : out Integer) is abstract;


--     type Synchronized_Base is synchronized interface;
   type Event is synchronized interface;
   procedure Wait (Object : in out Event) is abstract;
   procedure Signal (Object : in out Event) is abstract;


end Abstract_Interface;

with Abstract_Interface;

package Implementing_Interface is

   type Storage_Type is array (Integer range <>) of Integer;

   task Gary_Left is new Abstract_Interface.Mutex with
      entry Wait;
      entry Signal;
      entry Shutdown;
   end Gary_Left;

   task Gary_Right is new Abstract_Interface.Mutex with
      entry Wait;
      entry Signal;
      entry Shutdown;
   end Gary_Right;

   protected type Anh_Left is new Abstract_Interface.Buffer with
      Procedure Put (Data : in Integer);
      entry Get (Data : out Integer);
   private
      Data_Storage : Storage_Type (1 .. 10);
      Size : Integer := 0;
      In_Index : Positive := 1;
      Out_Index : Positive := 1;
   end Anh_Left;

   protected type Anh_Right is new Abstract_Interface.Buffer with
      Procedure Put (Data : in Integer);
      entry Get (Data : out Integer);
   private
      Data_Storage : Storage_Type (1 .. 10);
      Size : Integer := 0;
      In_Index : Positive := 1;
      Out_Index : Positive := 1;
   end Anh_Right;

   task type Brian_Left is new Abstract_Interface.Event with
      entry Wait;
      entry Signal;
   end Brian_Left;

   task type Brian_Right is new Abstract_Interface.Event with
      entry Wait;
      entry Signal;
   end Brian_Right;

   use Abstract_Interface;

   procedure Serialized_Code (Obj : in out Mutex'Class);
   procedure Consumer (Obj : in out Buffer'Class);
   procedure Producer (Obj : in out Buffer'Class;
                       Data : in Integer);
   procedure Serialized_Code (Obj : in out Event'Class);


end Implementing_Interface;

with Ada.Text_Io;

package body Implementing_Interface is

   use Ada;
   use Text_Io;

   task body Gary_Left is
   begin
      Put_Line ("Task Gary_Left start executes");

      loop
         select
            accept Wait do
               Put_Line ("task Gary_Left Wait for some one");
            end Wait;
         or
            accept Signal do
               Put_Line ("task Gary_Left Notifies some one");
            end Signal;
         or
            accept Shutdown;
            exit;
         end select;
      end loop;
      Put_Line ("task Gary_Left says goodbye");
   end Gary_Left;

   task body Gary_Right is
   begin
      Put_Line ("Task Gary_Right start executes");

      loop
         select
            accept Wait do
               Put_Line ("Wait for some one");
            end Wait;
            accept Signal do
               Put_Line ("Notify some one");
            end Signal;
         else
            select
               accept Shutdown;
               exit;
            or
               delay 1.0;
            end select;
         end select;
      end loop;
      Put_Line ("Task Gary_Right terminates");
   end Gary_Right;


   protected body Anh_Left is
      Procedure Put (Data : in Integer) is
      begin
         Put_Line ("Put data in buffer");
         Data_Storage (In_Index) := Data;
         In_Index := In_Index mod Data_Storage'Length + 1;
         Size := Size + 1;
      end Put;

      entry Get (Data : out Integer) when Size > 0 is
      begin
         Put_Line ("Extract data");
         Data := Data_Storage (Out_Index);
         Out_Index := Out_Index mod Data_Storage'Length + 1;
         Size := Size - 1;
      end Get;
   end Anh_Left;

   protected body Anh_Right is
      Procedure Put (Data : in Integer) is
      begin
         Put_Line ("Put data in buffer");
         Data_Storage (In_Index) := Data;
         In_Index := In_Index mod Data_Storage'Length + 1;
         Size := Size + 1;
      end Put;

      entry Get (Data : out Integer) when Size > 0 is
      begin
         Put_Line ("Extract data");
         Data := Data_Storage (Out_Index);
         Out_Index := Out_Index mod Data_Storage'Length + 1;
         Size := Size - 1;
      end Get;
   end Anh_Right;

   task body Brian_Left is
   begin
      loop
         accept Wait do
            Put_Line ("Wait for some one");
         end Wait;
         accept Signal do
            Put_Line ("Notify some one");
         end Signal;
      end loop;
   end Brian_Left;

   task body Brian_Right is
   begin
      loop
         accept Wait do
            Put_Line ("Wait for some one");
         end Wait;
         accept Signal do
            Put_Line ("Notify some one");
         end Signal;
      end loop;
   end Brian_Right;


   procedure Serialized_Code (Obj : in out Mutex'Class) is
   begin
      Obj.Wait;
      Put_Line ("Modifying data while protected by Mutex");
      Obj.Signal;
   end Serialized_Code;


   procedure Consumer (Obj : in out Buffer'Class) is
      Data : Integer := -1;
   begin
      Obj.Get (Data);
      Put_Line ("Data is extracted");
   end Consumer;

   procedure Producer (Obj : in out Buffer'Class;
                       Data : in Integer) is
   begin
      Obj.Put (Data);
      Put_Line ("Data is put in the buffer");
   end Producer;


   procedure Serialized_Code (Obj : in out Event'Class) is
   begin
      Obj.Wait;
      Put_Line ("Consume event notification by Event");
      Obj.Signal;
   end Serialized_Code;


end Implementing_Interface;

with Gnat.OS_Lib;

with Ada.Exceptions;
with Ada.Text_Io;

with Implementing_Interface;

procedure Bugs_Test is

   use Ada;
   use Text_Io;

begin

   Put_Line ("Minimum codes used to demonstrate the Assert_Failure");

   --$$$ Causing Assert_Failure (einfo.adb:507) in gnatgcc-4.1.0 and
gccgnat-4.2.0
   declare
      use Implementing_Interface;
   begin
        Serialized_Code (Gary_Left); -- Error occurs here
        Gary_Left.Shutdown;
      delay 2.0;
      Serialized_Code (Gary_Right);
      Gary_Right.Shutdown;
   end;

   -- Terminate all child tasks if they are still around
   Gnat.OS_Lib.OS_Exit(0);

exception
   when Error : others =>
      Put_Line ("Show stopper ==> " & Exceptions.Exception_Information
(Error));

      -- Terminate all child tasks if they still exist
      Gnat.OS_Lib.OS_Exit(0);

end Bugs_Test;

project Assert_Failure is

   for Main use ("bugs_test.adb");

   package Pretty_Printer is
      for Default_Switches ("ada") use ("-A4");
   end Pretty_Printer;

   package Compiler is
      for Default_Switches ("ada") use ("-gnat05");
   end Compiler;

end Assert_Failure;


-- 
           Summary: Assert Failure with Bug Box
           Product: gcc
           Version: 4.1.0
            Status: UNCONFIRMED
          Severity: normal
          Priority: P3
         Component: ada
        AssignedTo: unassigned at gcc dot gnu dot org
        ReportedBy: anhvofrcaus at gmail dot com
 GCC build triplet: 4.1.0 20060106 (prerelease) (i686-pc-linux-gnu)
  GCC host triplet: Red Hat Linux 9.0 on i686
GCC target triplet: i686


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=25838