File : acf-types.adb


------------------------------------------------------------------------

--         (c) 2001, Antonio Duran. All rights reserved               --

--                       aduran@inicia.es                             --

------------------------------------------------------------------------

-- The Ada Cryptographic Framework (ACF) is free software; you can    --

-- redistribute it and/or modify it under terms of the GNU General    --

-- Public License as published by the Free Software Foundation;       --

-- either version 2, or (at your option) any later version.           --

--                                                                    --

-- The ACF is distributed in the hope that it will be useful, but     --

-- WITHOUT ANY WARRANTY;  without even the implied warranty of        --

-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU   --

-- General Public License for  more details. You should have received --

-- a copy of the GNU General Public License distributed with the ACF; --

-- see file COPYING. If not, write to the Free Software Foundation,   --

-- 59 Temple Place - Suite 330,  Boston, MA 02111-1307, USA.          --

------------------------------------------------------------------------

-- Identification

--    File name         : acf-types.adb

--    File kind         : Ada package body.

--    Author            : Antonio Duran

--    Creation date     : November 20th., 2001

--    Current version   : 1.0

------------------------------------------------------------------------

-- Purpose:

-- Implements the functionality declared in its specification.

------------------------------------------------------------------------

-- Portability issues:

-- TBD.

------------------------------------------------------------------------

-- Performance issues:

-- TBD.

------------------------------------------------------------------------

-- Revision history:

--

-- Ver   Who   When     Why

-- 1.0   ADD   11202001 Initial implementation

--

------------------------------------------------------------------------


with Ada.Characters.Handling;       use Ada.Characters.Handling;
with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;

with Interfaces; use Interfaces;

