1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME 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-- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- 10-- -- 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. -- 17-- -- 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. -- 21-- -- 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/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32pragma Compiler_Unit; 33 34with System; use System; 35with System.Unsigned_Types; use System.Unsigned_Types; 36 37with Ada.Exceptions; use Ada.Exceptions; 38with Ada.Unchecked_Conversion; 39 40package body System.Bit_Ops is 41 42 subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive); 43 -- Dummy array type used to interpret the address values. We use the 44 -- unaligned version always, since this will handle both the aligned and 45 -- unaligned cases, and we always do these operations by bytes anyway. 46 -- Note: we use a ones origin array here so that the computations of the 47 -- length in bytes work correctly (give a non-negative value) for the 48 -- case of zero length bit strings). Note that we never allocate any 49 -- objects of this type (we can't because they would be absurdly big). 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 Ada.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 -- Local Subprograms -- 73 ----------------------- 74 75 procedure Raise_Error; 76 pragma No_Return (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) return Boolean 113 is 114 LeftB : constant Bits := To_Bits (Left); 115 RightB : constant Bits := To_Bits (Right); 116 117 begin 118 if Llen /= Rlen then 119 return False; 120 121 else 122 declare 123 BLen : constant Natural := Llen / 8; 124 Bitc : constant Natural := Llen mod 8; 125 126 begin 127 if LeftB (1 .. BLen) /= RightB (1 .. BLen) then 128 return False; 129 130 elsif Bitc /= 0 then 131 return 132 ((LeftB (BLen + 1) xor RightB (BLen + 1)) 133 and Masks (Bitc)) = 0; 134 135 else -- Bitc = 0 136 return True; 137 end if; 138 end; 139 end if; 140 end Bit_Eq; 141 142 ------------- 143 -- Bit_Not -- 144 ------------- 145 146 procedure Bit_Not 147 (Opnd : System.Address; 148 Len : Natural; 149 Result : System.Address) 150 is 151 OpndB : constant Bits := To_Bits (Opnd); 152 ResultB : constant Bits := To_Bits (Result); 153 154 begin 155 for J in 1 .. (Len + 7) / 8 loop 156 ResultB (J) := not OpndB (J); 157 end loop; 158 end Bit_Not; 159 160 ------------ 161 -- Bit_Or -- 162 ------------ 163 164 procedure Bit_Or 165 (Left : Address; 166 Llen : Natural; 167 Right : Address; 168 Rlen : Natural; 169 Result : Address) 170 is 171 LeftB : constant Bits := To_Bits (Left); 172 RightB : constant Bits := To_Bits (Right); 173 ResultB : constant Bits := To_Bits (Result); 174 175 begin 176 if Llen /= Rlen then 177 Raise_Error; 178 end if; 179 180 for J in 1 .. (Rlen + 7) / 8 loop 181 ResultB (J) := LeftB (J) or RightB (J); 182 end loop; 183 end Bit_Or; 184 185 ------------- 186 -- Bit_Xor -- 187 ------------- 188 189 procedure Bit_Xor 190 (Left : Address; 191 Llen : Natural; 192 Right : Address; 193 Rlen : Natural; 194 Result : Address) 195 is 196 LeftB : constant Bits := To_Bits (Left); 197 RightB : constant Bits := To_Bits (Right); 198 ResultB : constant Bits := To_Bits (Result); 199 200 begin 201 if Llen /= Rlen then 202 Raise_Error; 203 end if; 204 205 for J in 1 .. (Rlen + 7) / 8 loop 206 ResultB (J) := LeftB (J) xor RightB (J); 207 end loop; 208 end Bit_Xor; 209 210 ----------------- 211 -- Raise_Error -- 212 ----------------- 213 214 procedure Raise_Error is 215 begin 216 Raise_Exception 217 (Constraint_Error'Identity, "operand lengths are unequal"); 218 end Raise_Error; 219 220end System.Bit_Ops; 221