;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;; unlikely that anything with such fundamental arithmetic errors as
;;; these are going to get this far, it's probably worth checking.
(macrolet ((test (op res1 res2)
- `(progn
- (assert (= (,op 4 2) ,res1))
- (assert (= (,op 2 4) ,res2))
- (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 4 2)
- ,res1))
- (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 2 4)
- ,res2)))))
+ `(progn
+ (assert (= (,op 4 2) ,res1))
+ (assert (= (,op 2 4) ,res2))
+ (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 4 2)
+ ,res1))
+ (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 2 4)
+ ,res2)))))
(test + 6 6)
(test - 2 -2)
(test * 8 8)
(assert (= (coerce 1/2 '(complex float)) #c(0.5 0.0)))
(assert (= (coerce 1.0d0 '(complex float)) #c(1.0d0 0.0d0)))
+;;; (COERCE #c(<RATIONAL> <RATIONAL>) '(complex float)) resulted in
+;;; an error up to 0.8.17.31
+(assert (= (coerce #c(1 2) '(complex float)) #c(1.0 2.0)))
+
;;; COERCE also sometimes failed to verify that a particular coercion
;;; was possible (in particular coercing rationals to bounded float
;;; types.
;;; checkins later, we'll have doubled the coverage.
(dotimes (i 100)
(let* ((x (random most-positive-fixnum))
- (x2 (* x 2))
- (x3 (* x 3)))
- (let ((fn (handler-bind ((sb-ext:compiler-note #'error))
- (compile nil
- `(lambda (y)
- (declare (optimize speed) (type (integer 0 3) y))
- (* y ,x))))))
+ (x2 (* x 2))
+ (x3 (* x 3)))
+ (let ((fn (handler-bind ((sb-ext:compiler-note
+ (lambda (c)
+ (when (<= x3 most-positive-fixnum)
+ (error c)))))
+ (compile nil
+ `(lambda (y)
+ (declare (optimize speed) (type (integer 0 3) y))
+ (* y ,x))))))
(unless (and (= (funcall fn 0) 0)
- (= (funcall fn 1) x)
- (= (funcall fn 2) x2)
- (= (funcall fn 3) x3))
- (error "bad results for ~D" x)))))
+ (= (funcall fn 1) x)
+ (= (funcall fn 2) x2)
+ (= (funcall fn 3) x3))
+ (error "bad results for ~D" x)))))
;;; Bugs reported by Paul Dietz:
;;; x86 LEA bug:
(assert (= (funcall
- (compile nil '(lambda (x) (declare (bit x)) (+ x #xf0000000)))
- 1)
- #xf0000001))
+ (compile nil '(lambda (x) (declare (bit x)) (+ x #xf0000000)))
+ 1)
+ #xf0000001))
;;; LOGBITP on bignums:
(dolist (x '(((1+ most-positive-fixnum) 1 nil)
- ((1+ most-positive-fixnum) -1 t)
- ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
- ((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
- (1 (ash most-negative-fixnum 1) nil)
- (29 most-negative-fixnum t)
- (30 (ash most-negative-fixnum 1) t)
- (31 (ash most-negative-fixnum 1) t)
- (64 (ash most-negative-fixnum 36) nil)
- (65 (ash most-negative-fixnum 36) t)))
+ ((1+ most-positive-fixnum) -1 t)
+ ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
+ ((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
+ (1 (ash most-negative-fixnum 1) nil)
+ (#.(- sb-vm:n-word-bits sb-vm:n-lowtag-bits) most-negative-fixnum t)
+ (#.(1+ (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
+ (#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
+ (#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) nil)
+ (#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) t)))
(destructuring-bind (index int result) x
(assert (eq (eval `(logbitp ,index ,int)) result))))
;;; type inference leading to an internal compiler error:
(let ((f (compile nil '(lambda (x)
- (declare (type fixnum x))
- (ldb (byte 0 0) x)))))
+ (declare (type fixnum x))
+ (ldb (byte 0 0) x)))))
(assert (= (funcall f 1) 0))
(assert (= (funcall f most-positive-fixnum) 0))
(assert (= (funcall f -1) 0)))
((89 125 16) (ASH A (MIN 18 -706)))
(T (DPB -3 (BYTE 30 30) -1)))))))
(assert (= (funcall fn 1227072 -529823 -18 -792831) -2147483649)))
+
+;;; ASH of a negative bignum by a bignum count would erroneously
+;;; return 0 prior to sbcl-0.8.4.4
+(assert (= (ash (1- most-negative-fixnum) (1- most-negative-fixnum)) -1))
+
+;;; Whoops. Too much optimization in division operators for 0
+;;; divisor.
+(macrolet ((frob (name)
+ `(let ((fn (compile nil '(lambda (x)
+ (declare (optimize speed) (fixnum x))
+ (,name x 0)))))
+ (assert (raises-error? (funcall fn 1) division-by-zero)))))
+ (frob mod)
+ (frob truncate)
+ (frob rem)
+ (frob /)
+ (frob floor)
+ (frob ceiling))
+
+;; Check that the logic in SB-KERNEL::BASIC-COMPARE for doing fixnum/float
+;; comparisons without rationalizing the floats still gives the right anwers
+;; in the edge cases (had a fencepost error).
+(macrolet ((test (range type sign)
+ `(let (ints
+ floats
+ (start (- ,(find-symbol (format nil
+ "MOST-~A-EXACTLY-~A-FIXNUM"
+ sign type)
+ :sb-kernel)
+ ,range)))
+ (dotimes (i (1+ (* ,range 2)))
+ (let* ((x (+ start i))
+ (y (coerce x ',type)))
+ (push x ints)
+ (push y floats)))
+ (dolist (i ints)
+ (dolist (f floats)
+ (dolist (op '(< <= = >= >))
+ (unless (eq (funcall op i f)
+ (funcall op i (rationalize f)))
+ (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%"
+ op i f
+ op i (rationalize f)))
+ (unless (eq (funcall op f i)
+ (funcall op (rationalize f) i))
+ (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%"
+ op f i
+ op (rationalize f) i))))))))
+ (test 32 double-float negative)
+ (test 32 double-float positive)
+ (test 32 single-float negative)
+ (test 32 single-float positive))
+
+;; x86-64 sign-extension bug found using pfdietz's random tester.
+(assert (= 286142502
+ (funcall (lambda ()
+ (declare (notinline logxor))
+ (min (logxor 0 0 0 286142502))))))
+
+;; Small bugs in LOGCOUNT can still allow SBCL to be built and thus go
+;; unnoticed, so check more thoroughly here.
+(with-test (:name :logcount)
+ (flet ((test (x n)
+ (unless (= (logcount x) n)
+ (error "logcount failure for ~a" x))))
+ ;; Test with some patterns with well known number of ones/zeroes ...
+ (dotimes (i 128)
+ (let ((x (ash 1 i)))
+ (test x 1)
+ (test (- x) i)
+ (test (1- x) i)))
+ ;; ... and with some random integers of varying length.
+ (flet ((test-logcount (x)
+ (declare (type integer x))
+ (do ((result 0 (1+ result))
+ (x (if (minusp x)
+ (lognot x)
+ x)
+ (logand x (1- x))))
+ ((zerop x) result))))
+ (dotimes (i 200)
+ (let ((x (random (ash 1 i))))
+ (test x (test-logcount x))
+ (test (- x) (test-logcount (- x))))))))
projects / sbcl.git / blobdiff