1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . B I T _ O P S --
9 -- Copyright (C) 1996-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with System
.Unsigned_Types
; use System
.Unsigned_Types
;
34 with Ada
.Exceptions
; use Ada
.Exceptions
;
35 with Ada
.Unchecked_Conversion
;
37 package body System
.Bit_Ops
is
39 subtype Bits_Array
is System
.Unsigned_Types
.Packed_Bytes1
(Positive);
40 -- Dummy array type used to interpret the address values. We use the
41 -- unaligned version always, since this will handle both the aligned and
42 -- unaligned cases, and we always do these operations by bytes anyway.
43 -- Note: we use a ones origin array here so that the computations of the
44 -- length in bytes work correctly (give a non-negative value) for the
45 -- case of zero length bit strings). Note that we never allocate any
46 -- objects of this type (we can't because they would be absurdly big).
48 type Bits
is access Bits_Array
;
49 -- This is the actual type into which address values are converted
51 function To_Bits
is new Ada
.Unchecked_Conversion
(Address
, Bits
);
53 LE
: constant := Standard
'Default_Bit_Order;
54 -- Static constant set to 0 for big-endian, 1 for little-endian
56 -- The following is an array of masks used to mask the final byte, either
57 -- at the high end (big-endian case) or the low end (little-endian case).
59 Masks
: constant array (1 .. 7) of Packed_Byte
:= [
60 (1 - LE
) * 2#
1000_0000#
+ LE
* 2#
0000_0001#
,
61 (1 - LE
) * 2#
1100_0000#
+ LE
* 2#
0000_0011#
,
62 (1 - LE
) * 2#
1110_0000#
+ LE
* 2#
0000_0111#
,
63 (1 - LE
) * 2#
1111_0000#
+ LE
* 2#
0000_1111#
,
64 (1 - LE
) * 2#
1111_1000#
+ LE
* 2#
0001_1111#
,
65 (1 - LE
) * 2#
1111_1100#
+ LE
* 2#
0011_1111#
,
66 (1 - LE
) * 2#
1111_1110#
+ LE
* 2#
0111_1111#
];
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 procedure Raise_Error
;
73 pragma No_Return
(Raise_Error
);
74 -- Raise Constraint_Error, complaining about unequal lengths
87 LeftB
: constant Bits
:= To_Bits
(Left
);
88 RightB
: constant Bits
:= To_Bits
(Right
);
89 ResultB
: constant Bits
:= To_Bits
(Result
);
96 for J
in 1 .. (Rlen
+ 7) / 8 loop
97 ResultB
(J
) := LeftB
(J
) and RightB
(J
);
109 Rlen
: Natural) return Boolean
111 LeftB
: constant Bits
:= To_Bits
(Left
);
112 RightB
: constant Bits
:= To_Bits
(Right
);
115 pragma Annotate
(Gnatcheck
, Exempt_On
, "Improper_Returns",
116 "early returns for performance");
123 BLen
: constant Natural := Llen
/ 8;
124 Bitc
: constant Natural := Llen
mod 8;
127 if LeftB
(1 .. BLen
) /= RightB
(1 .. BLen
) then
132 ((LeftB
(BLen
+ 1) xor RightB
(BLen
+ 1))
133 and Masks
(Bitc
)) = 0;
141 pragma Annotate
(Gnatcheck
, Exempt_Off
, "Improper_Returns");
149 (Opnd
: System
.Address
;
151 Result
: System
.Address
)
153 OpndB
: constant Bits
:= To_Bits
(Opnd
);
154 ResultB
: constant Bits
:= To_Bits
(Result
);
157 for J
in 1 .. (Len
+ 7) / 8 loop
158 ResultB
(J
) := not OpndB
(J
);
173 LeftB
: constant Bits
:= To_Bits
(Left
);
174 RightB
: constant Bits
:= To_Bits
(Right
);
175 ResultB
: constant Bits
:= To_Bits
(Result
);
182 for J
in 1 .. (Rlen
+ 7) / 8 loop
183 ResultB
(J
) := LeftB
(J
) or RightB
(J
);
198 LeftB
: constant Bits
:= To_Bits
(Left
);
199 RightB
: constant Bits
:= To_Bits
(Right
);
200 ResultB
: constant Bits
:= To_Bits
(Result
);
207 for J
in 1 .. (Rlen
+ 7) / 8 loop
208 ResultB
(J
) := LeftB
(J
) xor RightB
(J
);
216 procedure Raise_Error
is
219 (Constraint_Error
'Identity, "operand lengths are unequal");