source: project/release/3/mathh/trunk/bitwise-extras.scm @ 8595

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

Save.

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