Fix a docstring typo.
[sbcl.git] / src / code / numbers.lisp
blob6a703cb29249c6d2da74dc8a0e835cf933c78bba
1 ;;;; This file contains the definitions of most number functions.
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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)
23 (cond ((null vars)
24 (unless (null types) (error "More types than vars."))
25 (when (cdr result)
26 (error "Duplicate case: ~S." body))
27 (setf (cdr result)
28 (sublis var-types body :test #'equal)))
29 ((null types)
30 (error "More vars than types."))
32 (flet ((frob (var type)
33 (parse-number-dispatch
34 (rest vars)
35 (or (assoc type (cdr result) :test #'equal)
36 (car (setf (cdr result)
37 (acons type nil (cdr result)))))
38 (rest types)
39 (acons `(dispatch-type ,var) type var-types)
40 body)))
41 (let ((type (first types))
42 (var (first vars)))
43 (if (and (consp type) (eq (first type) 'foreach))
44 (dolist (type (rest type))
45 (frob var type))
46 (frob var 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 bignum
52 complex ratio))
54 ;;; Should TYPE1 be tested before TYPE2?
55 (defun type-test-order (type1 type2)
56 (let ((o1 (position type1 *type-test-ordering*))
57 (o2 (position type2 *type-test-ordering*)))
58 (cond ((not o1) nil)
59 ((not o2) t)
61 (< o1 o2)))))
63 ;;; Return an ETYPECASE form that does the type dispatch, ordering the
64 ;;; cases for efficiency.
65 ;;; Check for some simple to detect problematic cases where the caller
66 ;;; used types that are not disjoint and where this may lead to
67 ;;; unexpected behaviour of the generated form, for example making
68 ;;; a clause unreachable, and throw an error if such a case is found.
69 ;;; An example:
70 ;;; (number-dispatch ((var1 integer) (var2 float))
71 ;;; ((fixnum single-float) a)
72 ;;; ((integer float) b))
73 ;;; Even though the types are not reordered here, the generated form,
74 ;;; basically
75 ;;; (etypecase var1
76 ;;; (fixnum (etypecase var2
77 ;;; (single-float a)))
78 ;;; (integer (etypecase var2
79 ;;; (float b))))
80 ;;; would fail at runtime if given var1 fixnum and var2 double-float,
81 ;;; even though the second clause matches this signature. To catch
82 ;;; this earlier than runtime we throw an error already here.
83 (defun generate-number-dispatch (vars error-tags cases)
84 (if vars
85 (let ((var (first vars))
86 (cases (sort cases #'type-test-order :key #'car)))
87 (flet ((error-if-sub-or-supertype (type1 type2)
88 (when (or (subtypep type1 type2)
89 (subtypep type2 type1))
90 (error "Types not disjoint: ~S ~S." type1 type2)))
91 (error-if-supertype (type1 type2)
92 (when (subtypep type2 type1)
93 (error "Type ~S ordered before subtype ~S."
94 type1 type2)))
95 (test-type-pairs (fun)
96 ;; Apply FUN to all (ordered) pairs of types from the
97 ;; cases.
98 (mapl (lambda (cases)
99 (when (cdr cases)
100 (let ((type1 (caar cases)))
101 (dolist (case (cdr cases))
102 (funcall fun type1 (car case))))))
103 cases)))
104 ;; For the last variable throw an error if a type is followed
105 ;; by a subtype, for all other variables additionally if a
106 ;; type is followed by a supertype.
107 (test-type-pairs (if (cdr vars)
108 #'error-if-sub-or-supertype
109 #'error-if-supertype)))
110 `((typecase ,var
111 ,@(mapcar (lambda (case)
112 `(,(first case)
113 ,@(generate-number-dispatch (rest vars)
114 (rest error-tags)
115 (cdr case))))
116 cases)
117 (t (go ,(first error-tags))))))
118 cases))
120 ) ; EVAL-WHEN
122 ;;; This is a vaguely case-like macro that does number cross-product
123 ;;; dispatches. The Vars are the variables we are dispatching off of.
124 ;;; The Type paired with each Var is used in the error message when no
125 ;;; case matches. Each case specifies a Type for each var, and is
126 ;;; executed when that signature holds. A type may be a list
127 ;;; (FOREACH Each-Type*), causing that case to be repeatedly
128 ;;; instantiated for every Each-Type. In the body of each case, any
129 ;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
130 ;;; type of that var in that instance of the case.
132 ;;; As an alternate to a case spec, there may be a form whose CAR is a
133 ;;; symbol. In this case, we apply the CAR of the form to the CDR and
134 ;;; treat the result of the call as a list of cases. This process is
135 ;;; not applied recursively.
137 ;;; Be careful when using non-disjoint types in different cases for the
138 ;;; same variable. Some uses will behave as intended, others not, as the
139 ;;; variables are dispatched off sequentially and clauses are reordered
140 ;;; for efficiency. Some, but not all, problematic cases are detected
141 ;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above
142 ;;; for an example.
143 (defmacro number-dispatch (var-specs &body cases)
144 (let ((res (list nil))
145 (vars (mapcar #'car var-specs))
146 (block (gensym)))
147 (dolist (case cases)
148 (if (symbolp (first case))
149 (let ((cases (apply (symbol-function (first case)) (rest case))))
150 (dolist (case cases)
151 (parse-number-dispatch vars res (first case) nil (rest case))))
152 (parse-number-dispatch vars res (first case) nil (rest case))))
154 (collect ((errors)
155 (error-tags))
156 (dolist (spec var-specs)
157 (let ((var (first spec))
158 (type (second spec))
159 (tag (gensym)))
160 (error-tags tag)
161 (errors tag)
162 (errors `(return-from
163 ,block
164 (error 'simple-type-error :datum ,var
165 :expected-type ',type
166 :format-control
167 "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
168 :format-arguments
169 (list ',var ',type ,var))))))
171 `(block ,block
172 (tagbody
173 (return-from ,block
174 ,@(generate-number-dispatch vars (error-tags)
175 (cdr res)))
176 ,@(errors))))))
178 ;;;; binary operation dispatching utilities
180 (eval-when (:compile-toplevel :execute)
182 ;;; Return NUMBER-DISPATCH forms for rational X float.
183 (defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
184 `(((single-float single-float) (,op ,x ,y))
185 (((foreach ,@rat-types)
186 (foreach single-float double-float #!+long-float long-float))
187 (,op (coerce ,x '(dispatch-type ,y)) ,y))
188 (((foreach single-float double-float #!+long-float long-float)
189 (foreach ,@rat-types))
190 (,op ,x (coerce ,y '(dispatch-type ,x))))
191 #!+long-float
192 (((foreach single-float double-float long-float) long-float)
193 (,op (coerce ,x 'long-float) ,y))
194 #!+long-float
195 ((long-float (foreach single-float double-float))
196 (,op ,x (coerce ,y 'long-float)))
197 (((foreach single-float double-float) double-float)
198 (,op (coerce ,x 'double-float) ,y))
199 ((double-float single-float)
200 (,op ,x (coerce ,y 'double-float)))))
202 ;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
203 (defun bignum-cross-fixnum (fix-op big-op)
204 `(((fixnum fixnum) (,fix-op x y))
205 ((fixnum bignum)
206 (,big-op (make-small-bignum x) y))
207 ((bignum fixnum)
208 (,big-op x (make-small-bignum y)))
209 ((bignum bignum)
210 (,big-op x y))))
212 ) ; EVAL-WHEN
214 ;;;; canonicalization utilities
216 ;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
217 ;;; used when we know that REALPART and IMAGPART are the same type, but
218 ;;; rational canonicalization might still need to be done.
219 #!-sb-fluid (declaim (inline canonical-complex))
220 (defun canonical-complex (realpart imagpart)
221 (if (eql imagpart 0)
222 realpart
223 (cond #!+long-float
224 ((and (typep realpart 'long-float)
225 (typep imagpart 'long-float))
226 (truly-the (complex long-float) (complex realpart imagpart)))
227 ((and (typep realpart 'double-float)
228 (typep imagpart 'double-float))
229 (truly-the (complex double-float) (complex realpart imagpart)))
230 ((and (typep realpart 'single-float)
231 (typep imagpart 'single-float))
232 (truly-the (complex single-float) (complex realpart imagpart)))
234 (%make-complex realpart imagpart)))))
236 ;;; Given a numerator and denominator with the GCD already divided
237 ;;; out, make a canonical rational. We make the denominator positive,
238 ;;; and check whether it is 1.
239 #!-sb-fluid (declaim (inline build-ratio))
240 (defun build-ratio (num den)
241 (multiple-value-bind (num den)
242 (if (minusp den)
243 (values (- num) (- den))
244 (values num den))
245 (cond
246 ((eql den 0)
247 (error 'division-by-zero
248 :operands (list num den)
249 :operation 'build-ratio))
250 ((eql den 1) num)
251 (t (%make-ratio num den)))))
253 ;;; Truncate X and Y, but bum the case where Y is 1.
254 #!-sb-fluid (declaim (inline maybe-truncate))
255 (defun maybe-truncate (x y)
256 (if (eql y 1)
258 (truncate x y)))
260 ;;;; COMPLEXes
262 (defun complex (realpart &optional (imagpart 0))
263 #!+sb-doc
264 "Return a complex number with the specified real and imaginary components."
265 (declare (explicit-check))
266 (flet ((%%make-complex (realpart imagpart)
267 (cond #!+long-float
268 ((and (typep realpart 'long-float)
269 (typep imagpart 'long-float))
270 (truly-the (complex long-float)
271 (complex realpart imagpart)))
272 ((and (typep realpart 'double-float)
273 (typep imagpart 'double-float))
274 (truly-the (complex double-float)
275 (complex realpart imagpart)))
276 ((and (typep realpart 'single-float)
277 (typep imagpart 'single-float))
278 (truly-the (complex single-float)
279 (complex realpart imagpart)))
281 (%make-complex realpart imagpart)))))
282 (number-dispatch ((realpart real) (imagpart real))
283 ((rational rational)
284 (canonical-complex realpart imagpart))
285 (float-contagion %%make-complex realpart imagpart (rational)))))
287 (defun realpart (number)
288 #!+sb-doc
289 "Extract the real part of a number."
290 (etypecase number
291 #!+long-float
292 ((complex long-float)
293 (truly-the long-float (realpart number)))
294 ((complex double-float)
295 (truly-the double-float (realpart number)))
296 ((complex single-float)
297 (truly-the single-float (realpart number)))
298 ((complex rational)
299 (%realpart number))
300 (number
301 number)))
303 (defun imagpart (number)
304 #!+sb-doc
305 "Extract the imaginary part of a number."
306 (etypecase number
307 #!+long-float
308 ((complex long-float)
309 (truly-the long-float (imagpart number)))
310 ((complex double-float)
311 (truly-the double-float (imagpart number)))
312 ((complex single-float)
313 (truly-the single-float (imagpart number)))
314 ((complex rational)
315 (%imagpart number))
316 (float
317 (* 0 number))
318 (number
319 0)))
321 (defun conjugate (number)
322 #!+sb-doc
323 "Return the complex conjugate of NUMBER. For non-complex numbers, this is
324 an identity."
325 (declare (type number number) (explicit-check))
326 (if (complexp number)
327 (complex (realpart number) (- (imagpart number)))
328 number))
330 (defun signum (number)
331 #!+sb-doc
332 "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
333 (declare (explicit-check))
334 (if (zerop number)
335 number
336 (if (rationalp number)
337 (if (plusp number) 1 -1)
338 (/ number (abs number)))))
340 ;;;; ratios
342 (defun numerator (number)
343 #!+sb-doc
344 "Return the numerator of NUMBER, which must be rational."
345 (numerator number))
347 (defun denominator (number)
348 #!+sb-doc
349 "Return the denominator of NUMBER, which must be rational."
350 (denominator number))
352 ;;;; arithmetic operations
353 ;;;;
354 ;;;; IMPORTANT NOTE: Accessing &REST arguments with NTH is actually extremely
355 ;;;; efficient in SBCL, as is taking their LENGTH -- so this code is very
356 ;;;; clever instead of being charmingly naive. Please check that "obvious"
357 ;;;; improvements don't actually ruin performance.
358 ;;;;
359 ;;;; (Granted that the difference between very clever and charmingly naivve
360 ;;;; can sometimes be sliced exceedingly thing...)
362 (macrolet ((define-arith (op init doc)
363 #!-sb-doc (declare (ignore doc))
364 `(defun ,op (&rest numbers)
365 (declare (explicit-check))
366 #!+sb-doc ,doc
367 (if numbers
368 (let ((result (the number (fast-&rest-nth 0 numbers))))
369 (do-rest-arg ((n) numbers 1 result)
370 (setq result (,op result n))))
371 ,init))))
372 (define-arith + 0
373 "Return the sum of its arguments. With no args, returns 0.")
374 (define-arith * 1
375 "Return the product of its arguments. With no args, returns 1."))
377 (defun - (number &rest more-numbers)
378 #!+sb-doc
379 "Subtract the second and all subsequent arguments from the first;
380 or with one argument, negate the first argument."
381 (declare (explicit-check))
382 (if more-numbers
383 (let ((result number))
384 (do-rest-arg ((n) more-numbers 0 result)
385 (setf result (- result n))))
386 (- number)))
388 (defun / (number &rest more-numbers)
389 #!+sb-doc
390 "Divide the first argument by each of the following arguments, in turn.
391 With one argument, return reciprocal."
392 (declare (explicit-check))
393 (if more-numbers
394 (let ((result number))
395 (do-rest-arg ((n) more-numbers 0 result)
396 (setf result (/ result n))))
397 (/ number)))
399 (defun 1+ (number)
400 #!+sb-doc
401 "Return NUMBER + 1."
402 (declare (explicit-check))
403 (1+ number))
405 (defun 1- (number)
406 #!+sb-doc
407 "Return NUMBER - 1."
408 (declare (explicit-check))
409 (1- number))
411 (eval-when (:compile-toplevel)
413 (sb!xc:defmacro two-arg-+/- (name op big-op)
414 `(defun ,name (x y)
415 (number-dispatch ((x number) (y number))
416 (bignum-cross-fixnum ,op ,big-op)
417 (float-contagion ,op x y)
419 ((complex complex)
420 (canonical-complex (,op (realpart x) (realpart y))
421 (,op (imagpart x) (imagpart y))))
422 (((foreach bignum fixnum ratio single-float double-float
423 #!+long-float long-float) complex)
424 (complex (,op x (realpart y)) (,op 0 (imagpart y))))
425 ((complex (or rational float))
426 (complex (,op (realpart x) y) (,op (imagpart x) 0)))
428 (((foreach fixnum bignum) ratio)
429 (let* ((dy (denominator y))
430 (n (,op (* x dy) (numerator y))))
431 (%make-ratio n dy)))
432 ((ratio integer)
433 (let* ((dx (denominator x))
434 (n (,op (numerator x) (* y dx))))
435 (%make-ratio n dx)))
436 ((ratio ratio)
437 (let* ((nx (numerator x))
438 (dx (denominator x))
439 (ny (numerator y))
440 (dy (denominator y))
441 (g1 (gcd dx dy)))
442 (if (eql g1 1)
443 (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
444 (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
445 (g2 (gcd t1 g1))
446 (t2 (truncate dx g1)))
447 (cond ((eql t1 0) 0)
448 ((eql g2 1)
449 (%make-ratio t1 (* t2 dy)))
450 (t (let* ((nn (truncate t1 g2))
451 (t3 (truncate dy g2))
452 (nd (if (eql t2 1) t3 (* t2 t3))))
453 (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
455 ) ; EVAL-WHEN
457 (two-arg-+/- two-arg-+ + add-bignums)
458 (two-arg-+/- two-arg-- - subtract-bignum)
460 (defun two-arg-* (x y)
461 (flet ((integer*ratio (x y)
462 (if (eql x 0) 0
463 (let* ((ny (numerator y))
464 (dy (denominator y))
465 (gcd (gcd x dy)))
466 (if (eql gcd 1)
467 (%make-ratio (* x ny) dy)
468 (let ((nn (* (truncate x gcd) ny))
469 (nd (truncate dy gcd)))
470 (if (eql nd 1)
472 (%make-ratio nn nd)))))))
473 (complex*real (x y)
474 (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
475 (number-dispatch ((x number) (y number))
476 (float-contagion * x y)
478 ((fixnum fixnum) (multiply-fixnums x y))
479 ((bignum fixnum) (multiply-bignum-and-fixnum x y))
480 ((fixnum bignum) (multiply-bignum-and-fixnum y x))
481 ((bignum bignum) (multiply-bignums x y))
483 ((complex complex)
484 (let* ((rx (realpart x))
485 (ix (imagpart x))
486 (ry (realpart y))
487 (iy (imagpart y)))
488 (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
489 (((foreach bignum fixnum ratio single-float double-float
490 #!+long-float long-float)
491 complex)
492 (complex*real y x))
493 ((complex (or rational float))
494 (complex*real x y))
496 (((foreach bignum fixnum) ratio) (integer*ratio x y))
497 ((ratio integer) (integer*ratio y x))
498 ((ratio ratio)
499 (let* ((nx (numerator x))
500 (dx (denominator x))
501 (ny (numerator y))
502 (dy (denominator y))
503 (g1 (gcd nx dy))
504 (g2 (gcd dx ny)))
505 (build-ratio (* (maybe-truncate nx g1)
506 (maybe-truncate ny g2))
507 (* (maybe-truncate dx g2)
508 (maybe-truncate dy g1))))))))
510 ;;; Divide two integers, producing a canonical rational. If a fixnum,
511 ;;; we see whether they divide evenly before trying the GCD. In the
512 ;;; bignum case, we don't bother, since bignum division is expensive,
513 ;;; and the test is not very likely to succeed.
514 (defun integer-/-integer (x y)
515 (if (and (typep x 'fixnum) (typep y 'fixnum))
516 (multiple-value-bind (quo rem) (truncate x y)
517 (if (zerop rem)
519 (let ((gcd (gcd x y)))
520 (declare (fixnum gcd))
521 (if (eql gcd 1)
522 (build-ratio x y)
523 (build-ratio (truncate x gcd) (truncate y gcd))))))
524 (let ((gcd (gcd x y)))
525 (if (eql gcd 1)
526 (build-ratio x y)
527 (build-ratio (truncate x gcd) (truncate y gcd))))))
529 (defun two-arg-/ (x y)
530 (number-dispatch ((x number) (y number))
531 (float-contagion / x y (ratio integer))
533 ((complex complex)
534 (let* ((rx (realpart x))
535 (ix (imagpart x))
536 (ry (realpart y))
537 (iy (imagpart y)))
538 (if (> (abs ry) (abs iy))
539 (let* ((r (/ iy ry))
540 (dn (* ry (+ 1 (* r r)))))
541 (canonical-complex (/ (+ rx (* ix r)) dn)
542 (/ (- ix (* rx r)) dn)))
543 (let* ((r (/ ry iy))
544 (dn (* iy (+ 1 (* r r)))))
545 (canonical-complex (/ (+ (* rx r) ix) dn)
546 (/ (- (* ix r) rx) dn))))))
547 (((foreach integer ratio single-float double-float) complex)
548 (let* ((ry (realpart y))
549 (iy (imagpart y)))
550 (if (> (abs ry) (abs iy))
551 (let* ((r (/ iy ry))
552 (dn (* ry (+ 1 (* r r)))))
553 (canonical-complex (/ x dn)
554 (/ (- (* x r)) dn)))
555 (let* ((r (/ ry iy))
556 (dn (* iy (+ 1 (* r r)))))
557 (canonical-complex (/ (* x r) dn)
558 (/ (- x) dn))))))
559 ((complex (or rational float))
560 (canonical-complex (/ (realpart x) y)
561 (/ (imagpart x) y)))
563 ((ratio ratio)
564 (let* ((nx (numerator x))
565 (dx (denominator x))
566 (ny (numerator y))
567 (dy (denominator y))
568 (g1 (gcd nx ny))
569 (g2 (gcd dx dy)))
570 (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
571 (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
573 ((integer integer)
574 (integer-/-integer x y))
576 ((integer ratio)
577 (if (zerop x)
579 (let* ((ny (numerator y))
580 (dy (denominator y))
581 (gcd (gcd x ny)))
582 (build-ratio (* (maybe-truncate x gcd) dy)
583 (maybe-truncate ny gcd)))))
585 ((ratio integer)
586 (let* ((nx (numerator x))
587 (gcd (gcd nx y)))
588 (build-ratio (maybe-truncate nx gcd)
589 (* (maybe-truncate y gcd) (denominator x)))))))
591 (defun %negate (n)
592 (declare (explicit-check))
593 (number-dispatch ((n number))
594 (((foreach fixnum single-float double-float #!+long-float long-float))
595 (%negate n))
596 ((bignum)
597 (negate-bignum n))
598 ((ratio)
599 (%make-ratio (- (numerator n)) (denominator n)))
600 ((complex)
601 (complex (- (realpart n)) (- (imagpart n))))))
603 ;;;; TRUNCATE and friends
605 (defun truncate (number &optional (divisor 1))
606 #!+sb-doc
607 "Return number (or number/divisor) as an integer, rounded toward 0.
608 The second returned value is the remainder."
609 (declare (explicit-check))
610 (macrolet ((truncate-float (rtype)
611 `(let* ((float-div (coerce divisor ',rtype))
612 (res (%unary-truncate (/ number float-div))))
613 (values res
614 (- number
615 (* (coerce res ',rtype) float-div))))))
616 (number-dispatch ((number real) (divisor real))
617 ((fixnum fixnum) (truncate number divisor))
618 (((foreach fixnum bignum) ratio)
619 (if (= (numerator divisor) 1)
620 (values (* number (denominator divisor)) 0)
621 (multiple-value-bind (quot rem)
622 (truncate (* number (denominator divisor))
623 (numerator divisor))
624 (values quot (/ rem (denominator divisor))))))
625 ((fixnum bignum)
626 (bignum-truncate (make-small-bignum number) divisor))
627 ((ratio (or float rational))
628 (let ((q (truncate (numerator number)
629 (* (denominator number) divisor))))
630 (values q (- number (* q divisor)))))
631 ((bignum fixnum)
632 (bignum-truncate number (make-small-bignum divisor)))
633 ((bignum bignum)
634 (bignum-truncate number divisor))
636 (((foreach single-float double-float #!+long-float long-float)
637 (or rational single-float))
638 (if (eql divisor 1)
639 (let ((res (%unary-truncate number)))
640 (values res (- number (coerce res '(dispatch-type number)))))
641 (truncate-float (dispatch-type number))))
642 #!+long-float
643 ((long-float (or single-float double-float long-float))
644 (truncate-float long-float))
645 #!+long-float
646 (((foreach double-float single-float) long-float)
647 (truncate-float long-float))
648 ((double-float (or single-float double-float))
649 (truncate-float double-float))
650 ((single-float double-float)
651 (truncate-float double-float))
652 (((foreach fixnum bignum ratio)
653 (foreach single-float double-float #!+long-float long-float))
654 (truncate-float (dispatch-type divisor))))))
656 ;; Only inline when no VOP exists
657 #!-multiply-high-vops (declaim (inline %multiply-high))
658 (defun %multiply-high (x y)
659 (declare (type word x y))
660 #!-multiply-high-vops
661 (values (sb!bignum:%multiply x y))
662 #!+multiply-high-vops
663 (%multiply-high x y))
665 (defun floor (number &optional (divisor 1))
666 #!+sb-doc
667 "Return the greatest integer not greater than number, or number/divisor.
668 The second returned value is (mod number divisor)."
669 (declare (explicit-check))
670 (floor number divisor))
672 (defun ceiling (number &optional (divisor 1))
673 #!+sb-doc
674 "Return the smallest integer not less than number, or number/divisor.
675 The second returned value is the remainder."
676 (declare (explicit-check))
677 (ceiling number divisor))
679 (defun rem (number divisor)
680 #!+sb-doc
681 "Return second result of TRUNCATE."
682 (declare (explicit-check))
683 (rem number divisor))
685 (defun mod (number divisor)
686 #!+sb-doc
687 "Return second result of FLOOR."
688 (declare (explicit-check))
689 (mod number divisor))
691 (defun round (number &optional (divisor 1))
692 #!+sb-doc
693 "Rounds number (or number/divisor) to nearest integer.
694 The second returned value is the remainder."
695 (declare (explicit-check))
696 (if (eql divisor 1)
697 (round number)
698 (multiple-value-bind (tru rem) (truncate number divisor)
699 (if (zerop rem)
700 (values tru rem)
701 (let ((thresh (/ (abs divisor) 2)))
702 (cond ((or (> rem thresh)
703 (and (= rem thresh) (oddp tru)))
704 (if (minusp divisor)
705 (values (- tru 1) (+ rem divisor))
706 (values (+ tru 1) (- rem divisor))))
707 ((let ((-thresh (- thresh)))
708 (or (< rem -thresh)
709 (and (= rem -thresh) (oddp tru))))
710 (if (minusp divisor)
711 (values (+ tru 1) (- rem divisor))
712 (values (- tru 1) (+ rem divisor))))
713 (t (values tru rem))))))))
715 (defmacro !define-float-rounding-function (name op doc)
716 `(defun ,name (number &optional (divisor 1))
717 ,doc
718 (multiple-value-bind (res rem) (,op number divisor)
719 (values (float res (if (floatp rem) rem 1.0)) rem))))
721 ;;; Declare these guys inline to let them get optimized a little.
722 ;;; ROUND and FROUND are not declared inline since they seem too
723 ;;; obscure and too big to inline-expand by default. Also, this gives
724 ;;; the compiler a chance to pick off the unary float case.
725 #!-sb-fluid (declaim (inline fceiling ffloor ftruncate))
726 (defun ftruncate (number &optional (divisor 1))
727 #!+sb-doc
728 "Same as TRUNCATE, but returns first value as a float."
729 (declare (explicit-check))
730 (macrolet ((ftruncate-float (rtype)
731 `(let* ((float-div (coerce divisor ',rtype))
732 (res (%unary-ftruncate (/ number float-div))))
733 (values res
734 (- number
735 (* (coerce res ',rtype) float-div))))))
736 (number-dispatch ((number real) (divisor real))
737 (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
738 (multiple-value-bind (q r)
739 (truncate number divisor)
740 (values (float q) r)))
741 (((foreach single-float double-float #!+long-float long-float)
742 (or rational single-float))
743 (if (eql divisor 1)
744 (let ((res (%unary-ftruncate number)))
745 (values res (- number (coerce res '(dispatch-type number)))))
746 (ftruncate-float (dispatch-type number))))
747 #!+long-float
748 ((long-float (or single-float double-float long-float))
749 (ftruncate-float long-float))
750 #!+long-float
751 (((foreach double-float single-float) long-float)
752 (ftruncate-float long-float))
753 ((double-float (or single-float double-float))
754 (ftruncate-float double-float))
755 ((single-float double-float)
756 (ftruncate-float double-float))
757 (((foreach fixnum bignum ratio)
758 (foreach single-float double-float #!+long-float long-float))
759 (ftruncate-float (dispatch-type divisor))))))
761 (defun ffloor (number &optional (divisor 1))
762 #!+sb-doc
763 "Same as FLOOR, but returns first value as a float."
764 (declare (explicit-check))
765 (multiple-value-bind (tru rem) (ftruncate number divisor)
766 (if (and (not (zerop rem))
767 (if (minusp divisor)
768 (plusp number)
769 (minusp number)))
770 (values (1- tru) (+ rem divisor))
771 (values tru rem))))
773 (defun fceiling (number &optional (divisor 1))
774 #!+sb-doc
775 "Same as CEILING, but returns first value as a float."
776 (declare (explicit-check))
777 (multiple-value-bind (tru rem) (ftruncate number divisor)
778 (if (and (not (zerop rem))
779 (if (minusp divisor)
780 (minusp number)
781 (plusp number)))
782 (values (+ tru 1) (- rem divisor))
783 (values tru rem))))
785 ;;; FIXME: this probably needs treatment similar to the use of
786 ;;; %UNARY-FTRUNCATE for FTRUNCATE.
787 (defun fround (number &optional (divisor 1))
788 #!+sb-doc
789 "Same as ROUND, but returns first value as a float."
790 (declare (explicit-check))
791 (multiple-value-bind (res rem)
792 (round number divisor)
793 (values (float res (if (floatp rem) rem 1.0)) rem)))
795 ;;;; comparisons
797 (defun = (number &rest more-numbers)
798 #!+sb-doc
799 "Return T if all of its arguments are numerically equal, NIL otherwise."
800 (declare (number number) (explicit-check))
801 (do-rest-arg ((n i) more-numbers 0 t)
802 (unless (= number n)
803 (return (do-rest-arg ((n) more-numbers (1+ i))
804 (the number n)))))) ; for effect
806 (defun /= (number &rest more-numbers)
807 #!+sb-doc
808 "Return T if no two of its arguments are numerically equal, NIL otherwise."
809 (declare (number number) (explicit-check))
810 (if more-numbers
811 (do ((n number (nth i more-numbers))
812 (i 0 (1+ i)))
813 ((>= i (length more-numbers))
815 (do-rest-arg ((n2) more-numbers i)
816 (when (= n n2)
817 (return-from /= nil))))
820 (macrolet ((def (op doc)
821 (declare (ignorable doc))
822 `(defun ,op (number &rest more-numbers)
823 #!+sb-doc ,doc
824 (declare (explicit-check))
825 (let ((n1 number))
826 (declare (real n1))
827 (do-rest-arg ((n2 i) more-numbers 0 t)
828 (if (,op n1 n2)
829 (setf n1 n2)
830 (return (do-rest-arg ((n) more-numbers (1+ i))
831 (the real n))))))))) ; for effect
832 (def < "Return T if its arguments are in strictly increasing order, NIL otherwise.")
833 (def > "Return T if its arguments are in strictly decreasing order, NIL otherwise.")
834 (def <= "Return T if arguments are in strictly non-decreasing order, NIL otherwise.")
835 (def >= "Return T if arguments are in strictly non-increasing order, NIL otherwise."))
837 (defun max (number &rest more-numbers)
838 #!+sb-doc
839 "Return the greatest of its arguments; among EQUALP greatest, return
840 the first."
841 (declare (explicit-check))
842 (let ((n number))
843 (declare (real n))
844 (do-rest-arg ((arg) more-numbers 0 n)
845 (when (> arg n)
846 (setf n arg)))))
848 (defun min (number &rest more-numbers)
849 #!+sb-doc
850 "Return the least of its arguments; among EQUALP least, return
851 the first."
852 (declare (explicit-check))
853 (let ((n number))
854 (declare (real n))
855 (do-rest-arg ((arg) more-numbers 0 n)
856 (when (< arg n)
857 (setf n arg)))))
859 (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
867 ;;; way instead.)
868 (defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
869 `(((fixnum fixnum) (,op x y))
871 ((single-float single-float) (,op x y))
872 #!+long-float
873 (((foreach single-float double-float long-float) long-float)
874 (,op (coerce x 'long-float) y))
875 #!+long-float
876 ((long-float (foreach single-float double-float))
877 (,op x (coerce y 'long-float)))
878 ((fixnum (foreach single-float double-float))
879 (if (float-infinity-p y)
880 ,infinite-y-finite-x
881 ;; If the fixnum has an exact float representation, do a
882 ;; float comparison. Otherwise do the slow float -> ratio
883 ;; conversion.
884 (multiple-value-bind (lo hi)
885 (case '(dispatch-type y)
886 (single-float
887 (values most-negative-exactly-single-float-fixnum
888 most-positive-exactly-single-float-fixnum))
889 (double-float
890 (values most-negative-exactly-double-float-fixnum
891 most-positive-exactly-double-float-fixnum)))
892 (if (<= lo y hi)
893 (,op (coerce x '(dispatch-type y)) y)
894 (,op x (rational y))))))
895 (((foreach single-float double-float) fixnum)
896 (if (eql y 0)
897 (,op x (coerce 0 '(dispatch-type x)))
898 (if (float-infinity-p x)
899 ,infinite-x-finite-y
900 ;; Likewise
901 (multiple-value-bind (lo hi)
902 (case '(dispatch-type x)
903 (single-float
904 (values most-negative-exactly-single-float-fixnum
905 most-positive-exactly-single-float-fixnum))
906 (double-float
907 (values most-negative-exactly-double-float-fixnum
908 most-positive-exactly-double-float-fixnum)))
909 (if (<= lo y hi)
910 (,op x (coerce y '(dispatch-type x)))
911 (,op (rational x) y))))))
912 (((foreach single-float double-float) double-float)
913 (,op (coerce x 'double-float) y))
914 ((double-float single-float)
915 (,op x (coerce y 'double-float)))
916 (((foreach single-float double-float #!+long-float long-float) rational)
917 (if (eql y 0)
918 (,op x (coerce 0 '(dispatch-type x)))
919 (if (float-infinity-p x)
920 ,infinite-x-finite-y
921 (,op (rational x) y))))
922 (((foreach bignum fixnum ratio) float)
923 (if (float-infinity-p y)
924 ,infinite-y-finite-x
925 (,op x (rational y))))))
926 ) ; EVAL-WHEN
928 (macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
929 `(defun ,name (x y)
930 (number-dispatch ((x real) (y real))
931 (basic-compare
933 :infinite-x-finite-y
934 (,op x (coerce 0 '(dispatch-type x)))
935 :infinite-y-finite-x
936 (,op (coerce 0 '(dispatch-type y)) y))
937 (((foreach fixnum bignum) ratio)
938 (,op x (,ratio-arg2 (numerator y)
939 (denominator y))))
940 ((ratio integer)
941 (,op (,ratio-arg1 (numerator x)
942 (denominator x))
944 ((ratio ratio)
945 (,op (* (numerator (truly-the ratio x))
946 (denominator (truly-the ratio y)))
947 (* (numerator (truly-the ratio y))
948 (denominator (truly-the ratio x)))))
949 ,@cases))))
950 (def-two-arg-</> two-arg-< < floor ceiling
951 ((fixnum bignum)
952 (bignum-plus-p y))
953 ((bignum fixnum)
954 (not (bignum-plus-p x)))
955 ((bignum bignum)
956 (minusp (bignum-compare x y))))
957 (def-two-arg-</> two-arg-> > ceiling floor
958 ((fixnum bignum)
959 (not (bignum-plus-p y)))
960 ((bignum fixnum)
961 (bignum-plus-p x))
962 ((bignum bignum)
963 (plusp (bignum-compare x y)))))
965 (defun two-arg-= (x y)
966 (number-dispatch ((x number) (y number))
967 (basic-compare =
968 ;; An infinite value is never equal to a finite value.
969 :infinite-x-finite-y nil
970 :infinite-y-finite-x nil)
971 ((fixnum (or bignum ratio)) nil)
973 ((bignum (or fixnum ratio)) nil)
974 ((bignum bignum)
975 (zerop (bignum-compare x y)))
977 ((ratio integer) nil)
978 ((ratio ratio)
979 (and (eql (numerator x) (numerator y))
980 (eql (denominator x) (denominator y))))
982 ((complex complex)
983 (and (= (realpart x) (realpart y))
984 (= (imagpart x) (imagpart y))))
985 (((foreach fixnum bignum ratio single-float double-float
986 #!+long-float long-float) complex)
987 (and (= x (realpart y))
988 (zerop (imagpart y))))
989 ((complex (or float rational))
990 (and (= (realpart x) y)
991 (zerop (imagpart x))))))
993 ;;;; logicals
995 (macrolet ((def (op init doc)
996 #!-sb-doc (declare (ignore doc))
997 `(defun ,op (&rest integers)
998 #!+sb-doc ,doc
999 (declare (explicit-check))
1000 (if integers
1001 (do ((result (fast-&rest-nth 0 integers)
1002 (,op result (fast-&rest-nth i integers)))
1003 (i 1 (1+ i)))
1004 ((>= i (length integers))
1005 result)
1006 (declare (integer result)))
1007 ,init))))
1008 (def logior 0 "Return the bit-wise or of its arguments. Args must be integers.")
1009 (def logxor 0 "Return the bit-wise exclusive or of its arguments. Args must be integers.")
1010 (def logand -1 "Return the bit-wise and of its arguments. Args must be integers.")
1011 (def logeqv -1 "Return the bit-wise equivalence of its arguments. Args must be integers."))
1013 (defun lognot (number)
1014 #!+sb-doc
1015 "Return the bit-wise logical not of integer."
1016 (declare (explicit-check))
1017 (etypecase number
1018 (fixnum (lognot (truly-the fixnum number)))
1019 (bignum (bignum-logical-not number))))
1021 (macrolet ((def (name explicit-check op big-op &optional doc)
1022 `(defun ,name (integer1 integer2)
1023 ,@(when doc (list doc))
1024 ,@(when explicit-check `((declare (explicit-check))))
1025 (let ((x integer1)
1026 (y integer2))
1027 (number-dispatch ((x integer) (y integer))
1028 (bignum-cross-fixnum ,op ,big-op))))))
1029 (def two-arg-and nil logand bignum-logical-and)
1030 (def two-arg-ior nil logior bignum-logical-ior)
1031 (def two-arg-xor nil logxor bignum-logical-xor)
1032 ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must
1033 ;; call the generic LOGNOT...
1034 (def two-arg-eqv nil logeqv (lambda (x y) (lognot (bignum-logical-xor x y))))
1035 (def lognand t lognand
1036 (lambda (x y) (lognot (bignum-logical-and x y)))
1037 #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
1038 (def lognor t lognor
1039 (lambda (x y) (lognot (bignum-logical-ior x y)))
1040 #!+sb-doc "Complement the logical OR of INTEGER1 and INTEGER2.")
1041 ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum
1042 (def logandc1 t logandc1
1043 (lambda (x y) (bignum-logical-and (bignum-logical-not x) y))
1044 #!+sb-doc "Bitwise AND (LOGNOT INTEGER1) with INTEGER2.")
1045 (def logandc2 t logandc2
1046 (lambda (x y) (bignum-logical-and x (bignum-logical-not y)))
1047 #!+sb-doc "Bitwise AND INTEGER1 with (LOGNOT INTEGER2).")
1048 (def logorc1 t logorc1
1049 (lambda (x y) (bignum-logical-ior (bignum-logical-not x) y))
1050 #!+sb-doc "Bitwise OR (LOGNOT INTEGER1) with INTEGER2.")
1051 (def logorc2 t logorc2
1052 (lambda (x y) (bignum-logical-ior x (bignum-logical-not y)))
1053 #!+sb-doc "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)."))
1055 (defun logcount (integer)
1056 #!+sb-doc
1057 "Count the number of 1 bits if INTEGER is non-negative,
1058 and the number of 0 bits if INTEGER is negative."
1059 (declare (explicit-check))
1060 (etypecase integer
1061 (fixnum
1062 (logcount (truly-the (integer 0
1063 #.(max sb!xc:most-positive-fixnum
1064 (lognot sb!xc:most-negative-fixnum)))
1065 (if (minusp (truly-the fixnum integer))
1066 (lognot (truly-the fixnum integer))
1067 integer))))
1068 (bignum
1069 (bignum-logcount integer))))
1071 (defun logtest (integer1 integer2)
1072 #!+sb-doc
1073 "Predicate which returns T if logand of integer1 and integer2 is not zero."
1074 (logtest integer1 integer2))
1076 (defun logbitp (index integer)
1077 #!+sb-doc
1078 "Predicate returns T if bit index of integer is a 1."
1079 (number-dispatch ((index integer) (integer integer))
1080 ((fixnum fixnum) (if (< index sb!vm:n-positive-fixnum-bits)
1081 (not (zerop (logand integer (ash 1 index))))
1082 (minusp integer)))
1083 ((fixnum bignum) (bignum-logbitp index integer))
1084 ((bignum (foreach fixnum bignum)) (minusp integer))))
1086 (defun ash (integer count)
1087 #!+sb-doc
1088 "Shifts integer left by count places preserving sign. - count shifts right."
1089 (declare (integer integer count) (explicit-check))
1090 (etypecase integer
1091 (fixnum
1092 (cond ((zerop integer)
1094 ((fixnump count)
1095 (let ((length (integer-length (truly-the fixnum integer)))
1096 (count (truly-the fixnum count)))
1097 (declare (fixnum length count))
1098 (cond ((and (plusp count)
1099 (>= (+ length count)
1100 sb!vm:n-word-bits))
1101 (bignum-ashift-left (make-small-bignum integer) count))
1103 (truly-the (signed-byte #.sb!vm:n-word-bits)
1104 (ash (truly-the fixnum integer) count))))))
1105 ((minusp count)
1106 (if (minusp integer) -1 0))
1108 (bignum-ashift-left (make-small-bignum integer) count))))
1109 (bignum
1110 (if (plusp count)
1111 (bignum-ashift-left integer count)
1112 (bignum-ashift-right integer (- count))))))
1114 (defun integer-length (integer)
1115 #!+sb-doc
1116 "Return the number of non-sign bits in the twos-complement representation
1117 of INTEGER."
1118 (declare (explicit-check))
1119 (etypecase integer
1120 (fixnum
1121 (integer-length (truly-the fixnum integer)))
1122 (bignum
1123 (bignum-integer-length integer))))
1125 ;;;; BYTE, bytespecs, and related operations
1127 (defun byte (size position)
1128 #!+sb-doc
1129 "Return a byte specifier which may be used by other byte functions
1130 (e.g. LDB)."
1131 (byte size position))
1133 (defun byte-size (bytespec)
1134 #!+sb-doc
1135 "Return the size part of the byte specifier bytespec."
1136 (byte-size bytespec))
1138 (defun byte-position (bytespec)
1139 #!+sb-doc
1140 "Return the position part of the byte specifier bytespec."
1141 (byte-position bytespec))
1143 (defun ldb (bytespec integer)
1144 #!+sb-doc
1145 "Extract the specified byte from integer, and right justify result."
1146 (ldb bytespec integer))
1148 (defun ldb-test (bytespec integer)
1149 #!+sb-doc
1150 "Return T if any of the specified bits in integer are 1's."
1151 (ldb-test bytespec integer))
1153 (defun mask-field (bytespec integer)
1154 #!+sb-doc
1155 "Extract the specified byte from integer, but do not right justify result."
1156 (mask-field bytespec integer))
1158 (defun dpb (newbyte bytespec integer)
1159 #!+sb-doc
1160 "Return new integer with newbyte in specified position, newbyte is right justified."
1161 (dpb newbyte bytespec integer))
1163 (defun deposit-field (newbyte bytespec integer)
1164 #!+sb-doc
1165 "Return new integer with newbyte in specified position, newbyte is not right justified."
1166 (deposit-field newbyte bytespec integer))
1168 (defun %ldb (size posn integer)
1169 (declare (type bit-index size posn) (explicit-check))
1170 ;; The naive algorithm is horrible in the general case.
1171 ;; Consider (LDB (BYTE 1 2) (SOME-GIANT-BIGNUM)) which has to shift the
1172 ;; input rightward 2 bits, consing a new bignum just to read 1 bit.
1173 (if (and (<= 0 size sb!vm:n-positive-fixnum-bits)
1174 (typep integer 'bignum))
1175 (sb!bignum::ldb-bignum=>fixnum size posn integer)
1176 (logand (ash integer (- posn))
1177 (1- (ash 1 size)))))
1179 (defun %mask-field (size posn integer)
1180 (declare (type bit-index size posn) (explicit-check))
1181 (logand integer (ash (1- (ash 1 size)) posn)))
1183 (defun %dpb (newbyte size posn integer)
1184 (declare (type bit-index size posn) (explicit-check))
1185 (let ((mask (1- (ash 1 size))))
1186 (logior (logand integer (lognot (ash mask posn)))
1187 (ash (logand newbyte mask) posn))))
1189 (defun %deposit-field (newbyte size posn integer)
1190 (declare (type bit-index size posn) (explicit-check))
1191 (let ((mask (ash (ldb (byte size 0) -1) posn)))
1192 (logior (logand newbyte mask)
1193 (logand integer (lognot mask)))))
1195 (defun sb!c::mask-signed-field (size integer)
1196 #!+sb-doc
1197 "Extract SIZE lower bits from INTEGER, considering them as a
1198 2-complement SIZE-bits representation of a signed integer."
1199 (macrolet ((msf (size integer)
1200 `(if (logbitp (1- ,size) ,integer)
1201 (dpb ,integer (byte (1- ,size) 0) -1)
1202 (ldb (byte (1- ,size) 0) ,integer))))
1203 (typecase size
1204 ((eql 0) 0)
1205 ((integer 1 #.sb!vm:n-fixnum-bits)
1206 (number-dispatch ((integer integer))
1207 ((fixnum) (msf size integer))
1208 ((bignum) (let ((fix (sb!c::mask-signed-field #.sb!vm:n-fixnum-bits (%bignum-ref integer 0))))
1209 (if (= size #.sb!vm:n-fixnum-bits)
1211 (msf size fix))))))
1212 ((integer (#.sb!vm:n-fixnum-bits) #.sb!vm:n-word-bits)
1213 (number-dispatch ((integer integer))
1214 ((fixnum) integer)
1215 ((bignum) (let ((word (sb!c::mask-signed-field #.sb!vm:n-word-bits (%bignum-ref integer 0))))
1216 (if (= size #.sb!vm:n-word-bits)
1217 word
1218 (msf size word))))))
1219 ((unsigned-byte) (msf size integer)))))
1221 ;;;; BOOLE
1223 ;;; The boole function dispaches to any logic operation depending on
1224 ;;; the value of a variable. Presently, legal selector values are [0..15].
1225 ;;; boole is open coded for calls with a constant selector. or with calls
1226 ;;; using any of the constants declared below.
1228 (defconstant boole-clr 0
1229 #!+sb-doc
1230 "Boole function op, makes BOOLE return 0.")
1232 (defconstant boole-set 1
1233 #!+sb-doc
1234 "Boole function op, makes BOOLE return -1.")
1236 (defconstant boole-1 2
1237 #!+sb-doc
1238 "Boole function op, makes BOOLE return integer1.")
1240 (defconstant boole-2 3
1241 #!+sb-doc
1242 "Boole function op, makes BOOLE return integer2.")
1244 (defconstant boole-c1 4
1245 #!+sb-doc
1246 "Boole function op, makes BOOLE return complement of integer1.")
1248 (defconstant boole-c2 5
1249 #!+sb-doc
1250 "Boole function op, makes BOOLE return complement of integer2.")
1252 (defconstant boole-and 6
1253 #!+sb-doc
1254 "Boole function op, makes BOOLE return logand of integer1 and integer2.")
1256 (defconstant boole-ior 7
1257 #!+sb-doc
1258 "Boole function op, makes BOOLE return logior of integer1 and integer2.")
1260 (defconstant boole-xor 8
1261 #!+sb-doc
1262 "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
1264 (defconstant boole-eqv 9
1265 #!+sb-doc
1266 "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
1268 (defconstant boole-nand 10
1269 #!+sb-doc
1270 "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
1272 (defconstant boole-nor 11
1273 #!+sb-doc
1274 "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
1276 (defconstant boole-andc1 12
1277 #!+sb-doc
1278 "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
1280 (defconstant boole-andc2 13
1281 #!+sb-doc
1282 "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
1284 (defconstant boole-orc1 14
1285 #!+sb-doc
1286 "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
1288 (defconstant boole-orc2 15
1289 #!+sb-doc
1290 "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
1292 (defun boole (op integer1 integer2)
1293 #!+sb-doc
1294 "Bit-wise boolean function on two integers. Function chosen by OP:
1295 0 BOOLE-CLR
1296 1 BOOLE-SET
1297 2 BOOLE-1
1298 3 BOOLE-2
1299 4 BOOLE-C1
1300 5 BOOLE-C2
1301 6 BOOLE-AND
1302 7 BOOLE-IOR
1303 8 BOOLE-XOR
1304 9 BOOLE-EQV
1305 10 BOOLE-NAND
1306 11 BOOLE-NOR
1307 12 BOOLE-ANDC1
1308 13 BOOLE-ANDC2
1309 14 BOOLE-ORC1
1310 15 BOOLE-ORC2"
1311 (case op
1312 (0 (boole 0 integer1 integer2))
1313 (1 (boole 1 integer1 integer2))
1314 (2 (boole 2 integer1 integer2))
1315 (3 (boole 3 integer1 integer2))
1316 (4 (boole 4 integer1 integer2))
1317 (5 (boole 5 integer1 integer2))
1318 (6 (boole 6 integer1 integer2))
1319 (7 (boole 7 integer1 integer2))
1320 (8 (boole 8 integer1 integer2))
1321 (9 (boole 9 integer1 integer2))
1322 (10 (boole 10 integer1 integer2))
1323 (11 (boole 11 integer1 integer2))
1324 (12 (boole 12 integer1 integer2))
1325 (13 (boole 13 integer1 integer2))
1326 (14 (boole 14 integer1 integer2))
1327 (15 (boole 15 integer1 integer2))
1328 (t (error 'type-error :datum op :expected-type '(mod 16)))))
1330 ;;;; GCD and LCM
1332 (defun gcd (&rest integers)
1333 #!+sb-doc
1334 "Return the greatest common divisor of the arguments, which must be
1335 integers. GCD with no arguments is defined to be 0."
1336 (declare (explicit-check))
1337 (case (length integers)
1338 (0 0)
1339 (1 (abs (the integer (fast-&rest-nth 0 integers))))
1340 (otherwise
1341 (do ((result (fast-&rest-nth 0 integers)
1342 (gcd result (the integer (fast-&rest-nth i integers))))
1343 (i 1 (1+ i)))
1344 ((>= i (length integers))
1345 result)
1346 (declare (integer result))))))
1348 (defun lcm (&rest integers)
1349 #!+sb-doc
1350 "Return the least common multiple of one or more integers. LCM of no
1351 arguments is defined to be 1."
1352 (declare (explicit-check))
1353 (case (length integers)
1354 (0 1)
1355 (1 (abs (the integer (fast-&rest-nth 0 integers))))
1356 (otherwise
1357 (do ((result (fast-&rest-nth 0 integers)
1358 (lcm result (the integer (fast-&rest-nth i integers))))
1359 (i 1 (1+ i)))
1360 ((>= i (length integers))
1361 result)
1362 (declare (integer result))))))
1364 (defun two-arg-lcm (n m)
1365 (declare (integer n m))
1366 (if (or (zerop n) (zerop m))
1368 ;; KLUDGE: I'm going to assume that it was written this way
1369 ;; originally for a reason. However, this is a somewhat
1370 ;; complicated way of writing the algorithm in the CLHS page for
1371 ;; LCM, and I don't know why. To be investigated. -- CSR,
1372 ;; 2003-09-11
1374 ;; It seems to me that this is written this way to avoid
1375 ;; unnecessary bignumification of intermediate results.
1376 ;; -- TCR, 2008-03-05
1377 (let ((m (abs m))
1378 (n (abs n)))
1379 (multiple-value-bind (max min)
1380 (if (> m n)
1381 (values m n)
1382 (values n m))
1383 (* (truncate max (gcd n m)) min)))))
1385 ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
1386 ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
1387 ;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
1388 ;;; of 0 before the dispatch so that the bignum code doesn't have to worry
1389 ;;; about "small bignum" zeros.
1390 (defun two-arg-gcd (u v)
1391 (cond ((eql u 0) (abs v))
1392 ((eql v 0) (abs u))
1394 (number-dispatch ((u integer) (v integer))
1395 ((fixnum fixnum)
1396 (locally
1397 (declare (optimize (speed 3) (safety 0)))
1398 (do ((k 0 (1+ k))
1399 (u (abs u) (ash u -1))
1400 (v (abs v) (ash v -1)))
1401 ((oddp (logior u v))
1402 (do ((temp (if (oddp u) (- v) (ash u -1))
1403 (ash temp -1)))
1404 (nil)
1405 (declare (fixnum temp))
1406 (when (oddp temp)
1407 (if (plusp temp)
1408 (setq u temp)
1409 (setq v (- temp)))
1410 (setq temp (- u v))
1411 (when (zerop temp)
1412 (let ((res (ash u k)))
1413 (declare (type sb!vm:signed-word res)
1414 (optimize (inhibit-warnings 3)))
1415 (return res))))))
1416 (declare (type (mod #.sb!vm:n-word-bits) k)
1417 (type sb!vm:signed-word u v)))))
1418 ((bignum bignum)
1419 (bignum-gcd u v))
1420 ((bignum fixnum)
1421 (bignum-gcd u (make-small-bignum v)))
1422 ((fixnum bignum)
1423 (bignum-gcd (make-small-bignum u) v))))))
1425 ;;; from Robert Smith; changed not to cons unnecessarily, and tuned for
1426 ;;; faster operation on fixnum inputs by compiling the central recursive
1427 ;;; algorithm twice, once using generic and once fixnum arithmetic, and
1428 ;;; dispatching on function entry into the applicable part. For maximum
1429 ;;; speed, the fixnum part recurs into itself, thereby avoiding further
1430 ;;; type dispatching. This pattern is not supported by NUMBER-DISPATCH
1431 ;;; thus some special-purpose macrology is needed.
1432 (defun isqrt (n)
1433 #!+sb-doc
1434 "Return the greatest integer less than or equal to the square root of N."
1435 (declare (type unsigned-byte n) (explicit-check))
1436 (macrolet
1437 ((isqrt-recursion (arg recurse fixnum-p)
1438 ;; Expands into code for the recursive step of the ISQRT
1439 ;; calculation. ARG is the input variable and RECURSE the name
1440 ;; of the function to recur into. If FIXNUM-P is true, some
1441 ;; type declarations are added that, together with ARG being
1442 ;; declared as a fixnum outside of here, make the resulting code
1443 ;; compile into fixnum-specialized code without any calls to
1444 ;; generic arithmetic. Else, the code works for bignums, too.
1445 ;; The input must be at least 16 to ensure that RECURSE is called
1446 ;; with a strictly smaller number and that the result is correct
1447 ;; (provided that RECURSE correctly implements ISQRT, itself).
1448 `(macrolet ((if-fixnum-p-truly-the (type expr)
1449 ,@(if fixnum-p
1450 '(`(truly-the ,type ,expr))
1451 '((declare (ignore type))
1452 expr))))
1453 (let* ((fourth-size (ash (1- (integer-length ,arg)) -2))
1454 (significant-half (ash ,arg (- (ash fourth-size 1))))
1455 (significant-half-isqrt
1456 (if-fixnum-p-truly-the
1457 (integer 1 #.(isqrt sb!xc:most-positive-fixnum))
1458 (,recurse significant-half)))
1459 (zeroth-iteration (ash significant-half-isqrt
1460 fourth-size)))
1461 (multiple-value-bind (quot rem)
1462 (floor ,arg zeroth-iteration)
1463 (let ((first-iteration (ash (+ zeroth-iteration quot) -1)))
1464 (cond ((oddp quot)
1465 first-iteration)
1466 ((> (if-fixnum-p-truly-the
1467 fixnum
1468 (expt (- first-iteration zeroth-iteration) 2))
1469 rem)
1470 (1- first-iteration))
1472 first-iteration))))))))
1473 (typecase n
1474 (fixnum (labels ((fixnum-isqrt (n)
1475 (declare (type fixnum n))
1476 (cond ((> n 24)
1477 (isqrt-recursion n fixnum-isqrt t))
1478 ((> n 15) 4)
1479 ((> n 8) 3)
1480 ((> n 3) 2)
1481 ((> n 0) 1)
1482 ((= n 0) 0))))
1483 (fixnum-isqrt n)))
1484 (bignum (isqrt-recursion n isqrt nil)))))
1486 ;;;; miscellaneous number predicates
1488 (macrolet ((def (name doc)
1489 (declare (ignorable doc))
1490 `(defun ,name (number) #!+sb-doc ,doc
1491 (declare (explicit-check))
1492 (,name number))))
1493 (def zerop "Is this number zero?")
1494 (def plusp "Is this real number strictly positive?")
1495 (def minusp "Is this real number strictly negative?")
1496 (def oddp "Is this integer odd?")
1497 (def evenp "Is this integer even?"))
1499 ;;;; modular functions
1501 (collect ((forms))
1502 (flet ((unsigned-definition (name lambda-list width)
1503 (let ((pattern (1- (ash 1 width))))
1504 `(defun ,name ,(copy-list lambda-list)
1505 (flet ((prepare-argument (x)
1506 (declare (integer x))
1507 (etypecase x
1508 ((unsigned-byte ,width) x)
1509 (fixnum (logand x ,pattern))
1510 (bignum (logand x ,pattern)))))
1511 (,name ,@(loop for arg in lambda-list
1512 collect `(prepare-argument ,arg)))))))
1513 (signed-definition (name lambda-list width)
1514 `(defun ,name ,(copy-list lambda-list)
1515 (flet ((prepare-argument (x)
1516 (declare (integer x))
1517 (etypecase x
1518 ((signed-byte ,width) x)
1519 (fixnum (sb!c::mask-signed-field ,width x))
1520 (bignum (sb!c::mask-signed-field ,width x)))))
1521 (,name ,@(loop for arg in lambda-list
1522 collect `(prepare-argument ,arg)))))))
1523 (flet ((do-mfuns (class)
1524 (loop for infos being each hash-value of (sb!c::modular-class-funs class)
1525 ;; FIXME: We need to process only "toplevel" functions
1526 when (listp infos)
1527 do (loop for info in infos
1528 for name = (sb!c::modular-fun-info-name info)
1529 and width = (sb!c::modular-fun-info-width info)
1530 and signedp = (sb!c::modular-fun-info-signedp info)
1531 and lambda-list = (sb!c::modular-fun-info-lambda-list info)
1532 if signedp
1533 do (forms (signed-definition name lambda-list width))
1534 else
1535 do (forms (unsigned-definition name lambda-list width))))))
1536 (do-mfuns sb!c::*untagged-unsigned-modular-class*)
1537 (do-mfuns sb!c::*untagged-signed-modular-class*)
1538 (do-mfuns sb!c::*tagged-modular-class*)))
1539 `(progn ,@(sort (forms) #'string< :key #'cadr)))
1541 ;;; KLUDGE: these out-of-line definitions can't use the modular
1542 ;;; arithmetic, as that is only (currently) defined for constant
1543 ;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more
1544 ;;; discussion of this hack. -- CSR, 2003-10-09
1545 #!-64-bit-registers
1546 (defun sb!vm::ash-left-mod32 (integer amount)
1547 (etypecase integer
1548 ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
1549 (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
1550 (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
1551 #!+64-bit-registers
1552 (defun sb!vm::ash-left-mod64 (integer amount)
1553 (etypecase integer
1554 ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
1555 (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
1556 (bignum (ldb (byte 64 0)
1557 (ash (logand integer #xffffffffffffffff) amount)))))
1559 #!+(or x86 x86-64 arm arm64)
1560 (defun sb!vm::ash-left-modfx (integer amount)
1561 (let ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)))
1562 (etypecase integer
1563 (fixnum (sb!c::mask-signed-field fixnum-width (ash integer amount)))
1564 (integer (sb!c::mask-signed-field fixnum-width (ash (sb!c::mask-signed-field fixnum-width integer) amount))))))