← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/rtl/objpas/classes/bits.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/rtl/objpas/classes/bits.inc
 
1
{
 
2
    This file is part of the Free Component Library (FCL)
 
3
    Copyright (c) 1999-2000 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
 
 
17
Procedure BitsError (Msg : string);
 
18
 
 
19
begin
 
20
  Raise EBitsError.Create(Msg) at get_caller_addr(get_frame);
 
21
end;
 
22
 
 
23
Procedure BitsErrorFmt (Msg : string; const Args : array of const);
 
24
 
 
25
begin
 
26
  Raise EBitsError.CreateFmt(Msg,args) at get_caller_addr(get_frame);
 
27
end;
 
28
 
 
29
procedure TBits.CheckBitIndex (Bit : longint;CurrentSize : Boolean);
 
30
 
 
31
begin
 
32
 if (bit<0) or (CurrentSize and (Bit>Size)) then
 
33
   BitsErrorFmt(SErrInvalidBitIndex,[bit]);
 
34
 if (bit>=MaxBitFlags) then
 
35
   BitsErrorFmt(SErrIndexTooLarge,[bit])
 
36
 
 
37
end;
 
38
 
 
39
{ ************* functions to match TBits class ************* }
 
40
 
 
41
function TBits.getSize : longint;
 
42
begin
 
43
   result := (FSize shl BITSHIFT) - 1;
 
44
end;
 
45
 
 
46
procedure TBits.setSize(value : longint);
 
47
begin
 
48
   grow(value - 1);
 
49
end;
 
50
 
 
51
procedure TBits.SetBit(bit : longint; value : Boolean);
 
52
begin
 
53
   if value = True then
 
54
      seton(bit)
 
55
   else
 
56
      clear(bit);
 
57
end;
 
58
 
 
59
function TBits.OpenBit : longint;
 
60
var
 
61
   loop : longint;
 
62
   loop2 : longint;
 
63
   startIndex : longint;
 
64
begin
 
65
   result := -1; {should only occur if the whole array is set}
 
66
   for loop := 0 to FSize - 1 do
 
67
   begin
 
68
      if FBits^[loop] <> $FFFFFFFF then
 
69
      begin
 
70
         startIndex := loop * 32;
 
71
         for loop2 := startIndex to startIndex + 31 do
 
72
         begin
 
73
            if get(loop2) = False then
 
74
            begin
 
75
               result := loop2;
 
76
               break; { use this as the index to return }
 
77
            end;
 
78
         end;
 
79
         break;  {stop looking for empty bit in records }
 
80
      end;
 
81
   end;
 
82
 
 
83
   if result = -1 then
 
84
      if FSize < MaxBitRec then
 
85
          result := FSize * 32;  {first bit of next record}
 
86
end;
 
87
 
 
88
{ ******************** TBits ***************************** }
 
89
 
 
90
constructor TBits.Create(theSize : longint = 0 );
 
91
begin
 
92
   FSize := 0;
 
93
   FBits := nil;
 
94
   findIndex := -1;
 
95
   findState := True;  { no reason just setting it to something }
 
96
   grow(theSize);
 
97
end;
 
98
 
 
99
destructor TBits.Destroy;
 
100
begin
 
101
   if FBits <> nil then
 
102
      FreeMem(FBits, FSize * SizeOf(longint));
 
103
   FBits := nil;
 
104
 
 
105
   inherited Destroy;
 
106
end;
 
107
 
 
108
procedure TBits.grow(nbit : longint);
 
109
var
 
110
   newSize : longint;
 
111
   loop : longint;
 
112
begin
 
113
   CheckBitindex(nbit,false);
 
114
 
 
115
   newSize :=  (nbit shr BITSHIFT) + 1;
 
116
 
 
117
   if newSize > FSize then
 
118
   begin
 
119
      ReAllocMem(FBits, newSize * SizeOf(longint));
 
120
      if FBits <> nil then
 
121
        begin
 
122
         if newSize > FSize then
 
123
            for loop := FSize to newSize - 1 do
 
124
               FBits^[loop] := 0;
 
125
         FSize := newSize;
 
126
       end
 
127
      else
 
128
        BitsError(SErrOutOfMemory);
 
129
   end;
 
130
end;
 
131
 
 
132
function TBits.getFSize : longint;
 
133
begin
 
134
   result := FSize;
 
135
end;
 
136
 
 
137
procedure TBits.seton(bit : longint);
 
138
var
 
139
   n : longint;
 
140
begin
 
141
   n := bit shr BITSHIFT;
 
142
   grow(bit);
 
143
   FBits^[n] := FBits^[n] or (longint(1) shl (bit and MASK));
 
144
end;
 
145
 
 
146
procedure TBits.clear(bit : longint);
 
147
var
 
148
   n : longint;
 
149
begin
 
150
   CheckBitIndex(bit,false);
 
151
   n := bit shr BITSHIFT;
 
152
   grow(bit);
 
153
   FBits^[n] := FBits^[n] and not(longint(1) shl (bit and MASK));
 
154
end;
 
155
 
 
156
procedure TBits.clearall;
 
157
var
 
158
   loop : longint;
 
159
begin
 
160
   for loop := 0 to FSize - 1 do
 
161
      FBits^[loop] := 0;
 
162
end;
 
163
 
 
164
function TBits.get(bit : longint) : Boolean;
 
165
var
 
166
   n : longint;
 
167
begin
 
168
   CheckBitIndex(bit,true);
 
169
   result := False;
 
170
   n := bit shr BITSHIFT;
 
171
   if (n < FSize) then
 
172
      result := (FBits^[n] and (longint(1) shl (bit and MASK))) <> 0;
 
173
end;
 
174
 
 
175
procedure TBits.andbits(bitset : TBits);
 
176
var
 
177
   n : longint;
 
178
   loop : longint;
 
179
begin
 
180
   if FSize < bitset.getFSize then
 
181
      n := FSize - 1
 
182
   else
 
183
      n := bitset.getFSize - 1;
 
184
 
 
185
   for loop := 0 to n do
 
186
      FBits^[loop] := FBits^[loop] and bitset.FBits^[loop];
 
187
 
 
188
   for loop := n + 1 to FSize - 1 do
 
189
      FBits^[loop] := 0;
 
190
end;
 
191
 
 
192
procedure TBits.notbits(bitset : TBits);
 
193
var
 
194
   n : longint;
 
195
   jj : longint;
 
196
   loop : longint;
 
197
begin
 
198
   if FSize < bitset.getFSize then
 
199
      n := FSize - 1
 
200
   else
 
201
      n := bitset.getFSize - 1;
 
202
 
 
203
   for loop := 0 to n do
 
204
   begin
 
205
      jj := FBits^[loop];
 
206
      FBits^[loop] := FBits^[loop] and (jj xor bitset.FBits^[loop]);
 
207
   end;
 
208
end;
 
209
 
 
210
procedure TBits.orbits(bitset : TBits);
 
211
var
 
212
   n : longint;
 
213
   loop : longint;
 
214
begin
 
215
   if FSize < bitset.getFSize then
 
216
      n := bitset.getFSize - 1
 
217
   else
 
218
      n := FSize - 1;
 
219
 
 
220
   grow(n shl BITSHIFT);
 
221
 
 
222
   for loop := 0 to n do
 
223
      FBits^[loop] := FBits^[loop] or bitset.FBits^[loop];
 
224
end;
 
225
 
 
226
procedure TBits.xorbits(bitset : TBits);
 
227
var
 
228
   n : longint;
 
229
   loop : longint;
 
230
begin
 
231
   if FSize < bitset.getFSize then
 
232
      n := bitset.getFSize - 1
 
233
   else
 
234
      n := FSize - 1;
 
235
 
 
236
   grow(n shl BITSHIFT);
 
237
 
 
238
   for loop := 0 to n do
 
239
      FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop];
 
