Mercurial > hg > sv-dependency-builds

annotate src/zlib-1.2.7/contrib/ada/mtest.adb @ 143:e95e00bdc3eb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Further win32 build updates
author Chris Cannam <cannam@all-day-breakfast.com>
date Mon, 09 Jan 2017 13:51:38 +0000
parents 8a15ff55d9af
children
rev   line source
cannam@89 1 ----------------------------------------------------------------
cannam@89 2 -- ZLib for Ada thick binding. --
cannam@89 3 -- --
cannam@89 4 -- Copyright (C) 2002-2003 Dmitriy Anisimkov --
cannam@89 5 -- --
cannam@89 6 -- Open source license information is in the zlib.ads file. --
cannam@89 7 ----------------------------------------------------------------
cannam@89 8 -- Continuous test for ZLib multithreading. If the test would fail
cannam@89 9 -- we should provide thread safe allocation routines for the Z_Stream.
cannam@89 10 --
cannam@89 11 -- $Id: mtest.adb,v 1.4 2004/07/23 07:49:54 vagul Exp $
cannam@89 12
cannam@89 13 with ZLib;
cannam@89 14 with Ada.Streams;
cannam@89 15 with Ada.Numerics.Discrete_Random;
cannam@89 16 with Ada.Text_IO;
cannam@89 17 with Ada.Exceptions;
cannam@89 18 with Ada.Task_Identification;
cannam@89 19
cannam@89 20 procedure MTest is
cannam@89 21 use Ada.Streams;
cannam@89 22 use ZLib;
cannam@89 23
cannam@89 24 Stop : Boolean := False;
cannam@89 25
cannam@89 26 pragma Atomic (Stop);
cannam@89 27
cannam@89 28 subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#;
cannam@89 29
cannam@89 30 package Random_Elements is
cannam@89 31 new Ada.Numerics.Discrete_Random (Visible_Symbols);
cannam@89 32
cannam@89 33 task type Test_Task;
cannam@89 34
cannam@89 35 task body Test_Task is
cannam@89 36 Buffer : Stream_Element_Array (1 .. 100_000);
cannam@89 37 Gen : Random_Elements.Generator;
cannam@89 38
cannam@89 39 Buffer_First : Stream_Element_Offset;
cannam@89 40 Compare_First : Stream_Element_Offset;
cannam@89 41
cannam@89 42 Deflate : Filter_Type;
cannam@89 43 Inflate : Filter_Type;
cannam@89 44
cannam@89 45 procedure Further (Item : in Stream_Element_Array);
cannam@89 46
cannam@89 47 procedure Read_Buffer
cannam@89 48 (Item : out Ada.Streams.Stream_Element_Array;
cannam@89 49 Last : out Ada.Streams.Stream_Element_Offset);
cannam@89 50
cannam@89 51 -------------
cannam@89 52 -- Further --
cannam@89 53 -------------
cannam@89 54
cannam@89 55 procedure Further (Item : in Stream_Element_Array) is
cannam@89 56
cannam@89 57 procedure Compare (Item : in Stream_Element_Array);
cannam@89 58
cannam@89 59 -------------
cannam@89 60 -- Compare --
cannam@89 61 -------------
cannam@89 62
cannam@89 63 procedure Compare (Item : in Stream_Element_Array) is
cannam@89 64 Next_First : Stream_Element_Offset := Compare_First + Item'Length;
cannam@89 65 begin
cannam@89 66 if Buffer (Compare_First .. Next_First - 1) /= Item then
cannam@89 67 raise Program_Error;
cannam@89 68 end if;
cannam@89 69
cannam@89 70 Compare_First := Next_First;
cannam@89 71 end Compare;
cannam@89 72
cannam@89 73 procedure Compare_Write is new ZLib.Write (Write => Compare);
cannam@89 74 begin
cannam@89 75 Compare_Write (Inflate, Item, No_Flush);
cannam@89 76 end Further;
cannam@89 77
cannam@89 78 -----------------
cannam@89 79 -- Read_Buffer --
cannam@89 80 -----------------
cannam@89 81
cannam@89 82 procedure Read_Buffer
cannam@89 83 (Item : out Ada.Streams.Stream_Element_Array;
cannam@89 84 Last : out Ada.Streams.Stream_Element_Offset)
cannam@89 85 is
cannam@89 86 Buff_Diff : Stream_Element_Offset := Buffer'Last - Buffer_First;
cannam@89 87 Next_First : Stream_Element_Offset;
cannam@89 88 begin
cannam@89 89 if Item'Length <= Buff_Diff then
cannam@89 90 Last := Item'Last;
cannam@89 91
cannam@89 92 Next_First := Buffer_First + Item'Length;
cannam@89 93
cannam@89 94 Item := Buffer (Buffer_First .. Next_First - 1);
cannam@89 95
cannam@89 96 Buffer_First := Next_First;
cannam@89 97 else
cannam@89 98 Last := Item'First + Buff_Diff;
cannam@89 99 Item (Item'First .. Last) := Buffer (Buffer_First .. Buffer'Last);
cannam@89 100 Buffer_First := Buffer'Last + 1;
cannam@89 101 end if;
cannam@89 102 end Read_Buffer;
cannam@89 103
cannam@89 104 procedure Translate is new Generic_Translate
cannam@89 105 (Data_In => Read_Buffer,
cannam@89 106 Data_Out => Further);
cannam@89 107
cannam@89 108 begin
cannam@89 109 Random_Elements.Reset (Gen);
cannam@89 110
cannam@89 111 Buffer := (others => 20);
cannam@89 112
cannam@89 113 Main : loop
cannam@89 114 for J in Buffer'Range loop
cannam@89 115 Buffer (J) := Random_Elements.Random (Gen);
cannam@89 116
cannam@89 117 Deflate_Init (Deflate);
cannam@89 118 Inflate_Init (Inflate);
cannam@89 119
cannam@89 120 Buffer_First := Buffer'First;
cannam@89 121 Compare_First := Buffer'First;
cannam@89 122
cannam@89 123 Translate (Deflate);
cannam@89 124
cannam@89 125 if Compare_First /= Buffer'Last + 1 then
cannam@89 126 raise Program_Error;
cannam@89 127 end if;
cannam@89 128
cannam@89 129 Ada.Text_IO.Put_Line
cannam@89 130 (Ada.Task_Identification.Image
cannam@89 131 (Ada.Task_Identification.Current_Task)
cannam@89 132 & Stream_Element_Offset'Image (J)
cannam@89 133 & ZLib.Count'Image (Total_Out (Deflate)));
cannam@89 134
cannam@89 135 Close (Deflate);
cannam@89 136 Close (Inflate);
cannam@89 137
cannam@89 138 exit Main when Stop;
cannam@89 139 end loop;
cannam@89 140 end loop Main;
cannam@89 141 exception
cannam@89 142 when E : others =>
cannam@89 143 Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
cannam@89 144 Stop := True;
cannam@89 145 end Test_Task;
cannam@89 146
cannam@89 147 Test : array (1 .. 4) of Test_Task;
cannam@89 148
cannam@89 149 pragma Unreferenced (Test);
cannam@89 150
cannam@89 151 Dummy : Character;
cannam@89 152
cannam@89 153 begin
cannam@89 154 Ada.Text_IO.Get_Immediate (Dummy);
cannam@89 155 Stop := True;
cannam@89 156 end MTest;