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