1 ----------------------------------------------------------------

     2 --  ZLib for Ada thick binding.                               --

     3 --                                                            --

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

     5 --                                                            --

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

     7 ----------------------------------------------------------------

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

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

    10 --

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

    12 

    13 with ZLib;

    14 with Ada.Streams;

    15 with Ada.Numerics.Discrete_Random;

    16 with Ada.Text_IO;

    17 with Ada.Exceptions;

    18 with Ada.Task_Identification;

    19 

    20 procedure MTest is

    21    use Ada.Streams;

    22    use ZLib;

    23 

    24    Stop : Boolean := False;

    25 

    26    pragma Atomic (Stop);

    27 

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

    29 

    30    package Random_Elements is

    31       new Ada.Numerics.Discrete_Random (Visible_Symbols);

    32 

    33    task type Test_Task;

    34 

    35    task body Test_Task is

    36       Buffer : Stream_Element_Array (1 .. 100_000);

    37       Gen : Random_Elements.Generator;

    38 

    39       Buffer_First  : Stream_Element_Offset;

    40       Compare_First : Stream_Element_Offset;

    41 

    42       Deflate : Filter_Type;

    43       Inflate : Filter_Type;

    44 

    45       procedure Further (Item : in Stream_Element_Array);

    46 

    47       procedure Read_Buffer

    48         (Item : out Ada.Streams.Stream_Element_Array;

    49          Last : out Ada.Streams.Stream_Element_Offset);

    50 

    51       -------------

    52       -- Further --

    53       -------------

    54 

    55       procedure Further (Item : in Stream_Element_Array) is

    56 

    57          procedure Compare (Item : in Stream_Element_Array);

    58 

    59          -------------

    60          -- Compare --

    61          -------------

    62 

    63          procedure Compare (Item : in Stream_Element_Array) is

    64             Next_First : Stream_Element_Offset := Compare_First + Item'Length;

    65          begin

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

    67                raise Program_Error;

    68             end if;

    69 

    70             Compare_First := Next_First;

    71          end Compare;

    72 

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

    74       begin

    75          Compare_Write (Inflate, Item, No_Flush);

    76       end Further;

    77 

    78       -----------------

    79       -- Read_Buffer --

    80       -----------------

    81 

    82       procedure Read_Buffer

    83         (Item : out Ada.Streams.Stream_Element_Array;

    84          Last : out Ada.Streams.Stream_Element_Offset)

    85       is

    86          Buff_Diff   : Stream_Element_Offset := Buffer'Last - Buffer_First;

    87          Next_First : Stream_Element_Offset;

    88       begin

    89          if Item'Length <= Buff_Diff then

    90             Last := Item'Last;

    91 

    92             Next_First := Buffer_First + Item'Length;

    93 

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

    95 

    96             Buffer_First := Next_First;

    97          else

    98             Last := Item'First + Buff_Diff;

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

   100             Buffer_First := Buffer'Last + 1;

   101          end if;

   102       end Read_Buffer;

   103 

   104       procedure Translate is new Generic_Translate

   105                                    (Data_In  => Read_Buffer,

   106                                     Data_Out => Further);

   107 

   108    begin

   109       Random_Elements.Reset (Gen);

   110 

   111       Buffer := (others => 20);

   112 

   113       Main : loop

   114          for J in Buffer'Range loop

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

   116 

   117             Deflate_Init (Deflate);

   118             Inflate_Init (Inflate);

   119 

   120             Buffer_First  := Buffer'First;

   121             Compare_First := Buffer'First;

   122 

   123             Translate (Deflate);

   124 

   125             if Compare_First /= Buffer'Last + 1 then

   126                raise Program_Error;

   127             end if;

   128 

   129             Ada.Text_IO.Put_Line

   130               (Ada.Task_Identification.Image

   131                  (Ada.Task_Identification.Current_Task)

   132                & Stream_Element_Offset'Image (J)

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

   134 

   135             Close (Deflate);

   136             Close (Inflate);

   137 

   138             exit Main when Stop;

   139          end loop;

   140       end loop Main;

   141    exception

   142       when E : others =>

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

   144          Stop := True;

   145    end Test_Task;

   146 

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

   148 

   149    pragma Unreferenced (Test);

   150 

   151    Dummy : Character;

   152 

   153 begin

   154    Ada.Text_IO.Get_Immediate (Dummy);

   155    Stop := True;

   156 end MTest;