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

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

Save.

File size: 16.8 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        n = COUNT( n, 0 );
122        n = COUNT( n, 1 );
123        n = COUNT( n, 2 );
124        n = COUNT( n, 3 );
125        n = COUNT( n, 4 );
126        #ifdef C_SIXTY_FOUR
127        n = COUNT( n, 5 );
128        #endif
129
130        return n;
131
132  #undef COUNT
133  #undef MASK
134  #undef TWO
135}
136
137static C_uword
138C_uword_rotate_bit_field( C_uword n, unsigned int s, unsigned int e, unsigned int c )
139{
140  if (0 != n) {
141    unsigned int wid = e - s;
142    unsigned int cnt = c % wid;
143    C_uword fld = BITS( n, s, e );
144    return BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) );
145  }
146
147  return 0;
148}
149
150static C_uword
151C_uword_reverse( C_uword n, int c )
152{
153  int isneg = ((C_word) n) < 0;
154  unsigned int mask = isneg ? ~((C_word) n) : n;
155  C_uword revval = 0;
156  for (--c; 0 <= c; --c, mask >>= 1) {
157    revval = (revval << 1) | (1 & mask) ;
158  }
159  return isneg ? ~revval : revval;
160}
161
162static C_uword
163C_uword_reverse_bit_field( C_uword n, unsigned int s, unsigned int e )
164{
165  unsigned int width = e - s;
166  C_uword mask = ~(((C_uword) -1) << width);
167  return (C_uword_reverse( (mask & (n >> s)), width ) << s) | (~(mask << s) & n);
168}
169<#
170
171;;
172
173(cond-expand
174  (unsafe
175
176    (define-inline (%check-fixnum loc obj) #t)
177
178    (define-inline (%check-list loc obj) #t)
179
180    (define-inline (%check-integer loc obj) #t)
181
182    (define-inline (%check-fixnum-bounds-order loc fx1 fx2) #t)
183
184    (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
185
186    (define-inline (%check-word-bits-range loc obj) #t)
187
188    (define-inline (%check-bits-range loc start end) #t)
189
190    (define-inline (%check-fixnum-bits-count loc count start end) #t) )
191
192  (else
193
194    (define-inline (%check-fixnum loc obj)
195      (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
196
197    (define-inline (%check-list loc obj)
198      (unless (%list? obj) (error-type-list loc obj)) )
199
200    (define-inline (%check-integer loc obj)
201      (unless (%integer? obj) (error-type-integer loc obj)) )
202
203    (define-inline (%check-fixnum-bounds-order loc fx1 fx2)
204      (unless (%fx<= fx1 fx2) (error-bounds-order loc start end)) )
205
206    (define-inline (%check-fixnum-range loc lfx fx hfx)
207      (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
208
209    (define-inline (%check-word-bits-range loc obj)
210       (%check-fixnum loc obj)
211       (%check-fixnum-range loc 0 obj machine-word-bits) )
212
213    (define-inline (%check-bits-range loc start end)
214      (%check-fixnum loc start)
215      (%check-fixnum loc end)
216      (%check-fixnum-bounds-order loc start end)
217      (%check-fixnum-range loc 0 start machine-word-precision)
218      (%check-fixnum-range loc 0 end machine-word-bits) )
219
220    (define-inline (%check-fixnum-bits-count loc count start end)
221      (unless (%fx< (%fxabs count) (%fx- end start)) (error-bits-count loc count start end)) ) ) )
222
223;;
224
225(define-inline (%boolean->bit obj) (if obj #b1 #b0))
226
227(define-inline (%boolean->bit* obj)
228  (if (and (%number? obj) (%zero? obj)) #b0
229      (%boolean->bit obj) ) )
230
231;; Fold operations
232
233;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
234
235(define-inline (%bwfold loc func init ls)
236  (%check-integer loc init)
237  (let loop ((ls ls) (acc init))
238    (if (%null? ls) acc
239        (let ((cur (%car ls)))
240          (%check-integer loc cur)
241          (loop (%cdr ls) (func acc cur)) ) ) ) )
242
243;;;
244
245(module err5rs-arithmetic-bitwise (;export
246  ;; ERR5RS
247  bitwise-and bitwise-ior bitwise-xor bitwise-not
248  bitwise-if
249  bitwise-test?
250  bitwise-bit-count
251  bitwise-length
252  bitwise-first-bit-set
253  bitwise-bit-set?
254  bitwise-copy-bit
255  bitwise-bit-field
256  bitwise-copy-bit-field
257  bitwise-rotate-bit-field
258  bitwise-reverse
259  bitwise-reverse-bit-field
260  bitwise-list->integer bitwise-integer->list
261  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
262  ;; Chicken Originals
263  chicken:bitwise-not chicken:bitwise-and chicken:bitwise-ior chicken:bitwise-xor
264  ;; Extras
265  pow2log2
266  bitwise-last-bit-set
267  bitwise-if-not
268  boolean->bit
269  *bitwise-and *bitwise-ior *bitwise-xor *bitwise-not
270  *bitwise-if
271  *bitwise-test?
272  *bitwise-bit-count
273  *bitwise-length
274  *bitwise-first-bit-set
275  *bitwise-last-bit-set
276  *bitwise-bit-set?
277  *bitwise-copy-bit
278  *bitwise-bit-field
279  *bitwise-copy-bit-field
280  *bitwise-rotate-bit-field
281  *bitwise-reverse
282  *bitwise-reverse-bit-field
283  *bitwise-list->integer *bitwise-integer->list
284  *bitwise-arithmetic-shift *bitwise-arithmetic-shift-left *bitwise-arithmetic-shift-right
285  *bitwise-if-not
286  *pow2log2)
287
288(import scheme
289        (rename chicken
290          (bitwise-and chicken:bitwise-and)
291          (bitwise-ior chicken:bitwise-ior)
292          (bitwise-xor chicken:bitwise-xor)
293          (bitwise-not chicken:bitwise-not))
294        foreign srfi-1 int-limits)
295
296(require-library srfi-1 int-limits)
297
298;;; Errors
299
300(cond-expand
301  (unsafe)
302  (else
303
304    (define (error-type-fixnum loc obj)
305      (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
306
307    (define (error-type-integer loc obj)
308      (##sys#signal-hook #:type-error loc "bad argument type - not an integer" obj) )
309
310    (define (error-type-list loc obj)
311      (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
312
313    (define-inline (error-outside-range loc obj low high)
314      (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
315
316    (define (error-bounds-order loc start end)
317      (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
318
319    (define (error-bits-count loc count start end)
320      (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) ) ) )
321
322;;; Unchecked Variants
323
324;; ERR5RS
325
326(define *bitwise-not
327  (foreign-lambda* integer ((unsigned-integer n))
328   "return( ~n );"))
329
330(define *bitwise-and
331  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
332   "return( n & m );"))
333
334(define *bitwise-ior
335  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
336   "return( n | m );"))
337
338(define *bitwise-xor
339  (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
340   "return( n ^ m );"))
341
342(define *bitwise-if
343  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
344   "return( BITS_MERGE( m, t, f ) );"))
345
346(define *bitwise-test?
347  (foreign-lambda* bool ((unsigned-integer a) (unsigned-integer b))
348   "return( BITS_TEST( a, b ) );"))
349
350(define *bitwise-bit-count
351  (foreign-lambda unsigned-int "C_uword_bits" unsigned-integer))
352
353(define *bitwise-length
354  (foreign-lambda* unsigned-int ((unsigned-integer n))
355   "return( C_uword_log2( ((C_word) n) < 0 ? ~n : n ) );"))
356
357(define *bitwise-first-bit-set
358  (foreign-lambda* int ((unsigned-integer n))
359   "return( C_UWORD_LOG2_FACTORS( n ) );"))
360
361(define *bitwise-bit-set?
362  (foreign-lambda* bool ((unsigned-integer n) (unsigned-int i))
363   "return( BIT_TEST( n, i ) );"))
364
365(define *bitwise-copy-bit
366  (foreign-lambda* integer ((unsigned-integer to) (unsigned-int i) (unsigned-int b))
367   "return( BIT_COPY( to, i, b ) );"))
368
369(define *bitwise-bit-field
370  (foreign-lambda* integer ((unsigned-integer n) (unsigned-int s) (unsigned-int e))
371   "return( BITS( n, s, e ) );"))
372
373(define *bitwise-copy-bit-field
374  (foreign-lambda* integer ((unsigned-integer t) (unsigned-int s) (unsigned-int e) (unsigned-integer f))
375   "return( BITS_COPY( t, s, e, f ) );"))
376
377(define *bitwise-rotate-bit-field
378  (foreign-lambda integer "C_uword_rotate_bit_field" unsigned-integer unsigned-int unsigned-int unsigned-int))
379
380(define *bitwise-reverse
381  (foreign-lambda integer "C_uword_reverse" unsigned-integer unsigned-int))
382
383#;
384(define (*bitwise-reverse n c)
385  (let ((negval? (%negative? n)))
386    (do ((mask (if negval? (%bitwise-not n) n) (%arithmetic-shift mask -1))
387         (count (%fxsub1 c) (%fxsub1 count))
388         (revval 0 (%bitwise-ior (%arithmetic-shift revval 1) (%bitwise-and 1 mask))) )
389        ((%fxnegative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
390
391(define *bitwise-reverse-bit-field
392  (foreign-lambda integer "C_uword_reverse_bit_field" unsigned-integer unsigned-int unsigned-int))
393
394#;
395(define (*bitwise-reverse-bit-field n s e)
396  (let* ((width (%fx- e s))
397         (mask (%bitwise-not (%arithmetic-shift -1 width)))
398         (field (%bitwise-and mask (%arithmetic-shift n (%fxneg s)))) )
399    (%bitwise-ior
400     (%arithmetic-shift (*bitwise-reverse field width) s)
401     (%bitwise-and (%bitwise-not (%arithmetic-shift mask s)) n)) ) )
402
403; returns (list lsb .. msb)
404(define (*bitwise-list->integer ls)
405  (let loop ((ls ls) (i 0) (n 0))
406    (if (%null? ls) n
407        (loop (%cdr ls) (%fxadd1 i) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
408
409; returns (list lsb .. msb)
410(define *bitwise-integer->list
411  (let ((zeros (make-list machine-word-bits #f)))
412    (lambda (n #!optional bitlen)
413      (if (%zero? n) (if bitlen (take zeros bitlen) zeros)
414          (let ((bitlen (or bitlen (*bitwise-length n))))
415            (let loop ((i 0) (ils '()))
416              (if (%fx= bitlen i) ils
417                  (loop (%fxadd1 i) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
418
419(define (*bitwise-arithmetic-shift value signed-count) (%arithmetic-shift value signed-count))
420
421(define (*bitwise-arithmetic-shift-left value count) (%arithmetic-shift value count))
422
423(define (*bitwise-arithmetic-shift-right value count) (%arithmetic-shift value (%fxneg count)))
424
425;; Extras
426
427(define *bitwise-if-not
428  (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
429   "return( BITS_MERGE_NOT( m, t, f ) );"))
430
431(define *bitwise-last-bit-set
432  (foreign-lambda* unsigned-int ((unsigned-integer n))
433   "return( C_uword_log2( n ) - 1);"))
434
435(define *pow2log2
436  (foreign-lambda* unsigned-int ((unsigned-integer n))
437   "return( 2 << C_uword_log2( n ) );"))
438
439;;; ERR5RS
440
441(define (bitwise-not value)
442  (%check-integer 'bitwise-not value)
443  (*bitwise-not value) )
444
445(define (bitwise-and value . values)
446  (%bwfold 'bitwise-and *bitwise-and value values) )
447
448(define (bitwise-ior value . values)
449  (%bwfold 'bitwise-ior *bitwise-ior value values) )
450
451(define (bitwise-xor value . values)
452  (%bwfold 'bitwise-xor *bitwise-xor value values) )
453
454(define (bitwise-if mask true false)
455  (%check-integer 'bitwise-if mask)
456  (%check-integer 'bitwise-if true)
457  (%check-integer 'bitwise-if false)
458  (*bitwise-if mask true false))
459
460(define (bitwise-test? a b)
461  (%check-integer 'bitwise-test? a)
462  (%check-integer 'bitwise-test? b)
463  (*bitwise-test? a b))
464
465(define (bitwise-bit-count value)
466  (%check-integer 'bitwise-bit-count value)
467  (*bitwise-bit-count value))
468
469(define (bitwise-length value)
470  (%check-integer 'bitwise-length value)
471  (*bitwise-length value))
472
473(define (bitwise-first-bit-set value)
474  (%check-integer 'bitwise-first-bit-set value)
475  (*bitwise-first-bit-set value))
476
477(define (bitwise-bit-set? value index)
478  (%check-integer 'bitwise-bit-set? value)
479  (%check-word-bits-range 'bitwise-bit-set? index)
480  (*bitwise-bit-set? value index))
481
482(define (bitwise-copy-bit to index bit)
483  (%check-integer 'bitwise-copy-bit to)
484  (%check-word-bits-range 'bitwise-copy-bit index)
485  (*bitwise-copy-bit to index (%boolean->bit* bit)) )
486
487(define (bitwise-bit-field value start end)
488  (%check-integer 'bitwise-bit-field value)
489  (%check-bits-range 'bitwise-bit-field start end)
490  (*bitwise-bit-field value start end))
491
492(define (bitwise-copy-bit-field to start end from)
493  (%check-integer 'bitwise-copy-bit-field to)
494  (%check-bits-range 'bitwise-copy-bit-field start end)
495  (%check-integer 'bitwise-copy-bit-field from)
496  (*bitwise-copy-bit-field to start end from))
497
498; Supports negative count for rotate right
499(define (bitwise-rotate-bit-field value start end count)
500  (%check-integer 'bitwise-rotate-bit-field value)
501  (%check-fixnum 'bitwise-rotate-bit-field count)
502  (%check-bits-range 'bitwise-rotate-bit-field start end)
503  (%check-fixnum-bits-count 'bitwise-rotate-bit-field count start end)
504  (*bitwise-rotate-bit-field value start end count) )
505
506(define (bitwise-reverse value count)
507  (%check-integer 'bitwise-reverse value)
508  (%check-word-bits-range 'bitwise-reverse count)
509  (*bitwise-reverse value count) )
510
511(define (bitwise-reverse-bit-field value start end)
512  (%check-integer 'bitwise-reverse-bit-field value)
513  (%check-bits-range 'bitwise-reverse-bit-field start end)
514  (*bitwise-reverse-bit-field value start end) )
515
516(define (bitwise-list->integer bits)
517  (%check-list 'bitwise-list->integer bits)
518  (*bitwise-list->integer bits) )
519
520(define (bitwise-integer->list value #!optional bitlen)
521  (%check-integer 'bitwise-integer->list value)
522  (when bitlen
523    (%check-word-bits-range 'bitwise-integer->list bitlen) )
524  (*bitwise-integer->list value bitlen) )
525
526(define (bitwise-arithmetic-shift value signed-count)
527  (%check-integer 'bitwise-arithmetic-shift value)
528  (%check-word-bits-range 'bitwise-arithmetic-shift (%fxabs signed-count))
529  (%arithmetic-shift value signed-count) )
530
531(define (bitwise-arithmetic-shift-left value count)
532  (%check-integer 'bitwise-arithmetic-shift-left value)
533  (%check-word-bits-range 'bitwise-arithmetic-shift-left count)
534  (%arithmetic-shift value count) )
535
536(define (bitwise-arithmetic-shift-right value count)
537  (%check-integer 'bitwise-arithmetic-shift-right value)
538  (%check-word-bits-range 'bitwise-arithmetic-shift-right count)
539  (%arithmetic-shift value (%fxneg count)) )
540
541;;; Extras
542
543(define (bitwise-if-not mask true false)
544  (%check-integer 'bitwise-if-not mask)
545  (%check-integer 'bitwise-if-not true)
546  (%check-integer 'bitwise-if-not false)
547  (*bitwise-if-not mask true false))
548
549(define (bitwise-last-bit-set value)
550  (%check-integer 'bitwise-last-bit-set value)
551  (*bitwise-last-bit-set value))
552
553(define (boolean->bit bit) (%boolean->bit* bit))
554
555(define (pow2log2 value)
556  (%check-integer 'pow2log2 value)
557  (*pow2log2 value) )
558
559) ;module err5rs-arithmetic-bitwise
Note: See TracBrowser for help on using the repository browser.