1 ------------------------------------------------------------------------------
3 -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . B I T _ O P S --
11 -- Copyright (C) 1996-2000 Free Software Foundation, Inc. --
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. --
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. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- Extensive contributions were provided by Ada Core Technologies Inc. --
34 ------------------------------------------------------------------------------
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
;
41 package body System
.Bit_Ops
is
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).
51 type Bits
is access Bits_Array
;
52 -- This is the actual type into which address values are converted
54 function To_Bits
is new Unchecked_Conversion
(Address
, Bits
);
56 LE
: constant := Standard
'Default_Bit_Order;
57 -- Static constant set to 0 for big-endian, 1 for little-endian
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).
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#
);
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 procedure Raise_Error
;
77 -- Raise Constraint_Error, complaining about unequal lengths
90 LeftB
: constant Bits
:= To_Bits
(Left
);
91 RightB
: constant Bits
:= To_Bits
(Right
);
92 ResultB
: constant Bits
:= To_Bits
(Result
);
99 for J
in 1 .. (Rlen
+ 7) / 8 loop
100 ResultB
(J
) := LeftB
(J
) and RightB
(J
);
115 LeftB
: constant Bits
:= To_Bits
(Left
);
116 RightB
: constant Bits
:= To_Bits
(Right
);
124 BLen
: constant Natural := Llen
/ 8;
125 Bitc
: constant Natural := Llen
mod 8;
131 elsif LeftB
(1 .. BLen
) /= RightB
(1 .. BLen
) then
136 ((LeftB
(BLen
+ 1) xor RightB
(BLen
+ 1))
137 and Masks
(Bitc
)) = 0;
151 (Opnd
: System
.Address
;
153 Result
: System
.Address
)
155 OpndB
: constant Bits
:= To_Bits
(Opnd
);
156 ResultB
: constant Bits
:= To_Bits
(Result
);
159 for J
in 1 .. (Len
+ 7) / 8 loop
160 ResultB
(J
) := not OpndB
(J
);
175 LeftB
: constant Bits
:= To_Bits
(Left
);
176 RightB
: constant Bits
:= To_Bits
(Right
);
177 ResultB
: constant Bits
:= To_Bits
(Result
);
184 for J
in 1 .. (Rlen
+ 7) / 8 loop
185 ResultB
(J
) := LeftB
(J
) or RightB
(J
);
200 LeftB
: constant Bits
:= To_Bits
(Left
);
201 RightB
: constant Bits
:= To_Bits
(Right
);
202 ResultB
: constant Bits
:= To_Bits
(Result
);
209 for J
in 1 .. (Rlen
+ 7) / 8 loop
210 ResultB
(J
) := LeftB
(J
) xor RightB
(J
);
218 procedure Raise_Error
is
220 Raise_Exception
(CE
, "unequal lengths in logical operation");