home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / s-bitops.adb < prev    next >
Text File  |  2000-07-19  |  8KB  |  224 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS                --
  4. --                                                                          --
  5. --                       S Y S T E M . B I T _ O P S                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.10 $
  10. --                                                                          --
  11. --         Copyright (C) 1996-2000 Free Software Foundation, Inc.           --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with GNAT.Exceptions;       use GNAT.Exceptions;
  37. with System;                use System;
  38. with System.Unsigned_Types; use System.Unsigned_Types;
  39. with Unchecked_Conversion;
  40.  
  41. package body System.Bit_Ops is
  42.  
  43.    subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive);
  44.    --  Unconstrained array used to interprete the address values. We use the
  45.    --  unaligned version always, since this will handle both the aligned and
  46.    --  unaligned cases, and we always do these operations by bytes anyway.
  47.    --  Note: we use a ones origin array here so that the computations of the
  48.    --  length in bytes work correctly (give a non-negative value) for the
  49.    --  case of zero length bit strings).
  50.  
  51.    type Bits is access Bits_Array;
  52.    --  This is the actual type into which address values are converted
  53.  
  54.    function To_Bits is new Unchecked_Conversion (Address, Bits);
  55.  
  56.    LE : constant := Standard'Default_Bit_Order;
  57.    --  Static constant set to 0 for big-endian, 1 for little-endian
  58.  
  59.    --  The following is an array of masks used to mask the final byte, either
  60.    --  at the high end (big-endian case) or the low end (little-endian case).
  61.  
  62.    Masks : constant array (1 .. 7) of Packed_Byte := (
  63.      (1 - LE) * 2#1000_0000# + LE * 2#0000_0001#,
  64.      (1 - LE) * 2#1100_0000# + LE * 2#0000_0011#,
  65.      (1 - LE) * 2#1110_0000# + LE * 2#0000_0111#,
  66.      (1 - LE) * 2#1111_0000# + LE * 2#0000_1111#,
  67.      (1 - LE) * 2#1111_1000# + LE * 2#0001_1111#,
  68.      (1 - LE) * 2#1111_1100# + LE * 2#0011_1111#,
  69.      (1 - LE) * 2#1111_1110# + LE * 2#0111_1111#);
  70.  
  71.  
  72.    -----------------------
  73.    -- Local Subprograms --
  74.    -----------------------
  75.  
  76.    procedure Raise_Error;
  77.    --  Raise Constraint_Error, complaining about unequal lengths
  78.  
  79.    -------------
  80.    -- Bit_And --
  81.    -------------
  82.  
  83.    procedure Bit_And
  84.      (Left   : Address;
  85.       Llen   : Natural;
  86.       Right  : Address;
  87.       Rlen   : Natural;
  88.       Result : Address)
  89.    is
  90.       LeftB   : constant Bits := To_Bits (Left);
  91.       RightB  : constant Bits := To_Bits (Right);
  92.       ResultB : constant Bits := To_Bits (Result);
  93.  
  94.    begin
  95.       if Llen /= Rlen then
  96.          Raise_Error;
  97.       end if;
  98.  
  99.       for J in 1 .. (Rlen + 7) / 8 loop
  100.          ResultB (J) := LeftB (J) and RightB (J);
  101.       end loop;
  102.    end Bit_And;
  103.  
  104.    ------------
  105.    -- Bit_Eq --
  106.    ------------
  107.  
  108.    function Bit_Eq
  109.      (Left  : Address;
  110.       Llen  : Natural;
  111.       Right : Address;
  112.       Rlen  : Natural)
  113.       return  Boolean
  114.    is
  115.       LeftB  : constant Bits := To_Bits (Left);
  116.       RightB : constant Bits := To_Bits (Right);
  117.  
  118.    begin
  119.       if Llen /= Rlen then
  120.          return False;
  121.  
  122.       else
  123.          declare
  124.             BLen : constant Natural := Llen / 8;
  125.             Bitc : constant Natural := Llen mod 8;
  126.  
  127.          begin
  128.             if Llen /= Rlen then
  129.                return False;
  130.  
  131.             elsif LeftB (1 .. BLen) /= RightB (1 .. BLen) then
  132.                return False;
  133.  
  134.             elsif Bitc /= 0 then
  135.                return
  136.                  ((LeftB (BLen + 1) xor RightB (BLen + 1))
  137.                    and Masks (Bitc)) = 0;
  138.  
  139.             else -- Bitc = 0
  140.                return True;
  141.             end if;
  142.          end;
  143.       end if;
  144.    end Bit_Eq;
  145.  
  146.    -------------
  147.    -- Bit_Not --
  148.    -------------
  149.  
  150.    procedure Bit_Not
  151.      (Opnd   : System.Address;
  152.       Len    : Natural;
  153.       Result : System.Address)
  154.    is
  155.       OpndB   : constant Bits := To_Bits (Opnd);
  156.       ResultB : constant Bits := To_Bits (Result);
  157.  
  158.    begin
  159.       for J in 1 .. (Len + 7) / 8 loop
  160.          ResultB (J) := not OpndB (J);
  161.       end loop;
  162.    end Bit_Not;
  163.  
  164.    ------------
  165.    -- Bit_Or --
  166.    ------------
  167.  
  168.    procedure Bit_Or
  169.      (Left   : Address;
  170.       Llen   : Natural;
  171.       Right  : Address;
  172.       Rlen   : Natural;
  173.       Result : Address)
  174.    is
  175.       LeftB   : constant Bits := To_Bits (Left);
  176.       RightB  : constant Bits := To_Bits (Right);
  177.       ResultB : constant Bits := To_Bits (Result);
  178.  
  179.    begin
  180.       if Llen /= Rlen then
  181.          Raise_Error;
  182.       end if;
  183.  
  184.       for J in 1 .. (Rlen + 7) / 8 loop
  185.          ResultB (J) := LeftB (J) or RightB (J);
  186.       end loop;
  187.    end Bit_Or;
  188.  
  189.    -------------
  190.    -- Bit_Xor --
  191.    -------------
  192.  
  193.    procedure Bit_Xor
  194.      (Left   : Address;
  195.       Llen   : Natural;
  196.       Right  : Address;
  197.       Rlen   : Natural;
  198.       Result : Address)
  199.    is
  200.       LeftB   : constant Bits := To_Bits (Left);
  201.       RightB  : constant Bits := To_Bits (Right);
  202.       ResultB : constant Bits := To_Bits (Result);
  203.  
  204.    begin
  205.       if Llen /= Rlen then
  206.          Raise_Error;
  207.       end if;
  208.  
  209.       for J in 1 .. (Rlen + 7) / 8 loop
  210.          ResultB (J) := LeftB (J) xor RightB (J);
  211.       end loop;
  212.    end Bit_Xor;
  213.  
  214.    -----------------
  215.    -- Raise_Error --
  216.    -----------------
  217.  
  218.    procedure Raise_Error is
  219.    begin
  220.       Raise_Exception (CE, "unequal lengths in logical operation");
  221.    end Raise_Error;
  222.  
  223. end System.Bit_Ops;
  224.