with System; use System;
with System.Pure_Exceptions; use System.Pure_Exceptions;
with System.Unsigned_Types; use System.Unsigned_Types;
with Unchecked_Conversion;
package body System.Bit_Ops is
subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive);
type Bits is access Bits_Array;
function To_Bits is new Unchecked_Conversion (Address, Bits);
LE : constant := Standard'Default_Bit_Order;
Masks : constant array (1 .. 7) of Packed_Byte := (
(1 - LE) * 2#1000_0000# + LE * 2#0000_0001#,
(1 - LE) * 2#1100_0000# + LE * 2#0000_0011#,
(1 - LE) * 2#1110_0000# + LE * 2#0000_0111#,
(1 - LE) * 2#1111_0000# + LE * 2#0000_1111#,
(1 - LE) * 2#1111_1000# + LE * 2#0001_1111#,
(1 - LE) * 2#1111_1100# + LE * 2#0011_1111#,
(1 - LE) * 2#1111_1110# + LE * 2#0111_1111#);
procedure Raise_Error;
procedure Bit_And
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : Address)
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
ResultB : constant Bits := To_Bits (Result);
begin
if Llen /= Rlen then
Raise_Error;
end if;
for J in 1 .. (Rlen + 7) / 8 loop
ResultB (J) := LeftB (J) and RightB (J);
end loop;
end Bit_And;
function Bit_Eq
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural)
return Boolean
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
begin
if Llen /= Rlen then
return False;
else
declare
BLen : constant Natural := Llen / 8;
Bitc : constant Natural := Llen mod 8;
begin
if LeftB (1 .. BLen) /= RightB (1 .. BLen) then
return False;
elsif Bitc /= 0 then
return
((LeftB (BLen + 1) xor RightB (BLen + 1))
and Masks (Bitc)) = 0;
else return True;
end if;
end;
end if;
end Bit_Eq;
procedure Bit_Not
(Opnd : System.Address;
Len : Natural;
Result : System.Address)
is
OpndB : constant Bits := To_Bits (Opnd);
ResultB : constant Bits := To_Bits (Result);
begin
for J in 1 .. (Len + 7) / 8 loop
ResultB (J) := not OpndB (J);
end loop;
end Bit_Not;
procedure Bit_Or
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : Address)
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
ResultB : constant Bits := To_Bits (Result);
begin
if Llen /= Rlen then
Raise_Error;
end if;
for J in 1 .. (Rlen + 7) / 8 loop
ResultB (J) := LeftB (J) or RightB (J);
end loop;
end Bit_Or;
procedure Bit_Xor
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : Address)
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
ResultB : constant Bits := To_Bits (Result);
begin
if Llen /= Rlen then
Raise_Error;
end if;
for J in 1 .. (Rlen + 7) / 8 loop
ResultB (J) := LeftB (J) xor RightB (J);
end loop;
end Bit_Xor;
procedure Raise_Error is
begin
Raise_Exception (CE, "unequal lengths in logical operation");
end Raise_Error;
end System.Bit_Ops;