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

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

Use of core immutable.

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