source: project/release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm @ 14031

Last change on this file since 14031 was 14031, checked in by Kon Lovett, 11 years ago

Update inlines. Testing.

File size: 17.3 KB
Line 
1;;;; err5rs-arithmetic-bitwise.scm
2;;;; Kon Lovett, Mar '09
3
4;; Issues
5;;
6;; - No support for the full-numeric-tower. All operations upon core numerics.
7
8;;; Prelude
9
10(declare
11        (usual-integrations)
12  (disable-interrupts)
13        (inline)
14        (local)
15        (no-procedure-checks)
16  (bound-to-procedure
17    ##sys#signal-hook
18    ##sys#string-append ) )
19
20;;
21
22(include "chicken-primitive-object-inlines")
23
24;;
25
26#>
27/* Bit operations */
28
29#define HIGH_MASK( p )                (-1 << (p))
30#define LOW_MASK( p )                 (~ HIGH_MASK( p ))
31
32#define HIGH_BITS( n, p )             ((n) & HIGH_MASK( p ))
33#define LOW_BITS( n, p )              ((n) & LOW_MASK( p ))
34
35#define BITS( n, s, e )               (((n) & LOW_MASK( e )) >> (s))
36#define ISOLATE_BITS( n, s, e )       (BITS( (n), (s), (e) ) << (s))
37
38#define BITS_MERGE( mask, a, b )      (((a) & (mask)) ^ ((b) & ~(mask)))
39#define BITS_MERGE_NOT( mask, a, b )  ((a) ^ (((a) ^ (b)) & (mask)))
40
41#define BITS_TEST( a, b )             (((a) & (b)) != 0)
42
43#define BITS_COPY( t, s, e, f ) \
44    (BITS_MERGE( HIGH_MASK( s ) & LOW_MASK( e ), (f) << (s), (t)))
45
46#define BIT_SET( n, p )               ((n) | (1 << (p)))
47#define BIT_CLEAR( n, p )             ((n) & ~ (1 << (p)))
48#define BIT_TEST( n, p )              ((n) & (1 << (p)))
49#define BIT_COPY( n, p, b )           BITS_MERGE( 1 << (p), (b) << (p), (n) )
50
51/* Integer log2 - high bit set */
52static C_uword
53C_uword_log2( C_uword n)
54{
55  static const C_uword
56  LogTable256[] = { /* 16 x 16 */
57    0, 0, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3,
58    4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
59    5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
60    5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
61    6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
62    6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
63    6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
64    6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
65    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
66    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
67    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
68    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
69    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
70    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
71    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
72    7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7};
73
74  C_uword r;
75
76  if (0 == n) return 0;
77
78  #ifdef C_SIXTY_FOUR
79  C_uword ttt;
80  if ((ttt = n >> 32)) {
81    C_uword tt;
82    if ((tt = ttt >> 16)) {
83      C_uword t;
84      r = (t = tt >> 8) ? 48 + LogTable256[ t ] : 40 + LogTable256[ tt ];
85    } else {
86      C_uword t;
87      r = (t = n >> 8) ? 32 + LogTable256[ t ] : 16 + LogTable256[ n ];
88    }
89  } else if ((ttt = ttt >> 16)) {
90    C_uword t;
91    r = (t = ttt >> 8) ? 24 + LogTable256[ t ] : 16 + LogTable256[ ttt ];
92  } else {
93    C_uword t;
94    r = (t = ttt >> 8) ? 8 + LogTable256[ t ] : LogTable256[ n ];
95  }
96  #else
97  C_uword tt;
98  if ((tt = n >> 16)) {
99    C_uword t;
100    r = (t = tt >> 8) ? 24 + LogTable256[ t ] : 16 + LogTable256[ tt ];
101  } else {
102    C_uword t;
103    r = (t = n >> 8) ? 8 + LogTable256[ t ] : LogTable256[ n ];
104  }
105  #endif
106
107  return r + 1;
108}
109
110/* - low bit set */
111#define C_UWORD_LOG2_FACTORS( n )   (C_uword_log2( (n) & -(n) ) - 1)
112
113/* Number of 1 bits */
114static C_uword
115C_uword_bits( C_uword n )
116{
117        #define TWO( c )       (0x1u << (c))
118        #define MASK( c )      (((C_uword) (-1)) / (TWO( TWO( c ) ) + 1u))
119        #define COUNT( x, c )  ((x) & MASK( c )) + (((x) >> (TWO( c ))) & MASK( c ))
120
121  if (0 == n) return 0;
122
123        n = COUNT( n, 0 );
124        n = COUNT( n, 1 );
125        n = COUNT( n, 2 );
126        n = COUNT( n, 3 );
127        n = COUNT( n, 4 );
128        #ifdef C_SIXTY_FOUR
129        n = COUNT( n, 5 );
130        #endif
131
132        return n;
133
134  #undef COUNT
135  #undef MASK
136  #undef TWO
137}
138
139static C_uword
140C_uword_rotate_bit_field( C_uword n, unsigned int s, unsigned int e, unsigned int c )
141{
142  if (0 != n) {
143    unsigned int wid = e - s;
144    unsigned int cnt = c % wid;
145    C_uword fld = BITS( n, s, e );
146    return BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) );
147  }
148
149  return 0;
150}
151
152static C_uword
153C_uword_reverse( C_uword n, int c )
154{
155  int isneg = ((C_word) n) < 0;
156  unsigned int mask = isneg ? ~((C_word) n) : n;
157  C_uword revval = 0;
158  for (--c; 0 <= c; --c, mask >>= 1) {
159    revval = (revval << 1) | (1 & mask) ;
160  }
161  return isneg ? ~revval : revval;
162}
163
164static C_uword
165C_uword_reverse_bit_field( C_uword n, unsigned int s, unsigned int e )
166{
167  unsigned int width = e - s;
168  C_uword mask = ~(((C_uword) -1) << width);
169  return (C_uword_reverse( (mask & (n >> s)), width ) << s) | (~(mask << s) & n);
170}
171<#
172
173;;
174
175(cond-expand
176  (unsafe
177
178    (define-inline (%check-fixnum loc obj) #t)
179
180    (define-inline (%check-list loc obj) #t)
181
182    (define-inline (%check-integer loc obj) #t)
183
184    (define-inline (%check-fixnum-bounds-order loc fx1 fx2) #t)
185
186    (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
187
188    (define-inline (%check-word-bits-range loc obj) #t)
189
190    (define-inline (%check-bits-range loc start end) #t)
191
192    (define-inline (%check-fixnum-bits-count loc count start end) #t) )
193
194  (else
195
196    (define-inline (%check-fixnum loc obj)
197      (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
198
199    (define-inline (%check-list loc obj)
200      (unless (%list? obj) (error-type-list loc obj)) )
201
202    (define-inline (%check-integer loc obj)
203      (unless (%integer? obj) (error-type-integer loc obj)) )
204
205    (define-inline (%check-fixnum-bounds-order loc fx1 fx2)
206      (unless (%fx<= fx1 fx2) (error-bounds-order loc start end)) )
207
208    (define-inline (%check-fixnum-range loc lfx fx hfx)
209      (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
210
211    (define-inline (%check-word-bits-range loc obj)
212       (%check-fixnum loc obj)
213       (%check-fixnum-range loc 0 obj machine-word-bits) )
214
215    (define-inline (%check-bits-range loc start end)
216      (%check-fixnum loc start)
217      (%check-fixnum loc end)
218      (%check-fixnum-bounds-order loc start end)
219      (%check-fixnum-range loc 0 start machine-word-precision)
220      (%check-fixnum-range loc 0 end machine-word-bits) )
221
222    (define-inline (%check-fixnum-bits-count loc count start end)
223      (unless (%fx< (%fxabs count) (%fx- end start))
224        (error-bits-count loc count start end)) ) ) )
225
226;;
227
228(define-inline (%boolean->bit obj) (if obj #b1 #b0))
229
230(define-inline (%boolean->bit* obj)
231  (if (and (%number? obj) (%zero? obj)) #b0
232      (%boolean->bit obj) ) )
233
234;; Fold operations
235
236;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
237
238(define-inline (%bwfold loc func init ls)
239  (%check-integer loc init)
240  (let loop ((ls ls) (acc init))
241    (if (%null? ls) acc
242        (let ((cur (%car ls)))
243          (%check-integer loc cur)
244          (loop (%cdr ls) (func acc cur)) ) ) ) )
245
246;;;
247
248(module err5rs-arithmetic-bitwise (;export
249  ;; ERR5RS
250  bitwise-and bitwise-ior bitwise-xor bitwise-not
251  bitwise-if
252  bitwise-test?
253  bitwise-bit-count
254  bitwise-length
255  bitwise-first-bit-set
256  bitwise-bit-set?
257  bitwise-copy-bit
258  bitwise-bit-field
259  bitwise-copy-bit-field
260  bitwise-rotate-bit-field
261  bitwise-reverse
262  bitwise-reverse-bit-field
263  bitwise-list->integer bitwise-integer->list
264  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
265  ;; Originals
266  chicken:bitwise-not chicken:bitwise-and chicken:bitwise-ior chicken:bitwise-xor
267  ;; Extras
268  pow2log2
269  bitwise-last-bit-set
270  bitwise-if-not
271  boolean->bit
272  *bitwise-and *bitwise-ior *bitwise-xor *bitwise-not
273  *bitwise-if
274  *bitwise-test?
275  *bitwise-bit-count
276  *bitwise-length
277  *bitwise-first-bit-set
278  *bitwise-last-bit-set
279  *bitwise-bit-set?
280  *bitwise-copy-bit
281  *bitwise-bit-field
282  *bitwise-copy-bit-field
283  *bitwise-rotate-bit-field
284  *bitwise-reverse
285  *bitwise-reverse-bit-field
286  *bitwise-list->integer *bitwise-integer->list
287  *bitwise-arithmetic-shift *bitwise-arithmetic-shift-left *bitwise-arithmetic-shift-right
288  *bitwise-if-not
289  *pow2log2)
290
291(import scheme
292        (rename chicken
293          (bitwise-and chicken:bitwise-and)
294          (bitwise-ior chicken:bitwise-ior)
295          (bitwise-xor chicken:bitwise-xor)
296          (bitwise-not chicken:bitwise-not))
297        foreign
298        (only int-limits machine-word-bits machine-word-precision))
299
300(require-library int-limits)
301
302;;; Errors
303
304(cond-expand
305  (unsafe)
306  (else
307
308    (define (error-type-fixnum loc obj)
309      (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
310
311    (define (error-type-integer loc obj)
312      (##sys#signal-hook #:type-error loc "bad argument type - not an integer" obj) )
313
314    (define (error-type-list loc obj)
315      (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
316
317    (define-inline (error-outside-range loc obj low high)
318      (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
319
320    (define (error-bounds-order loc start end)
321      (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
322
323    (define (error-bits-count loc count start end)
324      (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) ) ) )
325
326;;; Unchecked Variants
327
328;; ERR5RS
329
330(define *bitwise-not
331  (foreign-lambda* integer ((unsigned-integer n))
332   "return( ~n );"))
333
334(define *bitwise-and
335  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
336   "return( n & m );"))
337
338(define *bitwise-ior
339  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
340   "return( n | m );"))
341
342(define *bitwise-xor
343  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
344   "return( n ^ m );"))
345
346(define *bitwise-if
347  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
348   "return( BITS_MERGE( m, t, f ) );"))
349
350(define *bitwise-test?
351  (foreign-lambda* bool ((unsigned-integer a) (unsigned-integer b))
352   "return( BITS_TEST( a, b ) );"))
353
354(define *bitwise-bit-count
355  (foreign-lambda* unsigned-int ((unsigned-integer n))
356   "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : C_uword_bits( ~((C_word) n) ) );"))
357
358#;
359(define *bitwise-bit-count
360  (foreign-lambda* unsigned-int ((unsigned-integer n))
361   "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : ~((C_word) C_uword_bits( ~((C_word) n) )) );"))
362
363#;
364(define *bitwise-bit-count
365  (foreign-lambda unsigned-int "C_uword_bits" unsigned-integer))
366
367(define *bitwise-length
368  (foreign-lambda* unsigned-int ((unsigned-integer n))
369   "return( 0 <= ((C_word) n) ? C_uword_log2( n ) : C_uword_log2( ~((C_word) n) ) );"))
370
371#;
372(define *bitwise-length
373  (foreign-lambda unsigned-int "C_uword_log2" unsigned-integer))
374
375
376(define *bitwise-first-bit-set
377  (foreign-lambda* int ((unsigned-integer n))
378   "return( C_UWORD_LOG2_FACTORS( n ) );"))
379
380(define *bitwise-bit-set?
381  (foreign-lambda* bool ((unsigned-integer n) (unsigned-int i))
382   "return( BIT_TEST( n, i ) );"))
383
384(define *bitwise-copy-bit
385  (foreign-lambda* integer ((unsigned-integer to) (unsigned-int i) (unsigned-int b))
386   "return( BIT_COPY( to, i, b ) );"))
387
388(define *bitwise-bit-field
389  (foreign-lambda* integer ((unsigned-integer n) (unsigned-int s) (unsigned-int e))
390   "return( BITS( n, s, e ) );"))
391
392(define *bitwise-copy-bit-field
393  (foreign-lambda* integer ((unsigned-integer t) (unsigned-int s) (unsigned-int e) (unsigned-integer f))
394   "return( BITS_COPY( t, s, e, f ) );"))
395
396(define *bitwise-rotate-bit-field
397  (foreign-lambda integer "C_uword_rotate_bit_field" unsigned-integer unsigned-int unsigned-int unsigned-int))
398
399(define *bitwise-reverse
400  (foreign-lambda integer "C_uword_reverse" unsigned-integer unsigned-int))
401
402#;
403(define (*bitwise-reverse n c)
404  (let ((negval? (%negative? n)))
405    (do ((mask (if negval? (%bitwise-not n) n) (%arithmetic-shift mask -1))
406         (count (%fxsub1 c) (%fxsub1 count))
407         (revval 0 (%bitwise-ior (%arithmetic-shift revval 1) (%bitwise-and 1 mask))) )
408        ((%fxnegative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
409
410(define *bitwise-reverse-bit-field
411  (foreign-lambda integer "C_uword_reverse_bit_field" unsigned-integer unsigned-int unsigned-int))
412
413#;
414(define (*bitwise-reverse-bit-field n s e)
415  (let* ((width (%fx- e s))
416         (mask (%bitwise-not (%arithmetic-shift -1 width)))
417         (field (%bitwise-and mask (%arithmetic-shift n (%fxneg s)))) )
418    (%bitwise-ior
419     (%arithmetic-shift (*bitwise-reverse field width) s)
420     (%bitwise-and (%bitwise-not (%arithmetic-shift mask s)) n)) ) )
421
422; returns (list lsb .. msb)
423(define (*bitwise-list->integer ls)
424  (let loop ((ls ls) (i 0) (n 0))
425    (if (%null? ls) n
426        (loop (%cdr ls) (%fxadd1 i) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
427
428; returns (list lsb .. msb)
429(define *bitwise-integer->list
430  (let ((zeros (%make-list machine-word-bits #f)))
431    (lambda (n #!optional bitlen)
432      (if (%zero? n) (if bitlen (%list-take zeros bitlen) zeros)
433          (let ((bitlen (or bitlen (*bitwise-length n))))
434            (let loop ((i 0) (ils '()))
435              (if (%fx= bitlen i) ils
436                  (loop (%fxadd1 i) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
437
438(define (*bitwise-arithmetic-shift value signed-count) (%arithmetic-shift value signed-count))
439
440(define (*bitwise-arithmetic-shift-left value count) (%arithmetic-shift value count))
441
442(define (*bitwise-arithmetic-shift-right value count) (%arithmetic-shift value (%fxneg count)))
443
444;; Extras
445
446(define *bitwise-if-not
447  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
448   "return( BITS_MERGE_NOT( m, t, f ) );"))
449
450(define *bitwise-last-bit-set
451  (foreign-lambda* unsigned-int ((unsigned-integer n))
452   "return( 0 == n ? 0 : (C_uword_log2( n ) - 1) );"))
453
454(define *pow2log2
455  (foreign-lambda* unsigned-int ((unsigned-integer n))
456   "return( 2 << C_uword_log2( n ) );"))
457
458;;; ERR5RS
459
460(define (bitwise-not value)
461  (%check-integer 'bitwise-not value)
462  (*bitwise-not value) )
463
464(define (bitwise-and value . values)
465  (%bwfold 'bitwise-and *bitwise-and value values) )
466
467(define (bitwise-ior value . values)
468  (%bwfold 'bitwise-ior *bitwise-ior value values) )
469
470(define (bitwise-xor value . values)
471  (%bwfold 'bitwise-xor *bitwise-xor value values) )
472
473(define (bitwise-if mask true false)
474  (%check-integer 'bitwise-if mask)
475  (%check-integer 'bitwise-if true)
476  (%check-integer 'bitwise-if false)
477  (*bitwise-if mask true false))
478
479(define (bitwise-test? a b)
480  (%check-integer 'bitwise-test? a)
481  (%check-integer 'bitwise-test? b)
482  (*bitwise-test? a b))
483
484(define (bitwise-bit-count value)
485  (%check-integer 'bitwise-bit-count value)
486  (*bitwise-bit-count value))
487
488(define (bitwise-length value)
489  (%check-integer 'bitwise-length value)
490  (*bitwise-length value))
491
492(define (bitwise-first-bit-set value)
493  (%check-integer 'bitwise-first-bit-set value)
494  (*bitwise-first-bit-set value))
495
496(define (bitwise-bit-set? value index)
497  (%check-integer 'bitwise-bit-set? value)
498  (%check-word-bits-range 'bitwise-bit-set? index)
499  (*bitwise-bit-set? value index))
500
501(define (bitwise-copy-bit to index bit)
502  (%check-integer 'bitwise-copy-bit to)
503  (%check-word-bits-range 'bitwise-copy-bit index)
504  (*bitwise-copy-bit to index (%boolean->bit* bit)) )
505
506(define (bitwise-bit-field value start end)
507  (%check-integer 'bitwise-bit-field value)
508  (%check-bits-range 'bitwise-bit-field start end)
509  (*bitwise-bit-field value start end))
510
511(define (bitwise-copy-bit-field to start end from)
512  (%check-integer 'bitwise-copy-bit-field to)
513  (%check-bits-range 'bitwise-copy-bit-field start end)
514  (%check-integer 'bitwise-copy-bit-field from)
515  (*bitwise-copy-bit-field to start end from))
516
517; Supports negative count for rotate right
518(define (bitwise-rotate-bit-field value start end count)
519  (%check-integer 'bitwise-rotate-bit-field value)
520  (%check-fixnum 'bitwise-rotate-bit-field count)
521  (%check-bits-range 'bitwise-rotate-bit-field start end)
522  (%check-fixnum-bits-count 'bitwise-rotate-bit-field count start end)
523  (*bitwise-rotate-bit-field value start end count) )
524
525(define (bitwise-reverse value count)
526  (%check-integer 'bitwise-reverse value)
527  (%check-word-bits-range 'bitwise-reverse count)
528  (*bitwise-reverse value count) )
529
530(define (bitwise-reverse-bit-field value start end)
531  (%check-integer 'bitwise-reverse-bit-field value)
532  (%check-bits-range 'bitwise-reverse-bit-field start end)
533  (*bitwise-reverse-bit-field value start end) )
534
535(define (bitwise-list->integer bits)
536  (%check-list 'bitwise-list->integer bits)
537  (*bitwise-list->integer bits) )
538
539(define (bitwise-integer->list value #!optional bitlen)
540  (%check-integer 'bitwise-integer->list value)
541  (when bitlen
542    (%check-word-bits-range 'bitwise-integer->list bitlen) )
543  (*bitwise-integer->list value bitlen) )
544
545(define (bitwise-arithmetic-shift value signed-count)
546  (%check-integer 'bitwise-arithmetic-shift value)
547  (%check-word-bits-range 'bitwise-arithmetic-shift (%fxabs signed-count))
548  (%arithmetic-shift value signed-count) )
549
550(define (bitwise-arithmetic-shift-left value count)
551  (%check-integer 'bitwise-arithmetic-shift-left value)
552  (%check-word-bits-range 'bitwise-arithmetic-shift-left count)
553  (%arithmetic-shift value count) )
554
555(define (bitwise-arithmetic-shift-right value count)
556  (%check-integer 'bitwise-arithmetic-shift-right value)
557  (%check-word-bits-range 'bitwise-arithmetic-shift-right count)
558  (%arithmetic-shift value (%fxneg count)) )
559
560;;; Extras
561
562(define (bitwise-if-not mask true false)
563  (%check-integer 'bitwise-if-not mask)
564  (%check-integer 'bitwise-if-not true)
565  (%check-integer 'bitwise-if-not false)
566  (*bitwise-if-not mask true false))
567
568(define (bitwise-last-bit-set value)
569  (%check-integer 'bitwise-last-bit-set value)
570  (*bitwise-last-bit-set value))
571
572(define (boolean->bit bit) (%boolean->bit* bit))
573
574(define (pow2log2 value)
575  (%check-integer 'pow2log2 value)
576  (*pow2log2 value) )
577
578) ;module err5rs-arithmetic-bitwise
Note: See TracBrowser for help on using the repository browser.