Subversion Repositories openrisc

----------------------------------------------------------------

--  ZLib for Ada thick binding.                               --

--                                                            --

--  Copyright (C) 2002-2003 Dmitriy Anisimkov                 --

--                                                            --

--  Open source license information is in the zlib.ads file.  --

----------------------------------------------------------------

--  Continuous test for ZLib multithreading. If the test would fail

--  we should provide thread safe allocation routines for the Z_Stream.

--

--  $Id: mtest.adb,v 1.4 2004/07/23 07:49:54 vagul Exp $

with ZLib;

with Ada.Streams;

with Ada.Numerics.Discrete_Random;

with Ada.Text_IO;

with Ada.Exceptions;

with Ada.Task_Identification;

procedure MTest is

   use Ada.Streams;

   use ZLib;

   Stop : Boolean := False;

   pragma Atomic (Stop);

   subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#;

   package Random_Elements is

      new Ada.Numerics.Discrete_Random (Visible_Symbols);

   task type Test_Task;

   task body Test_Task is

      Buffer : Stream_Element_Array (1 .. 100_000);

      Gen : Random_Elements.Generator;

      Buffer_First  : Stream_Element_Offset;

      Compare_First : Stream_Element_Offset;

      Deflate : Filter_Type;

      Inflate : Filter_Type;

      procedure Further (Item : in Stream_Element_Array);

      procedure Read_Buffer

        (Item : out Ada.Streams.Stream_Element_Array;

         Last : out Ada.Streams.Stream_Element_Offset);

      -------------

      -- Further --

      -------------

      procedure Further (Item : in Stream_Element_Array) is

         procedure Compare (Item : in Stream_Element_Array);

         -------------

         -- Compare --

         -------------

         procedure Compare (Item : in Stream_Element_Array) is

            Next_First : Stream_Element_Offset := Compare_First + Item'Length;

         begin

            if Buffer (Compare_First .. Next_First - 1) /= Item then

               raise Program_Error;

            end if;

            Compare_First := Next_First;

         end Compare;

         procedure Compare_Write is new ZLib.Write (Write => Compare);

      begin

         Compare_Write (Inflate, Item, No_Flush);

      end Further;

      -----------------

      -- Read_Buffer --

      -----------------

      procedure Read_Buffer

        (Item : out Ada.Streams.Stream_Element_Array;

         Last : out Ada.Streams.Stream_Element_Offset)

      is

         Buff_Diff   : Stream_Element_Offset := Buffer'Last - Buffer_First;

         Next_First : Stream_Element_Offset;

      begin

         if Item'Length <= Buff_Diff then

            Last := Item'Last;

            Next_First := Buffer_First + Item'Length;

            Item := Buffer (Buffer_First .. Next_First - 1);

            Buffer_First := Next_First;

         else

            Last := Item'First + Buff_Diff;

            Item (Item'First .. Last) := Buffer (Buffer_First .. Buffer'Last);

            Buffer_First := Buffer'Last + 1;

         end if;

      end Read_Buffer;

      procedure Translate is new Generic_Translate

                                   (Data_In  => Read_Buffer,

                                    Data_Out => Further);

   begin

      Random_Elements.Reset (Gen);

      Buffer := (others => 20);

      Main : loop

         for J in Buffer'Range loop

            Buffer (J) := Random_Elements.Random (Gen);

            Deflate_Init (Deflate);

            Inflate_Init (Inflate);

            Buffer_First  := Buffer'First;

            Compare_First := Buffer'First;

            Translate (Deflate);

            if Compare_First /= Buffer'Last + 1 then

               raise Program_Error;

            end if;

            Ada.Text_IO.Put_Line

              (Ada.Task_Identification.Image

                 (Ada.Task_Identification.Current_Task)

               & Stream_Element_Offset'Image (J)

               & ZLib.Count'Image (Total_Out (Deflate)));

            Close (Deflate);

            Close (Inflate);

            exit Main when Stop;

         end loop;

      end loop Main;

   exception

      when E : others =>

         Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));

         Stop := True;

   end Test_Task;

   Test : array (1 .. 4) of Test_Task;

   pragma Unreferenced (Test);

   Dummy : Character;

begin

   Ada.Text_IO.Get_Immediate (Dummy);

   Stop := True;

end MTest;