9e052883 |
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; |