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

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

Save.

File size: 20.1 KB
Line 
1;;;; fixnum-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        (bound-to-procedure
11          ##sys#signal-hook
12          ##sys#make-string
13          ##sys#string-append )
14  (export
15    fixnum->string
16    fixnum-width
17    least-fixnum
18    greatest-fixnum
19    fx=?
20    fx<?
21    fx>?
22    fx<=?
23    fx>=?
24    fxcompare
25    fxzero?
26    fxpositive?
27    fxnegative?
28    fxodd?
29    fxeven?
30    *fxmax
31    *fxmin
32    fxmax-and-min
33    fxabs
34    fxpow2log2
35    fxdiv
36    fxdiv-and-mod
37    fxdiv0
38    fxmod0
39    fxdiv0-and-mod0
40    fx*/carry
41    fx+/carry
42    fx-/carry
43    fxadd1
44    fxsub1
45    fxmodulo
46    fxquotient
47    fxremainder
48    fxarithmetic-shift
49    fxarithmetic-shift-left
50    fxarithmetic-shift-right
51    *fx-
52    *fxand
53    *fxior
54    *fxxor
55    fxif
56    fxbit-count
57    fxlength
58    fxfirst-bit-set
59    fxlast-bit-set
60    fxbit-set?
61    fxcopy-bit
62    fxbit-field
63    fxcopy-bit-field
64    fxrotate-bit-field
65    fxreverse-bit-field ) )
66
67(use mathh-int)
68(use bitwise-extras)
69
70;;;
71
72(define-inline (fixnum-type-error loc obj)
73  (##sys#signal-hook #:type-error loc
74                     "bad argument type - not a fixnum" obj) )
75
76(define-inline (fixnum-zero-division-error loc fx1 fx2)
77  (##sys#signal-hook #:arithmetic-error loc
78                     "division by zero" fx1 fx2) )
79
80(define-inline (fixnum-representation-error loc fx1 fx2)
81  (##sys#signal-hook #:arithmetic-error loc
82                     "results not representable as fixnums" fx1 fx2) )
83
84(define-inline (check-fixnum loc obj)
85  (unless (##core#inline "C_fixnump" obj)
86    (fixnum-type-error loc obj) ) )
87
88(define-inline (check-non-negative-fixnum loc obj)
89  (unless (and (##core#inline "C_fixnump" obj)
90               (##core#inline "C_fixnum_less_or_equal_p" 0 obj))
91    (##sys#signal-hook #:type-error loc
92                       "bad argument type - not a non-negative fixnum" obj) ) )
93
94(define-inline (check-fixnum<= loc fx1 fx2)
95  (unless (##core#inline "C_fixnum_less_or_equal_p" fx1 fx2)
96    (##sys#signal-hook #:bounds-error loc
97                       "not a fixnum interval" fx1 fx2) ) )
98
99(define-inline (check-fixnum-bits loc fx)
100  (unless (##core#inline "C_fixnum_less_or_equal_p" fx fixnum-bits)
101    (##sys#signal-hook #:bounds-error loc
102                       "out of fixnum range" fx) ) )
103
104(define %fixnum-bits-end (##core#inline "C_fixnum_plus" fixnum-bits 1))
105
106(define-inline (check-fixnum-bits+1 loc fx)
107  (unless (##core#inline "C_fixnum_less_or_equal_p" fx %fixnum-bits-end)
108    (##sys#signal-hook #:bounds-error loc
109                       "out of fixnum range" fx) ) )
110
111(define-inline (check-zero-division loc fx1 fx2)
112  (when (##core#inline "C_eqp" 0 fx2)
113    (fixnum-zero-division-error loc fx1 fx2) ) )
114
115;;;
116
117#;
118(define->inline (%->fixnum value)
119  (if (##core#inline "C_fixnump" value)
120      value
121      (##core#inline_allocate ("C_a_i_bitwise_and" 4) value most-positive-machine-word) ) )
122
123;;;
124
125(define-inline (%fold1 loc func init lyst)
126  (check-fixnum loc init)
127  (let loop ([acc init] [lyst lyst])
128          (if (null? lyst)
129              acc
130              (let ([cur (car lyst)])
131          (check-fixnum loc cur)
132                (loop (func acc cur) (cdr lyst)) ) ) ) )
133
134(define-inline (%and-fold1 loc func init lyst)
135  (check-fixnum loc init)
136  (let loop ([prv init] [lyst lyst])
137          (or (null? lyst)
138        (let ([cur (car lyst)])
139          (check-fixnum loc cur)
140          (and (func prv (car lyst))
141               (loop (car lyst) (cdr lyst)) ) ) ) ) )
142
143;;;
144
145(define (%fx= x y)
146  (##core#inline "C_eqp" x y) )
147
148(define (%fx< x y)
149  (##core#inline "C_fixnum_lessp" x y) )
150
151(define (%fx> x y)
152  (##core#inline "C_fixnum_greaterp" x y) )
153
154(define (%fx>= x y)
155  (##core#inline "C_fixnum_greater_or_equal_p" x y) )
156
157(define (%fx<= x y)
158  (##core#inline "C_fixnum_less_or_equal_p" x y) )
159
160(define (%fxmax x y )
161  (##core#inline "C_i_fixnum_max" x y) )
162
163(define (%fxmin x y )
164  (##core#inline "C_i_fixnum_min" x y) )
165
166;;;
167
168(define %fxnegprec (##core#inline "C_fixnum_negate" fixnum-precision))
169
170;;;
171
172(define-inline (%fxdiv0-and-mod0 fxn fxd)
173  (let* ([quo ((##core#primitive "C_quotient") fxn fxd)]
174         [rem ((##core#primitive "C_minus")
175               fxn
176               ((##core#primitive "C_times") quo fxd))])
177    (cond [((##core#primitive "C_greater_or_equal_p") fxd 0)
178            (if ((##core#primitive "C_lessp")
179                 ((##core#primitive "C_times") rem 2)
180                 fxd)
181                (if ((##core#primitive "C_less_or_equal_p")
182                     ((##core#primitive "C_times") rem -2)
183                     fxd)
184                    (values quo rem)
185                    (values ((##core#primitive "C_minus") quo 1)
186                            ((##core#primitive "C_plus") rem fxd)) )
187                (values ((##core#primitive "C_plus") quo 1)
188                        ((##core#primitive "C_minus") rem fxd)) ) ]
189          [((##core#primitive "C_greaterp")
190            ((##core#primitive "C_times") rem -2)
191            fxd)
192            (if ((##core#primitive "C_greater_or_equal_p")
193                 ((##core#primitive "C_times") rem 2)
194                 fxd)
195                (values quo rem)
196                (values ((##core#primitive "C_plus") quo 1)
197                        ((##core#primitive "C_minus") rem fxd)) ) ]
198          [else
199            (values ((##core#primitive "C_minus") quo 1)
200                    ((##core#primitive "C_plus") rem fxd)) ] ) ) )
201
202(define-inline (%fxdiv0 fxn fxd)
203  (let* ([quo ((##core#primitive "C_quotient") fxn fxd)]
204         [rem ((##core#primitive "C_minus")
205               fxn
206               ((##core#primitive "C_times") quo fxd))])
207    (cond [((##core#primitive "C_greater_or_equal_p") fxd 0)
208            (if ((##core#primitive "C_lessp")
209                 ((##core#primitive "C_times") rem 2)
210                 fxd)
211                (if ((##core#primitive "C_less_or_equal_p")
212                     ((##core#primitive "C_times") rem -2)
213                     fxd)
214                    quo
215                    ((##core#primitive "C_minus") quo 1) )
216                ((##core#primitive "C_plus") quo 1) ) ]
217          [((##core#primitive "C_greaterp")
218            ((##core#primitive "C_times") rem -2)
219            fxd)
220            (if ((##core#primitive "C_greater_or_equal_p")
221                 ((##core#primitive "C_times") rem 2)
222                 fxd)
223                quo
224                ((##core#primitive "C_plus") quo 1) ) ]
225          [else
226            ((##core#primitive "C_minus") quo 1) ] ) ) )
227
228(define-inline (%fxmod0 fxn fxd)
229  (let* ([quo ((##core#primitive "C_quotient") fxn fxd)]
230         [rem ((##core#primitive "C_minus")
231               fxn
232               ((##core#primitive "C_times") quo fxd))])
233    (cond [((##core#primitive "C_greater_or_equal_p") fxd 0)
234            (if ((##core#primitive "C_lessp")
235                 ((##core#primitive "C_times") rem 2)
236                 fxd)
237                (if ((##core#primitive "C_less_or_equal_p")
238                     ((##core#primitive "C_times") rem -2) fxd)
239                    rem
240                    ((##core#primitive "C_plus") rem fxd) )
241                ((##core#primitive "C_minus") rem fxd) ) ]
242          [((##core#primitive "C_greaterp")
243            ((##core#primitive "C_times") rem -2)
244            fxd)
245            (if ((##core#primitive "C_greater_or_equal_p")
246                 ((##core#primitive "C_times") rem 2)
247                 fxd)
248                rem
249                ((##core#primitive "C_minus") rem fxd) ) ]
250          [else
251            ((##core#primitive "C_plus") rem fxd) ] ) ) )
252
253;;;
254
255(define (%fxand x y)
256  (##core#inline "C_fixnum_and" x y) )
257
258(define (%fxior x y)
259  (##core#inline "C_fixnum_or" x y) )
260
261(define (%fxxor x y)
262  (##core#inline "C_fixnum_xor" x y) )
263
264;;;
265
266(define (fixnum-width)
267  fixnum-precision )
268
269(define (least-fixnum)
270  most-negative-fixnum )
271
272(define (greatest-fixnum)
273  most-positive-fixnum )
274
275;;;
276
277(define (fx=? fx . rest)
278        (%and-fold1 'fx=? %fx= fx rest) )
279
280(define (fx<? fx . rest)
281        (%and-fold1 'fx<? %fx< fx rest) )
282
283(define (fx>? fx . rest)
284        (%and-fold1 'fx>? %fx> fx rest) )
285
286(define (fx<=? fx . rest)
287        (%and-fold1 'fx<=? %fx<= fx rest) )
288
289(define (fx>=? fx . rest)
290        (%and-fold1 'fx>=? %fx>= fx rest) )
291
292(define (fxcompare fx1 fx2)
293  (check-fixnum 'fxcompare fx1)
294  (check-fixnum 'fxcompare fx2)
295        (cond [(##core#inline "C_eqp" fx1 fx2)
296                0]
297              [(fx< fx1 fx2)
298                -1]
299              [else
300                1] ) )
301
302(define (*fxmax fx . rest)
303        (%fold1 'fxmax %fxmax fx rest) )
304
305(define (*fxmin fx . rest)
306        (%fold1 'fxmin %fxmin fx rest) )
307
308(define (fxmax-and-min fx . rest)
309  (check-fixnum 'fxmax-and-min fx)
310        (let loop ([mx fx]
311                   [mn fx]
312                   [lyst rest])
313          (if (null? lyst)
314              (values mx mn)
315              (let ([cur (car lyst)])
316          (check-fixnum 'fxmax-and-min cur)
317          (loop (##core#inline "C_i_fixnum_max" mx cur)
318                (##core#inline "C_i_fixnum_min" mn cur)
319                (cdr lyst)) ) ) ) )
320
321;;;
322
323(define (fxzero? fx)
324  (check-fixnum 'fxzero? fx)
325        (##core#inline "C_eqp" 0 fx) )
326
327(define (fxpositive? fx)
328  (check-fixnum 'fxpositive? fx)
329        (##core#inline "C_fixnum_lessp" 0 fx) )
330
331(define (fxnegative? fx)
332  (check-fixnum 'fxnegative? fx)
333        (##core#inline "C_fixnum_lessp" fx 0) )
334
335(define (fxodd? fx)
336  (check-fixnum 'fxodd? fx)
337        (##core#inline "C_eqp" 1 (##core#inline "C_fixnum_and" fx 1)) )
338
339(define (fxeven? fx)
340  (check-fixnum 'fxeven? fx)
341        (##core#inline "C_eqp" 0 (##core#inline "C_fixnum_and" fx 1)) )
342
343;;;
344
345(define (fxabs fx)
346  (check-fixnum 'fxabs fx)
347  (if (##core#inline "C_fixnum_lessp" fx 0)
348      (##core#inline "C_fixnum_negate" fx)
349      fx ) )
350
351(define (fxpow2log2 fx)
352  (check-fixnum 'fxpow2log2 fx)
353  (%pow2log2 fx) )
354
355(define (fxdiv fxn fxd)
356  (check-fixnum 'fxdiv fxn)
357  (check-fixnum 'fxdiv fxd)
358  (check-zero-division 'fxdiv fxn fxd)
359  (##core#inline "C_fixnum_divide" fxn fxd) )
360
361(define (fxdiv-and-mod fxn fxd)
362  (check-fixnum 'fxdiv-and-mod fxn)
363  (check-fixnum 'fxdiv-and-mod fxd)
364  (check-zero-division 'fxdiv fxn fxd)
365        (values (##core#inline "C_fixnum_divide" fxn fxd)
366                (##core#inline "C_fixnum_modulo" fxn fxd)) )
367
368(define (fxdiv0 fxn fxd)
369  (if (##core#inline "C_fixnump" fxn)
370      (if (##core#inline "C_fixnump" fxd)
371          (if (##core#inline "C_eqp" 0 fxd)
372              (fixnum-zero-division-error 'fxdiv0 fxn fxd)
373              (let ([d (%fxdiv0 fxn fxd)])
374                (if (##core#inline "C_fixnump" d)
375                    d
376                    (fixnum-representation-error 'fxdiv0 fxn fxd) ) ) )
377          (fixnum-type-error 'fxdiv0 fxd) )
378      (fixnum-type-error 'fxdiv0 fxn) ) )
379
380(define (fxmod0 fxn fxd)
381  (if (##core#inline "C_fixnump" fxn)
382      (if (##core#inline "C_fixnump" fxd)
383          (if (##core#inline "C_eqp" 0 fxd)
384              (fixnum-zero-division-error 'fxmod0 fxn fxd)
385              (let ([m (%fxmod0 fxn fxd)])
386                (if (##core#inline "C_fixnump" m)
387                    m
388                    (fixnum-representation-error 'fxmod0 fxn fxd) ) ) )
389          (fixnum-type-error 'fxmod0 fxd) )
390      (fixnum-type-error 'fxmod0 fxn) ) )
391
392(define (fxdiv0-and-mod0 fxn fxd)
393  (if (##core#inline "C_fixnump" fxn)
394      (if (##core#inline "C_fixnump" fxd)
395          (if (##core#inline "C_eqp" 0 fxd)
396              (fixnum-zero-division-error 'fxdiv0-and-mod0 fxn fxd)
397              (let-values ([(d m) (%fxdiv0-and-mod0 fxn fxd)])
398                (if (and (##core#inline "C_fixnump" d)
399                         (##core#inline "C_fixnump" m))
400                    (values d m)
401                    (fixnum-representation-error 'fxdiv0-and-mod0 fxn fxd) ) ) )
402          (fixnum-type-error 'fxdiv0-and-mod0 fxd) )
403      (fixnum-type-error 'fxdiv0-and-mod0 fxn) ) )
404
405(define (fx*/carry fx1 fx2 fx3)
406  (check-fixnum 'fx*/carry fx1)
407  (check-fixnum 'fx*/carry fx2)
408  (check-fixnum 'fx*/carry fx3)
409  (let ([res (##core#inline "C_fixnum_plus"
410              (##core#inline "C_fixnum_times" fx1 fx2)
411              fx3)])
412    (values res
413            (##core#inline_allocate ("C_a_i_arithmetic_shift" 4)
414             ((##core#primitive "C_plus")
415              ((##core#primitive "C_times") fx1 fx2)
416              ((##core#primitive "C_minus") fx3 res))
417             %fxnegprec) ) ) )
418
419(define (fx+/carry fx1 fx2 fx3)
420  (check-fixnum 'fx+/carry fx1)
421  (check-fixnum 'fx+/carry fx2)
422  (check-fixnum 'fx+/carry fx3)
423  (let ([res (##core#inline "C_fixnum_plus"
424              (##core#inline "C_fixnum_plus" fx1 fx2)
425              fx3)])
426    (values res
427            (##core#inline_allocate ("C_a_i_arithmetic_shift" 4)
428             ((##core#primitive "C_plus")
429              ((##core#primitive "C_plus") fx1 fx2)
430              ((##core#primitive "C_minus") fx3 res))
431             %fxnegprec) ) ) )
432
433(define (fx-/carry fx1 fx2 fx3)
434  (check-fixnum 'fx-/carry fx1)
435  (check-fixnum 'fx-/carry fx2)
436  (check-fixnum 'fx-/carry fx3)
437  (let ([res (##core#inline "C_fixnum_difference"
438              (##core#inline "C_fixnum_difference" fx1 fx2)
439              fx3)])
440    (values res
441            (##core#inline_allocate ("C_a_i_arithmetic_shift" 4)
442             ((##core#primitive "C_minus")
443              ((##core#primitive "C_minus") fx1 fx2)
444              ((##core#primitive "C_plus") res fx3))
445             %fxnegprec) ) ) )
446
447(define (fxadd1 fx)
448  (check-fixnum 'fxadd1 fx)
449  (##core#inline "C_fixnum_plus" fx 1) )
450
451(define (fxsub1 fx)
452  (check-fixnum 'fxsub1 fx)
453  (##core#inline "C_fixnum_difference" fx 1) )
454
455(define (fxquotient fxn fxd)
456  (check-fixnum 'fxquotient fxn)
457  (check-fixnum 'fxquotient fxd)
458  (check-zero-division 'fxquotient fxn fxd)
459  (##core#inline "C_fixnum_divide" fxn fxd) )
460
461(define (fxremainder fxn fxd)
462  (check-fixnum 'fxremainder fxn)
463  (check-fixnum 'fxremainder fxd)
464  (check-zero-division 'fxremainder fxn fxd)
465  (##core#inline "C_fixnum_difference"
466   fxn
467   (##core#inline "C_fixnum_times"
468    (##core#inline "C_fixnum_divide" fxn fxd)
469    fxd)) )
470
471(define (fxmodulo fxn fxd)
472  (check-fixnum 'fxmodulo fxn)
473  (check-fixnum 'fxmodulo fxd)
474  (check-zero-division 'fxmodulo fxn fxd)
475  (##core#inline "C_fixnum_modulo" fxn fxd) )
476
477(define (fxarithmetic-shift fx amount)
478  (check-fixnum 'fxarithmetic-shift fx)
479  (check-fixnum 'fxarithmetic-shift amount)
480  (if (##core#inline "C_fixnum_lessp" 0 amount)
481      (##core#inline "C_fixnum_shift_right"
482       fx
483       (##core#inline "C_fixnum_negate" amount))
484      (##core#inline "C_fixnum_shift_left" fx amount) ) )
485
486(define (fxarithmetic-shift-left fx amount)
487  (check-fixnum 'fxarithmetic-shift-left fx)
488  (check-non-negative-fixnum 'fxarithmetic-shift-left amount)
489  (##core#inline "C_fixnum_shift_left" fx amount) )
490
491(define (fxarithmetic-shift-right fx amount)
492  (check-fixnum 'fxarithmetic-shift-right fx)
493  (check-non-negative-fixnum 'fxarithmetic-shift-right amount)
494  (##core#inline "C_fixnum_shift_right" fx amount) )
495
496(define (*fx- fx1 . rest)
497  (check-fixnum 'fx- fx1)
498  (if (null? rest)
499      (##core#inline "C_fixnum_negate" fx1)
500      (let ([fx2 (car rest)])
501        (check-fixnum 'fx- fx2)
502        (##core#inline "C_fixnum_difference" fx1 fx2) ) ) )
503
504;;;
505
506(define (*fxand fx . rest)
507  (%fold1 'fxand %fxand fx rest) )
508
509(define (*fxior fx . rest)
510        (%fold1 'fxior %fxior fx rest) )
511
512(define (*fxxor fx . rest)
513        (%fold1 'fxxor %fxxor fx rest) )
514
515;;;
516
517(define fixnum->string
518  (let ([digits "0123456789ABCDEF"])
519    (lambda (fx #!optional (radix 10))
520      (letrec ([fx-digits
521                 (lambda (fx from to)
522                   (if (##core#inline "C_eqp" 0 fx)
523                       (values (##sys#make-string from)
524                               to)
525                       (let* ([quo
526                                (##core#inline "C_fixnum_divide" fx radix)]
527                              [digit
528                                (##core#inline "C_i_string_ref"
529                                 digits
530                                 (##core#inline "C_fixnum_difference"
531                                  fx
532                                  (##core#inline "C_fixnum_times" quo radix)))])
533                           (let-values ([(str to)
534                                         (fx-digits
535                                          quo
536                                          (##core#inline "C_fixnum_plus" from 1)
537                                          to)])
538                             (##core#inline "C_i_string_set" str to digit)
539                             (values str
540                                     (##core#inline "C_fixnum_plus" to 1)) ) ) ) ) ]
541               [fx->str
542                 (lambda (fx)
543                   (cond [(##core#inline "C_eqp" 0 fx)
544                           (##sys#make-string 1 #\0)]
545                         [(##core#inline "C_fixnum_lessp" 0 fx)
546                           (let ([str (fx-digits fx 0 0)])
547                             (noop str)
548                             str ) ]
549                         [(##core#inline "C_eqp" most-negative-fixnum fx)
550                           (##sys#string-append
551                            (fx->str (##core#inline "C_fixnum_divide" fx radix))
552                            (fx->str (##core#inline "C_fixnum_difference"
553                                      radix
554                                      (##core#inline "C_fixnum_modulo" fx radix))))]
555                         [else
556                           (let ([str (fx-digits (##core#inline "C_fixnum_negate" fx) 1 1)])
557                             (##core#inline "C_i_string_set" str 0 #\-)
558                             str ) ] ) ) ] )
559        ;
560        (check-fixnum 'fixnum->string fx)
561        (case radix
562          [(2 8 10 16)
563            (fx->str fx)]
564          [else
565            (##sys#signal-hook #:type-error 'fixnum->string
566                               "bad argument type - invalid radix" radix) ] ) ) ) ) )
567
568;;;
569
570(define (fxif mask true false)
571  (check-fixnum 'fxif mask)
572  (check-fixnum 'fxif true)
573  (check-fixnum 'fxif false)
574        (%bitwise-if mask true false) )
575
576(define (fxbit-count fx)
577  (check-fixnum 'fxbit-count fx)
578        (%bitwise-bit-count fx) )
579
580(define (fxlength fx)
581  (check-fixnum 'fxlength fx)
582        (%bitwise-length fx) )
583
584(define (fxfirst-bit-set fx)
585  (check-fixnum 'fxfirst-bit-set fx)
586        (%bitwise-first-bit-set fx) )
587
588(define (fxlast-bit-set fx)
589  (check-fixnum 'fxlast-bit-set fx)
590        (%bitwise-last-bit-set fx) )
591
592(define (fxbit-set? fx index)
593  (check-fixnum 'fxbit-set? fx)
594  (check-non-negative-fixnum 'fxbit-set? index)
595  (check-fixnum-bits 'fxbit-set? index)
596        (%bitwise-bit-set? fx index) )
597
598(define (fxcopy-bit fx index bit)
599  (check-fixnum 'fxcopy-bit fx)
600  (check-non-negative-fixnum 'fxcopy-bit index)
601  (check-fixnum-bits 'fxcopy-bit index)
602  (check-fixnum 'fxcopy-bit bit)
603        (%bitwise-copy-bit fx index bit) )
604
605(define (fxbit-field fx start end)
606  (check-fixnum 'fxbit-field fx)
607  (check-non-negative-fixnum 'fxbit-field start)
608  (check-non-negative-fixnum 'fxbit-field end)
609  (check-fixnum<= 'fxbit-field start end)
610  (check-fixnum-bits 'fxbit-field start)
611  (check-fixnum-bits+1 'fxbit-field end)
612        (%bitwise-bit-field fx start end) )
613
614(define (fxcopy-bit-field fxto start end fxfrom)
615  (check-fixnum 'fxcopy-bit-field fxto)
616  (check-non-negative-fixnum 'fxcopy-bit-field start)
617  (check-non-negative-fixnum 'fxcopy-bit-field end)
618  (check-fixnum<= 'fxcopy-bit-field start end)
619  (check-fixnum-bits 'fxcopy-bit-field start)
620  (check-fixnum-bits+1 'fxcopy-bit-field end)
621  (check-fixnum 'fxcopy-bit-field fxfrom)
622        (%bitwise-copy-bit-field fxto start end fxfrom) )
623
624(define (fxrotate-bit-field fx start end count)
625  (check-fixnum 'fxrotate-bit-field fx)
626  (check-non-negative-fixnum 'fxrotate-bit-field start)
627  (check-non-negative-fixnum 'fxrotate-bit-field end)
628  (check-fixnum<= 'fxrotate-bit-field start end)
629  (check-fixnum-bits 'fxrotate-bit-field start)
630  (check-fixnum-bits+1 'fxrotate-bit-field end)
631  (check-non-negative-fixnum 'fxrotate-bit-field count)
632  (unless (##core#inline "C_fixnum_less_or_equal_p"
633           count
634           (##core#inline "C_fixnum_difference" end start))
635    (##sys#signal-hook #:bounds-error 'fxrotate-bit-field
636                       "outside of interval" count start end) )
637        (%bitwise-rotate-bit-field fx start end count) )
638
639(define (fxreverse-bit-field fx start end)
640  (check-fixnum 'fxreverse-bit-field fx)
641  (check-non-negative-fixnum 'fxreverse-bit-field start)
642  (check-non-negative-fixnum 'fxreverse-bit-field end)
643  (check-fixnum<= 'fxreverse-bit-field start end)
644  (check-fixnum-bits 'fxreverse-bit-field start)
645  (check-fixnum-bits+1 'fxreverse-bit-field end)
646        (%bitwise-reverse-bit-field fx start end) )
Note: See TracBrowser for help on using the repository browser.