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

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

R6RS test suite.

File size: 18.4 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
137#if 0 /* Unused */
138static const unsigned char
139BitReverseTable256[] = {
140  0x00, 0x80, 0x40, 0xC0, 0x20, 0xA0, 0x60, 0xE0, 0x10, 0x90, 0x50, 0xD0, 0x30, 0xB0, 0x70, 0xF0,
141  0x08, 0x88, 0x48, 0xC8, 0x28, 0xA8, 0x68, 0xE8, 0x18, 0x98, 0x58, 0xD8, 0x38, 0xB8, 0x78, 0xF8,
142  0x04, 0x84, 0x44, 0xC4, 0x24, 0xA4, 0x64, 0xE4, 0x14, 0x94, 0x54, 0xD4, 0x34, 0xB4, 0x74, 0xF4,
143  0x0C, 0x8C, 0x4C, 0xCC, 0x2C, 0xAC, 0x6C, 0xEC, 0x1C, 0x9C, 0x5C, 0xDC, 0x3C, 0xBC, 0x7C, 0xFC,
144  0x02, 0x82, 0x42, 0xC2, 0x22, 0xA2, 0x62, 0xE2, 0x12, 0x92, 0x52, 0xD2, 0x32, 0xB2, 0x72, 0xF2,
145  0x0A, 0x8A, 0x4A, 0xCA, 0x2A, 0xAA, 0x6A, 0xEA, 0x1A, 0x9A, 0x5A, 0xDA, 0x3A, 0xBA, 0x7A, 0xFA,
146  0x06, 0x86, 0x46, 0xC6, 0x26, 0xA6, 0x66, 0xE6, 0x16, 0x96, 0x56, 0xD6, 0x36, 0xB6, 0x76, 0xF6,
147  0x0E, 0x8E, 0x4E, 0xCE, 0x2E, 0xAE, 0x6E, 0xEE, 0x1E, 0x9E, 0x5E, 0xDE, 0x3E, 0xBE, 0x7E, 0xFE,
148  0x01, 0x81, 0x41, 0xC1, 0x21, 0xA1, 0x61, 0xE1, 0x11, 0x91, 0x51, 0xD1, 0x31, 0xB1, 0x71, 0xF1,
149  0x09, 0x89, 0x49, 0xC9, 0x29, 0xA9, 0x69, 0xE9, 0x19, 0x99, 0x59, 0xD9, 0x39, 0xB9, 0x79, 0xF9,
150  0x05, 0x85, 0x45, 0xC5, 0x25, 0xA5, 0x65, 0xE5, 0x15, 0x95, 0x55, 0xD5, 0x35, 0xB5, 0x75, 0xF5,
151  0x0D, 0x8D, 0x4D, 0xCD, 0x2D, 0xAD, 0x6D, 0xED, 0x1D, 0x9D, 0x5D, 0xDD, 0x3D, 0xBD, 0x7D, 0xFD,
152  0x03, 0x83, 0x43, 0xC3, 0x23, 0xA3, 0x63, 0xE3, 0x13, 0x93, 0x53, 0xD3, 0x33, 0xB3, 0x73, 0xF3,
153  0x0B, 0x8B, 0x4B, 0xCB, 0x2B, 0xAB, 0x6B, 0xEB, 0x1B, 0x9B, 0x5B, 0xDB, 0x3B, 0xBB, 0x7B, 0xFB,
154  0x07, 0x87, 0x47, 0xC7, 0x27, 0xA7, 0x67, 0xE7, 0x17, 0x97, 0x57, 0xD7, 0x37, 0xB7, 0x77, 0xF7,
155  0x0F, 0x8F, 0x4F, 0xCF, 0x2F, 0xAF, 0x6F, 0xEF, 0x1F, 0x9F, 0x5F, 0xDF, 0x3F, 0xBF, 0x7F, 0xFF};
156
157#define REVERSE_BYTE( b )   BitReverseTable256[ (b) ]
158
159#define REVERSE_LOW_BITS( b, w ) \
160    ((CHAR_BIT == (w)) \
161        ? REVERSE_BYTE( b ) \
162        : (HIGH_BITS( REVERSE_BYTE( LOW_BITS( (b), (w) ) ), (w) ) >> (w)))
163
164#define REVERSE_BITS( b, s, e ) \
165    ((0 == (s)) \
166        ? REVERSE_LOW_BITS( (b), (e) ) \
167        : (REVERSE_LOW_BITS( ((b) >> (e)), ((e) - (s)) ) << (e)))
168#endif
169
170#if 0 /* Doesn't work */
171static C_uword
172C_uword_bits_reverse( C_uword n, C_uword s, C_uword e)
173{
174  #define FULBYT( n )   ((n) / CHAR_BIT)
175  #define REMBYT( n )   (0 == ((n) % CHAR_BIT) ? 0 : 1)
176  #define TOTBYT( n )   (FULBYT( n ) + REMBYT( n ))
177  #ifdef C_BIG_ENDIAN
178  # define BYTPTR( n, p )   (((uint8_t *) &n) + (sizeof( C_uword ) - FULBYT( p )))
179  #else
180  # define BYTPTR( n, p )   (((uint8_t *) &n) + FULBYT( e ))
181  #endif
182
183  #ifdef C_SIXTY_FOUR
184  #else
185  #endif
186
187  C_uword wid = e - s;
188
189  C_uword SS = s % CHAR_BIT;
190  C_uword EE = e % CHAR_BIT;
191  C_word FUL = (C_word) wid - (SS * CHAR_BIT) - (EE * CHAR_BIT);
192
193  C_uword SE = MIN( CHAR_BIT, EE );
194  C_uword ES = MAX( 0, FUL );
195
196  uint8_t *srt = BYTPTR( n, e );
197  uint8_t *end = BYTPTR( n, s );
198
199  for ( ; end > srt; ++srt, --end) {
200    C_uword tmp = REVERSE_BYTE( *srt );
201    *srt = REVERSE_BYTE( *end );
202    *end = temp;
203  }
204
205  *srt = REVERSE_BITS( *srt, s % CHAR_BIT, e % CHAR_BIT );
206  *end = REVERSE_BITS( *end, s % CHAR_BIT, e % CHAR_BIT );
207}
208#endif
209
210static C_uword
211C_word_bits_bit_count( C_word n )
212{
213  C_return( (0 < n)
214              ? C_uword_bits( (C_uword) n )
215              : ((0 == n) ? 0 : /*~*/ C_uword_bits( (C_uword) ~n )) );
216}
217
218#if 0 /* Doesn't work */
219static C_uword
220C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
221{
222  #define ASH( n , s )  ((0 < (s)) ? ((n) << (s)) : ((n) >> -(s)))
223
224  C_uword wid = e - s;
225
226  if (0 == wid) C_return( n );
227  else {
228    C_word cnt = c % wid;
229    C_uword msk = LOW_MASK( wid );
230    C_uword fld = BITS( n, s, e );
231
232    C_return( ((((msk & ASH( fld, cnt )) | ASH( fld, cnt - wid ))) << s) | (n & ~ (msk << s)) );
233  }
234
235  #undef ASH
236}
237#else
238static C_uword
239C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e, C_uword c )
240{
241  if (0 == n) C_return( n );
242  else {
243    C_uword wid = e - s;
244    C_uword cnt = c % wid;
245    C_uword fld = BITS( n, s, e );
246
247    #if 0
248    C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
249    #else
250    C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
251    #endif
252  }
253}
254#endif
255<#
256
257;;
258
259(cond-expand
260  (unsafe
261
262    (define-inline (%check-fixnum loc obj) #t)
263
264    (define-inline (%check-list loc obj) #t)
265
266    (define-inline (%check-integer loc obj) #t)
267
268    (define-inline (%check-fixnum-bounds-order loc fx1 fx2) #t)
269
270    (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
271
272    (define-inline (%check-word-bits-range loc obj) #t)
273
274    (define-inline (%check-bits-range loc start end) #t)
275
276    (define-inline (%check-fixnum-bits-count loc count start end) #t) )
277
278  (else
279
280    (define-inline (%check-fixnum loc obj)
281      (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
282
283    (define-inline (%check-list loc obj)
284      (unless (%list? obj) (error-type-list loc obj)) )
285
286    (define-inline (%check-integer loc obj)
287      (unless (%integer? obj) (error-type-integer loc obj)) )
288
289    (define-inline (%check-fixnum-bounds-order loc fx1 fx2)
290      (unless (%fx<= fx1 fx2) (error-bounds-order loc start end)) )
291
292    (define-inline (%check-fixnum-range loc lfx fx hfx)
293      (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
294
295    (define-inline (%check-word-bits-range loc obj)
296       (%check-fixnum loc obj)
297       (%check-fixnum-range loc 0 obj machine-word-bits) )
298
299    (define-inline (%check-bits-range loc start end)
300      (%check-fixnum loc start)
301      (%check-fixnum loc end)
302      (%check-fixnum-bounds-order loc start end)
303      (%check-fixnum-range loc 0 start machine-word-precision)
304      (%check-fixnum-range loc 0 end machine-word-bits) )
305
306    (define-inline (%check-fixnum-bits-count loc count start end)
307      (unless (%fx< (%fxabs count) (%fx- end start)) (error-bits-count loc count start end)) ) ) )
308
309;;
310
311(define-inline (%boolean->bit obj) (if obj #b1 #b0))
312
313(define-inline (%boolean->bit* obj)
314  (if (and (%number? obj) (%zero? obj)) #b0
315      (%boolean->bit obj) ) )
316
317;;;
318
319(module err5rs-arithmetic-bitwise (;export
320  ; ERR5RS
321  ;;bitwise-and bitwise-ior bitwise-xor bitwise-not - from chicken
322  bitwise-if
323  bitwise-test?
324  bitwise-bit-count
325  bitwise-length
326  bitwise-first-bit-set
327  bitwise-bit-set?
328  bitwise-copy-bit
329  bitwise-bit-field
330  bitwise-copy-bit-field
331  bitwise-rotate-bit-field
332  bitwise-reverse
333  bitwise-reverse-bit-field
334  bitwise-list->integer bitwise-integer->list
335  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
336  ; Extras
337  pow2log2
338  bitwise-last-bit-set
339  bitwise-if-not
340  boolean->bit
341  *bitwise-if
342  *bitwise-test?
343  *bitwise-bit-count
344  *bitwise-length
345  *bitwise-first-bit-set
346  *bitwise-last-bit-set
347  *bitwise-bit-set?
348  *bitwise-copy-bit
349  *bitwise-bit-field
350  *bitwise-copy-bit-field
351  *bitwise-rotate-bit-field
352  *bitwise-reverse
353  *bitwise-reverse-bit-field
354  *bitwise-list->integer *bitwise-integer->list
355  *bitwise-arithmetic-shift *bitwise-arithmetic-shift-left *bitwise-arithmetic-shift-right
356  *bitwise-if-not
357  *pow2log2)
358
359(import scheme chicken foreign srfi-1 int-limits)
360
361(require-library srfi-1 int-limits)
362
363;;; Errors
364
365(cond-expand
366  (unsafe)
367  (else
368
369    (define (error-type-fixnum loc obj)
370      (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
371
372    (define (error-type-integer loc obj)
373      (##sys#signal-hook #:type-error loc "bad argument type - not an integer" obj) )
374
375    (define (error-type-list loc obj)
376      (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
377
378    (define-inline (error-outside-range loc obj low high)
379      (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
380
381    (define (error-bounds-order loc start end)
382      (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
383
384    (define (error-bits-count loc count start end)
385      (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) ) ) )
386
387;;; Unchecked Variants
388
389;; ERR5RS
390
391(define *bitwise-if
392  (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
393   "C_return( BITS_MERGE( m, t, f ) );"))
394
395(define *bitwise-test?
396  (foreign-lambda* bool ((integer a) (integer b))
397   "C_return( BITS_TEST( a, b ) );"))
398
399(define *bitwise-bit-count
400  (foreign-lambda unsigned-int "C_word_bits_bit_count" integer))
401
402(define *bitwise-length
403  (foreign-lambda* unsigned-int ((integer n))
404   "C_return( C_uword_log2( (C_uword) ((n < 0) ? ~ n : n ) ) );"))
405
406(define *bitwise-first-bit-set
407  (foreign-lambda* int ((integer n))
408   "C_return( C_UWORD_LOG2_FACTORS( (C_uword) n ) );"))
409
410(define *bitwise-bit-set?
411  (foreign-lambda* bool ((integer n) (unsigned-int i))
412   "C_return( BIT_TEST( n, i ) );"))
413
414(define *bitwise-copy-bit
415  (foreign-lambda* integer ((integer to) (unsigned-int i) (unsigned-int b))
416   "C_return( BIT_COPY( to, i, b ) );"))
417
418(define *bitwise-bit-field
419  (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e))
420   "C_return( BITS( n, s, e ) );"))
421
422(define *bitwise-copy-bit-field
423  (foreign-lambda* integer ((integer t) (unsigned-int s) (unsigned-int e) (integer f))
424   "C_return( BITS_COPY( t, s, e, f ) );"))
425
426(define *bitwise-rotate-bit-field
427  (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e) (unsigned-int c))
428   "C_return( C_uword_bits_rotate_bit_field( (C_uword) n, s, e, c ) );"))
429
430(define (*bitwise-reverse n c)
431  (let ((negval? (%negative? n)))
432    (do ((mask (if negval? (%bitwise-not n) n) (%arithmetic-shift mask -1))
433         (count (%fxsub1 c) (%fxsub1 count))
434         (revval 0 (%bitwise-ior (%arithmetic-shift revval 1) (%bitwise-and 1 mask))) )
435        ((%fxnegative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
436
437#; ;DOESN'T WORK
438(define *bitwise-reverse-bit-field
439  (foreign-lambda integer "C_uword_bits_reverse" integer unsigned-int unsigned-int))
440
441(define (*bitwise-reverse-bit-field n s e)
442  (let* ((width (%fx- e s))
443         (mask (%bitwise-not (%arithmetic-shift -1 width)))
444         (field (%bitwise-and mask (%arithmetic-shift n (%fxneg s)))) )
445    (%bitwise-ior
446     (%arithmetic-shift (*bitwise-reverse field width) s)
447     (%bitwise-and (%bitwise-not (%arithmetic-shift mask s)) n)) ) )
448
449; returns (list lsb .. msb)
450(define (*bitwise-list->integer lyst)
451  (let loop ((ls lyst) (i 0) (n 0))
452    (if (%null? ls) n
453        (loop (%cdr ls) (%fx+ i 1) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
454
455; returns (list lsb .. msb)
456(define *bitwise-integer->list
457  (let ((zeros (make-list machine-word-bits #f)))
458    (lambda (n #!optional bitlen)
459      (if (%zero? n)
460          (if bitlen (take zeros bitlen) zeros)
461          (let ((bitlen (or bitlen (*bitwise-length n))))
462            (let loop ((i 0) (ils '()))
463              (if (%fx= bitlen i) ils
464                  (loop (%fxadd1 i) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
465
466(define (*bitwise-arithmetic-shift value signed-count)
467  (%arithmetic-shift value signed-count) )
468
469(define (*bitwise-arithmetic-shift-left value count)
470  (%arithmetic-shift value count) )
471
472(define (*bitwise-arithmetic-shift-right value count)
473   (%arithmetic-shift value (%fxneg count)) )
474
475;; Extras
476
477(define *bitwise-if-not
478  (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
479   "C_return( BITS_MERGE_NOT( m, t, f ) );"))
480
481(define *bitwise-last-bit-set
482  (foreign-lambda* unsigned-int ((integer n))
483   "C_return( C_uword_log2( (C_uword) n ) );"))
484
485(define *pow2log2
486  (foreign-lambda* unsigned-int ((integer n))
487   "C_return( 2 << C_uword_log2( (C_uword) n ) );"))
488
489;;; ERR5RS
490
491(define (bitwise-if mask true false)
492  (%check-integer 'bitwise-if mask)
493  (%check-integer 'bitwise-if true)
494  (%check-integer 'bitwise-if false)
495  (*bitwise-if mask true false))
496
497(define (bitwise-test? a b)
498  (%check-integer 'bitwise-test? a)
499  (%check-integer 'bitwise-test? b)
500  (*bitwise-test? a b))
501
502(define (bitwise-bit-count value)
503  (%check-integer 'bitwise-bit-count value)
504  (*bitwise-bit-count value))
505
506(define (bitwise-length value)
507  (%check-integer 'bitwise-length value)
508  (*bitwise-length value))
509
510(define (bitwise-first-bit-set value)
511  (%check-integer 'bitwise-first-bit-set value)
512  (*bitwise-first-bit-set value))
513
514(define (bitwise-bit-set? value index)
515  (%check-integer 'bitwise-bit-set? value)
516  (%check-word-bits-range 'bitwise-bit-set? index)
517  (*bitwise-bit-set? value index))
518
519(define (bitwise-copy-bit to index bit)
520  (%check-integer 'bitwise-copy-bit to)
521  (%check-word-bits-range 'bitwise-copy-bit index)
522  (*bitwise-copy-bit to index (%boolean->bit* bit)) )
523
524(define (bitwise-bit-field value start end)
525  (%check-integer 'bitwise-bit-field value)
526  (%check-bits-range 'bitwise-bit-field start end)
527  (*bitwise-bit-field value start end))
528
529(define (bitwise-copy-bit-field to start end from)
530  (%check-integer 'bitwise-copy-bit-field to)
531  (%check-bits-range 'bitwise-copy-bit-field start end)
532  (%check-integer 'bitwise-copy-bit-field from)
533  (*bitwise-copy-bit-field to start end from))
534
535; Supports negative count for rotate right
536(define (bitwise-rotate-bit-field value start end count)
537  (%check-integer 'bitwise-rotate-bit-field value)
538  (%check-fixnum 'bitwise-rotate-bit-field count)
539  (%check-bits-range 'bitwise-rotate-bit-field start end)
540  (%check-fixnum-bits-count 'bitwise-rotate-bit-field count start end)
541  (*bitwise-rotate-bit-field value start end count) )
542
543(define (bitwise-reverse value count)
544  (%check-integer 'bitwise-reverse value)
545  (%check-word-bits-range 'bitwise-reverse count)
546  (*bitwise-reverse value count) )
547
548(define (bitwise-reverse-bit-field value start end)
549  (%check-integer 'bitwise-reverse-bit-field value)
550  (%check-bits-range 'bitwise-reverse-bit-field start end)
551  (*bitwise-reverse-bit-field value start end) )
552
553(define (bitwise-list->integer lyst)
554  (%check-list 'bitwise-list->integer lyst)
555  (*bitwise-list->integer lyst) )
556
557(define (bitwise-integer->list value #!optional bitlen)
558  (%check-integer 'bitwise-integer->list value)
559  (when bitlen
560    (%check-word-bits-range 'bitwise-integer->list bitlen) )
561  (*bitwise-integer->list value bitlen) )
562
563(define (bitwise-arithmetic-shift value signed-count)
564  (%check-integer 'bitwise-arithmetic-shift value)
565  (%check-word-bits-range 'bitwise-arithmetic-shift (%fxabs signed-count))
566  (%arithmetic-shift value signed-count) )
567
568(define (bitwise-arithmetic-shift-left value count)
569  (%check-integer 'bitwise-arithmetic-shift-left value)
570  (%check-word-bits-range 'bitwise-arithmetic-shift-left count)
571  (%arithmetic-shift value count) )
572
573(define (bitwise-arithmetic-shift-right value count)
574  (%check-integer 'bitwise-arithmetic-shift-right value)
575  (%check-word-bits-range 'bitwise-arithmetic-shift-right count)
576  (%arithmetic-shift value (%fxneg count)) )
577
578;;; Extras
579
580(define (bitwise-if-not mask true false)
581  (%check-integer 'bitwise-if-not mask)
582  (%check-integer 'bitwise-if-not true)
583  (%check-integer 'bitwise-if-not false)
584  (*bitwise-if-not mask true false))
585
586(define (bitwise-last-bit-set value)
587  (%check-integer 'bitwise-last-bit-set value)
588  (*bitwise-last-bit-set value))
589
590(define (boolean->bit bit) (%boolean->bit* bit))
591
592(define (pow2log2 value)
593  (%check-integer 'pow2log2 value)
594  (*pow2log2 value) )
595
596) ;module err5rs-arithmetic-bitwise
Note: See TracBrowser for help on using the repository browser.