diff options
Diffstat (limited to 'cpukit/zlib/contrib/ada/zlib.adb')
| -rw-r--r-- | cpukit/zlib/contrib/ada/zlib.adb | 701 |
1 files changed, 0 insertions, 701 deletions
diff --git a/cpukit/zlib/contrib/ada/zlib.adb b/cpukit/zlib/contrib/ada/zlib.adb deleted file mode 100644 index 8927b48f1b..0000000000 --- a/cpukit/zlib/contrib/ada/zlib.adb +++ /dev/null @@ -1,701 +0,0 @@ ----------------------------------------------------------------- --- ZLib for Ada thick binding. -- --- -- --- Copyright (C) 2002-2004 Dmitriy Anisimkov -- --- -- --- Open source license information is in the zlib.ads file. -- ----------------------------------------------------------------- - --- $Id$ - -with Ada.Exceptions; -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -with Interfaces.C.Strings; - -with ZLib.Thin; - -package body ZLib is - - use type Thin.Int; - - type Z_Stream is new Thin.Z_Stream; - - type Return_Code_Enum is - (OK, - STREAM_END, - NEED_DICT, - ERRNO, - STREAM_ERROR, - DATA_ERROR, - MEM_ERROR, - BUF_ERROR, - VERSION_ERROR); - - type Flate_Step_Function is access - function (Strm : in Thin.Z_Streamp; Flush : in Thin.Int) return Thin.Int; - pragma Convention (C, Flate_Step_Function); - - type Flate_End_Function is access - function (Ctrm : in Thin.Z_Streamp) return Thin.Int; - pragma Convention (C, Flate_End_Function); - - type Flate_Type is record - Step : Flate_Step_Function; - Done : Flate_End_Function; - end record; - - subtype Footer_Array is Stream_Element_Array (1 .. 8); - - Simple_GZip_Header : constant Stream_Element_Array (1 .. 10) - := (16#1f#, 16#8b#, -- Magic header - 16#08#, -- Z_DEFLATED - 16#00#, -- Flags - 16#00#, 16#00#, 16#00#, 16#00#, -- Time - 16#00#, -- XFlags - 16#03# -- OS code - ); - -- The simplest gzip header is not for informational, but just for - -- gzip format compatibility. - -- Note that some code below is using assumption - -- Simple_GZip_Header'Last > Footer_Array'Last, so do not make - -- Simple_GZip_Header'Last <= Footer_Array'Last. - - Return_Code : constant array (Thin.Int range <>) of Return_Code_Enum - := (0 => OK, - 1 => STREAM_END, - 2 => NEED_DICT, - -1 => ERRNO, - -2 => STREAM_ERROR, - -3 => DATA_ERROR, - -4 => MEM_ERROR, - -5 => BUF_ERROR, - -6 => VERSION_ERROR); - - Flate : constant array (Boolean) of Flate_Type - := (True => (Step => Thin.Deflate'Access, - Done => Thin.DeflateEnd'Access), - False => (Step => Thin.Inflate'Access, - Done => Thin.InflateEnd'Access)); - - Flush_Finish : constant array (Boolean) of Flush_Mode - := (True => Finish, False => No_Flush); - - procedure Raise_Error (Stream : in Z_Stream); - pragma Inline (Raise_Error); - - procedure Raise_Error (Message : in String); - pragma Inline (Raise_Error); - - procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int); - - procedure Free is new Ada.Unchecked_Deallocation - (Z_Stream, Z_Stream_Access); - - function To_Thin_Access is new Ada.Unchecked_Conversion - (Z_Stream_Access, Thin.Z_Streamp); - - procedure Translate_GZip - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode); - -- Separate translate routine for make gzip header. - - procedure Translate_Auto - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode); - -- translate routine without additional headers. - - ----------------- - -- Check_Error -- - ----------------- - - procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int) is - use type Thin.Int; - begin - if Code /= Thin.Z_OK then - Raise_Error - (Return_Code_Enum'Image (Return_Code (Code)) - & ": " & Last_Error_Message (Stream)); - end if; - end Check_Error; - - ----------- - -- Close -- - ----------- - - procedure Close - (Filter : in out Filter_Type; - Ignore_Error : in Boolean := False) - is - Code : Thin.Int; - begin - if not Ignore_Error and then not Is_Open (Filter) then - raise Status_Error; - end if; - - Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm)); - - if Ignore_Error or else Code = Thin.Z_OK then - Free (Filter.Strm); - else - declare - Error_Message : constant String - := Last_Error_Message (Filter.Strm.all); - begin - Free (Filter.Strm); - Ada.Exceptions.Raise_Exception - (ZLib_Error'Identity, - Return_Code_Enum'Image (Return_Code (Code)) - & ": " & Error_Message); - end; - end if; - end Close; - - ----------- - -- CRC32 -- - ----------- - - function CRC32 - (CRC : in Unsigned_32; - Data : in Ada.Streams.Stream_Element_Array) - return Unsigned_32 - is - use Thin; - begin - return Unsigned_32 (crc32 (ULong (CRC), - Data'Address, - Data'Length)); - end CRC32; - - procedure CRC32 - (CRC : in out Unsigned_32; - Data : in Ada.Streams.Stream_Element_Array) is - begin - CRC := CRC32 (CRC, Data); - end CRC32; - - ------------------ - -- Deflate_Init -- - ------------------ - - procedure Deflate_Init - (Filter : in out Filter_Type; - Level : in Compression_Level := Default_Compression; - Strategy : in Strategy_Type := Default_Strategy; - Method : in Compression_Method := Deflated; - Window_Bits : in Window_Bits_Type := Default_Window_Bits; - Memory_Level : in Memory_Level_Type := Default_Memory_Level; - Header : in Header_Type := Default) - is - use type Thin.Int; - Win_Bits : Thin.Int := Thin.Int (Window_Bits); - begin - if Is_Open (Filter) then - raise Status_Error; - end if; - - -- We allow ZLib to make header only in case of default header type. - -- Otherwise we would either do header by ourselfs, or do not do - -- header at all. - - if Header = None or else Header = GZip then - Win_Bits := -Win_Bits; - end if; - - -- For the GZip CRC calculation and make headers. - - if Header = GZip then - Filter.CRC := 0; - Filter.Offset := Simple_GZip_Header'First; - else - Filter.Offset := Simple_GZip_Header'Last + 1; - end if; - - Filter.Strm := new Z_Stream; - Filter.Compression := True; - Filter.Stream_End := False; - Filter.Header := Header; - - if Thin.Deflate_Init - (To_Thin_Access (Filter.Strm), - Level => Thin.Int (Level), - method => Thin.Int (Method), - windowBits => Win_Bits, - memLevel => Thin.Int (Memory_Level), - strategy => Thin.Int (Strategy)) /= Thin.Z_OK - then - Raise_Error (Filter.Strm.all); - end if; - end Deflate_Init; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (Filter : in out Filter_Type; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) - is - No_Data : Stream_Element_Array := (1 .. 0 => 0); - Last : Stream_Element_Offset; - begin - Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush); - end Flush; - - ----------------------- - -- Generic_Translate -- - ----------------------- - - procedure Generic_Translate - (Filter : in out ZLib.Filter_Type; - In_Buffer_Size : in Integer := Default_Buffer_Size; - Out_Buffer_Size : in Integer := Default_Buffer_Size) - is - In_Buffer : Stream_Element_Array - (1 .. Stream_Element_Offset (In_Buffer_Size)); - Out_Buffer : Stream_Element_Array - (1 .. Stream_Element_Offset (Out_Buffer_Size)); - Last : Stream_Element_Offset; - In_Last : Stream_Element_Offset; - In_First : Stream_Element_Offset; - Out_Last : Stream_Element_Offset; - begin - Main : loop - Data_In (In_Buffer, Last); - - In_First := In_Buffer'First; - - loop - Translate - (Filter => Filter, - In_Data => In_Buffer (In_First .. Last), - In_Last => In_Last, - Out_Data => Out_Buffer, - Out_Last => Out_Last, - Flush => Flush_Finish (Last < In_Buffer'First)); - - if Out_Buffer'First <= Out_Last then - Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last)); - end if; - - exit Main when Stream_End (Filter); - - -- The end of in buffer. - - exit when In_Last = Last; - - In_First := In_Last + 1; - end loop; - end loop Main; - - end Generic_Translate; - - ------------------ - -- Inflate_Init -- - ------------------ - - procedure Inflate_Init - (Filter : in out Filter_Type; - Window_Bits : in Window_Bits_Type := Default_Window_Bits; - Header : in Header_Type := Default) - is - use type Thin.Int; - Win_Bits : Thin.Int := Thin.Int (Window_Bits); - - procedure Check_Version; - -- Check the latest header types compatibility. - - procedure Check_Version is - begin - if Version <= "1.1.4" then - Raise_Error - ("Inflate header type " & Header_Type'Image (Header) - & " incompatible with ZLib version " & Version); - end if; - end Check_Version; - - begin - if Is_Open (Filter) then - raise Status_Error; - end if; - - case Header is - when None => - Check_Version; - - -- Inflate data without headers determined - -- by negative Win_Bits. - - Win_Bits := -Win_Bits; - when GZip => - Check_Version; - - -- Inflate gzip data defined by flag 16. - - Win_Bits := Win_Bits + 16; - when Auto => - Check_Version; - - -- Inflate with automatic detection - -- of gzip or native header defined by flag 32. - - Win_Bits := Win_Bits + 32; - when Default => null; - end case; - - Filter.Strm := new Z_Stream; - Filter.Compression := False; - Filter.Stream_End := False; - Filter.Header := Header; - - if Thin.Inflate_Init - (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK - then - Raise_Error (Filter.Strm.all); - end if; - end Inflate_Init; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (Filter : in Filter_Type) return Boolean is - begin - return Filter.Strm /= null; - end Is_Open; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error (Message : in String) is - begin - Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message); - end Raise_Error; - - procedure Raise_Error (Stream : in Z_Stream) is - begin - Raise_Error (Last_Error_Message (Stream)); - end Raise_Error; - - ---------- - -- Read -- - ---------- - - procedure Read - (Filter : in out Filter_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode := No_Flush) - is - In_Last : Stream_Element_Offset; - Item_First : Ada.Streams.Stream_Element_Offset := Item'First; - V_Flush : Flush_Mode := Flush; - - begin - pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1); - pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last); - - loop - if Rest_Last = Buffer'First - 1 then - V_Flush := Finish; - - elsif Rest_First > Rest_Last then - Read (Buffer, Rest_Last); - Rest_First := Buffer'First; - - if Rest_Last < Buffer'First then - V_Flush := Finish; - end if; - end if; - - Translate - (Filter => Filter, - In_Data => Buffer (Rest_First .. Rest_Last), - In_Last => In_Last, - Out_Data => Item (Item_First .. Item'Last), - Out_Last => Last, - Flush => V_Flush); - - Rest_First := In_Last + 1; - - exit when Stream_End (Filter) - or else Last = Item'Last - or else (Last >= Item'First and then Allow_Read_Some); - - Item_First := Last + 1; - end loop; - end Read; - - ---------------- - -- Stream_End -- - ---------------- - - function Stream_End (Filter : in Filter_Type) return Boolean is - begin - if Filter.Header = GZip and Filter.Compression then - return Filter.Stream_End - and then Filter.Offset = Footer_Array'Last + 1; - else - return Filter.Stream_End; - end if; - end Stream_End; - - -------------- - -- Total_In -- - -------------- - - function Total_In (Filter : in Filter_Type) return Count is - begin - return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all)); - end Total_In; - - --------------- - -- Total_Out -- - --------------- - - function Total_Out (Filter : in Filter_Type) return Count is - begin - return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all)); - end Total_Out; - - --------------- - -- Translate -- - --------------- - - procedure Translate - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) is - begin - if Filter.Header = GZip and then Filter.Compression then - Translate_GZip - (Filter => Filter, - In_Data => In_Data, - In_Last => In_Last, - Out_Data => Out_Data, - Out_Last => Out_Last, - Flush => Flush); - else - Translate_Auto - (Filter => Filter, - In_Data => In_Data, - In_Last => In_Last, - Out_Data => Out_Data, - Out_Last => Out_Last, - Flush => Flush); - end if; - end Translate; - - -------------------- - -- Translate_Auto -- - -------------------- - - procedure Translate_Auto - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) - is - use type Thin.Int; - Code : Thin.Int; - - begin - if not Is_Open (Filter) then - raise Status_Error; - end if; - - if Out_Data'Length = 0 and then In_Data'Length = 0 then - raise Constraint_Error; - end if; - - Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length); - Set_In (Filter.Strm.all, In_Data'Address, In_Data'Length); - - Code := Flate (Filter.Compression).Step - (To_Thin_Access (Filter.Strm), - Thin.Int (Flush)); - - if Code = Thin.Z_STREAM_END then - Filter.Stream_End := True; - else - Check_Error (Filter.Strm.all, Code); - end if; - - In_Last := In_Data'Last - - Stream_Element_Offset (Avail_In (Filter.Strm.all)); - Out_Last := Out_Data'Last - - Stream_Element_Offset (Avail_Out (Filter.Strm.all)); - end Translate_Auto; - - -------------------- - -- Translate_GZip -- - -------------------- - - procedure Translate_GZip - (Filter : in out Filter_Type; - In_Data : in Ada.Streams.Stream_Element_Array; - In_Last : out Ada.Streams.Stream_Element_Offset; - Out_Data : out Ada.Streams.Stream_Element_Array; - Out_Last : out Ada.Streams.Stream_Element_Offset; - Flush : in Flush_Mode) - is - Out_First : Stream_Element_Offset; - - procedure Add_Data (Data : in Stream_Element_Array); - -- Add data to stream from the Filter.Offset till necessary, - -- used for add gzip headr/footer. - - procedure Put_32 - (Item : in out Stream_Element_Array; - Data : in Unsigned_32); - pragma Inline (Put_32); - - -------------- - -- Add_Data -- - -------------- - - procedure Add_Data (Data : in Stream_Element_Array) is - Data_First : Stream_Element_Offset renames Filter.Offset; - Data_Last : Stream_Element_Offset; - Data_Len : Stream_Element_Offset; -- -1 - Out_Len : Stream_Element_Offset; -- -1 - begin - Out_First := Out_Last + 1; - - if Data_First > Data'Last then - return; - end if; - - Data_Len := Data'Last - Data_First; - Out_Len := Out_Data'Last - Out_First; - - if Data_Len <= Out_Len then - Out_Last := Out_First + Data_Len; - Data_Last := Data'Last; - else - Out_Last := Out_Data'Last; - Data_Last := Data_First + Out_Len; - end if; - - Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last); - - Data_First := Data_Last + 1; - Out_First := Out_Last + 1; - end Add_Data; - - ------------ - -- Put_32 -- - ------------ - - procedure Put_32 - (Item : in out Stream_Element_Array; - Data : in Unsigned_32) - is - D : Unsigned_32 := Data; - begin - for J in Item'First .. Item'First + 3 loop - Item (J) := Stream_Element (D and 16#FF#); - D := Shift_Right (D, 8); - end loop; - end Put_32; - - begin - Out_Last := Out_Data'First - 1; - - if not Filter.Stream_End then - Add_Data (Simple_GZip_Header); - - Translate_Auto - (Filter => Filter, - In_Data => In_Data, - In_Last => In_Last, - Out_Data => Out_Data (Out_First .. Out_Data'Last), - Out_Last => Out_Last, - Flush => Flush); - - CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last)); - end if; - - if Filter.Stream_End and then Out_Last <= Out_Data'Last then - -- This detection method would work only when - -- Simple_GZip_Header'Last > Footer_Array'Last - - if Filter.Offset = Simple_GZip_Header'Last + 1 then - Filter.Offset := Footer_Array'First; - end if; - - declare - Footer : Footer_Array; - begin - Put_32 (Footer, Filter.CRC); - Put_32 (Footer (Footer'First + 4 .. Footer'Last), - Unsigned_32 (Total_In (Filter))); - Add_Data (Footer); - end; - end if; - end Translate_GZip; - - ------------- - -- Version -- - ------------- - - function Version return String is - begin - return Interfaces.C.Strings.Value (Thin.zlibVersion); - end Version; - - ----------- - -- Write -- - ----------- - - procedure Write - (Filter : in out Filter_Type; - Item : in Ada.Streams.Stream_Element_Array; - Flush : in Flush_Mode := No_Flush) - is - Buffer : Stream_Element_Array (1 .. Buffer_Size); - In_Last : Stream_Element_Offset; - Out_Last : Stream_Element_Offset; - In_First : Stream_Element_Offset := Item'First; - begin - if Item'Length = 0 and Flush = No_Flush then - return; - end if; - - loop - Translate - (Filter => Filter, - In_Data => Item (In_First .. Item'Last), - In_Last => In_Last, - Out_Data => Buffer, - Out_Last => Out_Last, - Flush => Flush); - - if Out_Last >= Buffer'First then - Write (Buffer (1 .. Out_Last)); - end if; - - exit when In_Last = Item'Last or Stream_End (Filter); - - In_First := In_Last + 1; - end loop; - end Write; - -end ZLib; |