cannam@128: ----------------------------------------------------------------
cannam@128: --  ZLib for Ada thick binding.                               --
cannam@128: --                                                            --
cannam@128: --  Copyright (C) 2002-2003 Dmitriy Anisimkov                 --
cannam@128: --                                                            --
cannam@128: --  Open source license information is in the zlib.ads file.  --
cannam@128: ----------------------------------------------------------------
cannam@128: --  Continuous test for ZLib multithreading. If the test would fail
cannam@128: --  we should provide thread safe allocation routines for the Z_Stream.
cannam@128: --
cannam@128: --  $Id: mtest.adb,v 1.4 2004/07/23 07:49:54 vagul Exp $
cannam@128: 
cannam@128: with ZLib;
cannam@128: with Ada.Streams;
cannam@128: with Ada.Numerics.Discrete_Random;
cannam@128: with Ada.Text_IO;
cannam@128: with Ada.Exceptions;
cannam@128: with Ada.Task_Identification;
cannam@128: 
cannam@128: procedure MTest is
cannam@128:    use Ada.Streams;
cannam@128:    use ZLib;
cannam@128: 
cannam@128:    Stop : Boolean := False;
cannam@128: 
cannam@128:    pragma Atomic (Stop);
cannam@128: 
cannam@128:    subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#;
cannam@128: 
cannam@128:    package Random_Elements is
cannam@128:       new Ada.Numerics.Discrete_Random (Visible_Symbols);
cannam@128: 
cannam@128:    task type Test_Task;
cannam@128: 
cannam@128:    task body Test_Task is
cannam@128:       Buffer : Stream_Element_Array (1 .. 100_000);
cannam@128:       Gen : Random_Elements.Generator;
cannam@128: 
cannam@128:       Buffer_First  : Stream_Element_Offset;
cannam@128:       Compare_First : Stream_Element_Offset;
cannam@128: 
cannam@128:       Deflate : Filter_Type;
cannam@128:       Inflate : Filter_Type;
cannam@128: 
cannam@128:       procedure Further (Item : in Stream_Element_Array);
cannam@128: 
cannam@128:       procedure Read_Buffer
cannam@128:         (Item : out Ada.Streams.Stream_Element_Array;
cannam@128:          Last : out Ada.Streams.Stream_Element_Offset);
cannam@128: 
cannam@128:       -------------
cannam@128:       -- Further --
cannam@128:       -------------
cannam@128: 
cannam@128:       procedure Further (Item : in Stream_Element_Array) is
cannam@128: 
cannam@128:          procedure Compare (Item : in Stream_Element_Array);
cannam@128: 
cannam@128:          -------------
cannam@128:          -- Compare --
cannam@128:          -------------
cannam@128: 
cannam@128:          procedure Compare (Item : in Stream_Element_Array) is
cannam@128:             Next_First : Stream_Element_Offset := Compare_First + Item'Length;
cannam@128:          begin
cannam@128:             if Buffer (Compare_First .. Next_First - 1) /= Item then
cannam@128:                raise Program_Error;
cannam@128:             end if;
cannam@128: 
cannam@128:             Compare_First := Next_First;
cannam@128:          end Compare;
cannam@128: 
cannam@128:          procedure Compare_Write is new ZLib.Write (Write => Compare);
cannam@128:       begin
cannam@128:          Compare_Write (Inflate, Item, No_Flush);
cannam@128:       end Further;
cannam@128: 
cannam@128:       -----------------
cannam@128:       -- Read_Buffer --
cannam@128:       -----------------
cannam@128: 
cannam@128:       procedure Read_Buffer
cannam@128:         (Item : out Ada.Streams.Stream_Element_Array;
cannam@128:          Last : out Ada.Streams.Stream_Element_Offset)
cannam@128:       is
cannam@128:          Buff_Diff   : Stream_Element_Offset := Buffer'Last - Buffer_First;
cannam@128:          Next_First : Stream_Element_Offset;
cannam@128:       begin
cannam@128:          if Item'Length <= Buff_Diff then
cannam@128:             Last := Item'Last;
cannam@128: 
cannam@128:             Next_First := Buffer_First + Item'Length;
cannam@128: 
cannam@128:             Item := Buffer (Buffer_First .. Next_First - 1);
cannam@128: 
cannam@128:             Buffer_First := Next_First;
cannam@128:          else
cannam@128:             Last := Item'First + Buff_Diff;
cannam@128:             Item (Item'First .. Last) := Buffer (Buffer_First .. Buffer'Last);
cannam@128:             Buffer_First := Buffer'Last + 1;
cannam@128:          end if;
cannam@128:       end Read_Buffer;
cannam@128: 
cannam@128:       procedure Translate is new Generic_Translate
cannam@128:                                    (Data_In  => Read_Buffer,
cannam@128:                                     Data_Out => Further);
cannam@128: 
cannam@128:    begin
cannam@128:       Random_Elements.Reset (Gen);
cannam@128: 
cannam@128:       Buffer := (others => 20);
cannam@128: 
cannam@128:       Main : loop
cannam@128:          for J in Buffer'Range loop
cannam@128:             Buffer (J) := Random_Elements.Random (Gen);
cannam@128: 
cannam@128:             Deflate_Init (Deflate);
cannam@128:             Inflate_Init (Inflate);
cannam@128: 
cannam@128:             Buffer_First  := Buffer'First;
cannam@128:             Compare_First := Buffer'First;
cannam@128: 
cannam@128:             Translate (Deflate);
cannam@128: 
cannam@128:             if Compare_First /= Buffer'Last + 1 then
cannam@128:                raise Program_Error;
cannam@128:             end if;
cannam@128: 
cannam@128:             Ada.Text_IO.Put_Line
cannam@128:               (Ada.Task_Identification.Image
cannam@128:                  (Ada.Task_Identification.Current_Task)
cannam@128:                & Stream_Element_Offset'Image (J)
cannam@128:                & ZLib.Count'Image (Total_Out (Deflate)));
cannam@128: 
cannam@128:             Close (Deflate);
cannam@128:             Close (Inflate);
cannam@128: 
cannam@128:             exit Main when Stop;
cannam@128:          end loop;
cannam@128:       end loop Main;
cannam@128:    exception
cannam@128:       when E : others =>
cannam@128:          Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
cannam@128:          Stop := True;
cannam@128:    end Test_Task;
cannam@128: 
cannam@128:    Test : array (1 .. 4) of Test_Task;
cannam@128: 
cannam@128:    pragma Unreferenced (Test);
cannam@128: 
cannam@128:    Dummy : Character;
cannam@128: 
cannam@128: begin
cannam@128:    Ada.Text_IO.Get_Immediate (Dummy);
cannam@128:    Stop := True;
cannam@128: end MTest;