1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 1999-2008 by the Free Pascal development team 4 5 See the file COPYING.FPC, included in this distribution, 6 for details about the copyright. 7 8 This program is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 12 **********************************************************************} 13{****************************************************************************} 14{* TBits *} 15{****************************************************************************} 16 17Procedure BitsError (const Msg : string); 18begin 19 Raise EBitsError.Create(Msg) at get_caller_addr(get_frame), get_caller_frame(get_frame); 20end; 21 22Procedure BitsErrorFmt (const Msg : string; const Args : array of const); 23begin 24 Raise EBitsError.CreateFmt(Msg,args) at get_caller_addr(get_frame), get_caller_frame(get_frame); 25end; 26 27{Min function for Longint} 28Function liMin(X, Y: Longint): Longint; 29 begin 30 Result := X; 31 if X > Y then Result := Y; 32 end; 33 34procedure TBits.CheckBitIndex (Bit : longint;CurrentSize : Boolean); 35 36begin 37 if (bit<0) or (CurrentSize and (Bit >= FBSize)) then 38 BitsErrorFmt(SErrInvalidBitIndex,[bit]); 39 if (bit>=MaxBitFlags) then 40 BitsErrorFmt(SErrIndexTooLarge,[bit]) 41 42end; 43 44{ ************* functions to match TBits class ************* } 45 46procedure TBits.setSize(value: longint); 47var 48 newSize, loop: LongInt; 49begin 50 CheckBitIndex(value, false); 51 52 if value <> 0 then 53 newSize := (value shr BITSHIFT) + 1 54 else 55 newSize := 0; 56 57 if newSize <> FSize then 58 begin 59 ReAllocMem(FBits, newSize * SizeOf(longint)); 60 if FBits <> nil then 61 begin 62 if newSize > FSize then 63 for loop := FSize to newSize - 1 do 64 FBits^[loop] := 0; 65 end 66 else if newSize > 0 then 67 BitsError(SErrOutOfMemory); { isn't ReallocMem supposed to throw EOutOfMemory? } 68 FSize := newSize; 69 end; 70 FBSize := value; 71end; 72 73procedure TBits.SetBit(bit : longint; value : Boolean); 74var 75 n: Integer; 76begin 77 grow(bit+1); { validates bit range and adjusts FBSize if necessary } 78 n := bit shr BITSHIFT; 79 if value then 80 FBits^[n] := FBits^[n] or (longword(1) shl (bit and MASK)) 81 else 82 FBits^[n] := FBits^[n] and not (longword(1) shl (bit and MASK)); 83end; 84 85function TBits.OpenBit : longint; 86var 87 loop : longint; 88 loop2 : longint; 89begin 90 result := -1; {should only occur if the whole array is set} 91 { map 0 to -1, 1..32 to 0, etc } 92 for loop := 0 to ((FBSize + MASK) shr BITSHIFT) - 1 do 93 begin 94 if FBits^[loop] <> $FFFFFFFF then 95 begin 96 for loop2 := 0 to MASK do 97 begin 98 if (FBits^[loop] and (longint(1) shl loop2)) = 0 then 99 begin 100 result := (loop shl BITSHIFT) + loop2; 101 if result > FBSize then 102 result := FBSize; 103 Exit; 104 end; 105 end; 106 end; 107 end; 108 109 if FSize < MaxBitRec then 110 result := FBSize; {first bit of next record} 111end; 112 113{ ******************** TBits ***************************** } 114 115constructor TBits.Create(theSize : longint = 0 ); 116begin 117 FSize := 0; 118 FBSize := 0; 119 FBits := nil; 120 findIndex := -1; 121 findState := True; { no reason just setting it to something } 122 if TheSize > 0 then grow(theSize); 123end; 124 125destructor TBits.Destroy; 126begin 127 if FBits <> nil then 128 FreeMem(FBits, FSize * SizeOf(longint)); 129 FBits := nil; 130 131 inherited Destroy; 132end; 133 134procedure TBits.grow(nbit: longint); 135begin 136 if nbit > FBSize then 137 SetSize(nbit); 138end; 139 140function TBits.getFSize : longint; 141begin 142 result := FSize; 143end; 144 145procedure TBits.seton(bit : longint); 146begin 147 SetBit(bit, True); 148end; 149 150procedure TBits.clear(bit : longint); 151begin 152 SetBit(bit, False); 153end; 154 155procedure TBits.clearall; 156var 157 loop : longint; 158begin 159 for loop := 0 to FSize - 1 do 160 FBits^[loop] := 0; 161{ don't clear FBSize here, it will cause exceptions on subsequent reading bit values } 162{ use 'Size := 0' to reset everything and deallocate storage } 163end; 164 165function TBits.get(bit : longint) : Boolean; 166var 167 n : longint; 168begin 169 CheckBitIndex(bit,true); 170 result := False; 171 n := bit shr BITSHIFT; 172 if (n < FSize) then 173 result := (FBits^[n] and (longint(1) shl (bit and MASK))) <> 0; 174end; 175 176procedure TBits.CopyBits(BitSet : TBits); 177begin 178 setSize(bitset.Size); 179 Move(bitset.FBits^,FBits^,FSize*SizeOf(cardinal)); 180end; 181 182procedure TBits.andbits(bitset : TBits); 183var 184 n : longint; 185 loop : longint; 186begin 187 if FSize < bitset.getFSize then 188 n := FSize - 1 189 else 190 n := bitset.getFSize - 1; 191 192 for loop := 0 to n do 193 FBits^[loop] := FBits^[loop] and bitset.FBits^[loop]; 194 195 for loop := n + 1 to FSize - 1 do 196 FBits^[loop] := 0; 197end; 198 199procedure TBits.notbits(bitset : TBits); 200var 201 n : longint; 202 loop : longint; 203begin 204 if FSize < bitset.getFSize then 205 n := FSize - 1 206 else 207 n := bitset.getFSize - 1; 208 209 for loop := 0 to n do 210 FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop]; 211end; 212 213procedure TBits.orbits(bitset : TBits); 214var 215 loop : longint; 216begin 217 grow(bitset.Size); 218 219 for loop := 0 to bitset.getFSize-1 do 220 FBits^[loop] := FBits^[loop] or bitset.FBits^[loop]; 221end; 222 223procedure TBits.xorbits(bitset : TBits); 224var 225 loop : longint; 226begin 227 grow(bitset.Size); 228 229 for loop := 0 to bitset.getFSize-1 do 230 FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop]; 231end; 232 233function TBits.Equals(Obj : TObject): Boolean; 234begin 235 if Obj is TBits then 236 Result := Equals(TBits(Obj)) 237 else 238 Result := inherited Equals(Obj); 239end; 240 241function TBits.equals(bitset : TBits) : Boolean; 242var 243 n : longint; 244 loop : longint; 245begin 246 result := False; 247 248 if FSize < bitset.getFSize then 249 n := FSize - 1 250 else 251 n := bitset.getFSize - 1; 252 253 for loop := 0 to n do 254 if FBits^[loop] <> bitset.FBits^[loop] then exit; 255 256 if FSize - 1 > n then 257 begin 258 for loop := n to FSize - 1 do 259 if FBits^[loop] <> 0 then exit; 260 end 261 else if bitset.getFSize - 1 > n then 262 for loop := n to bitset.getFSize - 1 do 263 if bitset.FBits^[loop] <> 0 then exit; 264 265 result := True; {passed all tests} 266end; 267 268 269{ us this in place of calling FindFirstBit. It sets the current } 270{ index used by FindNextBit and FindPrevBit } 271 272procedure TBits.SetIndex(index : longint); 273begin 274 CheckBitIndex(index,true); 275 findIndex := index; 276end; 277 278 279{ When state is set to True it looks for bits that are turned On (1) } 280{ and when it is set to False it looks for bits that are turned } 281{ off (0). } 282 283function TBits.FindFirstBit(state : boolean) : longint; 284var 285 loop : longint; 286 loop2 : longint; 287 startIndex : longint; 288 stopIndex : Longint; 289 compareVal : cardinal; 290begin 291 result := -1; {should only occur if none are set} 292 293 findState := state; 294 295 if state = False then 296 compareVal := $FFFFFFFF { looking for off bits } 297 else 298 compareVal := $00000000; { looking for on bits } 299 300 for loop := 0 to FSize - 1 do 301 begin 302 if FBits^[loop] <> compareVal then 303 begin 304 startIndex := loop * 32; 305 stopIndex:= liMin(StartIndex+31,FBSize -1); 306 for loop2 := startIndex to stopIndex do 307 begin 308 if get(loop2) = state then 309 begin 310 result := loop2; 311 break; { use this as the index to return } 312 end; 313 end; 314 break; {stop looking for bit in records } 315 end; 316 end; 317 318 findIndex := result; 319end; 320 321function TBits.FindNextBit : longint; 322var 323 loop : longint; 324begin 325 result := -1; { will occur only if no other bits set to } 326 { current findState } 327 328 if findIndex > -1 then { must have called FindFirstBit first } 329 begin { or set the start index } 330 331 for loop := findIndex + 1 to FBSize-1 do 332 begin 333 if get(loop) = findState then 334 begin 335 result := loop; 336 break; 337 end; 338 end; 339 340 findIndex := result; 341 end; 342end; 343 344function TBits.FindPrevBit : longint; 345var 346 loop : longint; 347begin 348 result := -1; { will occur only if no other bits set to } 349 { current findState } 350 351 if findIndex > -1 then { must have called FindFirstBit first } 352 begin { or set the start index } 353 for loop := findIndex - 1 downto 0 do 354 begin 355 if get(loop) = findState then 356 begin 357 result := loop; 358 break; 359 end; 360 end; 361 362 findIndex := result; 363 end; 364end; 365 366 367