minix/common/dist/zlib/contrib/ada/mtest.adb
Lionel Sambuc 44bedb31d8 Importing common/dist/zlib
Change-Id: I46de716a98ccc501ca32b2a9445d9964594ddc61
2013-01-14 11:36:27 +01:00

156 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;