240
end;
 
241
 
 
242
function TBits.equals(bitset : TBits) : Boolean;
 
243
var
 
244
   n : longint;
 
245
   loop : longint;
 
246
begin
 
247
   result := False;
 
248
 
 
249
   if FSize < bitset.getFSize then
 
250
      n := FSize - 1
 
251
   else
 
252
      n := bitset.getFSize - 1;
 
253
 
 
254
   for loop := 0 to n do
 
255
      if FBits^[loop] <> bitset.FBits^[loop] then exit;
 
256
 
 
257
   if FSize - 1 > n then
 
258
   begin
 
259
      for loop := n to FSize - 1 do
 
260
         if FBits^[loop] <> 0 then exit;
 
261
   end
 
262
   else if bitset.getFSize - 1 > n then
 
263
      for loop := n to bitset.getFSize - 1 do
 
264
         if bitset.FBits^[loop] <> 0 then exit;
 
265
 
 
266
   result := True;  {passed all tests}
 
267
end;
 
268
 
 
269
 
 
270
{ us this in place of calling FindFirstBit. It sets the current }
 
271
{ index used by FindNextBit and FindPrevBit                     }
 
272
 
 
273
procedure TBits.SetIndex(index : longint);
 
274
begin
 
275
   findIndex := index;
 
276
end;
 
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
 
 
283
function TBits.FindFirstBit(state : boolean) : longint;
 
284
var
 
285
   loop : longint;
 
286
   loop2 : longint;
 
287
   startIndex : longint;
 
288
   compareVal : cardinal;
 
289
begin
 
290
   result := -1; {should only occur if none are set}
 
291
 
 
292
   findState := state;
 
293
 
 
294
   if state = False then
 
295
      compareVal := $FFFFFFFF  { looking for off bits }
 
296
   else
 
297
      compareVal := $00000000; { looking for on bits }
 
298
 
 
299
   for loop := 0 to FSize - 1 do
 
300
   begin
 
301
      if FBits^[loop] <> compareVal then
 
302
      begin
 
303
         startIndex := loop * 32;
 
304
         for loop2 := startIndex to startIndex + 31 do
 
305
         begin
 
306
            if get(loop2) = state then
 
307
            begin
 
308
               result := loop2;
 
309
               break; { use this as the index to return }
 
310
            end;
 
311
         end;
 
312
         break;  {stop looking for bit in records }
 
313
      end;
 
314
   end;
 
315
 
 
316
   findIndex := result;
 
317
end;
 
318
 
 
319
function TBits.FindNextBit : longint;
 
320
var
 
321
   loop : longint;
 
322
   maxVal : longint;
 
323
begin
 
324
   result := -1;  { will occur only if no other bits set to }
 
325
                  { current findState                        }
 
326
 
 
327
   if findIndex > -1 then { must have called FindFirstBit first }
 
328
   begin                  { or set the start index              }
 
329
      maxVal := (FSize * 32) - 1;
 
330
 
 
331
      for loop := findIndex + 1 to maxVal  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;
 
342
end;
 
343
 
 
344
function TBits.FindPrevBit : longint;
 
345
var
 
346
   loop : longint;
 
347
begin
 
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;
 
364
end;
 
365
 
 
366