source: s10k/CommonLibs/zlib-1.2.8/contrib/ada/mtest.adb@ 1154

Last change on this file since 1154 was 1096, checked in by s10k, 7 years ago

Added zlib, quazip, basicxmlsyntaxhighlighter, conditionalsemaphore and linenumberdisplay libraries. zlib and quazip are pre-compiled, but you can compile them yourself, just delete the dll files (or equivalent binary files to your OS)

File size: 4.4 KB
Line 
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
13with ZLib;
14with Ada.Streams;
15with Ada.Numerics.Discrete_Random;
16with Ada.Text_IO;
17with Ada.Exceptions;
18with Ada.Task_Identification;
19
20procedure 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
153begin
154 Ada.Text_IO.Get_Immediate (Dummy);
155 Stop := True;
156end MTest;
Note: See TracBrowser for help on using the repository browser.