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

Last change on this file since 13604 was 13604, checked in by Kon Lovett, 12 years ago

Save.

File size: 18.4 KB
Line 
1;;;; err5rs-arithmetic-bitwise.scm
2;;;; Kon Lovett, Mar '09
3
4
5;;; Prelude
6
7(declare
8        (usual-integrations)
9  (disable-interrupts)
10        (arithmetic-type generic)
11        (inline)
12        #;(local)
13        (no-bound-checks)
14        (no-procedure-checks)
15  (bound-to-procedure
16    ##sys#check-list
17    ##sys#check-integer
18    ##sys#check-exact
19    ##sys#signal-hook
20    ##sys#string-append ) )
21
22(require-library srfi-1 int-limits)
23
24(include "chicken-primitive-object-inlines")
25
26#>
27/* Bit operations */
28
29#define HIGH_MASK( s )                (-1 << (s))
30#define LOW_MASK( s )                 (~ HIGH_MASK( s ))
31
32#define HIGH_BITS( n, s )             ((n) & HIGH_MASK( s ))
33#define LOW_BITS( n, s )              ((n) & LOW_MASK( s ))
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, s )               ((n) | (1 << (s)))
47#define BIT_CLEAR( n, s )             ((n) & ~ (1 << (s)))
48#define BIT_TEST( n, s )              ((n) & (1 << (s)))
49#define BIT_COPY( n, s, b )           BITS_MERGE( 1 << (s), (b) << (s), (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 )
221{
222  #define ASH( n, s )  ((0 < (s)) ? ((n) << (s)) : ((n) >> -(s)))
223  C_uword wid = e - s;
224  C_word cnt = count % wid;
225  C_uword msk = LOW_MASK( wid );
226  C_uword fld = BITS( n, s, e );
227  C_return( ((((msk & ASH( fld, cnt )) | ASH( fld, cnt - wid ))) << s) | (n & ~ (msk << s)) );
228  #undef ASH
229}
230#else
231static C_uword
232C_uword_bits_rotate_bit_field( C_uword n, C_uword s, C_uword e )
233{
234  if (0 == n) C_return( n );
235  else {
236    C_uword wid = e - s;
237    C_uword cnt = count % wid;
238    C_uword fld = BITS( n, s, e );
239    C_return( BITS_COPY( n, s, e, ((fld << cnt) ^ (fld >> (wid - cnt))) ) );
240  }
241}
242#endif
243<#
244
245;;
246
247(define-inline (%check-list loc obj) (##sys#check-list obj loc))
248
249(define-inline (%check-integer loc obj) (##sys#check-integer obj loc))
250
251(define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc)
252
253(define-inline (%check-non-negative-fixnum loc obj)
254  (unless (and (%fixnum? obj) (%fx<= 0 obj))
255    (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative fixnum" obj) ) )
256
257(define-inline (%check-fixnum<= loc fx1 fx2)
258  (unless (%fx<= fx1 fx2)
259    (##sys#signal-hook #:bounds-error loc "not a fixnum interval" fx1 fx2) ) )
260
261(define-inline (%check-word-bits loc fx)
262  (unless (%fx<= fx machine-word-bits)
263    (##sys#signal-hook #:bounds-error loc "out of integer range" fx) ) )
264
265(define *word-bits-end* (%fx+ machine-word-bits 1))
266
267(define-inline (%check-word-bits+1 loc fx)
268  (unless (%fx<= fx *word-bits-end*)
269    (##sys#signal-hook #:bounds-error loc "out of integer range" fx) ) )
270
271;;
272
273(define-inline (%boolean->bit b) (if b 1 0))
274
275(define-inline (%boolean->bit* bit) (if (zero? bit) 0 (%boolean->bit bit)))
276
277(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
278
279(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
280
281(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
282
283(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
284
285(define-inline (%negative? x) (##core#inline "C_i_negativep" x))
286
287
288;;;
289
290(module err5rs-arithmetic-bitwise (;export
291  ; ERR5RS
292  ;;bitwise-and bitwise-ior bitwise-xor bitwise-not - from chicken
293  bitwise-if
294  bitwise-test?
295  bitwise-bit-count
296  bitwise-length
297  bitwise-first-bit-set bitwise-last-bit-set
298  bitwise-bit-set?
299  bitwise-copy-bit
300  bitwise-bit-field
301  bitwise-copy-bit-field
302  bitwise-rotate-bit-field
303  bitwise-reverse
304  bitwise-reverse-bit-field
305  bitwise-list->integer bitwise-integer->list
306  bitwise-arithmetic-shift bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
307  ; Extras
308  bitwise-if-not
309  *bitwise-if
310  *bitwise-test?
311  *bitwise-bit-count
312  *bitwise-length
313  *bitwise-first-bit-set *bitwise-last-bit-set
314  *bitwise-bit-set?
315  *bitwise-copy-bit
316  *bitwise-bit-field
317  *bitwise-copy-bit-field
318  *bitwise-rotate-bit-field
319  *bitwise-reverse
320  *bitwise-reverse-bit-field
321  *bitwise-list->integer *bitwise-integer->list
322  *bitwise-arithmetic-shift *bitwise-arithmetic-shift-left *bitwise-arithmetic-shift-right
323  *bitwise-if-not
324  *pow2log2
325  boolean->bit
326  pow2log2)
327
328(import scheme chicken foreign srfi-1 int-limits)
329
330
331;;; Extras
332
333(define *bitwise-if
334  (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
335   "C_return( BITS_MERGE( m, t, f ) );"))
336
337(define *bitwise-test?
338  (foreign-lambda* bool ((integer a) (integer b))
339   "C_return( BITS_TEST( a, b ) );"))
340
341(define *bitwise-bit-count
342  (foreign-lambda unsigned-int "C_word_bits_bit_count" integer))
343
344(define *bitwise-length
345  (foreign-lambda* unsigned-int ((integer n))
346   "C_return( C_uword_log2( (C_uword) ((n < 0) ? ~ n : n ) ) );"))
347
348(define *bitwise-first-bit-set
349  (foreign-lambda* int ((integer n))
350   "C_return( C_UWORD_LOG2_FACTORS( (C_uword) n ) );"))
351
352(define *bitwise-last-bit-set
353  (foreign-lambda* unsigned-int ((integer n))
354   "C_return( C_uword_log2( (C_uword) n ) );"))
355
356(define *bitwise-bit-set?
357  (foreign-lambda* bool ((integer n) (unsigned-int i))
358   "C_return( BIT_TEST( n, i ) );"))
359
360(define *bitwise-copy-bit
361  (foreign-lambda* integer ((integer to) (unsigned-int i) (unsigned-int b))
362   "C_return( BIT_COPY( to, i, b ) );"))
363
364(define *bitwise-bit-field
365  (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e))
366   "C_return( BITS( n, s, e ) );"))
367
368(define *bitwise-copy-bit-field
369  (foreign-lambda* integer ((integer t) (unsigned-int s) (unsigned-int e) (integer f))
370   "C_return( BITS_COPY( t, s, e, f ) );"))
371
372(define *bitwise-rotate-bit-field
373  (foreign-lambda* integer ((integer n) (unsigned-int s) (unsigned-int e))
374   "C_return( C_uword_bits_rotate_bit_field( (C_uword) n, s, e ) );"))
375
376(define (*bitwise-reverse n c)
377  (let ((negval? (%negative? n)))
378    (do ((mask (if negval? (%bitwise-not n) n) (%arithmetic-shift mask -1))
379         (count (%fx- c 1) (%fx- c 1))
380         (revval 0 (%bitwise-ior (%arithmetic-shift revval 1) (%bitwise-and 1 mask))) )
381        ((%negative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
382
383#; ;DOESN'T WORK
384(define *bitwise-reverse-bit-field
385  (foreign-lambda integer "C_uword_bits_reverse" integer unsigned-int unsigned-int))
386
387(define (*bitwise-reverse-bit-field n s e)
388  (let* ((width (%fx- e s))
389         (mask (%bitwise-not (%arithmetic-shift -1 width)))
390         (field (%bitwise-and mask (%arithmetic-shift n %fxneg s)))) )
391    (%bitwise-ior
392     (%arithmetic-shift (*bitwise-reverse field width) s)
393     (%bitwise-and (%bitwise-not (%arithmetic-shift mask s)) n)) ) )
394
395; returns (list lsb .. msb)
396(define (*bitwise-list->integer lyst)
397  (let loop ((ls lyst) (i 0) (n 0))
398    (if (%null? ls) n
399        (loop (%cdr ls) (%fx+ i 1) (*bitwise-copy-bit n i (%boolean->bit (%car ls)))) ) ) )
400
401; returns (list lsb .. msb)
402(define *bitwise-integer->list
403  (let ((zeros (make-list machine-word-bits #f)))
404    (lambda (n #!optional bitlen)
405      (if (zero? n)
406          (if bitlen (take zeros bitlen) zeros)
407          (let ((bitlen (or bitlen (*bitwise-length n))))
408            (let loop ((i 0) (ils '()))
409              (if (%fx= bitlen i) ils
410                  (loop (%fx+ i 1) (%cons (*bitwise-bit-set? n i) ils)) ) ) ) ) ) ) )
411
412(define (*bitwise-arithmetic-shift value signed-count)
413  (%arithmetic-shift value signed-count) )
414
415(define (*bitwise-arithmetic-shift-left value count)
416  (%arithmetic-shift value count) )
417
418(define (*bitwise-arithmetic-shift-right value count)
419   (%arithmetic-shift value (%fxneg count)) )
420
421;; Extras
422
423(define *bitwise-if-not
424  (foreign-lambda* unsigned-int ((integer m) (integer t) (integer f))
425   "C_return( BITS_MERGE_NOT( m, t, f ) );"))
426
427(define *pow2log2
428  (foreign-lambda* unsigned-int ((integer n))
429   "C_return( 2 << C_uword_log2( (C_uword) n ) );"))
430
431
432;;; ERR5RS
433
434(define (bitwise-if mask true false)
435  (%check-integer 'bitwise-if mask)
436  (%check-integer 'bitwise-if true)
437  (%check-integer 'bitwise-if false)
438  (*bitwise-if mask true false))
439
440(define (bitwise-test? a b)
441  (%check-integer 'bitwise-test? a)
442  (%check-integer 'bitwise-test? b)
443  (*bitwise-test? a b))
444
445(define (bitwise-bit-count value)
446  (%check-integer 'bitwise-bit-count value)
447  (*bitwise-bit-count value))
448
449(define (bitwise-length value)
450  (%check-integer 'bitwise-length value)
451  (*bitwise-length value))
452
453(define (bitwise-first-bit-set value)
454  (%check-integer 'bitwise-first-bit-set value)
455  (*bitwise-first-bit-set value))
456
457(define (bitwise-last-bit-set value)
458  (%check-integer 'bitwise-last-bit-set value)
459  (*bitwise-last-bit-set value))
460
461(define (bitwise-bit-set? value index)
462  (%check-integer 'bitwise-bit-set? value)
463  (%check-non-negative-fixnum 'bitwise-bit-set? index)
464  (%check-word-bits 'bitwise-bit-set? index)
465  (*bitwise-bit-set? value index))
466
467(define (bitwise-copy-bit to index bit)
468  (%check-integer 'bitwise-copy-bit to)
469  (%check-non-negative-fixnum 'bitwise-copy-bit index)
470  (%check-word-bits 'bitwise-copy-bit index)
471  (*bitwise-copy-bit to index (%boolean->bit* bit) bit)) )
472
473(define (bitwise-bit-field value start end)
474  (%check-integer 'bitwise-bit-field value)
475  (%check-non-negative-fixnum 'bitwise-bit-field start)
476  (%check-non-negative-fixnum 'bitwise-bit-field end)
477  (%check-fixnum<= 'bitwise-bit-field start end)
478  (%check-word-bits 'bitwise-bit-field start)
479  (%check-word-bits+1 'bitwise-bit-field end)
480  (*bitwise-bit-field value start end))
481
482(define (bitwise-copy-bit-field to start end from)
483  (%check-integer 'bitwise-copy-bit-field to)
484  (%check-non-negative-fixnum 'bitwise-copy-bit-field start)
485  (%check-non-negative-fixnum 'bitwise-copy-bit-field end)
486  (%check-fixnum<= 'bitwise-copy-bit-field start end)
487  (%check-word-bits 'bitwise-copy-bit-field start)
488  (%check-word-bits+1 'bitwise-copy-bit-field end)
489  (%check-integer 'bitwise-copy-bit-field from)
490  (*bitwise-copy-bit-field to start end from))
491
492(define (bitwise-rotate-bit-field value start end count)
493  (%check-integer 'bitwise-rotate-bit-field value)
494  (%check-non-negative-fixnum 'bitwise-rotate-bit-field start)
495  (%check-non-negative-fixnum 'bitwise-rotate-bit-field end)
496  (%check-fixnum<= 'bitwise-rotate-bit-field start end)
497  (%check-word-bits 'bitwise-rotate-bit-field start)
498  (%check-word-bits+1 'bitwise-rotate-bit-field end)
499  (%check-fixnum 'bitwise-rotate-bit-field count)
500  (unless (%fx- count (%fx- end start))
501    (##sys#signal-hook #:bounds-error 'bitwise-rotate-bit-field "outside of interval" count start end) )
502  (%check-word-bits 'bitwise-rotate-bit-field count)
503  (*bitwise-rotate-bit-field value start end count) )
504
505(define (bitwise-reverse value count)
506  (%check-integer 'bitwise-reverse value)
507  (%check-non-negative-fixnum 'bitwise-reverse count)
508  (%check-word-bits '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-non-negative-fixnum 'bitwise-reverse-bit-field start)
514  (%check-non-negative-fixnum 'bitwise-reverse-bit-field end)
515  (%check-fixnum<= 'bitwise-reverse-bit-field start end)
516  (%check-word-bits 'bitwise-reverse-bit-field start)
517  (%check-word-bits+1 'bitwise-reverse-bit-field end)
518  (*bitwise-reverse-bit-field value start end) )
519
520(define (bitwise-list->integer lyst)
521  (%check-list 'bitwise-list->integer lyst)
522  (*bitwise-list->integer lyst) )
523
524(define (bitwise-integer->list value #!optional bitlen)
525  (%check-integer 'bitwise-integer->list value)
526  (when bitlen
527    (%check-non-negative-fixnum 'bitwise-integer->list bitlen)
528    (%check-word-bits 'bitwise-integer->list bitlen) )
529  (bitwise-integer->list value bitlen) )
530
531(define (bitwise-arithmetic-shift value signed-count)
532  (%check-integer 'bitwise-arithmetic-shift value)
533  (%check-fixnum 'bitwise-arithmetic-shift signed-count)
534  (let ([count (if (%fx< signed-count 0) (%fxneg signed-count) signed-count)])
535    (%check-word-bits 'bitwise-arithmetic-shift count) )
536  (%arithmetic-shift value signed-count) )
537
538(define (bitwise-arithmetic-shift-left value count)
539  (%check-integer 'bitwise-arithmetic-shift-left value)
540  (%check-non-negative-fixnum 'bitwise-arithmetic-shift-left count)
541  (%check-word-bits 'bitwise-arithmetic-shift-left count)
542  (%arithmetic-shift value count) )
543
544(define (bitwise-arithmetic-shift-right value count)
545  (%check-integer 'bitwise-arithmetic-shift-right value)
546  (%check-non-negative-fixnum 'bitwise-arithmetic-shift-right count)
547  (%check-word-bits 'bitwise-arithmetic-shift-right count)
548  (%arithmetic-shift value (%fxneg count)) )
549
550;; Extras
551
552(define (bitwise-if-not mask true false)
553  (%check-integer 'bitwise-if-not mask)
554  (%check-integer 'bitwise-if-not true)
555  (%check-integer 'bitwise-if-not false)
556  (*bitwise-if-not mask true false))
557
558(define (boolean->bit bit)
559  (%boolean->bit* bit) )
560
561(define (pow2log2 value)
562  (%check-integer 'pow2log2 value)
563  (*pow2log2 value) )
564
565) ;module err5rs-arithmetic-bitwise
Note: See TracBrowser for help on using the repository browser.