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;