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