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-2013, 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_Warning;
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