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
 13with ZLib;
 14with Ada.Streams;
 15with Ada.Numerics.Discrete_Random;
 16with Ada.Text_IO;
 17with Ada.Exceptions;
 18with Ada.Task_Identification;
 19
 20procedure 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
153begin
154   Ada.Text_IO.Get_Immediate (Dummy);
155   Stop := True;
156end MTest;