kc3-lang/zlib/contrib/ada/mtest.adb

Branch - branch -master

• Show log

  Commit

• Hash : 7a695576
  Author :
  Date : 2011-09-09T23:23:45
  

  zlib 1.2.1.2
  

Download

• contrib/ada/mtest.adb

• ----------------------------------------------------------------
  --  ZLib for Ada thick binding.                               --
  --                                                            --
  --  Copyright (C) 2002-2003 Dmitriy Anisimkov                 --
  --                                                            --
  --  Open source license information is in the zlib.ads file.  --
  ----------------------------------------------------------------
  --  Continuous test for ZLib multithreading. If the test would fail
  --  we should provide thread safe allocation routines for the Z_Stream.
  --
  --  $Id: mtest.adb,v 1.4 2004/07/23 07:49:54 vagul Exp $
  
  with ZLib;
  with Ada.Streams;
  with Ada.Numerics.Discrete_Random;
  with Ada.Text_IO;
  with Ada.Exceptions;
  with Ada.Task_Identification;
  
  procedure MTest is
     use Ada.Streams;
     use ZLib;
  
     Stop : Boolean := False;
  
     pragma Atomic (Stop);
  
     subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#;
  
     package Random_Elements is
        new Ada.Numerics.Discrete_Random (Visible_Symbols);
  
     task type Test_Task;
  
     task body Test_Task is
        Buffer : Stream_Element_Array (1 .. 100_000);
        Gen : Random_Elements.Generator;
  
        Buffer_First  : Stream_Element_Offset;
        Compare_First : Stream_Element_Offset;
  
        Deflate : Filter_Type;
        Inflate : Filter_Type;
  
        procedure Further (Item : in Stream_Element_Array);
  
        procedure Read_Buffer
          (Item : out Ada.Streams.Stream_Element_Array;
           Last : out Ada.Streams.Stream_Element_Offset);
  
        -------------
        -- Further --
        -------------
  
        procedure Further (Item : in Stream_Element_Array) is
  
           procedure Compare (Item : in Stream_Element_Array);
  
           -------------
           -- Compare --
           -------------
  
           procedure Compare (Item : in Stream_Element_Array) is
              Next_First : Stream_Element_Offset := Compare_First + Item'Length;
           begin
              if Buffer (Compare_First .. Next_First - 1) /= Item then
                 raise Program_Error;
              end if;
  
              Compare_First := Next_First;
           end Compare;
  
           procedure Compare_Write is new ZLib.Write (Write => Compare);
        begin
           Compare_Write (Inflate, Item, No_Flush);
        end Further;
  
        -----------------
        -- Read_Buffer --
        -----------------
  
        procedure Read_Buffer
          (Item : out Ada.Streams.Stream_Element_Array;
           Last : out Ada.Streams.Stream_Element_Offset)
        is
           Buff_Diff   : Stream_Element_Offset := Buffer'Last - Buffer_First;
           Next_First : Stream_Element_Offset;
        begin
           if Item'Length <= Buff_Diff then
              Last := Item'Last;
  
              Next_First := Buffer_First + Item'Length;
  
              Item := Buffer (Buffer_First .. Next_First - 1);
  
              Buffer_First := Next_First;
           else
              Last := Item'First + Buff_Diff;
              Item (Item'First .. Last) := Buffer (Buffer_First .. Buffer'Last);
              Buffer_First := Buffer'Last + 1;
           end if;
        end Read_Buffer;
  
        procedure Translate is new Generic_Translate
                                     (Data_In  => Read_Buffer,
                                      Data_Out => Further);
  
     begin
        Random_Elements.Reset (Gen);
  
        Buffer := (others => 20);
  
        Main : loop
           for J in Buffer'Range loop
              Buffer (J) := Random_Elements.Random (Gen);
  
              Deflate_Init (Deflate);
              Inflate_Init (Inflate);
  
              Buffer_First  := Buffer'First;
              Compare_First := Buffer'First;
  
              Translate (Deflate);
  
              if Compare_First /= Buffer'Last + 1 then
                 raise Program_Error;
              end if;
  
              Ada.Text_IO.Put_Line
                (Ada.Task_Identification.Image
                   (Ada.Task_Identification.Current_Task)
                 & Stream_Element_Offset'Image (J)
                 & ZLib.Count'Image (Total_Out (Deflate)));
  
              Close (Deflate);
              Close (Inflate);
  
              exit Main when Stop;
           end loop;
        end loop Main;
     exception
        when E : others =>
           Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
           Stop := True;
     end Test_Task;
  
     Test : array (1 .. 4) of Test_Task;
  
     pragma Unreferenced (Test);
  
     Dummy : Character;
  
  begin
     Ada.Text_IO.Get_Immediate (Dummy);
     Stop := True;
  end MTest;
  

Download