1 ;;;; This file contains the definitions of most number functions.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!KERNEL")
14 ;;;; the NUMBER-DISPATCH macro
16 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
18 ;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
19 ;;; with the type dispatches and bodies. Result is a tree built of
20 ;;; alists representing the dispatching off each arg (in order). The
21 ;;; leaf is the body to be executed in that case.
22 (defun parse-number-dispatch (vars result types var-types body
)
24 (unless (null types
) (error "More types than vars."))
26 (error "Duplicate case: ~S." body
))
28 (sublis var-types body
:test
#'equal
)))
30 (error "More vars than types."))
32 (flet ((frob (var type
)
33 (parse-number-dispatch
35 (or (assoc type
(cdr result
) :test
#'equal
)
36 (car (setf (cdr result
)
37 (acons type nil
(cdr result
)))))
39 (acons `(dispatch-type ,var
) type var-types
)
41 (let ((type (first types
))
43 (if (and (consp type
) (eq (first type
) 'foreach
))
44 (dolist (type (rest type
))
48 ;;; our guess for the preferred order in which to do type tests
49 ;;; (cheaper and/or more probable first.)
50 (defparameter *type-test-ordering
*
51 '(fixnum single-float double-float integer
#!+long-float long-float
52 sb
!vm
:signed-word word bignum
55 ;;; Should TYPE1 be tested before TYPE2?
56 (defun type-test-order (type1 type2
)
57 (let ((o1 (position type1
*type-test-ordering
*))
58 (o2 (position type2
*type-test-ordering
*)))
64 ;;; Return an ETYPECASE form that does the type dispatch, ordering the
65 ;;; cases for efficiency.
66 ;;; Check for some simple to detect problematic cases where the caller
67 ;;; used types that are not disjoint and where this may lead to
68 ;;; unexpected behaviour of the generated form, for example making
69 ;;; a clause unreachable, and throw an error if such a case is found.
71 ;;; (number-dispatch ((var1 integer) (var2 float))
72 ;;; ((fixnum single-float) a)
73 ;;; ((integer float) b))
74 ;;; Even though the types are not reordered here, the generated form,
77 ;;; (fixnum (etypecase var2
78 ;;; (single-float a)))
79 ;;; (integer (etypecase var2
81 ;;; would fail at runtime if given var1 fixnum and var2 double-float,
82 ;;; even though the second clause matches this signature. To catch
83 ;;; this earlier than runtime we throw an error already here.
84 (defun generate-number-dispatch (vars error-tags cases
)
86 (let ((var (first vars
))
87 (cases (sort cases
#'type-test-order
:key
#'car
)))
88 (flet ((error-if-sub-or-supertype (type1 type2
)
89 (when (or (subtypep type1 type2
)
90 (subtypep type2 type1
))
91 (error "Types not disjoint: ~S ~S." type1 type2
)))
92 (error-if-supertype (type1 type2
)
93 (when (subtypep type2 type1
)
94 (error "Type ~S ordered before subtype ~S."
96 (test-type-pairs (fun)
97 ;; Apply FUN to all (ordered) pairs of types from the
101 (let ((type1 (caar cases
)))
102 (dolist (case (cdr cases
))
103 (funcall fun type1
(car case
))))))
105 ;; For the last variable throw an error if a type is followed
106 ;; by a subtype, for all other variables additionally if a
107 ;; type is followed by a supertype.
108 (test-type-pairs (if (cdr vars
)
109 #'error-if-sub-or-supertype
110 #'error-if-supertype
)))
112 ,@(mapcar (lambda (case)
114 ,@(generate-number-dispatch (rest vars
)
118 (t (go ,(first error-tags
))))))
123 ;;; This is a vaguely case-like macro that does number cross-product
124 ;;; dispatches. The Vars are the variables we are dispatching off of.
125 ;;; The Type paired with each Var is used in the error message when no
126 ;;; case matches. Each case specifies a Type for each var, and is
127 ;;; executed when that signature holds. A type may be a list
128 ;;; (FOREACH Each-Type*), causing that case to be repeatedly
129 ;;; instantiated for every Each-Type. In the body of each case, any
130 ;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
131 ;;; type of that var in that instance of the case.
133 ;;; As an alternate to a case spec, there may be a form whose CAR is a
134 ;;; symbol. In this case, we apply the CAR of the form to the CDR and
135 ;;; treat the result of the call as a list of cases. This process is
136 ;;; not applied recursively.
138 ;;; Be careful when using non-disjoint types in different cases for the
139 ;;; same variable. Some uses will behave as intended, others not, as the
140 ;;; variables are dispatched off sequentially and clauses are reordered
141 ;;; for efficiency. Some, but not all, problematic cases are detected
142 ;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above
144 (defmacro number-dispatch
(var-specs &body cases
)
145 (let ((res (list nil
))
146 (vars (mapcar #'car var-specs
))
149 (if (symbolp (first case
))
150 (let ((cases (apply (symbol-function (first case
)) (rest case
))))
152 (parse-number-dispatch vars res
(first case
) nil
(rest case
))))
153 (parse-number-dispatch vars res
(first case
) nil
(rest case
))))
157 (dolist (spec var-specs
)
158 (let ((var (first spec
))
164 (sb!c
::internal-type-error-call var type
))))
169 ,@(generate-number-dispatch vars
(error-tags)
173 ;;;; binary operation dispatching utilities
175 (eval-when (:compile-toplevel
:execute
)
177 ;;; Return NUMBER-DISPATCH forms for rational X float.
178 (defun float-contagion (op x y
&optional
(rat-types '(fixnum bignum ratio
)))
179 `(((single-float single-float
) (,op
,x
,y
))
180 (((foreach ,@rat-types
)
181 (foreach single-float double-float
#!+long-float long-float
))
182 (,op
(coerce ,x
'(dispatch-type ,y
)) ,y
))
183 (((foreach single-float double-float
#!+long-float long-float
)
184 (foreach ,@rat-types
))
185 (,op
,x
(coerce ,y
'(dispatch-type ,x
))))
187 (((foreach single-float double-float long-float
) long-float
)
188 (,op
(coerce ,x
'long-float
) ,y
))
190 ((long-float (foreach single-float double-float
))
191 (,op
,x
(coerce ,y
'long-float
)))
192 (((foreach single-float double-float
) double-float
)
193 (,op
(coerce ,x
'double-float
) ,y
))
194 ((double-float single-float
)
195 (,op
,x
(coerce ,y
'double-float
)))))
197 ;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
198 (defun bignum-cross-fixnum (fix-op big-op
)
199 `(((fixnum fixnum
) (,fix-op x y
))
201 (,big-op
(make-small-bignum x
) y
))
203 (,big-op x
(make-small-bignum y
)))
209 ;;;; canonicalization utilities
211 ;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
212 ;;; used when we know that REALPART and IMAGPART are the same type, but
213 ;;; rational canonicalization might still need to be done.
214 #!-sb-fluid
(declaim (inline canonical-complex
))
215 (defun canonical-complex (realpart imagpart
)
219 ((and (typep realpart
'long-float
)
220 (typep imagpart
'long-float
))
221 (truly-the (complex long-float
) (complex realpart imagpart
)))
222 ((and (typep realpart
'double-float
)
223 (typep imagpart
'double-float
))
224 (truly-the (complex double-float
) (complex realpart imagpart
)))
225 ((and (typep realpart
'single-float
)
226 (typep imagpart
'single-float
))
227 (truly-the (complex single-float
) (complex realpart imagpart
)))
229 (%make-complex realpart imagpart
)))))
231 ;;; Given a numerator and denominator with the GCD already divided
232 ;;; out, make a canonical rational. We make the denominator positive,
233 ;;; and check whether it is 1.
234 #!-sb-fluid
(declaim (inline build-ratio
))
235 (defun build-ratio (num den
)
236 (multiple-value-bind (num den
)
238 (values (- num
) (- den
))
242 (error 'division-by-zero
243 :operands
(list num den
)
246 (t (%make-ratio num den
)))))
248 ;;; Truncate X and Y, but bum the case where Y is 1.
249 #!-sb-fluid
(declaim (inline maybe-truncate
))
250 (defun maybe-truncate (x y
)
257 (defun complex (realpart &optional
(imagpart 0))
258 "Return a complex number with the specified real and imaginary components."
259 (declare (explicit-check))
260 (flet ((%%make-complex
(realpart imagpart
)
262 ((and (typep realpart
'long-float
)
263 (typep imagpart
'long-float
))
264 (truly-the (complex long-float
)
265 (complex realpart imagpart
)))
266 ((and (typep realpart
'double-float
)
267 (typep imagpart
'double-float
))
268 (truly-the (complex double-float
)
269 (complex realpart imagpart
)))
270 ((and (typep realpart
'single-float
)
271 (typep imagpart
'single-float
))
272 (truly-the (complex single-float
)
273 (complex realpart imagpart
)))
275 (%make-complex realpart imagpart
)))))
276 (number-dispatch ((realpart real
) (imagpart real
))
278 (canonical-complex realpart imagpart
))
279 (float-contagion %%make-complex realpart imagpart
(rational)))))
281 (defun realpart (number)
282 "Extract the real part of a number."
285 ((complex long-float
)
286 (truly-the long-float
(realpart number
)))
287 ((complex double-float
)
288 (truly-the double-float
(realpart number
)))
289 ((complex single-float
)
290 (truly-the single-float
(realpart number
)))
296 (defun imagpart (number)
297 "Extract the imaginary part of a number."
300 ((complex long-float
)
301 (truly-the long-float
(imagpart number
)))
302 ((complex double-float
)
303 (truly-the double-float
(imagpart number
)))
304 ((complex single-float
)
305 (truly-the single-float
(imagpart number
)))
313 (defun conjugate (number)
314 "Return the complex conjugate of NUMBER. For non-complex numbers, this is
316 (declare (type number number
) (explicit-check))
317 (if (complexp number
)
318 (complex (realpart number
) (- (imagpart number
)))
321 (defun signum (number)
322 "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
323 (declare (explicit-check))
326 (number-dispatch ((number number
))
327 (((foreach fixnum rational single-float double-float
))
329 (coerce 1 '(dispatch-type number
))
330 (coerce -
1 '(dispatch-type number
))))
332 (/ number
(abs number
))))))
336 (defun numerator (number)
337 "Return the numerator of NUMBER, which must be rational."
340 (defun denominator (number)
341 "Return the denominator of NUMBER, which must be rational."
342 (denominator number
))
344 ;;;; arithmetic operations
346 ;;;; IMPORTANT NOTE: Accessing &REST arguments with NTH is actually extremely
347 ;;;; efficient in SBCL, as is taking their LENGTH -- so this code is very
348 ;;;; clever instead of being charmingly naive. Please check that "obvious"
349 ;;;; improvements don't actually ruin performance.
351 ;;;; (Granted that the difference between very clever and charmingly naivve
352 ;;;; can sometimes be sliced exceedingly thing...)
354 (macrolet ((define-arith (op init doc
)
355 `(defun ,op
(&rest numbers
)
356 (declare (explicit-check))
359 (let ((result (the number
(fast-&rest-nth
0 numbers
))))
360 (do-rest-arg ((n) numbers
1 result
)
361 (setq result
(,op result n
))))
364 "Return the sum of its arguments. With no args, returns 0.")
366 "Return the product of its arguments. With no args, returns 1."))
368 (defun - (number &rest more-numbers
)
369 "Subtract the second and all subsequent arguments from the first;
370 or with one argument, negate the first argument."
371 (declare (explicit-check))
373 (let ((result number
))
374 (do-rest-arg ((n) more-numbers
0 result
)
375 (setf result
(- result n
))))
378 (defun / (number &rest more-numbers
)
379 "Divide the first argument by each of the following arguments, in turn.
380 With one argument, return reciprocal."
381 (declare (explicit-check))
383 (let ((result number
))
384 (do-rest-arg ((n) more-numbers
0 result
)
385 (setf result
(/ result n
))))
390 (declare (explicit-check))
395 (declare (explicit-check))
398 (eval-when (:compile-toplevel
)
400 (sb!xc
:defmacro two-arg-
+/-
(name op big-op
)
402 (number-dispatch ((x number
) (y number
))
403 (bignum-cross-fixnum ,op
,big-op
)
404 (float-contagion ,op x y
)
407 (canonical-complex (,op
(realpart x
) (realpart y
))
408 (,op
(imagpart x
) (imagpart y
))))
409 (((foreach bignum fixnum ratio single-float double-float
410 #!+long-float long-float
) complex
)
411 (complex (,op x
(realpart y
)) (,op
0 (imagpart y
))))
412 ((complex (or rational float
))
413 (complex (,op
(realpart x
) y
) (,op
(imagpart x
) 0)))
415 (((foreach fixnum bignum
) ratio
)
416 (let* ((dy (denominator y
))
417 (n (,op
(* x dy
) (numerator y
))))
420 (let* ((dx (denominator x
))
421 (n (,op
(numerator x
) (* y dx
))))
424 (let* ((nx (numerator x
))
430 (%make-ratio
(,op
(* nx dy
) (* dx ny
)) (* dx dy
))
431 (let* ((t2 (truncate dx g1
))
432 (t1 (,op
(* nx
(truncate dy g1
)) (* t2 ny
)))
436 (%make-ratio t1
(* t2 dy
)))
437 (t (let* ((nn (truncate t1 g2
))
438 (t3 (truncate dy g2
))
439 (nd (if (eql t2
1) t3
(* t2 t3
))))
440 (if (eql nd
1) nn
(%make-ratio nn nd
))))))))))))
444 (two-arg-+/- two-arg-
+ + add-bignums
)
445 (two-arg-+/- two-arg-- - subtract-bignum
)
447 (defun two-arg-* (x y
)
448 (flet ((integer*ratio
(x y
)
450 (let* ((ny (numerator y
))
454 (%make-ratio
(* x ny
) dy
)
455 (let ((nn (* (truncate x gcd
) ny
))
456 (nd (truncate dy gcd
)))
459 (%make-ratio nn nd
)))))))
461 (canonical-complex (* (realpart x
) y
) (* (imagpart x
) y
))))
462 (number-dispatch ((x number
) (y number
))
463 (float-contagion * x y
)
465 ((fixnum fixnum
) (multiply-fixnums x y
))
466 ((bignum fixnum
) (multiply-bignum-and-fixnum x y
))
467 ((fixnum bignum
) (multiply-bignum-and-fixnum y x
))
468 ((bignum bignum
) (multiply-bignums x y
))
471 (let* ((rx (realpart x
))
475 (canonical-complex (- (* rx ry
) (* ix iy
)) (+ (* rx iy
) (* ix ry
)))))
476 (((foreach bignum fixnum ratio single-float double-float
477 #!+long-float long-float
)
480 ((complex (or rational float
))
483 (((foreach bignum fixnum
) ratio
) (integer*ratio x y
))
484 ((ratio integer
) (integer*ratio y x
))
486 (let* ((nx (numerator x
))
492 (build-ratio (* (maybe-truncate nx g1
)
493 (maybe-truncate ny g2
))
494 (* (maybe-truncate dx g2
)
495 (maybe-truncate dy g1
))))))))
497 ;;; Divide two integers, producing a canonical rational. If a fixnum,
498 ;;; we see whether they divide evenly before trying the GCD. In the
499 ;;; bignum case, we don't bother, since bignum division is expensive,
500 ;;; and the test is not very likely to succeed.
501 (defun integer-/-integer
(x y
)
502 (if (and (typep x
'fixnum
) (typep y
'fixnum
))
503 (multiple-value-bind (quo rem
) (truncate x y
)
506 (let ((gcd (gcd x y
)))
507 (declare (fixnum gcd
))
510 (build-ratio (truncate x gcd
) (truncate y gcd
))))))
511 (let ((gcd (gcd x y
)))
514 (build-ratio (truncate x gcd
) (truncate y gcd
))))))
516 (defun two-arg-/ (x y
)
517 (number-dispatch ((x number
) (y number
))
518 (float-contagion / x y
(ratio integer
))
521 (let* ((rx (realpart x
))
525 (if (> (abs ry
) (abs iy
))
527 (dn (* ry
(+ 1 (* r r
)))))
528 (canonical-complex (/ (+ rx
(* ix r
)) dn
)
529 (/ (- ix
(* rx r
)) dn
)))
531 (dn (* iy
(+ 1 (* r r
)))))
532 (canonical-complex (/ (+ (* rx r
) ix
) dn
)
533 (/ (- (* ix r
) rx
) dn
))))))
534 (((foreach integer ratio single-float double-float
) complex
)
535 (let* ((ry (realpart y
))
537 (if (> (abs ry
) (abs iy
))
539 (dn (* ry
(+ 1 (* r r
)))))
540 (canonical-complex (/ x dn
)
543 (dn (* iy
(+ 1 (* r r
)))))
544 (canonical-complex (/ (* x r
) dn
)
546 ((complex (or rational float
))
547 (canonical-complex (/ (realpart x
) y
)
551 (let* ((nx (numerator x
))
557 (build-ratio (* (maybe-truncate nx g1
) (maybe-truncate dy g2
))
558 (* (maybe-truncate dx g2
) (maybe-truncate ny g1
)))))
561 (integer-/-integer x y
))
566 (let* ((ny (numerator y
))
569 (build-ratio (* (maybe-truncate x gcd
) dy
)
570 (maybe-truncate ny gcd
)))))
573 (let* ((nx (numerator x
))
575 (build-ratio (maybe-truncate nx gcd
)
576 (* (maybe-truncate y gcd
) (denominator x
)))))))
579 (declare (explicit-check))
580 (number-dispatch ((n number
))
581 (((foreach fixnum single-float double-float
#!+long-float long-float
))
586 (%make-ratio
(- (numerator n
)) (denominator n
)))
588 (complex (- (realpart n
)) (- (imagpart n
))))))
590 ;;;; TRUNCATE and friends
592 (defun truncate (number &optional
(divisor 1))
593 "Return number (or number/divisor) as an integer, rounded toward 0.
594 The second returned value is the remainder."
595 (declare (explicit-check))
596 (macrolet ((truncate-float (rtype)
597 `(let* ((float-div (coerce divisor
',rtype
))
598 (res (%unary-truncate
(/ number float-div
))))
601 (* (coerce res
',rtype
) float-div
))))))
602 (number-dispatch ((number real
) (divisor real
))
603 ((fixnum fixnum
) (truncate number divisor
))
604 (((foreach fixnum bignum
) ratio
)
605 (if (= (numerator divisor
) 1)
606 (values (* number
(denominator divisor
)) 0)
607 (multiple-value-bind (quot rem
)
608 (truncate (* number
(denominator divisor
))
610 (values quot
(/ rem
(denominator divisor
))))))
612 (bignum-truncate (make-small-bignum number
) divisor
))
613 ((ratio (or float rational
))
614 (let ((q (truncate (numerator number
)
615 (* (denominator number
) divisor
))))
616 (values q
(- number
(* q divisor
)))))
618 (bignum-truncate number
(make-small-bignum divisor
)))
620 (bignum-truncate number divisor
))
622 (((foreach single-float double-float
#!+long-float long-float
)
623 (or rational single-float
))
625 (let ((res (%unary-truncate number
)))
626 (values res
(- number
(coerce res
'(dispatch-type number
)))))
627 (truncate-float (dispatch-type number
))))
629 ((long-float (or single-float double-float long-float
))
630 (truncate-float long-float
))
632 (((foreach double-float single-float
) long-float
)
633 (truncate-float long-float
))
634 ((double-float (or single-float double-float
))
635 (truncate-float double-float
))
636 ((single-float double-float
)
637 (truncate-float double-float
))
638 (((foreach fixnum bignum ratio
)
639 (foreach single-float double-float
#!+long-float long-float
))
640 (truncate-float (dispatch-type divisor
))))))
642 (defun %multiply-high
(x y
)
643 (declare (type word x y
))
644 (%multiply-high x y
))
646 (defun floor (number &optional
(divisor 1))
647 "Return the greatest integer not greater than number, or number/divisor.
648 The second returned value is (mod number divisor)."
649 (declare (explicit-check))
650 (floor number divisor
))
652 (defun ceiling (number &optional
(divisor 1))
653 "Return the smallest integer not less than number, or number/divisor.
654 The second returned value is the remainder."
655 (declare (explicit-check))
656 (ceiling number divisor
))
658 (defun rem (number divisor
)
659 "Return second result of TRUNCATE."
660 (declare (explicit-check))
661 (rem number divisor
))
663 (defun mod (number divisor
)
664 "Return second result of FLOOR."
665 (declare (explicit-check))
666 (mod number divisor
))
668 (defun round (number &optional
(divisor 1))
669 "Rounds number (or number/divisor) to nearest integer.
670 The second returned value is the remainder."
671 (declare (explicit-check))
674 (multiple-value-bind (tru rem
) (truncate number divisor
)
677 (let ((thresh (/ (abs divisor
) 2)))
678 (cond ((or (> rem thresh
)
679 (and (= rem thresh
) (oddp tru
)))
681 (values (- tru
1) (+ rem divisor
))
682 (values (+ tru
1) (- rem divisor
))))
683 ((let ((-thresh (- thresh
)))
685 (and (= rem -thresh
) (oddp tru
))))
687 (values (+ tru
1) (- rem divisor
))
688 (values (- tru
1) (+ rem divisor
))))
689 (t (values tru rem
))))))))
691 (defmacro !define-float-rounding-function
(name op doc
)
692 `(defun ,name
(number &optional
(divisor 1))
694 (multiple-value-bind (res rem
) (,op number divisor
)
695 (values (float res
(if (floatp rem
) rem
1.0)) rem
))))
697 ;;; Declare these guys inline to let them get optimized a little.
698 ;;; ROUND and FROUND are not declared inline since they seem too
699 ;;; obscure and too big to inline-expand by default. Also, this gives
700 ;;; the compiler a chance to pick off the unary float case.
701 #!-sb-fluid
(declaim (inline fceiling ffloor ftruncate
))
702 (defun ftruncate (number &optional
(divisor 1))
703 "Same as TRUNCATE, but returns first value as a float."
704 (declare (explicit-check))
705 (macrolet ((ftruncate-float (rtype)
706 `(let* ((float-div (coerce divisor
',rtype
))
707 (res (%unary-ftruncate
(/ number float-div
))))
710 (* (coerce res
',rtype
) float-div
))))))
711 (number-dispatch ((number real
) (divisor real
))
712 (((foreach fixnum bignum ratio
) (or fixnum bignum ratio
))
713 (multiple-value-bind (q r
)
714 (truncate number divisor
)
715 (values (float q
) r
)))
716 (((foreach single-float double-float
#!+long-float long-float
)
717 (or rational single-float
))
719 (let ((res (%unary-ftruncate number
)))
720 (values res
(- number
(coerce res
'(dispatch-type number
)))))
721 (ftruncate-float (dispatch-type number
))))
723 ((long-float (or single-float double-float long-float
))
724 (ftruncate-float long-float
))
726 (((foreach double-float single-float
) long-float
)
727 (ftruncate-float long-float
))
728 ((double-float (or single-float double-float
))
729 (ftruncate-float double-float
))
730 ((single-float double-float
)
731 (ftruncate-float double-float
))
732 (((foreach fixnum bignum ratio
)
733 (foreach single-float double-float
#!+long-float long-float
))
734 (ftruncate-float (dispatch-type divisor
))))))
736 (defun ffloor (number &optional
(divisor 1))
737 "Same as FLOOR, but returns first value as a float."
738 (declare (explicit-check))
739 (multiple-value-bind (tru rem
) (ftruncate number divisor
)
740 (if (and (not (zerop rem
))
744 (values (1- tru
) (+ rem divisor
))
747 (defun fceiling (number &optional
(divisor 1))
748 "Same as CEILING, but returns first value as a float."
749 (declare (explicit-check))
750 (multiple-value-bind (tru rem
) (ftruncate number divisor
)
751 (if (and (not (zerop rem
))
755 (values (+ tru
1) (- rem divisor
))
758 ;;; FIXME: this probably needs treatment similar to the use of
759 ;;; %UNARY-FTRUNCATE for FTRUNCATE.
760 (defun fround (number &optional
(divisor 1))
761 "Same as ROUND, but returns first value as a float."
762 (declare (explicit-check))
763 (multiple-value-bind (res rem
)
764 (round number divisor
)
765 (values (float res
(if (floatp rem
) rem
1.0)) rem
)))
769 (defun = (number &rest more-numbers
)
770 "Return T if all of its arguments are numerically equal, NIL otherwise."
771 (declare (number number
) (explicit-check))
772 (do-rest-arg ((n i
) more-numbers
0 t
)
774 (return (do-rest-arg ((n) more-numbers
(1+ i
))
775 (the number n
)))))) ; for effect
777 (defun /= (number &rest more-numbers
)
778 "Return T if no two of its arguments are numerically equal, NIL otherwise."
779 (declare (number number
) (explicit-check))
781 (do ((n number
(nth i more-numbers
))
783 ((>= i
(length more-numbers
))
785 (do-rest-arg ((n2) more-numbers i
)
787 (return-from /= nil
))))
790 (macrolet ((def (op doc
)
791 `(defun ,op
(number &rest more-numbers
)
793 (declare (explicit-check))
796 (do-rest-arg ((n2 i
) more-numbers
0 t
)
799 (return (do-rest-arg ((n) more-numbers
(1+ i
))
800 (the real n
))))))))) ; for effect
801 (def < "Return T if its arguments are in strictly increasing order, NIL otherwise.")
802 (def > "Return T if its arguments are in strictly decreasing order, NIL otherwise.")
803 (def <= "Return T if arguments are in strictly non-decreasing order, NIL otherwise.")
804 (def >= "Return T if arguments are in strictly non-increasing order, NIL otherwise."))
806 (defun max (number &rest more-numbers
)
807 "Return the greatest of its arguments; among EQUALP greatest, return
809 (declare (explicit-check))
812 (do-rest-arg ((arg) more-numbers
0 n
)
816 (defun min (number &rest more-numbers
)
817 "Return the least of its arguments; among EQUALP least, return
819 (declare (explicit-check))
822 (do-rest-arg ((arg) more-numbers
0 n
)
826 (defmacro make-fixnum-float-comparer
(operation integer float float-type
)
827 (multiple-value-bind (min max
)
830 (values most-negative-fixnum-single-float most-positive-fixnum-single-float
))
832 (values most-negative-fixnum-double-float most-positive-fixnum-double-float
)))
833 ` (cond ((> ,float
,max
)
842 (let ((quot (%unary-truncate
,float
)))
845 `(and (= quot
,integer
)
846 (= (float quot
,float
) ,float
)))
848 `(cond ((> ,integer quot
))
852 (> (float quot
,float
) ,float
))))
854 `(cond ((< ,integer quot
))
858 (< (float quot
,float
) ,float
))))))))))
860 (eval-when (:compile-toplevel
:execute
)
861 ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
862 ;;; to handle the case when X or Y is a floating-point infinity and
863 ;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec
864 ;;; says that comparisons are done by converting the float to a
865 ;;; rational when comparing with a rational, but infinities can't be
866 ;;; converted to a rational, so we show some initiative and do it this
868 (defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x
)
869 `(((fixnum fixnum
) (,op x y
))
870 ((single-float single-float
) (,op x y
))
872 (((foreach single-float double-float long-float
) long-float
)
873 (,op
(coerce x
'long-float
) y
))
875 ((long-float (foreach single-float double-float
))
876 (,op x
(coerce y
'long-float
)))
877 ((fixnum (foreach single-float double-float
))
878 (if (float-infinity-p y
)
880 (make-fixnum-float-comparer ,op x y
(dispatch-type y
))))
881 (((foreach single-float double-float
) fixnum
)
883 (,op x
(coerce 0 '(dispatch-type x
)))
884 (if (float-infinity-p x
)
887 (make-fixnum-float-comparer ,(case op
891 y x
(dispatch-type x
)))))
892 (((foreach single-float double-float
) double-float
)
893 (,op
(coerce x
'double-float
) y
))
894 ((double-float single-float
)
895 (,op x
(coerce y
'double-float
)))
896 (((foreach single-float double-float
#!+long-float long-float
) rational
)
898 (,op x
(coerce 0 '(dispatch-type x
)))
899 (if (float-infinity-p x
)
901 (,op
(rational x
) y
))))
902 (((foreach bignum fixnum ratio
) float
)
903 (if (float-infinity-p y
)
905 (,op x
(rational y
))))))
909 (macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2
&rest cases
)
911 (number-dispatch ((x real
) (y real
))
915 (,op x
(coerce 0 '(dispatch-type x
)))
917 (,op
(coerce 0 '(dispatch-type y
)) y
))
918 (((foreach fixnum bignum
) ratio
)
919 (,op x
(,ratio-arg2
(numerator y
)
922 (,op
(,ratio-arg1
(numerator x
)
926 (,op
(* (numerator (truly-the ratio x
))
927 (denominator (truly-the ratio y
)))
928 (* (numerator (truly-the ratio y
))
929 (denominator (truly-the ratio x
)))))
931 (def-two-arg-</> two-arg-
< < floor ceiling
935 (not (bignum-plus-p x
)))
937 (minusp (bignum-compare x y
))))
938 (def-two-arg-</> two-arg-
> > ceiling floor
940 (not (bignum-plus-p y
)))
944 (plusp (bignum-compare x y
)))))
946 (defun two-arg-= (x y
)
947 (number-dispatch ((x number
) (y number
))
949 ;; An infinite value is never equal to a finite value.
950 :infinite-x-finite-y nil
951 :infinite-y-finite-x nil
)
952 ((fixnum (or bignum ratio
)) nil
)
954 ((bignum (or fixnum ratio
)) nil
)
956 (zerop (bignum-compare x y
)))
958 ((ratio integer
) nil
)
960 (and (eql (numerator x
) (numerator y
))
961 (eql (denominator x
) (denominator y
))))
964 (and (= (realpart x
) (realpart y
))
965 (= (imagpart x
) (imagpart y
))))
966 (((foreach fixnum bignum ratio single-float double-float
967 #!+long-float long-float
) complex
)
968 (and (= x
(realpart y
))
969 (zerop (imagpart y
))))
970 ((complex (or float rational
))
971 (and (= (realpart x
) y
)
972 (zerop (imagpart x
))))))
976 (macrolet ((def (op init doc
)
977 `(defun ,op
(&rest integers
)
979 (declare (explicit-check))
981 (do ((result (fast-&rest-nth
0 integers
)
982 (,op result
(fast-&rest-nth i integers
)))
984 ((>= i
(length integers
))
986 (declare (integer result
)))
988 (def logior
0 "Return the bit-wise or of its arguments. Args must be integers.")
989 (def logxor
0 "Return the bit-wise exclusive or of its arguments. Args must be integers.")
990 (def logand -
1 "Return the bit-wise and of its arguments. Args must be integers.")
991 (def logeqv -
1 "Return the bit-wise equivalence of its arguments. Args must be integers."))
993 (defun lognot (number)
994 "Return the bit-wise logical not of integer."
995 (declare (explicit-check))
997 (fixnum (lognot (truly-the fixnum number
)))
998 (bignum (bignum-logical-not number
))))
1000 (macrolet ((def (name explicit-check op big-op
&optional doc
)
1001 `(defun ,name
(integer1 integer2
)
1002 ,@(when doc
(list doc
))
1003 ,@(when explicit-check
`((declare (explicit-check))))
1006 (number-dispatch ((x integer
) (y integer
))
1007 (bignum-cross-fixnum ,op
,big-op
))))))
1008 (def two-arg-and nil logand bignum-logical-and
)
1009 (def two-arg-ior nil logior bignum-logical-ior
)
1010 (def two-arg-xor nil logxor bignum-logical-xor
)
1011 ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must
1012 ;; call the generic LOGNOT...
1013 (def two-arg-eqv nil logeqv
(lambda (x y
) (lognot (bignum-logical-xor x y
))))
1014 (def lognand t lognand
1015 (lambda (x y
) (lognot (bignum-logical-and x y
)))
1016 "Complement the logical AND of INTEGER1 and INTEGER2.")
1017 (def lognor t lognor
1018 (lambda (x y
) (lognot (bignum-logical-ior x y
)))
1019 "Complement the logical OR of INTEGER1 and INTEGER2.")
1020 ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum
1021 (def logandc1 t logandc1
1022 (lambda (x y
) (bignum-logical-and (bignum-logical-not x
) y
))
1023 "Bitwise AND (LOGNOT INTEGER1) with INTEGER2.")
1024 (def logandc2 t logandc2
1025 (lambda (x y
) (bignum-logical-and x
(bignum-logical-not y
)))
1026 "Bitwise AND INTEGER1 with (LOGNOT INTEGER2).")
1027 (def logorc1 t logorc1
1028 (lambda (x y
) (bignum-logical-ior (bignum-logical-not x
) y
))
1029 "Bitwise OR (LOGNOT INTEGER1) with INTEGER2.")
1030 (def logorc2 t logorc2
1031 (lambda (x y
) (bignum-logical-ior x
(bignum-logical-not y
)))
1032 "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)."))
1034 (defun logcount (integer)
1035 "Count the number of 1 bits if INTEGER is non-negative,
1036 and the number of 0 bits if INTEGER is negative."
1037 (declare (explicit-check))
1040 (logcount (truly-the (integer 0
1041 #.
(max sb
!xc
:most-positive-fixnum
1042 (lognot sb
!xc
:most-negative-fixnum
)))
1043 (if (minusp (truly-the fixnum integer
))
1044 (lognot (truly-the fixnum integer
))
1047 (bignum-logcount integer
))))
1049 (defun logtest (integer1 integer2
)
1050 "Predicate which returns T if logand of integer1 and integer2 is not zero."
1051 (logtest integer1 integer2
))
1053 (defun logbitp (index integer
)
1054 "Predicate returns T if bit index of integer is a 1."
1055 (number-dispatch ((index integer
) (integer integer
))
1056 ((fixnum fixnum
) (if (< index sb
!vm
:n-positive-fixnum-bits
)
1057 (not (zerop (logand integer
(ash 1 index
))))
1059 ((fixnum bignum
) (bignum-logbitp index integer
))
1060 ((bignum (foreach fixnum bignum
)) (minusp integer
))))
1062 (defun ash (integer count
)
1063 "Shifts integer left by count places preserving sign. - count shifts right."
1064 (declare (integer integer count
) (explicit-check))
1067 (cond ((zerop integer
)
1070 (let ((length (integer-length (truly-the fixnum integer
)))
1071 (count (truly-the fixnum count
)))
1072 (declare (fixnum length count
))
1073 (cond ((and (plusp count
)
1074 (>= (+ length count
)
1076 (bignum-ashift-left-fixnum integer count
))
1078 (truly-the (signed-byte #.sb
!vm
:n-word-bits
)
1079 (ash (truly-the fixnum integer
) count
))))))
1081 (if (minusp integer
) -
1 0))
1083 (bignum-ashift-left (make-small-bignum integer
) count
))))
1086 (bignum-ashift-left integer count
)
1087 (bignum-ashift-right integer
(- count
))))))
1089 (defun integer-length (integer)
1090 "Return the number of non-sign bits in the twos-complement representation
1092 (declare (explicit-check))
1095 (integer-length (truly-the fixnum integer
)))
1097 (bignum-integer-length integer
))))
1099 ;;;; BYTE, bytespecs, and related operations
1101 (defun byte (size position
)
1102 "Return a byte specifier which may be used by other byte functions
1104 (byte size position
))
1106 (defun byte-size (bytespec)
1107 "Return the size part of the byte specifier bytespec."
1108 (byte-size bytespec
))
1110 (defun byte-position (bytespec)
1111 "Return the position part of the byte specifier bytespec."
1112 (byte-position bytespec
))
1114 (defun ldb (bytespec integer
)
1115 "Extract the specified byte from integer, and right justify result."
1116 (ldb bytespec integer
))
1118 (defun ldb-test (bytespec integer
)
1119 "Return T if any of the specified bits in integer are 1's."
1120 (ldb-test bytespec integer
))
1122 (defun mask-field (bytespec integer
)
1123 "Extract the specified byte from integer, but do not right justify result."
1124 (mask-field bytespec integer
))
1126 (defun dpb (newbyte bytespec integer
)
1127 "Return new integer with newbyte in specified position, newbyte is right justified."
1128 (dpb newbyte bytespec integer
))
1130 (defun deposit-field (newbyte bytespec integer
)
1131 "Return new integer with newbyte in specified position, newbyte is not right justified."
1132 (deposit-field newbyte bytespec integer
))
1134 (defun %ldb
(size posn integer
)
1135 (declare (type bit-index size posn
) (explicit-check))
1136 ;; The naive algorithm is horrible in the general case.
1137 ;; Consider (LDB (BYTE 1 2) (SOME-GIANT-BIGNUM)) which has to shift the
1138 ;; input rightward 2 bits, consing a new bignum just to read 1 bit.
1139 (if (and (<= 0 size sb
!vm
:n-positive-fixnum-bits
)
1140 (typep integer
'bignum
))
1141 (sb!bignum
::ldb-bignum
=>fixnum size posn integer
)
1142 (logand (ash integer
(- posn
))
1143 (1- (ash 1 size
)))))
1145 (defun %mask-field
(size posn integer
)
1146 (declare (type bit-index size posn
) (explicit-check))
1147 (logand integer
(ash (1- (ash 1 size
)) posn
)))
1149 (defun %dpb
(newbyte size posn integer
)
1150 (declare (type bit-index size posn
) (explicit-check))
1151 (let ((mask (1- (ash 1 size
))))
1152 (logior (logand integer
(lognot (ash mask posn
)))
1153 (ash (logand newbyte mask
) posn
))))
1155 (defun %deposit-field
(newbyte size posn integer
)
1156 (declare (type bit-index size posn
) (explicit-check))
1157 (let ((mask (ash (ldb (byte size
0) -
1) posn
)))
1158 (logior (logand newbyte mask
)
1159 (logand integer
(lognot mask
)))))
1161 (defun sb!c
::mask-signed-field
(size integer
)
1162 "Extract SIZE lower bits from INTEGER, considering them as a
1163 2-complement SIZE-bits representation of a signed integer."
1164 (macrolet ((msf (size integer
)
1165 `(if (logbitp (1- ,size
) ,integer
)
1166 (dpb ,integer
(byte (1- ,size
) 0) -
1)
1167 (ldb (byte (1- ,size
) 0) ,integer
))))
1170 ((integer 1 #.sb
!vm
:n-fixnum-bits
)
1171 (number-dispatch ((integer integer
))
1172 ((fixnum) (msf size integer
))
1173 ((bignum) (let ((fix (sb!c
::mask-signed-field
#.sb
!vm
:n-fixnum-bits
(%bignum-ref integer
0))))
1174 (if (= size
#.sb
!vm
:n-fixnum-bits
)
1177 ((integer (#.sb
!vm
:n-fixnum-bits
) #.sb
!vm
:n-word-bits
)
1178 (number-dispatch ((integer integer
))
1180 ((bignum) (let ((word (sb!c
::mask-signed-field
#.sb
!vm
:n-word-bits
(%bignum-ref integer
0))))
1181 (if (= size
#.sb
!vm
:n-word-bits
)
1183 (msf size word
))))))
1184 ((unsigned-byte) (msf size integer
)))))
1188 (defun boole (op integer1 integer2
)
1189 "Bit-wise boolean function on two integers. Function chosen by OP:
1207 (0 (boole 0 integer1 integer2
))
1208 (1 (boole 1 integer1 integer2
))
1209 (2 (boole 2 integer1 integer2
))
1210 (3 (boole 3 integer1 integer2
))
1211 (4 (boole 4 integer1 integer2
))
1212 (5 (boole 5 integer1 integer2
))
1213 (6 (boole 6 integer1 integer2
))
1214 (7 (boole 7 integer1 integer2
))
1215 (8 (boole 8 integer1 integer2
))
1216 (9 (boole 9 integer1 integer2
))
1217 (10 (boole 10 integer1 integer2
))
1218 (11 (boole 11 integer1 integer2
))
1219 (12 (boole 12 integer1 integer2
))
1220 (13 (boole 13 integer1 integer2
))
1221 (14 (boole 14 integer1 integer2
))
1222 (15 (boole 15 integer1 integer2
))
1223 (t (error 'type-error
:datum op
:expected-type
'(mod 16)))))
1227 (defun gcd (&rest integers
)
1228 "Return the greatest common divisor of the arguments, which must be
1229 integers. GCD with no arguments is defined to be 0."
1230 (declare (explicit-check))
1231 (case (length integers
)
1233 (1 (abs (the integer
(fast-&rest-nth
0 integers
))))
1235 (do ((result (fast-&rest-nth
0 integers
)
1236 (gcd result
(the integer
(fast-&rest-nth i integers
))))
1238 ((>= i
(length integers
))
1240 (declare (integer result
))))))
1242 (defun lcm (&rest integers
)
1243 "Return the least common multiple of one or more integers. LCM of no
1244 arguments is defined to be 1."
1245 (declare (explicit-check))
1246 (case (length integers
)
1248 (1 (abs (the integer
(fast-&rest-nth
0 integers
))))
1250 (do ((result (fast-&rest-nth
0 integers
)
1251 (lcm result
(the integer
(fast-&rest-nth i integers
))))
1253 ((>= i
(length integers
))
1255 (declare (integer result
))))))
1257 (defun two-arg-lcm (n m
)
1258 (declare (integer n m
))
1259 (if (or (zerop n
) (zerop m
))
1261 ;; KLUDGE: I'm going to assume that it was written this way
1262 ;; originally for a reason. However, this is a somewhat
1263 ;; complicated way of writing the algorithm in the CLHS page for
1264 ;; LCM, and I don't know why. To be investigated. -- CSR,
1267 ;; It seems to me that this is written this way to avoid
1268 ;; unnecessary bignumification of intermediate results.
1269 ;; -- TCR, 2008-03-05
1272 (multiple-value-bind (max min
)
1276 (* (truncate max
(gcd n m
)) min
)))))
1278 ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
1279 ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
1280 ;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
1281 ;;; of 0 before the dispatch so that the bignum code doesn't have to worry
1282 ;;; about "small bignum" zeros.
1283 (defun two-arg-gcd (u v
)
1284 (cond ((eql u
0) (abs v
))
1287 (number-dispatch ((u integer
) (v integer
))
1290 (declare (optimize (speed 3) (safety 0)))
1292 (u (abs u
) (ash u -
1))
1293 (v (abs v
) (ash v -
1)))
1294 ((oddp (logior u v
))
1295 (do ((temp (if (oddp u
) (- v
) (ash u -
1))
1298 (declare (fixnum temp
))
1305 (let ((res (ash u k
)))
1306 (declare (type sb
!vm
:signed-word res
)
1307 (optimize (inhibit-warnings 3)))
1309 (declare (type (mod #.sb
!vm
:n-word-bits
) k
)
1310 (type sb
!vm
:signed-word u v
)))))
1314 (bignum-gcd u
(make-small-bignum v
)))
1316 (bignum-gcd (make-small-bignum u
) v
))))))
1318 ;;; from Robert Smith; changed not to cons unnecessarily, and tuned for
1319 ;;; faster operation on fixnum inputs by compiling the central recursive
1320 ;;; algorithm twice, once using generic and once fixnum arithmetic, and
1321 ;;; dispatching on function entry into the applicable part. For maximum
1322 ;;; speed, the fixnum part recurs into itself, thereby avoiding further
1323 ;;; type dispatching. This pattern is not supported by NUMBER-DISPATCH
1324 ;;; thus some special-purpose macrology is needed.
1326 "Return the greatest integer less than or equal to the square root of N."
1327 (declare (type unsigned-byte n
) (explicit-check))
1329 ((isqrt-recursion (arg recurse fixnum-p
)
1330 ;; Expands into code for the recursive step of the ISQRT
1331 ;; calculation. ARG is the input variable and RECURSE the name
1332 ;; of the function to recur into. If FIXNUM-P is true, some
1333 ;; type declarations are added that, together with ARG being
1334 ;; declared as a fixnum outside of here, make the resulting code
1335 ;; compile into fixnum-specialized code without any calls to
1336 ;; generic arithmetic. Else, the code works for bignums, too.
1337 ;; The input must be at least 16 to ensure that RECURSE is called
1338 ;; with a strictly smaller number and that the result is correct
1339 ;; (provided that RECURSE correctly implements ISQRT, itself).
1340 `(macrolet ((if-fixnum-p-truly-the (type expr
)
1342 '(`(truly-the ,type
,expr
))
1343 '((declare (ignore type
))
1345 (let* ((fourth-size (ash (1- (integer-length ,arg
)) -
2))
1346 (significant-half (ash ,arg
(- (ash fourth-size
1))))
1347 (significant-half-isqrt
1348 (if-fixnum-p-truly-the
1349 (integer 1 #.
(isqrt sb
!xc
:most-positive-fixnum
))
1350 (,recurse significant-half
)))
1351 (zeroth-iteration (ash significant-half-isqrt
1353 (multiple-value-bind (quot rem
)
1354 (floor ,arg zeroth-iteration
)
1355 (let ((first-iteration (ash (+ zeroth-iteration quot
) -
1)))
1358 ((> (if-fixnum-p-truly-the
1360 (expt (- first-iteration zeroth-iteration
) 2))
1362 (1- first-iteration
))
1364 first-iteration
))))))))
1366 (fixnum (labels ((fixnum-isqrt (n)
1367 (declare (type fixnum n
))
1369 (isqrt-recursion n fixnum-isqrt t
))
1376 (bignum (isqrt-recursion n isqrt nil
)))))
1378 ;;;; miscellaneous number predicates
1380 (macrolet ((def (name doc
)
1381 `(defun ,name
(number) ,doc
1382 (declare (explicit-check))
1384 (def zerop
"Is this number zero?")
1385 (def plusp
"Is this real number strictly positive?")
1386 (def minusp
"Is this real number strictly negative?")
1387 (def oddp
"Is this integer odd?")
1388 (def evenp
"Is this integer even?"))
1390 ;;;; modular functions
1393 (flet ((unsigned-definition (name lambda-list width
)
1394 (let ((pattern (1- (ash 1 width
))))
1395 `(defun ,name
,(copy-list lambda-list
)
1396 (flet ((prepare-argument (x)
1397 (declare (integer x
))
1399 ((unsigned-byte ,width
) x
)
1400 (fixnum (logand x
,pattern
))
1401 (bignum (logand x
,pattern
)))))
1402 (,name
,@(loop for arg in lambda-list
1403 collect
`(prepare-argument ,arg
)))))))
1404 (signed-definition (name lambda-list width
)
1405 `(defun ,name
,(copy-list lambda-list
)
1406 (flet ((prepare-argument (x)
1407 (declare (integer x
))
1409 ((signed-byte ,width
) x
)
1410 (fixnum (sb!c
::mask-signed-field
,width x
))
1411 (bignum (sb!c
::mask-signed-field
,width x
)))))
1412 (,name
,@(loop for arg in lambda-list
1413 collect
`(prepare-argument ,arg
)))))))
1414 (flet ((do-mfuns (class)
1415 (loop for infos being each hash-value of
(sb!c
::modular-class-funs class
)
1416 ;; FIXME: We need to process only "toplevel" functions
1418 do
(loop for info in infos
1419 for name
= (sb!c
::modular-fun-info-name info
)
1420 and width
= (sb!c
::modular-fun-info-width info
)
1421 and signedp
= (sb!c
::modular-fun-info-signedp info
)
1422 and lambda-list
= (sb!c
::modular-fun-info-lambda-list info
)
1424 do
(forms (signed-definition name lambda-list width
))
1426 do
(forms (unsigned-definition name lambda-list width
))))))
1427 (do-mfuns sb
!c
::*untagged-unsigned-modular-class
*)
1428 (do-mfuns sb
!c
::*untagged-signed-modular-class
*)
1429 (do-mfuns sb
!c
::*tagged-modular-class
*)))
1430 `(progn ,@(sort (forms) #'string
< :key
#'cadr
)))
1432 ;;; KLUDGE: these out-of-line definitions can't use the modular
1433 ;;; arithmetic, as that is only (currently) defined for constant
1434 ;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more
1435 ;;; discussion of this hack. -- CSR, 2003-10-09
1437 (defun sb!vm
::ash-left-mod32
(integer amount
)
1439 ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount
)))
1440 (fixnum (ldb (byte 32 0) (ash (logand integer
#xffffffff
) amount
)))
1441 (bignum (ldb (byte 32 0) (ash (logand integer
#xffffffff
) amount
)))))
1443 (defun sb!vm
::ash-left-mod64
(integer amount
)
1445 ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount
)))
1446 (fixnum (ldb (byte 64 0) (ash (logand integer
#xffffffffffffffff
) amount
)))
1447 (bignum (ldb (byte 64 0)
1448 (ash (logand integer
#xffffffffffffffff
) amount
)))))
1450 #!+(or x86 x86-64 arm arm64
)
1451 (defun sb!vm
::ash-left-modfx
(integer amount
)
1452 (let ((fixnum-width (- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
)))
1454 (fixnum (sb!c
::mask-signed-field fixnum-width
(ash integer amount
)))
1455 (integer (sb!c
::mask-signed-field fixnum-width
(ash (sb!c
::mask-signed-field fixnum-width integer
) amount
))))))