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