Mercurial > hg > CbC > CbC_gcc

comparison zlib/contrib/ada/mtest.adb @ 51:ae3a4bfb450b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
add some files of version 4.4.3 that have been forgotten.
author kent <kent@cr.ie.u-ryukyu.ac.jp>
date Sun, 07 Feb 2010 18:27:48 +0900
parents
children
comparison
equal deleted inserted replaced
47:3bfb6c00c1e0 51:ae3a4bfb450b
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;