package body ACF.Types is

   ---------------------------------------------------------------------

   -- Constants

   ---------------------------------------------------------------------


   --+---[Hex_Digits]---------------------------------------------------

   --|   Array containing the hexadecimal digits for each possible

   --|   value of a nibble.

   --+------------------------------------------------------------------


   Hex_Digits        : constant array(Byte range 16#00# .. 16#0F#)
                                    of Character :=
      (
         '0', '1', '2', '3', '4', '5', '6', '7',
         '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'
      );

   ---------------------------------------------------------------------

   -- Subprogram bodies

   ---------------------------------------------------------------------


   ---------------------------------------------------------------------

   -- Obtaining parts of basic modular type's values

   ---------------------------------------------------------------------


   --+---[Lo_Nibble]----------------------------------------------------


   function    Lo_Nibble(
                  B              : in     Byte)
      return   Byte
   is
   begin
      return (B and 16#0F#);
   end Lo_Nibble;

   --+---[Hi_Nibble]----------------------------------------------------


   function    Hi_Nibble(
                  B              : in     Byte)
      return   Byte
   is
   begin
      return (Shift_Right(B, 4) and 16#0F#);
   end Hi_Nibble;

   --+---[Lo_Byte]------------------------------------------------------


   function    Lo_Byte(
                  T              : in     Two_Bytes)
      return   Byte
   is
   begin
      return Byte(T and 16#00FF#);
   end Lo_Byte;

   --+---[Hi_Byte]------------------------------------------------------


   function    Hi_Byte(
                  T              : in     Two_Bytes)
      return   Byte
   is
   begin
      return Byte(Shift_Right(T, 8) and 16#00FF#);
   end Hi_Byte;

   --+---[Lo_Two_Bytes]-------------------------------------------------


   function    Lo_Two_Bytes(
                  F              : in     Four_Bytes)
      return   Two_Bytes
   is
   begin
      return Two_Bytes(F and 16#0000_FFFF#);
   end Lo_Two_Bytes;

   --+---[Hi_Two_Bytes]-------------------------------------------------


   function    Hi_Two_Bytes(
                  F              : in     Four_Bytes)
      return   Two_Bytes
   is
   begin
      return Two_Bytes(Shift_Right(F, 16) and 16#0000_FFFF#);
   end Hi_Two_Bytes;

   --+---[Lo_Four_Bytes]------------------------------------------------


   function    Lo_Four_Bytes(
                  E              : in     Eight_Bytes)
      return   Four_Bytes
   is
   begin
      return Four_Bytes(E and 16#0000_0000_FFFF_FFFF#);
   end Lo_Four_Bytes;

   --+---[Hi_Four_Bytes]------------------------------------------------


   function    Hi_Four_Bytes(
                  E              : in     Eight_Bytes)
      return   Four_Bytes
   is
   begin
      return Four_Bytes(
                  Shift_Right(E, 32) and
                  16#0000_0000_FFFF_FFFF#);
   end Hi_Four_Bytes;

   ---------------------------------------------------------------------

   -- Building modular type's values

   ---------------------------------------------------------------------


   --+---[Make_Two_Bytes]-----------------------------------------------


   function    Make_Two_Bytes(
                  L              : in     Byte;
                  H              : in     Byte)
      return   Two_Bytes
   is
   begin
      return (
         Two_Bytes(L) or
         Shift_Left(Two_Bytes(H), 8));
   end Make_Two_Bytes;

   --+---[Make_Four_Bytes]----------------------------------------------


   function    Make_Four_Bytes(
                  LL             : in     Byte;
                  LH             : in     Byte;
                  HL             : in     Byte;
                  Hh             : in     Byte)
      return   Four_Bytes
   is
   begin
      return (
         Four_Bytes(LL) or
         Shift_Left(Four_Bytes(LH), 8) or
         Shift_Left(Four_Bytes(HL), 16) or
         Shift_Left(Four_Bytes(HH), 24));
   end Make_Four_Bytes;

   --+---[Make_Four_Bytes]----------------------------------------------


   function    Make_Four_Bytes(
                  L              : in     Two_Bytes;
                  H              : in     Two_Bytes)
      return   Four_Bytes
   is
   begin
      return (
         Four_Bytes(L) or
         Shift_Left(Four_Bytes(H), 16));
   end Make_Four_Bytes;

   --+---[Make_Eight_Bytes]---------------------------------------------


   function    Make_Eight_Bytes(
                  LLL            : in     Byte;
                  LLH            : in     Byte;
                  LHL            : in     Byte;
                  LHH            : in     Byte;
                  HLL            : in     Byte;
                  HLH            : in     Byte;
                  HHL            : in     Byte;
                  HHH            : in     Byte)
      return   Eight_Bytes
   is
   begin
      return (
         Eight_Bytes(LLL) or
         Shift_Left(Eight_Bytes(LLH), 8) or
         Shift_Left(Eight_Bytes(LHL), 16) or
         Shift_Left(Eight_Bytes(LHH), 24) or
         Shift_Left(Eight_Bytes(HLL), 32) or
         Shift_Left(Eight_Bytes(HLH), 40) or
         Shift_Left(Eight_Bytes(HHL), 48) or
         Shift_Left(Eight_Bytes(HHH), 56));
   end Make_Eight_Bytes;

   --+---[Make_Eight_Bytes]---------------------------------------------


   function    Make_Eight_Bytes(
                  LL             : in     Two_Bytes;
                  LH             : in     Two_Bytes;
                  HL             : in     Two_Bytes;
                  HH             : in     Two_Bytes)
      return   Eight_Bytes
   is
   begin
      return (
         Eight_Bytes(LL) or
         Shift_Left(Eight_Bytes(LH), 16) or
         Shift_Left(Eight_Bytes(HL), 32) or
         Shift_Left(Eight_Bytes(HH), 48));
   end Make_Eight_Bytes;

   --+---[Make_Eight_Bytes]---------------------------------------------


   function    Make_Eight_Bytes(
                  L              : in     Four_Bytes;
                  H              : in     Four_Bytes)
      return   Eight_Bytes
   is
   begin
      return (
         Eight_Bytes(L) or
         Shift_Left(Eight_Bytes(H), 32));
   end Make_Eight_Bytes;

   ---------------------------------------------------------------------

   -- Obtaining byte arrays

   ---------------------------------------------------------------------


   --+---[To_Byte_Array]------------------------------------------------


   function    To_Byte_Array(
                  B              : in     Byte;
                  Order          : in     Byte_Order := Little_Endian)
      return   Byte_Array
   is
   begin
      return (1 => B);
   end To_Byte_Array;

   --+---[To_Byte_Array]------------------------------------------------


   function    To_Byte_Array(
                  T              : in     Two_Bytes;
                  Order          : in     Byte_Order := Little_Endian)
      return   Byte_Array
   is
   begin
      if Order = Little_Endian then
         return (1 => Hi_Byte(T), 2 => Lo_Byte(T));
      else
         return (1 => Lo_Byte(T), 2 => Hi_Byte(T));
      end if;
   end To_Byte_Array;

   --+---[To_Byte_Array]------------------------------------------------


   function    To_Byte_Array(
                  F              : in     Four_Bytes;
                  Order          : in     Byte_Order := Little_Endian)
      return   Byte_Array
   is
   begin
      if Order = Little_Endian then
         return (
            1 => Hi_Byte(Hi_Two_Bytes(F)),
            2 => Lo_Byte(Hi_Two_Bytes(F)),
            3 => Hi_Byte(Lo_Two_Bytes(F)),
            4 => Lo_Byte(Lo_Two_Bytes(F)));
      else
         return (
            1 => Lo_Byte(Lo_Two_Bytes(F)),
            2 => Hi_Byte(Lo_Two_Bytes(F)),
            3 => Lo_Byte(Hi_Two_Bytes(F)),
            4 => Hi_Byte(Hi_Two_Bytes(F)));
      end if;
   end To_Byte_Array;

   --+---[To_Byte_Array]------------------------------------------------


   function    To_Byte_Array(
                  E              : in     Eight_Bytes;
                  Order          : in     Byte_Order := Little_Endian)
      return   Byte_Array
   is
   begin
      if Order = Little_Endian then
         return (
            1 => Hi_Byte(Hi_Two_Bytes(Hi_Four_Bytes(E))),
            2 => Lo_Byte(Hi_Two_Bytes(Hi_Four_Bytes(E))),
            3 => Hi_Byte(Lo_Two_Bytes(Hi_Four_Bytes(E))),
            4 => Lo_Byte(Lo_Two_Bytes(Hi_Four_Bytes(E))),
            5 => Hi_Byte(Hi_Two_Bytes(Lo_Four_Bytes(E))),
            6 => Lo_Byte(Hi_Two_Bytes(Lo_Four_Bytes(E))),
            7 => Hi_Byte(Lo_Two_Bytes(Lo_Four_Bytes(E))),
            8 => Lo_Byte(Lo_Two_Bytes(Lo_Four_Bytes(E))));
      else
         return (
            1 => Lo_Byte(Lo_Two_Bytes(Lo_Four_Bytes(E))),
            2 => Hi_Byte(Lo_Two_Bytes(Lo_Four_Bytes(E))),
            3 => Lo_Byte(Hi_Two_Bytes(Lo_Four_Bytes(E))),
            4 => Hi_Byte(Hi_Two_Bytes(Lo_Four_Bytes(E))),
            5 => Lo_Byte(Lo_Two_Bytes(Hi_Four_Bytes(E))),
            6 => Hi_Byte(Lo_Two_Bytes(Hi_Four_Bytes(E))),
            7 => Lo_Byte(Hi_Two_Bytes(Hi_Four_Bytes(E))),
            8 => Hi_Byte(Hi_Two_Bytes(Hi_Four_Bytes(E))));
      end if;
   end To_Byte_Array;

   ---------------------------------------------------------------------

   -- Accessing and modifying individual bit values

   ---------------------------------------------------------------------


   --+---[Get_Bit_Value]------------------------------------------------


   function    Get_Bit_Value(
                  From           : in     Byte;
                  At_Position    : in     Natural)
      return   Boolean
   is
   begin
      if At_Position <= 7 then
         return ((From and Shift_Left(Byte(1), At_Position)) /= 0);
      else
         return False;
      end if;
   end Get_Bit_Value;

   --+---[Get_Bit_Value]------------------------------------------------


   function    Get_Bit_Value(
                  From           : in     Two_Bytes;
                  At_Position    : in     Natural)
      return   Boolean
   is
   begin
      if At_Position <= 15 then
         return ((From and Shift_Left(Two_Bytes(1), At_Position)) /= 0);
      else
         return False;
      end if;
   end Get_Bit_Value;

   --+---[Get_Bit_Value]------------------------------------------------


   function    Get_Bit_Value(
                  From           : in     Four_Bytes;
                  At_Position    : in     Natural)
      return   Boolean
   is
   begin
      if At_Position <= 31 then
         return (
            (From and Shift_Left(Four_Bytes(1), At_Position)) /= 0);
      else
         return False;
      end if;
   end Get_Bit_Value;

   --+---[Get_Bit_Value]------------------------------------------------


   function    Get_Bit_Value(
                  From           : in     Eight_Bytes;
                  At_Position    : in     Natural)
      return   Boolean
   is
   begin
      if At_Position <= 63 then
         return (
            (From and Shift_Left(Eight_Bytes(1), At_Position)) /= 0);
      else
         return False;
      end if;
   end Get_Bit_Value;

   --+---[Set_Bit_Value]------------------------------------------------


   procedure   Set_Bit_Value(
                  Into           : in out Byte;
                  At_Position    : in     Natural;
                  To             : in     Boolean)
   is
   begin
      if At_Position <= 7 then
         if To then
            Into := Into or (Rotate_Left(Byte(1), At_Position));
         else
            Into := Into and (Rotate_Left(Byte(16#FE#), At_Position));
         end if;
      end if;
   end Set_Bit_Value;

   --+---[Set_Bit_Value]------------------------------------------------


   procedure   Set_Bit_Value(
                  Into           : in out Two_Bytes;
                  At_Position    : in     Natural;
                  To             : in     Boolean)
   is
   begin
      if At_Position <= 15 then
         if To then
            Into := Into or
                    (Rotate_Left(Two_Bytes(1), At_Position));
         else
            Into := Into and
                    (Rotate_Left(Two_Bytes(16#FFFE#), At_Position));
         end if;
      end if;
   end Set_Bit_Value;

   --+---[Set_Bit_Value]------------------------------------------------


   procedure   Set_Bit_Value(
                  Into           : in out Four_Bytes;
                  At_Position    : in     Natural;
                  To             : in     Boolean)
   is
   begin
      if At_Position <= 31 then
         if To then
            Into := Into or
                    (Rotate_Left(Four_Bytes(1), At_Position));
         else
            Into := Into and
                    (Rotate_Left(Four_Bytes(16#FFFF_FFFE#),
                                 At_Position));
         end if;
      end if;
   end Set_Bit_Value;

   --+---[Set_Bit_Value]------------------------------------------------


   procedure   Set_Bit_Value(
                  Into           : in out Eight_Bytes;
                  At_Position    : in     Natural;
                  To             : in     Boolean)
   is
   begin
      if At_Position <= 63 then
         if To then
            Into := Into or
                    (Rotate_Left(Eight_Bytes(1), At_Position));
         else
            Into := Into and
                    (Rotate_Left(Eight_Bytes(16#FFFF_FFFF_FFFF_FFFE#),
                                 At_Position));
         end if;
      end if;
   end Set_Bit_Value;

   --+---[To_Hex_String]------------------------------------------------


   function    To_Hex_String(
                  Value          : in     Byte;
                  Preffix        : in     String := "";
                  Suffix         : in     String := "";
                  Digit_Case     : in     Hex_Digit_Case := Upper_Case)
      return   String
   is
      R              : Unbounded_String;
   begin
      Append(R, Hex_Digits(Hi_Nibble(Value)));
      Append(R, Hex_Digits(Lo_Nibble(Value)));

      if Digit_Case = Lower_Case then
         return (Preffix & To_String(R) & Suffix);
      else
         return (Preffix & To_Upper(To_String(R)) & Suffix);
      end if;
   end To_Hex_String;

   --+---[To_Hex_String]------------------------------------------------


   function    To_Hex_String(
                  Value          : in     Two_Bytes;
                  Preffix        : in     String := "";
                  Suffix         : in     String := "";
                  Digit_Case     : in     Hex_Digit_Case := Upper_Case)
      return   String
   is
      R              : Unbounded_String;
      B              : Byte_Array := To_Byte_Array(Value);
   begin
      for I in B'Range loop
         Append(R, Hex_Digits(Hi_Nibble(B(I))));
         Append(R, Hex_Digits(Lo_Nibble(B(I))));
      end loop;

      if Digit_Case = Lower_Case then
         return (Preffix & To_String(R) & Suffix);
      else
         return (Preffix & To_Upper(To_String(R)) & Suffix);
      end if;
   end To_Hex_String;

   --+---[To_Hex_String]------------------------------------------------


   function    To_Hex_String(
                  Value          : in     Four_Bytes;
                  Preffix        : in     String := "";
                  Suffix         : in     String := "";
                  Digit_Case     : in     Hex_Digit_Case := Upper_Case)
      return   String
   is
      R              : Unbounded_String;
      B              : Byte_Array := To_Byte_Array(Value);
   begin
      for I in B'Range loop
         Append(R, Hex_Digits(Hi_Nibble(B(I))));
         Append(R, Hex_Digits(Lo_Nibble(B(I))));
      end loop;

      if Digit_Case = Lower_Case then
         return (Preffix & To_String(R) & Suffix);
      else
         return (Preffix & To_Upper(To_String(R)) & Suffix);
      end if;
   end To_Hex_String;

   --+---[To_Hex_String]------------------------------------------------


   function    To_Hex_String(
                  Value          : in     Eight_Bytes;
                  Preffix        : in     String := "";
                  Suffix         : in     String := "";
                  Digit_Case     : in     Hex_Digit_Case := Upper_Case)
      return   String
   is
      R              : Unbounded_String;
      B              : Byte_Array := To_Byte_Array(Value);
   begin
      for I in B'Range loop
         Append(R, Hex_Digits(Hi_Nibble(B(I))));
         Append(R, Hex_Digits(Lo_Nibble(B(I))));
      end loop;

      if Digit_Case = Lower_Case then
         return (Preffix & To_String(R) & Suffix);
      else
         return (Preffix & To_Upper(To_String(R)) & Suffix);
      end if;
   end To_Hex_String;

end ACF.Types;