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

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

Save.

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