common/dist/zlib/contrib/ada/mtest.adb

   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;