Hacker/Hacker.iso/HACKER/DECOMP/DECAF/basidefi.adb

Text File | 1996-09-19 | 22.0 KB | 571 lines

--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: Gilles Demailly
--
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose.  It is provided "as is" without express
-- or implied warranty.
--

with Ada.Unchecked_Conversion;
with System;
-- the constant Default_Bit_Order provided by package System
-- allow us to code only one body for package Basic_Definitions


package body Basic_Definitions is

   -- Most significant bit for all integer types
   Msb    : constant := 0;

   -- Less significant bit for each integer type
   Lsb_8  : constant := 7;
   Lsb_16 : constant := 15;
   Lsb_32 : constant := 31;
   Lsb_64 : constant := 63;

   -- index type of types represented by 8, 16, 32 and 64 bits
   -----------------------------------------------------------
   subtype Bits_8_Index  is Natural range Msb .. Lsb_8;
   subtype Bits_16_Index is Natural range Msb .. Lsb_16;
   subtype Bits_32_Index is Natural range Msb .. Lsb_32;
   subtype Bits_64_Index is Natural range Msb .. Lsb_64;

   -- boolean arrays types (size 8, 16, 32 and 64) used to
   -- make logical operations for integer types based
   -- on 8, 16, 32 and 64 bits
   -------------------------------------------------------
   type Bits_8  is array (Bits_8_Index'Range)  of Boolean;
   pragma Pack (Bits_8);

   type Bits_16 is array (Bits_16_Index'Range) of Boolean;
   pragma Pack (Bits_16);

   type Bits_32 is array (Bits_32_Index'Range) of Boolean;
   pragma Pack (Bits_32);

   type Bits_64 is array (Bits_64_Index'Range) of Boolean;
   pragma Pack (Bits_64);

   -- subtypes used to limit shift operations on 8, 16, 32 and 64 bits
   -- wide integer types
   -------------------------------------------------------------------
   subtype Allowed_Shift_8  is Natural range 0..Integer_8_Size;
   subtype Allowed_Shift_16 is Natural range 0..Integer_16_Size;
   subtype Allowed_Shift_32 is Natural range 0..Integer_32_Size;
   subtype Allowed_Shift_64 is Natural range 0..Integer_64_Size;

   -- null constants used to initialize results
   --------------------------------------------
   Null_Bits_8  : constant Bits_8  := (others => False);
   Null_Bits_16 : constant Bits_16 := (others => False);
   Null_Bits_32 : constant Bits_32 := (others => False);
   Null_Bits_64 : constant Bits_64 := (others => False);


   -- conversion functions (both sides) between boolean arrays
   -- and integer types represented by 8, 16, 32 and 64 bits
   -----------------------------------------------------------

   function To_Bits is new Ada.Unchecked_Conversion (Unsigned_8,  Bits_8);
   function To_Bits is new Ada.Unchecked_Conversion (Unsigned_16, Bits_16);
   function To_Bits is new Ada.Unchecked_Conversion (Unsigned_32, Bits_32);
   function To_Bits is new Ada.Unchecked_Conversion (Unsigned_64, Bits_64);

   function To_Unsigned is new Ada.Unchecked_Conversion (Bits_8,  Unsigned_8);
   function To_Unsigned is new Ada.Unchecked_Conversion (Bits_16, Unsigned_16);
   function To_Unsigned is new Ada.Unchecked_Conversion (Bits_32, Unsigned_32);
   function To_Unsigned is new Ada.Unchecked_Conversion (Bits_64, Unsigned_64);



   -- shift functions strategy :
   --  all these functions make first a conversion to a boolean array
   --  then shift boolean values (the order depends on the constant
   --  System.Default_Bit_Order which enable us to provide portable
   --  code) and then make a conversion back to the integer type

   function Shift_Left
               (Value  : Unsigned_8;
                Amount : Natural)
            return Unsigned_8 is
     Shift      : constant Allowed_Shift_8 := Allowed_Shift_8 (Amount);
     Value_Bits : constant Bits_8          := To_Bits (Value);
     Result     : Bits_8                   := Null_Bits_8;
   begin
      if Shift < Integer_8_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Msb .. (Lsb_8 - Shift)) := Value_Bits (Shift .. Lsb_8);
            when System.Low_Order_First =>
               Result (Shift .. Lsb_8) := Value_Bits (Msb .. (Lsb_8 - Shift));
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Left;

   function Shift_Right
               (Value  : Unsigned_8;
                Amount : Natural)
            return Unsigned_8 is
     Shift      : constant Allowed_Shift_8 := Allowed_Shift_8 (Amount);
     Value_Bits : constant Bits_8          := To_Bits (Value);
     Result     : Bits_8                   := Null_Bits_8;
   begin
      if Shift < Integer_8_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Shift .. Lsb_8) := Value_Bits (Msb .. (Lsb_8 - Shift));
            when System.Low_Order_First =>
               Result (Msb .. (Lsb_8 - Shift)) := Value_Bits (Shift .. Lsb_8);
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Right;

   function Shift_Left
               (Value  : Unsigned_16;
                Amount : Natural)
            return Unsigned_16 is
     Shift      : constant Allowed_Shift_16 := Allowed_Shift_16 (Amount);
     Value_Bits : constant Bits_16          := To_Bits (Value);
     Result     : Bits_16                   := Null_Bits_16;
   begin
      if Shift < Integer_16_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Msb .. (Lsb_16 - Shift)) := Value_Bits (Shift .. Lsb_16);
            when System.Low_Order_First =>
               Result (Shift .. Lsb_16) := Value_Bits (Msb .. (Lsb_16 - Shift));
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Left;

   function Shift_Right
               (Value  : Unsigned_16;
                Amount : Natural)
            return Unsigned_16 is
     Shift      : constant Allowed_Shift_16 := Allowed_Shift_16 (Amount);
     Value_Bits : constant Bits_16          := To_Bits (Value);
     Result     : Bits_16                   := Null_Bits_16;
   begin
      if Shift < Integer_16_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Shift .. Lsb_16) := Value_Bits (Msb .. (Lsb_16 - Shift));
            when System.Low_Order_First =>
               Result (Msb .. (Lsb_16 - Shift)) := Value_Bits (Shift .. Lsb_16);
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Right;

   function Shift_Left
               (Value  : Unsigned_32;
                Amount : Natural)
            return Unsigned_32 is
     Shift      : constant Allowed_Shift_32 := Allowed_Shift_32 (Amount);
     Value_Bits : constant Bits_32          := To_Bits (Value);
     Result     : Bits_32                   := Null_Bits_32;
   begin
      if Shift < Integer_32_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Msb .. (Lsb_32 - Shift)) := Value_Bits (Shift .. Lsb_32);
            when System.Low_Order_First =>
               Result (Shift .. Lsb_32) := Value_Bits (Msb .. (Lsb_32 - Shift));
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Left;

   function Shift_Right
               (Value  : Unsigned_32;
                Amount : Natural)
            return Unsigned_32 is
     Shift      : constant Allowed_Shift_32 := Allowed_Shift_32 (Amount);
     Value_Bits : constant Bits_32          := To_Bits (Value);
     Result     : Bits_32                   := Null_Bits_32;
   begin
      if Shift < Integer_32_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Shift .. Lsb_32) := Value_Bits (Msb .. (Lsb_32 - Shift));
            when System.Low_Order_First =>
               Result (Msb .. (Lsb_32 - Shift)) := Value_Bits (Shift .. Lsb_32);
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Right;

   function Shift_Left
               (Value  : Unsigned_64;
                Amount : Natural)
            return Unsigned_64 is
     Shift      : constant Allowed_Shift_64 := Allowed_Shift_64 (Amount);
     Value_Bits : constant Bits_64          := To_Bits (Value);
     Result     : Bits_64                   := Null_Bits_64;
   begin
      if Shift < Integer_64_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Msb .. (Lsb_64 - Shift)) := Value_Bits (Shift .. Lsb_64);
            when System.Low_Order_First =>
               Result (Shift .. Lsb_64) := Value_Bits (Msb .. (Lsb_64 - Shift));
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Left;

   function Shift_Right
               (Value  : Unsigned_64;
                Amount : Natural)
            return Unsigned_64 is
     Shift      : constant Allowed_Shift_64 := Allowed_Shift_64 (Amount);
     Value_Bits : constant Bits_64          := To_Bits (Value);
     Result     : Bits_64                   := Null_Bits_64;
   begin
      if Shift < Integer_64_Size then
         case System.Default_Bit_Order is
            when System.High_Order_First =>
               Result (Shift .. Lsb_64) := Value_Bits (Msb .. (Lsb_64 - Shift));
            when System.Low_Order_First =>
               Result (Msb .. (Lsb_64 - Shift)) := Value_Bits (Shift .. Lsb_64);
         end case;
      end if;
      return To_Unsigned (Result);
   end Shift_Right;

   --
   -- "and", "or", "not" functions strategy :
   --  all these functions make first a conversion of the argument(s)
   --  to boolean array(s) to apply the logical operation
   --  and then make a conversion back to the integer type
   --

   function "and" (Left, Right : Unsigned_8)  return Unsigned_8 is
   begin
      return To_Unsigned (To_Bits (Left) and To_Bits (Right));
   end "and";

   function "and" (Left, Right : Unsigned_16) return Unsigned_16 is
   begin
      return To_Unsigned (To_Bits (Left) and To_Bits (Right));
   end "and";

   function "and" (Left, Right : Unsigned_32) return Unsigned_32 is
   begin
      return To_Unsigned (To_Bits (Left) and To_Bits (Right));
   end "and";

   function "and" (Left, Right : Unsigned_64) return Unsigned_64 is
   begin
      return To_Unsigned (To_Bits (Left) and To_Bits (Right));
   end "and";

   function "or" (Left, Right : Unsigned_8)  return Unsigned_8 is
   begin
      return To_Unsigned (To_Bits (Left) or To_Bits (Right));
   end "or";

   function "or" (Left, Right : Unsigned_16) return Unsigned_16 is
   begin
      return To_Unsigned (To_Bits (Left) or To_Bits (Right));
   end "or";

   function "or" (Left, Right : Unsigned_32) return Unsigned_32 is
   begin
      return To_Unsigned (To_Bits (Left) or To_Bits (Right));
   end "or";

   function "or" (Left, Right : Unsigned_64) return Unsigned_64 is
   begin
      return To_Unsigned (To_Bits (Left) or To_Bits (Right));
   end "or";

   function "xor" (Left, Right : Unsigned_8)  return Unsigned_8 is
   begin
      return To_Unsigned (To_Bits (Left) xor To_Bits (Right));
   end "xor";

   function "xor" (Left, Right : Unsigned_16) return Unsigned_16 is
   begin
      return To_Unsigned (To_Bits (Left) xor To_Bits (Right));
   end "xor";

   function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is
   begin
      return To_Unsigned (To_Bits (Left) xor To_Bits (Right));
   end "xor";

   function "xor" (Left, Right : Unsigned_64) return Unsigned_64 is
   begin
      return To_Unsigned (To_Bits (Left) xor To_Bits (Right));
   end "xor";

   function "not" (Right : Unsigned_8)  return Unsigned_8 is
   begin
      return To_Unsigned (not To_Bits (Right));
   end "not";

   function "not" (Right : Unsigned_16) return Unsigned_16 is
   begin
      return To_Unsigned (not To_Bits (Right));
   end "not";

   function "not" (Right : Unsigned_32) return Unsigned_32 is
   begin
      return To_Unsigned (not To_Bits (Right));
   end "not";

   function "not" (Right : Unsigned_64) return Unsigned_64 is
   begin
      return To_Unsigned (not To_Bits (Right));
   end "not";

   --
   -- bit_at, Extract_Bits, Replace_Bits functions strategy :
   --  all these functions make first a conversion to a boolean array
   --  then perform the operation on the boolean values (the order
   --  depends on the constant System.Default_Bit_Order which enable us
   --  to provide portable code) and then make a conversion back
   --  to the integer type
   --

   function Bit_At (Value : Unsigned_8;  Index : Natural) return Boolean is
      Value_Bits : constant Bits_8       := To_Bits (Value);
      Real_Index : constant Bits_8_Index := Bits_8_Index (Index);
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            return Value_Bits (Real_Index);
         when System.Low_Order_First =>
            return Value_Bits (Lsb_8 - Real_Index);
      end case;
   end Bit_At;

   function Bit_At (Value : Unsigned_16; Index : Natural) return Boolean is
      Value_Bits : constant Bits_16       := To_Bits (Value);
      Real_Index : constant Bits_16_Index := Bits_16_Index (Index);
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            return Value_Bits (Real_Index);
         when System.Low_Order_First =>
            return Value_Bits (Lsb_16 - Real_Index);
      end case;
   end Bit_At;

   function Bit_At (Value : Unsigned_32; Index : Natural) return Boolean is
      Value_Bits : constant Bits_32       := To_Bits (Value);
      Real_Index : constant Bits_32_Index := Bits_32_Index (Index);
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            return Value_Bits (Real_Index);
         when System.Low_Order_First =>
            return Value_Bits (Lsb_32 - Real_Index);
      end case;
   end Bit_At;

   function Bit_At (Value : Unsigned_64; Index : Natural) return Boolean is
      Value_Bits : constant Bits_64       := To_Bits (Value);
      Real_Index : constant Bits_64_Index := Bits_64_Index (Index);
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            return Value_Bits (Real_Index);
         when System.Low_Order_First =>
            return Value_Bits (Lsb_64 - Real_Index);
      end case;
   end Bit_At;

   function Extract_Bits
               (Value  : Unsigned_8;
                Start  : Natural;
                Amount : Natural)
            return Unsigned_8 is
      Value_Bits : constant Bits_8       := To_Bits (Value);
      Real_Start : constant Bits_8_Index := Bits_8_Index (Start);
      Real_Last  : constant Bits_8_Index := Bits_8_Index (Start + Amount -1);
      Res_Start  : constant Bits_8_Index := Bits_8_Index (Lsb_8 - Amount +1);
      Result     : Bits_8                := Null_Bits_8;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Res_Start .. Lsb_8) := Value_Bits (Real_Start .. Real_Last);
         when System.Low_Order_First =>
            Result (0 .. Lsb_8 - Res_Start) :=
              Value_Bits (Lsb_8 - Real_Last .. Lsb_8 - Real_Start);
      end case;
      return To_Unsigned (Result);
   end Extract_Bits;

   function Extract_Bits
               (Value  : Unsigned_16;
                Start  : Natural;
                Amount : Natural)
            return Unsigned_16 is
      Value_Bits : constant Bits_16       := To_Bits (Value);
      Real_Start : constant Bits_16_Index := Bits_16_Index (Start);
      Real_Last  : constant Bits_16_Index := Bits_16_Index (Start + Amount -1);
      Res_Start  : constant Bits_16_Index := Bits_16_Index (Lsb_16 - Amount +1);
      Result     : Bits_16                := Null_Bits_16;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Res_Start .. Lsb_16) :=
              Value_Bits (Real_Start .. Real_Last);
         when System.Low_Order_First =>
            Result (0 .. Lsb_16 - Res_Start) :=
              Value_Bits (Lsb_16 - Real_Last .. Lsb_16 - Real_Start);
      end case;
      return To_Unsigned (Result);
   end Extract_Bits;

   function Extract_Bits
               (Value  : Unsigned_32;
                Start  : Natural;
                Amount : Natural)
            return Unsigned_32 is
      Value_Bits : constant Bits_32       := To_Bits (Value);
      Real_Start : constant Bits_32_Index := Bits_32_Index (Start);
      Real_Last  : constant Bits_32_Index := Bits_32_Index (Start + Amount -1);
      Res_Start  : constant Bits_32_Index := Bits_32_Index (Lsb_32 - Amount +1);
      Result     : Bits_32                := Null_Bits_32;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Res_Start .. Lsb_32) :=
              Value_Bits (Real_Start .. Real_Last);
         when System.Low_Order_First =>
            Result (0 .. Lsb_32 - Res_Start) :=
              Value_Bits (Lsb_32 - Real_Last .. Lsb_32 - Real_Start);
      end case;
      return To_Unsigned (Result);
   end Extract_Bits;

   function Extract_Bits
               (Value  : Unsigned_64;
                Start  : Natural;
                Amount : Natural)
            return Unsigned_64 is
      Value_Bits : constant Bits_64       := To_Bits (Value);
      Real_Start : constant Bits_64_Index := Bits_64_Index (Start);
      Real_Last  : constant Bits_64_Index := Bits_64_Index (Start + Amount -1);
      Res_Start  : constant Bits_64_Index := Bits_64_Index (Lsb_64 - Amount +1);
      Result     : Bits_64                := Null_Bits_64;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Res_Start .. Lsb_64) :=
              Value_Bits (Real_Start .. Real_Last);
         when System.Low_Order_First =>
            Result (0 .. Lsb_64 - Res_Start) :=
              Value_Bits (Lsb_64 - Real_Last .. Lsb_64 - Real_Start);
      end case;
      return To_Unsigned (Result);
   end Extract_Bits;

   function Replace_Bits
               (Value  : Unsigned_8;
                Start  : Natural;
                Amount : Natural;
                Source : Unsigned_8)
            return Unsigned_8 is
      Value_Bits : constant Bits_8       := To_Bits (Value);
      Src_Bits   : constant Bits_8       := To_Bits (Source);
      Real_Start : constant Bits_8_Index := Bits_8_Index (Start);
      Real_Last  : constant Bits_8_Index := Bits_8_Index (Start + Amount -1);
      Src_Start  : constant Bits_8_Index := Bits_8_Index (Lsb_8 - Amount +1);
      Result     : Bits_8                := Value_Bits;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Real_Start .. Real_Last) := Src_Bits (Src_Start .. Lsb_8);
         when System.Low_Order_First =>
            Result (Lsb_8 - Real_Last .. Lsb_8 - Real_Start) :=
              Src_Bits (0 .. Lsb_8 - Src_Start);
      end case;
      return To_Unsigned (Result);
   end Replace_Bits;

   function Replace_Bits
               (Value  : Unsigned_16;
                Start  : Natural;
                Amount : Natural;
                Source : Unsigned_16)
            return Unsigned_16 is
      Value_Bits : constant Bits_16       := To_Bits (Value);
      Src_Bits   : constant Bits_16       := To_Bits (Source);
      Real_Start : constant Bits_16_Index := Bits_16_Index (Start);
      Real_Last  : constant Bits_16_Index := Bits_16_Index (Start + Amount -1);
      Src_Start  : constant Bits_16_Index := Bits_16_Index (Lsb_16 - Amount +1);
      Result     : Bits_16                := Value_Bits;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Real_Start .. Real_Last) := Src_Bits (Src_Start .. Lsb_16);
         when System.Low_Order_First =>
            Result (Lsb_16 - Real_Last .. Lsb_16 - Real_Start) :=
              Src_Bits (0 .. Lsb_16 - Src_Start);
      end case;
      return To_Unsigned (Result);
   end Replace_Bits;

   function Replace_Bits
               (Value  : Unsigned_32;
                Start  : Natural;
                Amount : Natural;
                Source : Unsigned_32)
            return Unsigned_32 is
      Value_Bits : constant Bits_32       := To_Bits (Value);
      Src_Bits   : constant Bits_32       := To_Bits (Source);
      Real_Start : constant Bits_32_Index := Bits_32_Index (Start);
      Real_Last  : constant Bits_32_Index := Bits_32_Index (Start + Amount -1);
      Src_Start  : constant Bits_32_Index := Bits_32_Index (Lsb_32 - Amount +1);
      Result     : Bits_32                := Value_Bits;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Real_Start .. Real_Last) := Src_Bits (Src_Start .. Lsb_32);
         when System.Low_Order_First =>
            Result (Lsb_32 - Real_Last .. Lsb_32 - Real_Start) :=
              Src_Bits (0 .. Lsb_32 - Src_Start);
      end case;
      return To_Unsigned (Result);
   end Replace_Bits;

   function Replace_Bits
               (Value  : Unsigned_64;
                Start  : Natural;
                Amount : Natural;
                Source : Unsigned_64)
            return Unsigned_64 is
      Value_Bits : constant Bits_64       := To_Bits (Value);
      Src_Bits   : constant Bits_64       := To_Bits (Source);
      Real_Start : constant Bits_64_Index := Bits_64_Index (Start);
      Real_Last  : constant Bits_64_Index := Bits_64_Index (Start + Amount -1);
      Src_Start  : constant Bits_64_Index := Bits_64_Index (Lsb_64 - Amount +1);
      Result     : Bits_64                := Value_Bits;
   begin
      case System.Default_Bit_Order is
         when System.High_Order_First =>
            Result (Real_Start .. Real_Last) := Src_Bits (Src_Start .. Lsb_64);
         when System.Low_Order_First =>
            Result (Lsb_64 - Real_Last .. Lsb_64 - Real_Start) :=
              Src_Bits (0 .. Lsb_64 - Src_Start);
      end case;
      return To_Unsigned (Result);
   end Replace_Bits;

end Basic_Definitions;