Avoid some exceptions in WAIT-UNTIL-FD-USABLE on Windows
[sbcl.git] / src / code / numbers.lisp
1 ;;;; This file contains the definitions of most number functions.
2
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.
11
12 (in-package "SB!KERNEL")
13 \f
14 ;;;; the NUMBER-DISPATCH macro
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17
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."))
31         (t
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)))))))
47
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))
53
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)
60           (t
61            (< o1 o2)))))
62
63 ;;; Return an ETYPECASE form that does the type dispatch, ordering the
64 ;;; cases for efficiency.
65 (defun generate-number-dispatch (vars error-tags cases)
66   (if vars
67       (let ((var (first vars))
68             (cases (sort cases #'type-test-order :key #'car)))
69         `((typecase ,var
70             ,@(mapcar (lambda (case)
71                         `(,(first case)
72                           ,@(generate-number-dispatch (rest vars)
73                                                       (rest error-tags)
74                                                       (cdr case))))
75                       cases)
76             (t (go ,(first error-tags))))))
77       cases))
78
79 ) ; EVAL-WHEN
80
81 ;;; This is a vaguely case-like macro that does number cross-product
82 ;;; dispatches. The Vars are the variables we are dispatching off of.
83 ;;; The Type paired with each Var is used in the error message when no
84 ;;; case matches. Each case specifies a Type for each var, and is
85 ;;; executed when that signature holds. A type may be a list
86 ;;; (FOREACH Each-Type*), causing that case to be repeatedly
87 ;;; instantiated for every Each-Type. In the body of each case, any
88 ;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
89 ;;; type of that var in that instance of the case.
90 ;;;
91 ;;; As an alternate to a case spec, there may be a form whose CAR is a
92 ;;; symbol. In this case, we apply the CAR of the form to the CDR and
93 ;;; treat the result of the call as a list of cases. This process is
94 ;;; not applied recursively.
95 (defmacro number-dispatch (var-specs &body cases)
96   (let ((res (list nil))
97         (vars (mapcar #'car var-specs))
98         (block (gensym)))
99     (dolist (case cases)
100       (if (symbolp (first case))
101           (let ((cases (apply (symbol-function (first case)) (rest case))))
102             (dolist (case cases)
103               (parse-number-dispatch vars res (first case) nil (rest case))))
104           (parse-number-dispatch vars res (first case) nil (rest case))))
105
106     (collect ((errors)
107               (error-tags))
108       (dolist (spec var-specs)
109         (let ((var (first spec))
110               (type (second spec))
111               (tag (gensym)))
112           (error-tags tag)
113           (errors tag)
114           (errors `(return-from
115                     ,block
116                     (error 'simple-type-error :datum ,var
117                            :expected-type ',type
118                            :format-control
119                            "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
120                            :format-arguments
121                            (list ',var ',type ,var))))))
122
123       `(block ,block
124          (tagbody
125            (return-from ,block
126                         ,@(generate-number-dispatch vars (error-tags)
127                                                     (cdr res)))
128            ,@(errors))))))
129 \f
130 ;;;; binary operation dispatching utilities
131
132 (eval-when (:compile-toplevel :execute)
133
134 ;;; Return NUMBER-DISPATCH forms for rational X float.
135 (defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
136   `(((single-float single-float) (,op ,x ,y))
137     (((foreach ,@rat-types)
138       (foreach single-float double-float #!+long-float long-float))
139      (,op (coerce ,x '(dispatch-type ,y)) ,y))
140     (((foreach single-float double-float #!+long-float long-float)
141       (foreach ,@rat-types))
142      (,op ,x (coerce ,y '(dispatch-type ,x))))
143     #!+long-float
144     (((foreach single-float double-float long-float) long-float)
145      (,op (coerce ,x 'long-float) ,y))
146     #!+long-float
147     ((long-float (foreach single-float double-float))
148      (,op ,x (coerce ,y 'long-float)))
149     (((foreach single-float double-float) double-float)
150      (,op (coerce ,x 'double-float) ,y))
151     ((double-float single-float)
152      (,op ,x (coerce ,y 'double-float)))))
153
154 ;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
155 (defun bignum-cross-fixnum (fix-op big-op)
156   `(((fixnum fixnum) (,fix-op x y))
157     ((fixnum bignum)
158      (,big-op (make-small-bignum x) y))
159     ((bignum fixnum)
160      (,big-op x (make-small-bignum y)))
161     ((bignum bignum)
162      (,big-op x y))))
163
164 ) ; EVAL-WHEN
165 \f
166 ;;;; canonicalization utilities
167
168 ;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
169 ;;; used when we know that REALPART and IMAGPART are the same type, but
170 ;;; rational canonicalization might still need to be done.
171 #!-sb-fluid (declaim (inline canonical-complex))
172 (defun canonical-complex (realpart imagpart)
173   (if (eql imagpart 0)
174       realpart
175       (cond #!+long-float
176             ((and (typep realpart 'long-float)
177                   (typep imagpart 'long-float))
178              (truly-the (complex long-float) (complex realpart imagpart)))
179             ((and (typep realpart 'double-float)
180                   (typep imagpart 'double-float))
181              (truly-the (complex double-float) (complex realpart imagpart)))
182             ((and (typep realpart 'single-float)
183                   (typep imagpart 'single-float))
184              (truly-the (complex single-float) (complex realpart imagpart)))
185             (t
186              (%make-complex realpart imagpart)))))
187
188 ;;; Given a numerator and denominator with the GCD already divided
189 ;;; out, make a canonical rational. We make the denominator positive,
190 ;;; and check whether it is 1.
191 #!-sb-fluid (declaim (inline build-ratio))
192 (defun build-ratio (num den)
193   (multiple-value-bind (num den)
194       (if (minusp den)
195           (values (- num) (- den))
196           (values num den))
197     (cond
198       ((eql den 0)
199        (error 'division-by-zero
200               :operands (list num den)
201               :operation 'build-ratio))
202       ((eql den 1) num)
203       (t (%make-ratio num den)))))
204
205 ;;; Truncate X and Y, but bum the case where Y is 1.
206 #!-sb-fluid (declaim (inline maybe-truncate))
207 (defun maybe-truncate (x y)
208   (if (eql y 1)
209       x
210       (truncate x y)))
211 \f
212 ;;;; COMPLEXes
213
214 (defun complex (realpart &optional (imagpart 0))
215   #!+sb-doc
216   "Return a complex number with the specified real and imaginary components."
217   (flet ((%%make-complex (realpart imagpart)
218            (cond #!+long-float
219                  ((and (typep realpart 'long-float)
220                        (typep imagpart 'long-float))
221                   (truly-the (complex long-float)
222                              (complex realpart imagpart)))
223                  ((and (typep realpart 'double-float)
224                        (typep imagpart 'double-float))
225                   (truly-the (complex double-float)
226                              (complex realpart imagpart)))
227                  ((and (typep realpart 'single-float)
228                        (typep imagpart 'single-float))
229                   (truly-the (complex single-float)
230                              (complex realpart imagpart)))
231                  (t
232                   (%make-complex realpart imagpart)))))
233   (number-dispatch ((realpart real) (imagpart real))
234     ((rational rational)
235      (canonical-complex realpart imagpart))
236     (float-contagion %%make-complex realpart imagpart (rational)))))
237
238 (defun realpart (number)
239   #!+sb-doc
240   "Extract the real part of a number."
241   (etypecase number
242     #!+long-float
243     ((complex long-float)
244      (truly-the long-float (realpart number)))
245     ((complex double-float)
246      (truly-the double-float (realpart number)))
247     ((complex single-float)
248      (truly-the single-float (realpart number)))
249     ((complex rational)
250      (sb!kernel:%realpart number))
251     (number
252      number)))
253
254 (defun imagpart (number)
255   #!+sb-doc
256   "Extract the imaginary part of a number."
257   (etypecase number
258     #!+long-float
259     ((complex long-float)
260      (truly-the long-float (imagpart number)))
261     ((complex double-float)
262      (truly-the double-float (imagpart number)))
263     ((complex single-float)
264      (truly-the single-float (imagpart number)))
265     ((complex rational)
266      (sb!kernel:%imagpart number))
267     (float
268      (* 0 number))
269     (number
270      0)))
271
272 (defun conjugate (number)
273   #!+sb-doc
274   "Return the complex conjugate of NUMBER. For non-complex numbers, this is
275   an identity."
276   (declare (type number number))
277   (if (complexp number)
278       (complex (realpart number) (- (imagpart number)))
279       number))
280
281 (defun signum (number)
282   #!+sb-doc
283   "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
284   (if (zerop number)
285       number
286       (if (rationalp number)
287           (if (plusp number) 1 -1)
288           (/ number (abs number)))))
289 \f
290 ;;;; ratios
291
292 (defun numerator (number)
293   #!+sb-doc
294   "Return the numerator of NUMBER, which must be rational."
295   (numerator number))
296
297 (defun denominator (number)
298   #!+sb-doc
299   "Return the denominator of NUMBER, which must be rational."
300   (denominator number))
301 \f
302 ;;;; arithmetic operations
303
304 (macrolet ((define-arith (op init doc)
305              #!-sb-doc (declare (ignore doc))
306              `(defun ,op (&rest args)
307                 #!+sb-doc ,doc
308                 (if (null args) ,init
309                     (do ((args (cdr args) (cdr args))
310                          (result (car args) (,op result (car args))))
311                         ((null args) result)
312                       ;; to signal TYPE-ERROR when exactly 1 arg of wrong type:
313                       (declare (type number result)))))))
314   (define-arith + 0
315     "Return the sum of its arguments. With no args, returns 0.")
316   (define-arith * 1
317     "Return the product of its arguments. With no args, returns 1."))
318
319 (defun - (number &rest more-numbers)
320   #!+sb-doc
321   "Subtract the second and all subsequent arguments from the first;
322   or with one argument, negate the first argument."
323   (if more-numbers
324       (do ((nlist more-numbers (cdr nlist))
325            (result number))
326           ((atom nlist) result)
327          (declare (list nlist))
328          (setq result (- result (car nlist))))
329       (- number)))
330
331 (defun / (number &rest more-numbers)
332   #!+sb-doc
333   "Divide the first argument by each of the following arguments, in turn.
334   With one argument, return reciprocal."
335   (if more-numbers
336       (do ((nlist more-numbers (cdr nlist))
337            (result number))
338           ((atom nlist) result)
339          (declare (list nlist))
340          (setq result (/ result (car nlist))))
341       (/ number)))
342
343 (defun 1+ (number)
344   #!+sb-doc
345   "Return NUMBER + 1."
346   (1+ number))
347
348 (defun 1- (number)
349   #!+sb-doc
350   "Return NUMBER - 1."
351   (1- number))
352
353 (eval-when (:compile-toplevel)
354
355 (sb!xc:defmacro two-arg-+/- (name op big-op)
356   `(defun ,name (x y)
357      (number-dispatch ((x number) (y number))
358        (bignum-cross-fixnum ,op ,big-op)
359        (float-contagion ,op x y)
360
361        ((complex complex)
362         (canonical-complex (,op (realpart x) (realpart y))
363                            (,op (imagpart x) (imagpart y))))
364        (((foreach bignum fixnum ratio single-float double-float
365                   #!+long-float long-float) complex)
366         (complex (,op x (realpart y)) (,op 0 (imagpart y))))
367        ((complex (or rational float))
368         (complex (,op (realpart x) y) (,op (imagpart x) 0)))
369
370        (((foreach fixnum bignum) ratio)
371         (let* ((dy (denominator y))
372                (n (,op (* x dy) (numerator y))))
373           (%make-ratio n dy)))
374        ((ratio integer)
375         (let* ((dx (denominator x))
376                (n (,op (numerator x) (* y dx))))
377           (%make-ratio n dx)))
378        ((ratio ratio)
379         (let* ((nx (numerator x))
380                (dx (denominator x))
381                (ny (numerator y))
382                (dy (denominator y))
383                (g1 (gcd dx dy)))
384           (if (eql g1 1)
385               (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
386               (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
387                      (g2 (gcd t1 g1))
388                      (t2 (truncate dx g1)))
389                 (cond ((eql t1 0) 0)
390                       ((eql g2 1)
391                        (%make-ratio t1 (* t2 dy)))
392                       (t (let* ((nn (truncate t1 g2))
393                                 (t3 (truncate dy g2))
394                                 (nd (if (eql t2 1) t3 (* t2 t3))))
395                            (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
396
397 ) ; EVAL-WHEN
398
399 (two-arg-+/- two-arg-+ + add-bignums)
400 (two-arg-+/- two-arg-- - subtract-bignum)
401
402 (defun two-arg-* (x y)
403   (flet ((integer*ratio (x y)
404            (if (eql x 0) 0
405                (let* ((ny (numerator y))
406                       (dy (denominator y))
407                       (gcd (gcd x dy)))
408                  (if (eql gcd 1)
409                      (%make-ratio (* x ny) dy)
410                      (let ((nn (* (truncate x gcd) ny))
411                            (nd (truncate dy gcd)))
412                        (if (eql nd 1)
413                            nn
414                            (%make-ratio nn nd)))))))
415          (complex*real (x y)
416            (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
417     (number-dispatch ((x number) (y number))
418       (float-contagion * x y)
419
420       ((fixnum fixnum) (multiply-fixnums x y))
421       ((bignum fixnum) (multiply-bignum-and-fixnum x y))
422       ((fixnum bignum) (multiply-bignum-and-fixnum y x))
423       ((bignum bignum) (multiply-bignums x y))
424
425       ((complex complex)
426        (let* ((rx (realpart x))
427               (ix (imagpart x))
428               (ry (realpart y))
429               (iy (imagpart y)))
430          (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
431       (((foreach bignum fixnum ratio single-float double-float
432                  #!+long-float long-float)
433         complex)
434        (complex*real y x))
435       ((complex (or rational float))
436        (complex*real x y))
437
438       (((foreach bignum fixnum) ratio) (integer*ratio x y))
439       ((ratio integer) (integer*ratio y x))
440       ((ratio ratio)
441        (let* ((nx (numerator x))
442               (dx (denominator x))
443               (ny (numerator y))
444               (dy (denominator y))
445               (g1 (gcd nx dy))
446               (g2 (gcd dx ny)))
447          (build-ratio (* (maybe-truncate nx g1)
448                          (maybe-truncate ny g2))
449                       (* (maybe-truncate dx g2)
450                          (maybe-truncate dy g1))))))))
451
452 ;;; Divide two integers, producing a canonical rational. If a fixnum,
453 ;;; we see whether they divide evenly before trying the GCD. In the
454 ;;; bignum case, we don't bother, since bignum division is expensive,
455 ;;; and the test is not very likely to succeed.
456 (defun integer-/-integer (x y)
457   (if (and (typep x 'fixnum) (typep y 'fixnum))
458       (multiple-value-bind (quo rem) (truncate x y)
459         (if (zerop rem)
460             quo
461             (let ((gcd (gcd x y)))
462               (declare (fixnum gcd))
463               (if (eql gcd 1)
464                   (build-ratio x y)
465                   (build-ratio (truncate x gcd) (truncate y gcd))))))
466       (let ((gcd (gcd x y)))
467         (if (eql gcd 1)
468             (build-ratio x y)
469             (build-ratio (truncate x gcd) (truncate y gcd))))))
470
471 (defun two-arg-/ (x y)
472   (number-dispatch ((x number) (y number))
473     (float-contagion / x y (ratio integer))
474
475     ((complex complex)
476      (let* ((rx (realpart x))
477             (ix (imagpart x))
478             (ry (realpart y))
479             (iy (imagpart y)))
480        (if (> (abs ry) (abs iy))
481            (let* ((r (/ iy ry))
482                   (dn (* ry (+ 1 (* r r)))))
483              (canonical-complex (/ (+ rx (* ix r)) dn)
484                                 (/ (- ix (* rx r)) dn)))
485            (let* ((r (/ ry iy))
486                   (dn (* iy (+ 1 (* r r)))))
487              (canonical-complex (/ (+ (* rx r) ix) dn)
488                                 (/ (- (* ix r) rx) dn))))))
489     (((foreach integer ratio single-float double-float) complex)
490      (let* ((ry (realpart y))
491             (iy (imagpart y)))
492        (if (> (abs ry) (abs iy))
493            (let* ((r (/ iy ry))
494                   (dn (* ry (+ 1 (* r r)))))
495              (canonical-complex (/ x dn)
496                                 (/ (- (* x r)) dn)))
497            (let* ((r (/ ry iy))
498                   (dn (* iy (+ 1 (* r r)))))
499              (canonical-complex (/ (* x r) dn)
500                                 (/ (- x) dn))))))
501     ((complex (or rational float))
502      (canonical-complex (/ (realpart x) y)
503                         (/ (imagpart x) y)))
504
505     ((ratio ratio)
506      (let* ((nx (numerator x))
507             (dx (denominator x))
508             (ny (numerator y))
509             (dy (denominator y))
510             (g1 (gcd nx ny))
511             (g2 (gcd dx dy)))
512        (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
513                     (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
514
515     ((integer integer)
516      (integer-/-integer x y))
517
518     ((integer ratio)
519      (if (zerop x)
520          0
521          (let* ((ny (numerator y))
522                 (dy (denominator y))
523                 (gcd (gcd x ny)))
524            (build-ratio (* (maybe-truncate x gcd) dy)
525                         (maybe-truncate ny gcd)))))
526
527     ((ratio integer)
528      (let* ((nx (numerator x))
529             (gcd (gcd nx y)))
530        (build-ratio (maybe-truncate nx gcd)
531                     (* (maybe-truncate y gcd) (denominator x)))))))
532
533 (defun %negate (n)
534   (number-dispatch ((n number))
535     (((foreach fixnum single-float double-float #!+long-float long-float))
536      (%negate n))
537     ((bignum)
538      (negate-bignum n))
539     ((ratio)
540      (%make-ratio (- (numerator n)) (denominator n)))
541     ((complex)
542      (complex (- (realpart n)) (- (imagpart n))))))
543 \f
544 ;;;; TRUNCATE and friends
545
546 (defun truncate (number &optional (divisor 1))
547   #!+sb-doc
548   "Return number (or number/divisor) as an integer, rounded toward 0.
549   The second returned value is the remainder."
550   (macrolet ((truncate-float (rtype)
551                `(let* ((float-div (coerce divisor ',rtype))
552                        (res (%unary-truncate (/ number float-div))))
553                   (values res
554                           (- number
555                              (* (coerce res ',rtype) float-div))))))
556     (number-dispatch ((number real) (divisor real))
557       ((fixnum fixnum) (truncate number divisor))
558       (((foreach fixnum bignum) ratio)
559        (let ((q (truncate (* number (denominator divisor))
560                           (numerator divisor))))
561          (values q (- number (* q divisor)))))
562       ((fixnum bignum)
563        (bignum-truncate (make-small-bignum number) divisor))
564       ((ratio (or float rational))
565        (let ((q (truncate (numerator number)
566                           (* (denominator number) divisor))))
567          (values q (- number (* q divisor)))))
568       ((bignum fixnum)
569        (bignum-truncate number (make-small-bignum divisor)))
570       ((bignum bignum)
571        (bignum-truncate number divisor))
572
573       (((foreach single-float double-float #!+long-float long-float)
574         (or rational single-float))
575        (if (eql divisor 1)
576            (let ((res (%unary-truncate number)))
577              (values res (- number (coerce res '(dispatch-type number)))))
578            (truncate-float (dispatch-type number))))
579       #!+long-float
580       ((long-float (or single-float double-float long-float))
581        (truncate-float long-float))
582       #!+long-float
583       (((foreach double-float single-float) long-float)
584        (truncate-float long-float))
585       ((double-float (or single-float double-float))
586        (truncate-float double-float))
587       ((single-float double-float)
588        (truncate-float double-float))
589       (((foreach fixnum bignum ratio)
590         (foreach single-float double-float #!+long-float long-float))
591        (truncate-float (dispatch-type divisor))))))
592
593 ;;; Declare these guys inline to let them get optimized a little.
594 ;;; ROUND and FROUND are not declared inline since they seem too
595 ;;; obscure and too big to inline-expand by default. Also, this gives
596 ;;; the compiler a chance to pick off the unary float case.
597 ;;;
598 ;;; CEILING and FLOOR are implemented in terms of %CEILING and %FLOOR
599 ;;; if no better transform can be found: they aren't inline directly,
600 ;;; since we want to try a transform specific to them before letting
601 ;;; the transform for TRUNCATE pick up the slack.
602 #!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate %floor %ceiling))
603 (defun %floor (number divisor)
604   ;; If the numbers do not divide exactly and the result of
605   ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
606   ;; and augment the remainder by the divisor.
607   (multiple-value-bind (tru rem) (truncate number divisor)
608     (if (and (not (zerop rem))
609              (if (minusp divisor)
610                  (plusp number)
611                  (minusp number)))
612         (values (1- tru) (+ rem divisor))
613         (values tru rem))))
614
615 (defun floor (number &optional (divisor 1))
616   #!+sb-doc
617   "Return the greatest integer not greater than number, or number/divisor.
618   The second returned value is (mod number divisor)."
619   (%floor number divisor))
620
621 (defun %ceiling (number divisor)
622   ;; If the numbers do not divide exactly and the result of
623   ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
624   ;; and decrement the remainder by the divisor.
625   (multiple-value-bind (tru rem) (truncate number divisor)
626     (if (and (not (zerop rem))
627              (if (minusp divisor)
628                  (minusp number)
629                  (plusp number)))
630         (values (+ tru 1) (- rem divisor))
631         (values tru rem))))
632
633 (defun ceiling (number &optional (divisor 1))
634   #!+sb-doc
635   "Return the smallest integer not less than number, or number/divisor.
636   The second returned value is the remainder."
637   (%ceiling number divisor))
638
639 (defun round (number &optional (divisor 1))
640   #!+sb-doc
641   "Rounds number (or number/divisor) to nearest integer.
642   The second returned value is the remainder."
643   (if (eql divisor 1)
644       (round number)
645       (multiple-value-bind (tru rem) (truncate number divisor)
646         (if (zerop rem)
647             (values tru rem)
648             (let ((thresh (/ (abs divisor) 2)))
649               (cond ((or (> rem thresh)
650                          (and (= rem thresh) (oddp tru)))
651                      (if (minusp divisor)
652                          (values (- tru 1) (+ rem divisor))
653                          (values (+ tru 1) (- rem divisor))))
654                     ((let ((-thresh (- thresh)))
655                        (or (< rem -thresh)
656                            (and (= rem -thresh) (oddp tru))))
657                      (if (minusp divisor)
658                          (values (+ tru 1) (- rem divisor))
659                          (values (- tru 1) (+ rem divisor))))
660                     (t (values tru rem))))))))
661
662 (defun rem (number divisor)
663   #!+sb-doc
664   "Return second result of TRUNCATE."
665   (multiple-value-bind (tru rem) (truncate number divisor)
666     (declare (ignore tru))
667     rem))
668
669 (defun mod (number divisor)
670   #!+sb-doc
671   "Return second result of FLOOR."
672   (let ((rem (rem number divisor)))
673     (if (and (not (zerop rem))
674              (if (minusp divisor)
675                  (plusp number)
676                  (minusp number)))
677         (+ rem divisor)
678         rem)))
679
680 (defmacro !define-float-rounding-function (name op doc)
681   `(defun ,name (number &optional (divisor 1))
682     ,doc
683     (multiple-value-bind (res rem) (,op number divisor)
684       (values (float res (if (floatp rem) rem 1.0)) rem))))
685
686 (defun ftruncate (number &optional (divisor 1))
687   #!+sb-doc
688   "Same as TRUNCATE, but returns first value as a float."
689   (macrolet ((ftruncate-float (rtype)
690                `(let* ((float-div (coerce divisor ',rtype))
691                        (res (%unary-ftruncate (/ number float-div))))
692                   (values res
693                           (- number
694                              (* (coerce res ',rtype) float-div))))))
695     (number-dispatch ((number real) (divisor real))
696       (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
697        (multiple-value-bind (q r)
698            (truncate number divisor)
699          (values (float q) r)))
700       (((foreach single-float double-float #!+long-float long-float)
701         (or rational single-float))
702        (if (eql divisor 1)
703            (let ((res (%unary-ftruncate number)))
704              (values res (- number (coerce res '(dispatch-type number)))))
705            (ftruncate-float (dispatch-type number))))
706       #!+long-float
707       ((long-float (or single-float double-float long-float))
708        (ftruncate-float long-float))
709       #!+long-float
710       (((foreach double-float single-float) long-float)
711        (ftruncate-float long-float))
712       ((double-float (or single-float double-float))
713        (ftruncate-float double-float))
714       ((single-float double-float)
715        (ftruncate-float double-float))
716       (((foreach fixnum bignum ratio)
717         (foreach single-float double-float #!+long-float long-float))
718        (ftruncate-float (dispatch-type divisor))))))
719
720 (defun ffloor (number &optional (divisor 1))
721   "Same as FLOOR, but returns first value as a float."
722   (multiple-value-bind (tru rem) (ftruncate number divisor)
723     (if (and (not (zerop rem))
724              (if (minusp divisor)
725                  (plusp number)
726                  (minusp number)))
727         (values (1- tru) (+ rem divisor))
728         (values tru rem))))
729
730 (defun fceiling (number &optional (divisor 1))
731   "Same as CEILING, but returns first value as a float."
732   (multiple-value-bind (tru rem) (ftruncate number divisor)
733     (if (and (not (zerop rem))
734              (if (minusp divisor)
735                  (minusp number)
736                  (plusp number)))
737         (values (+ tru 1) (- rem divisor))
738         (values tru rem))))
739
740 ;;; FIXME: this probably needs treatment similar to the use of
741 ;;; %UNARY-FTRUNCATE for FTRUNCATE.
742 (defun fround (number &optional (divisor 1))
743   "Same as ROUND, but returns first value as a float."
744   (multiple-value-bind (res rem)
745       (round number divisor)
746     (values (float res (if (floatp rem) rem 1.0)) rem)))
747 \f
748 ;;;; comparisons
749
750 (defun = (number &rest more-numbers)
751   #!+sb-doc
752   "Return T if all of its arguments are numerically equal, NIL otherwise."
753   (declare (truly-dynamic-extent more-numbers))
754   (the number number)
755   (do ((nlist more-numbers (cdr nlist)))
756       ((atom nlist) t)
757      (declare (list nlist))
758      (if (not (= (car nlist) number)) (return nil))))
759
760 (defun /= (number &rest more-numbers)
761   #!+sb-doc
762   "Return T if no two of its arguments are numerically equal, NIL otherwise."
763   (declare (truly-dynamic-extent more-numbers))
764   (do* ((head (the number number) (car nlist))
765         (nlist more-numbers (cdr nlist)))
766        ((atom nlist) t)
767      (declare (list nlist))
768      (unless (do* ((nl nlist (cdr nl)))
769                   ((atom nl) t)
770                (declare (list nl))
771                (if (= head (car nl)) (return nil)))
772        (return nil))))
773
774 (defun < (number &rest more-numbers)
775   #!+sb-doc
776   "Return T if its arguments are in strictly increasing order, NIL otherwise."
777   (declare (truly-dynamic-extent more-numbers))
778   (do* ((n (the number number) (car nlist))
779         (nlist more-numbers (cdr nlist)))
780        ((atom nlist) t)
781      (declare (list nlist))
782      (if (not (< n (car nlist))) (return nil))))
783
784 (defun > (number &rest more-numbers)
785   #!+sb-doc
786   "Return T if its arguments are in strictly decreasing order, NIL otherwise."
787   (declare (truly-dynamic-extent more-numbers))
788   (do* ((n (the number number) (car nlist))
789         (nlist more-numbers (cdr nlist)))
790        ((atom nlist) t)
791      (declare (list nlist))
792      (if (not (> n (car nlist))) (return nil))))
793
794 (defun <= (number &rest more-numbers)
795   #!+sb-doc
796   "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
797   (declare (truly-dynamic-extent more-numbers))
798   (do* ((n (the number number) (car nlist))
799         (nlist more-numbers (cdr nlist)))
800        ((atom nlist) t)
801      (declare (list nlist))
802      (if (not (<= n (car nlist))) (return nil))))
803
804 (defun >= (number &rest more-numbers)
805   #!+sb-doc
806   "Return T if arguments are in strictly non-increasing order, NIL otherwise."
807   (declare (truly-dynamic-extent more-numbers))
808   (do* ((n (the number number) (car nlist))
809         (nlist more-numbers (cdr nlist)))
810        ((atom nlist) t)
811      (declare (list nlist))
812      (if (not (>= n (car nlist))) (return nil))))
813
814 (defun max (number &rest more-numbers)
815   #!+sb-doc
816   "Return the greatest of its arguments; among EQUALP greatest, return
817 the first."
818   (declare (truly-dynamic-extent more-numbers))
819   (do ((nlist more-numbers (cdr nlist))
820        (result number))
821       ((null nlist) (return result))
822      (declare (list nlist))
823      (declare (type real number result))
824      (if (> (car nlist) result) (setq result (car nlist)))))
825
826 (defun min (number &rest more-numbers)
827   #!+sb-doc
828   "Return the least of its arguments; among EQUALP least, return
829 the first."
830   (declare (truly-dynamic-extent more-numbers))
831   (do ((nlist more-numbers (cdr nlist))
832        (result number))
833       ((null nlist) (return result))
834      (declare (list nlist))
835      (declare (type real number result))
836      (if (< (car nlist) result) (setq result (car nlist)))))
837
838 (eval-when (:compile-toplevel :execute)
839
840 ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
841 ;;; to handle the case when X or Y is a floating-point infinity and
842 ;;; the other arg is a rational. (Section 12.1.4.1 of the ANSI spec
843 ;;; says that comparisons are done by converting the float to a
844 ;;; rational when comparing with a rational, but infinities can't be
845 ;;; converted to a rational, so we show some initiative and do it this
846 ;;; way instead.)
847 (defun basic-compare (op &key infinite-x-finite-y infinite-y-finite-x)
848   `(((fixnum fixnum) (,op x y))
849
850     ((single-float single-float) (,op x y))
851     #!+long-float
852     (((foreach single-float double-float long-float) long-float)
853      (,op (coerce x 'long-float) y))
854     #!+long-float
855     ((long-float (foreach single-float double-float))
856      (,op x (coerce y 'long-float)))
857     ((fixnum (foreach single-float double-float))
858      (if (float-infinity-p y)
859          ,infinite-y-finite-x
860          ;; If the fixnum has an exact float representation, do a
861          ;; float comparison. Otherwise do the slow float -> ratio
862          ;; conversion.
863          (multiple-value-bind (lo hi)
864              (case '(dispatch-type y)
865                (single-float
866                 (values most-negative-exactly-single-float-fixnum
867                         most-positive-exactly-single-float-fixnum))
868                (double-float
869                 (values most-negative-exactly-double-float-fixnum
870                         most-positive-exactly-double-float-fixnum)))
871            (if (<= lo y hi)
872                (,op (coerce x '(dispatch-type y)) y)
873                (,op x (rational y))))))
874     (((foreach single-float double-float) fixnum)
875      (if (eql y 0)
876          (,op x (coerce 0 '(dispatch-type x)))
877          (if (float-infinity-p x)
878              ,infinite-x-finite-y
879              ;; Likewise
880              (multiple-value-bind (lo hi)
881                  (case '(dispatch-type x)
882                    (single-float
883                     (values most-negative-exactly-single-float-fixnum
884                             most-positive-exactly-single-float-fixnum))
885                    (double-float
886                     (values most-negative-exactly-double-float-fixnum
887                             most-positive-exactly-double-float-fixnum)))
888                (if (<= lo y hi)
889                    (,op x (coerce y '(dispatch-type x)))
890                    (,op (rational x) y))))))
891     (((foreach single-float double-float) double-float)
892      (,op (coerce x 'double-float) y))
893     ((double-float single-float)
894      (,op x (coerce y 'double-float)))
895     (((foreach single-float double-float #!+long-float long-float) rational)
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              (,op (rational x) y))))
901     (((foreach bignum fixnum ratio) float)
902      (if (float-infinity-p y)
903          ,infinite-y-finite-x
904          (,op x (rational y))))))
905 ) ; EVAL-WHEN
906
907 (macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
908              `(defun ,name (x y)
909                 (number-dispatch ((x real) (y real))
910                                  (basic-compare
911                                   ,op
912                                   :infinite-x-finite-y
913                                   (,op x (coerce 0 '(dispatch-type x)))
914                                   :infinite-y-finite-x
915                                   (,op (coerce 0 '(dispatch-type y)) y))
916                                  (((foreach fixnum bignum) ratio)
917                                   (,op x (,ratio-arg2 (numerator y)
918                                                       (denominator y))))
919                                  ((ratio integer)
920                                   (,op (,ratio-arg1 (numerator x)
921                                                     (denominator x))
922                                        y))
923                                  ((ratio ratio)
924                                   (,op (* (numerator   (truly-the ratio x))
925                                           (denominator (truly-the ratio y)))
926                                        (* (numerator   (truly-the ratio y))
927                                           (denominator (truly-the ratio x)))))
928                                  ,@cases))))
929   (def-two-arg-</> two-arg-< < floor ceiling
930     ((fixnum bignum)
931      (bignum-plus-p y))
932     ((bignum fixnum)
933      (not (bignum-plus-p x)))
934     ((bignum bignum)
935      (minusp (bignum-compare x y))))
936   (def-two-arg-</> two-arg-> > ceiling floor
937     ((fixnum bignum)
938      (not (bignum-plus-p y)))
939     ((bignum fixnum)
940      (bignum-plus-p x))
941     ((bignum bignum)
942      (plusp (bignum-compare x y)))))
943
944 (defun two-arg-= (x y)
945   (number-dispatch ((x number) (y number))
946     (basic-compare =
947                    ;; An infinite value is never equal to a finite value.
948                    :infinite-x-finite-y nil
949                    :infinite-y-finite-x nil)
950     ((fixnum (or bignum ratio)) nil)
951
952     ((bignum (or fixnum ratio)) nil)
953     ((bignum bignum)
954      (zerop (bignum-compare x y)))
955
956     ((ratio integer) nil)
957     ((ratio ratio)
958      (and (eql (numerator x) (numerator y))
959           (eql (denominator x) (denominator y))))
960
961     ((complex complex)
962      (and (= (realpart x) (realpart y))
963           (= (imagpart x) (imagpart y))))
964     (((foreach fixnum bignum ratio single-float double-float
965                #!+long-float long-float) complex)
966      (and (= x (realpart y))
967           (zerop (imagpart y))))
968     ((complex (or float rational))
969      (and (= (realpart x) y)
970           (zerop (imagpart x))))))
971 \f
972 ;;;; logicals
973
974 (defun logior (&rest integers)
975   #!+sb-doc
976   "Return the bit-wise or of its arguments. Args must be integers."
977   (declare (list integers))
978   (if integers
979       (do ((result (pop integers) (logior result (pop integers))))
980           ((null integers) result)
981         (declare (integer result)))
982       0))
983
984 (defun logxor (&rest integers)
985   #!+sb-doc
986   "Return the bit-wise exclusive or of its arguments. Args must be integers."
987   (declare (list integers))
988   (if integers
989       (do ((result (pop integers) (logxor result (pop integers))))
990           ((null integers) result)
991         (declare (integer result)))
992       0))
993
994 (defun logand (&rest integers)
995   #!+sb-doc
996   "Return the bit-wise and of its arguments. Args must be integers."
997   (declare (list integers))
998   (if integers
999       (do ((result (pop integers) (logand result (pop integers))))
1000           ((null integers) result)
1001         (declare (integer result)))
1002       -1))
1003
1004 (defun logeqv (&rest integers)
1005   #!+sb-doc
1006   "Return the bit-wise equivalence of its arguments. Args must be integers."
1007   (declare (list integers))
1008   (if integers
1009       (do ((result (pop integers) (logeqv result (pop integers))))
1010           ((null integers) result)
1011         (declare (integer result)))
1012       -1))
1013
1014 (defun lognot (number)
1015   #!+sb-doc
1016   "Return the bit-wise logical not of integer."
1017   (etypecase number
1018     (fixnum (lognot (truly-the fixnum number)))
1019     (bignum (bignum-logical-not number))))
1020
1021 (macrolet ((def (name op big-op &optional doc)
1022              `(defun ,name (integer1 integer2)
1023                 ,@(when doc
1024                     (list doc))
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 logand bignum-logical-and)
1030   (def two-arg-ior logior bignum-logical-ior)
1031   (def two-arg-xor 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 logeqv (lambda (x y) (lognot (bignum-logical-xor x y))))
1035   (def lognand 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 lognor
1039        (lambda (x y) (lognot (bignum-logical-ior x y)))
1040        #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
1041   ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum
1042   (def logandc1 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 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 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 logorc2
1052        (lambda (x y) (bignum-logical-ior x (bignum-logical-not y)))
1053        #!+sb-doc "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)."))
1054
1055 (defun logcount (integer)
1056   #!+sb-doc
1057   "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits
1058   if INTEGER is negative."
1059   (etypecase integer
1060     (fixnum
1061      (logcount (truly-the (integer 0
1062                                    #.(max sb!xc:most-positive-fixnum
1063                                           (lognot sb!xc:most-negative-fixnum)))
1064                           (if (minusp (truly-the fixnum integer))
1065                               (lognot (truly-the fixnum integer))
1066                               integer))))
1067     (bignum
1068      (bignum-logcount integer))))
1069
1070 (defun logtest (integer1 integer2)
1071   #!+sb-doc
1072   "Predicate which returns T if logand of integer1 and integer2 is not zero."
1073   (logtest integer1 integer2))
1074
1075 (defun logbitp (index integer)
1076   #!+sb-doc
1077   "Predicate returns T if bit index of integer is a 1."
1078   (number-dispatch ((index integer) (integer integer))
1079     ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits))
1080                          (minusp integer)
1081                          (not (zerop (logand integer (ash 1 index))))))
1082     ((fixnum bignum) (bignum-logbitp index integer))
1083     ((bignum (foreach fixnum bignum)) (minusp integer))))
1084
1085 (defun ash (integer count)
1086   #!+sb-doc
1087   "Shifts integer left by count places preserving sign. - count shifts right."
1088   (declare (integer integer count))
1089   (etypecase integer
1090     (fixnum
1091      (cond ((zerop integer)
1092             0)
1093            ((fixnump count)
1094             (let ((length (integer-length (truly-the fixnum integer)))
1095                   (count (truly-the fixnum count)))
1096               (declare (fixnum length count))
1097               (cond ((and (plusp count)
1098                           (> (+ length count)
1099                              (integer-length most-positive-fixnum)))
1100                      (bignum-ashift-left (make-small-bignum integer) count))
1101                     (t
1102                      (truly-the fixnum
1103                                 (ash (truly-the fixnum integer) count))))))
1104            ((minusp count)
1105             (if (minusp integer) -1 0))
1106            (t
1107             (bignum-ashift-left (make-small-bignum integer) count))))
1108     (bignum
1109      (if (plusp count)
1110          (bignum-ashift-left integer count)
1111          (bignum-ashift-right integer (- count))))))
1112
1113 (defun integer-length (integer)
1114   #!+sb-doc
1115   "Return the number of non-sign bits in the twos-complement representation
1116   of INTEGER."
1117   (etypecase integer
1118     (fixnum
1119      (integer-length (truly-the fixnum integer)))
1120     (bignum
1121      (bignum-integer-length integer))))
1122 \f
1123 ;;;; BYTE, bytespecs, and related operations
1124
1125 (defun byte (size position)
1126   #!+sb-doc
1127   "Return a byte specifier which may be used by other byte functions
1128   (e.g. LDB)."
1129   (byte size position))
1130
1131 (defun byte-size (bytespec)
1132   #!+sb-doc
1133   "Return the size part of the byte specifier bytespec."
1134   (byte-size bytespec))
1135
1136 (defun byte-position (bytespec)
1137   #!+sb-doc
1138   "Return the position part of the byte specifier bytespec."
1139   (byte-position bytespec))
1140
1141 (defun ldb (bytespec integer)
1142   #!+sb-doc
1143   "Extract the specified byte from integer, and right justify result."
1144   (ldb bytespec integer))
1145
1146 (defun ldb-test (bytespec integer)
1147   #!+sb-doc
1148   "Return T if any of the specified bits in integer are 1's."
1149   (ldb-test bytespec integer))
1150
1151 (defun mask-field (bytespec integer)
1152   #!+sb-doc
1153   "Extract the specified byte from integer,  but do not right justify result."
1154   (mask-field bytespec integer))
1155
1156 (defun dpb (newbyte bytespec integer)
1157   #!+sb-doc
1158   "Return new integer with newbyte in specified position, newbyte is right justified."
1159   (dpb newbyte bytespec integer))
1160
1161 (defun deposit-field (newbyte bytespec integer)
1162   #!+sb-doc
1163   "Return new integer with newbyte in specified position, newbyte is not right justified."
1164   (deposit-field newbyte bytespec integer))
1165
1166 (defun %ldb (size posn integer)
1167   (logand (ash integer (- posn))
1168           (1- (ash 1 size))))
1169
1170 (defun %mask-field (size posn integer)
1171   (logand integer (ash (1- (ash 1 size)) posn)))
1172
1173 (defun %dpb (newbyte size posn integer)
1174   (let ((mask (1- (ash 1 size))))
1175     (logior (logand integer (lognot (ash mask posn)))
1176             (ash (logand newbyte mask) posn))))
1177
1178 (defun %deposit-field (newbyte size posn integer)
1179   (let ((mask (ash (ldb (byte size 0) -1) posn)))
1180     (logior (logand newbyte mask)
1181             (logand integer (lognot mask)))))
1182
1183 (defun sb!c::mask-signed-field (size integer)
1184   #!+sb-doc
1185   "Extract SIZE lower bits from INTEGER, considering them as a
1186 2-complement SIZE-bits representation of a signed integer."
1187   (cond ((zerop size)
1188          0)
1189         ((logbitp (1- size) integer)
1190          (dpb integer (byte size 0) -1))
1191         (t
1192          (ldb (byte size 0) integer))))
1193
1194 \f
1195 ;;;; BOOLE
1196
1197 ;;; The boole function dispaches to any logic operation depending on
1198 ;;;     the value of a variable. Presently, legal selector values are [0..15].
1199 ;;;     boole is open coded for calls with a constant selector. or with calls
1200 ;;;     using any of the constants declared below.
1201
1202 (defconstant boole-clr 0
1203   #!+sb-doc
1204   "Boole function op, makes BOOLE return 0.")
1205
1206 (defconstant boole-set 1
1207   #!+sb-doc
1208   "Boole function op, makes BOOLE return -1.")
1209
1210 (defconstant boole-1   2
1211   #!+sb-doc
1212   "Boole function op, makes BOOLE return integer1.")
1213
1214 (defconstant boole-2   3
1215   #!+sb-doc
1216   "Boole function op, makes BOOLE return integer2.")
1217
1218 (defconstant boole-c1  4
1219   #!+sb-doc
1220   "Boole function op, makes BOOLE return complement of integer1.")
1221
1222 (defconstant boole-c2  5
1223   #!+sb-doc
1224   "Boole function op, makes BOOLE return complement of integer2.")
1225
1226 (defconstant boole-and 6
1227   #!+sb-doc
1228   "Boole function op, makes BOOLE return logand of integer1 and integer2.")
1229
1230 (defconstant boole-ior 7
1231   #!+sb-doc
1232   "Boole function op, makes BOOLE return logior of integer1 and integer2.")
1233
1234 (defconstant boole-xor 8
1235   #!+sb-doc
1236   "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
1237
1238 (defconstant boole-eqv 9
1239   #!+sb-doc
1240   "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
1241
1242 (defconstant boole-nand  10
1243   #!+sb-doc
1244   "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
1245
1246 (defconstant boole-nor   11
1247   #!+sb-doc
1248   "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
1249
1250 (defconstant boole-andc1 12
1251   #!+sb-doc
1252   "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
1253
1254 (defconstant boole-andc2 13
1255   #!+sb-doc
1256   "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
1257
1258 (defconstant boole-orc1  14
1259   #!+sb-doc
1260   "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
1261
1262 (defconstant boole-orc2  15
1263   #!+sb-doc
1264   "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
1265
1266 (defun boole (op integer1 integer2)
1267   #!+sb-doc
1268   "Bit-wise boolean function on two integers. Function chosen by OP:
1269         0       BOOLE-CLR
1270         1       BOOLE-SET
1271         2       BOOLE-1
1272         3       BOOLE-2
1273         4       BOOLE-C1
1274         5       BOOLE-C2
1275         6       BOOLE-AND
1276         7       BOOLE-IOR
1277         8       BOOLE-XOR
1278         9       BOOLE-EQV
1279         10      BOOLE-NAND
1280         11      BOOLE-NOR
1281         12      BOOLE-ANDC1
1282         13      BOOLE-ANDC2
1283         14      BOOLE-ORC1
1284         15      BOOLE-ORC2"
1285   (case op
1286     (0 (boole 0 integer1 integer2))
1287     (1 (boole 1 integer1 integer2))
1288     (2 (boole 2 integer1 integer2))
1289     (3 (boole 3 integer1 integer2))
1290     (4 (boole 4 integer1 integer2))
1291     (5 (boole 5 integer1 integer2))
1292     (6 (boole 6 integer1 integer2))
1293     (7 (boole 7 integer1 integer2))
1294     (8 (boole 8 integer1 integer2))
1295     (9 (boole 9 integer1 integer2))
1296     (10 (boole 10 integer1 integer2))
1297     (11 (boole 11 integer1 integer2))
1298     (12 (boole 12 integer1 integer2))
1299     (13 (boole 13 integer1 integer2))
1300     (14 (boole 14 integer1 integer2))
1301     (15 (boole 15 integer1 integer2))
1302     (t (error 'type-error :datum op :expected-type '(mod 16)))))
1303 \f
1304 ;;;; GCD and LCM
1305
1306 (defun gcd (&rest integers)
1307   #!+sb-doc
1308   "Return the greatest common divisor of the arguments, which must be
1309   integers. Gcd with no arguments is defined to be 0."
1310   (cond ((null integers) 0)
1311         ((null (cdr integers)) (abs (the integer (car integers))))
1312         (t
1313          (do ((gcd (the integer (car integers))
1314                    (gcd gcd (the integer (car rest))))
1315               (rest (cdr integers) (cdr rest)))
1316              ((null rest) gcd)
1317            (declare (integer gcd)
1318                     (list rest))))))
1319
1320 (defun lcm (&rest integers)
1321   #!+sb-doc
1322   "Return the least common multiple of one or more integers. LCM of no
1323   arguments is defined to be 1."
1324   (cond ((null integers) 1)
1325         ((null (cdr integers)) (abs (the integer (car integers))))
1326         (t
1327          (do ((lcm (the integer (car integers))
1328                    (lcm lcm (the integer (car rest))))
1329               (rest (cdr integers) (cdr rest)))
1330              ((null rest) lcm)
1331            (declare (integer lcm) (list rest))))))
1332
1333 (defun two-arg-lcm (n m)
1334   (declare (integer n m))
1335   (if (or (zerop n) (zerop m))
1336       0
1337       ;; KLUDGE: I'm going to assume that it was written this way
1338       ;; originally for a reason.  However, this is a somewhat
1339       ;; complicated way of writing the algorithm in the CLHS page for
1340       ;; LCM, and I don't know why.  To be investigated.  -- CSR,
1341       ;; 2003-09-11
1342       ;;
1343       ;;    It seems to me that this is written this way to avoid
1344       ;;    unnecessary bignumification of intermediate results.
1345       ;;        -- TCR, 2008-03-05
1346       (let ((m (abs m))
1347             (n (abs n)))
1348         (multiple-value-bind (max min)
1349             (if (> m n)
1350                 (values m n)
1351                 (values n m))
1352           (* (truncate max (gcd n m)) min)))))
1353
1354 ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
1355 ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
1356 ;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
1357 ;;; of 0 before the dispatch so that the bignum code doesn't have to worry
1358 ;;; about "small bignum" zeros.
1359 (defun two-arg-gcd (u v)
1360   (cond ((eql u 0) (abs v))
1361         ((eql v 0) (abs u))
1362         (t
1363          (number-dispatch ((u integer) (v integer))
1364            ((fixnum fixnum)
1365             (locally
1366                 (declare (optimize (speed 3) (safety 0)))
1367               (do ((k 0 (1+ k))
1368                    (u (abs u) (ash u -1))
1369                    (v (abs v) (ash v -1)))
1370                   ((oddp (logior u v))
1371                    (do ((temp (if (oddp u) (- v) (ash u -1))
1372                               (ash temp -1)))
1373                        (nil)
1374                      (declare (fixnum temp))
1375                      (when (oddp temp)
1376                        (if (plusp temp)
1377                            (setq u temp)
1378                            (setq v (- temp)))
1379                        (setq temp (- u v))
1380                        (when (zerop temp)
1381                          (let ((res (ash u k)))
1382                            (declare (type sb!vm:signed-word res)
1383                                     (optimize (inhibit-warnings 3)))
1384                            (return res))))))
1385                 (declare (type (mod #.sb!vm:n-word-bits) k)
1386                          (type sb!vm:signed-word u v)))))
1387            ((bignum bignum)
1388             (bignum-gcd u v))
1389            ((bignum fixnum)
1390             (bignum-gcd u (make-small-bignum v)))
1391            ((fixnum bignum)
1392             (bignum-gcd (make-small-bignum u) v))))))
1393 \f
1394 ;;;; from Robert Smith
1395 (defun isqrt (n)
1396   #!+sb-doc
1397   "Return the root of the nearest integer less than n which is a perfect
1398    square."
1399   (declare (type unsigned-byte n))
1400   (cond
1401     ((> n 24)
1402      (let* ((n-fourth-size (ash (1- (integer-length n)) -2))
1403             (n-significant-half (ash n (- (ash n-fourth-size 1))))
1404             (n-significant-half-isqrt (isqrt n-significant-half))
1405             (zeroth-iteration (ash n-significant-half-isqrt n-fourth-size))
1406             (qr (multiple-value-list (floor n zeroth-iteration)))
1407             (first-iteration (ash (+ zeroth-iteration (first qr)) -1)))
1408        (cond ((oddp (first qr))
1409               first-iteration)
1410              ((> (expt (- first-iteration zeroth-iteration) 2) (second qr))
1411               (1- first-iteration))
1412              (t
1413               first-iteration))))
1414     ((> n 15) 4)
1415     ((> n  8) 3)
1416     ((> n  3) 2)
1417     ((> n  0) 1)
1418     ((= n  0) 0)))
1419 \f
1420 ;;;; miscellaneous number predicates
1421
1422 (macrolet ((def (name doc)
1423              `(defun ,name (number) ,doc (,name number))))
1424   (def zerop "Is this number zero?")
1425   (def plusp "Is this real number strictly positive?")
1426   (def minusp "Is this real number strictly negative?")
1427   (def oddp "Is this integer odd?")
1428   (def evenp "Is this integer even?"))
1429 \f
1430 ;;;; modular functions
1431 #.
1432 (collect ((forms))
1433   (flet ((unsigned-definition (name lambda-list width)
1434            (let ((pattern (1- (ash 1 width))))
1435              `(defun ,name ,lambda-list
1436                (flet ((prepare-argument (x)
1437                         (declare (integer x))
1438                         (etypecase x
1439                           ((unsigned-byte ,width) x)
1440                           (fixnum (logand x ,pattern))
1441                           (bignum (logand x ,pattern)))))
1442                  (,name ,@(loop for arg in lambda-list
1443                                 collect `(prepare-argument ,arg)))))))
1444          (signed-definition (name lambda-list width)
1445            `(defun ,name ,lambda-list
1446               (flet ((prepare-argument (x)
1447                        (declare (integer x))
1448                        (etypecase x
1449                          ((signed-byte ,width) x)
1450                          (fixnum (sb!c::mask-signed-field ,width x))
1451                          (bignum (sb!c::mask-signed-field ,width x)))))
1452                 (,name ,@(loop for arg in lambda-list
1453                                collect `(prepare-argument ,arg)))))))
1454     (flet ((do-mfuns (class)
1455              (loop for infos being each hash-value of (sb!c::modular-class-funs class)
1456                    ;; FIXME: We need to process only "toplevel" functions
1457                    when (listp infos)
1458                    do (loop for info in infos
1459                             for name = (sb!c::modular-fun-info-name info)
1460                             and width = (sb!c::modular-fun-info-width info)
1461                             and signedp = (sb!c::modular-fun-info-signedp info)
1462                             and lambda-list = (sb!c::modular-fun-info-lambda-list info)
1463                             if signedp
1464                             do (forms (signed-definition name lambda-list width))
1465                             else
1466                             do (forms (unsigned-definition name lambda-list width))))))
1467       (do-mfuns sb!c::*untagged-unsigned-modular-class*)
1468       (do-mfuns sb!c::*untagged-signed-modular-class*)
1469       (do-mfuns sb!c::*tagged-modular-class*)))
1470   `(progn ,@(sort (forms) #'string< :key #'cadr)))
1471
1472 ;;; KLUDGE: these out-of-line definitions can't use the modular
1473 ;;; arithmetic, as that is only (currently) defined for constant
1474 ;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
1475 ;;; discussion of this hack.  -- CSR, 2003-10-09
1476 #!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
1477 (defun sb!vm::ash-left-mod32 (integer amount)
1478   (etypecase integer
1479     ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
1480     (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
1481     (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
1482 #!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
1483 (defun sb!vm::ash-left-mod64 (integer amount)
1484   (etypecase integer
1485     ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
1486     (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
1487     (bignum (ldb (byte 64 0)
1488                  (ash (logand integer #xffffffffffffffff) amount)))))
1489
1490 #!+x86
1491 (defun sb!vm::ash-left-smod30 (integer amount)
1492   (etypecase integer
1493     ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
1494     (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
1495
1496 #!+x86-64
1497 (defun sb!vm::ash-left-smod61 (integer amount)
1498   (etypecase integer
1499     ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
1500     (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount)))))