Menu
▾
▴
[Sbcl-commits] CVS: sbcl/tests float.impure.lisp, 1.11, 1.12 float.pure.lisp, 1.46, 1.47
|
From: Paul K. <pk...@us...> - 2009-07-06 13:18:13
|
Update of /cvsroot/sbcl/sbcl/tests In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv13867/tests Modified Files: float.impure.lisp float.pure.lisp Log Message: 1.0.29.54.rc3: Make float tests consume less memory * A test introduced in 1.0.29.44 uses a lot of memory during compilation. Split the definition into multiple toplevel functions to avoid exhausting the heap. Index: float.impure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/float.impure.lisp,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- float.impure.lisp 17 Feb 2008 13:26:16 -0000 1.11 +++ float.impure.lisp 6 Jul 2009 13:18:09 -0000 1.12 @@ -138,3 +138,99 @@ (simple-type-error () (return-from bug-407b :type-error))))) (assert (eq :type-error (bug-407b))) + +;; 1.0.29.44 introduces a ton of changes for complex floats +;; on x86-64. Huge test of doom to help catch weird corner +;; cases. +;; Abuse the framework to also test some float arithmetic +;; changes wrt constant arguments in 1.0.29.54. +(defmacro def-compute (name real-type + &optional (complex-type `(complex ,real-type))) + `(defun ,name (x y r) + (declare (type ,complex-type x y) + (type ,real-type r)) + (flet ((reflections (x) + (values x + (conjugate x) + (complex (- (realpart x)) (imagpart x)) + (- x))) + (compute (x y r) + (declare (type ,complex-type x y) + (type ,real-type r)) + (list (1+ x) (* 2 x) (/ x 2) (= 1 x) + (+ x y) (+ r x) (+ x r) + (- x y) (- r x) (- x r) + (* x y) (* x r) (* r x) + (unless (zerop y) + (/ x y)) + (unless (zerop r) + (/ x r)) + (unless (zerop x) + (/ r x)) + (conjugate x) (conjugate r) + (abs r) (- r) (= 1 r) + (- x) (1+ r) (* 2 r) (/ r 2) + (complex r) (complex r r) (complex 0 r) + (= x y) (= r x) (= y r) (= x (complex 0 r)) + (= r (realpart x)) (= (realpart x) r) + (> r (realpart x)) (< r (realpart x)) + (> (realpart x) r) (< (realpart x) r) + (eql x y) (eql x (complex r)) (eql y (complex r)) + (eql x (complex r r)) (eql y (complex 0 r)) + (eql r (realpart x)) (eql (realpart x) r)))) + (declare (inline reflections)) + (multiple-value-bind (x1 x2 x3 x4) (reflections x) + (multiple-value-bind (y1 y2 y3 y4) (reflections y) + #.(let ((form '(list))) + (dolist (x '(x1 x2 x3 x4) (reverse form)) + (dolist (y '(y1 y2 y3 y4)) + (push `(list ,x ,y r + (append (compute ,x ,y r) + (compute ,x ,y (- r)))) + form))))))))) + +(def-compute compute-number real number) +(def-compute compute-single single-float) +(def-compute compute-double double-float) + +(labels ((equal-enough (x y) + (cond ((eql x y)) + ((or (complexp x) + (complexp y)) + (or (eql (coerce x '(complex double-float)) + (coerce y '(complex double-float))) + (and (equal-enough (realpart x) (realpart y)) + (equal-enough (imagpart x) (imagpart y))))) + ((numberp x) + (or (eql (coerce x 'double-float) (coerce y 'double-float)) + (< (abs (- x y)) 1d-5)))))) + (let* ((reals '(0 1 2)) + (complexes '#.(let ((reals '(0 1 2)) + (cpx '())) + (dolist (x reals (nreverse cpx)) + (dolist (y reals) + (push (complex x y) cpx)))))) + (declare (notinline every)) + (dolist (r reals) + (dolist (x complexes) + (dolist (y complexes) + (let ((value (compute-number x y r)) + (single (compute-single (coerce x '(complex single-float)) + (coerce y '(complex single-float)) + (coerce r 'single-float))) + (double (compute-double (coerce x '(complex double-float)) + (coerce y '(complex double-float)) + (coerce r 'double-float)))) + (assert (every (lambda (pos ref single double) + (declare (ignorable pos)) + (every (lambda (ref single double) + (or (and (equal-enough ref single) + (equal-enough ref double)) + (and (not (numberp single)) ;; -ve 0s + (equal-enough single double)))) + (fourth ref) (fourth single) (fourth double))) + '((0 0) (0 1) (0 2) (0 3) + (1 0) (1 1) (1 2) (1 3) + (2 0) (2 1) (2 2) (2 3) + (3 0) (3 1) (3 2) (3 3)) + value single double)))))))) Index: float.pure.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/float.pure.lisp,v retrieving revision 1.46 retrieving revision 1.47 diff -u -d -r1.46 -r1.47 --- float.pure.lisp 28 Jun 2009 21:37:05 -0000 1.46 +++ float.pure.lisp 6 Jul 2009 13:18:09 -0000 1.47 @@ -233,90 +233,3 @@ (assert (eql 0.0d0 (funcall f 123.0d0 0.0))) (assert (eql 0.0d0 (funcall f 123.0d0 0.0d0))) (assert (eql 0.0d0 (funcall f 123.0 0.0d0))))) - -;; 1.0.29.44 introduces a ton of changes for complex floats -;; on x86-64. Huge test of doom to help catch weird corner -;; cases. -;; Abuse the framework to also test some float arithmetic -;; changes wrt constant arguments in 1.0.29.54. -(with-test (:name :float-arithmetic) - (labels ((equal-enough (x y) - (cond ((eql x y)) - ((or (complexp x) - (complexp y)) - (or (eql (coerce x '(complex double-float)) - (coerce y '(complex double-float))) - (and (equal-enough (realpart x) (realpart y)) - (equal-enough (imagpart x) (imagpart y))))) - ((numberp x) - (or (eql (coerce x 'double-float) (coerce y 'double-float)) - (< (abs (- x y)) 1d-5))))) - (reflections (x) - (values x - (conjugate x) - (complex (- (realpart x)) (imagpart x)) - (- x))) - (compute (x y r) - (list (1+ x) (* 2 x) (/ x 2) (= 1 x) - (+ x y) (+ r x) (+ x r) - (- x y) (- r x) (- x r) - (* x y) (* x r) (* r x) - (unless (zerop y) - (/ x y)) - (unless (zerop r) - (/ x r)) - (unless (zerop x) - (/ r x)) - (conjugate x) (conjugate r) - (abs r) (- r) (= 1 r) - (- x) (1+ r) (* 2 r) (/ r 2) - (complex r) (complex r r) (complex 0 r) - (= x y) (= r x) (= y r) (= x (complex 0 r)) - (= r (realpart x)) (= (realpart x) r) - (> r (realpart x)) (< r (realpart x)) - (> (realpart x) r) (< (realpart x) r) - (eql x y) (eql x (complex r)) (eql y (complex r)) - (eql x (complex r r)) (eql y (complex 0 r)) - (eql r (realpart x)) (eql (realpart x) r))) - (compute-all (x y r) - (multiple-value-bind (x1 x2 x3 x4) (reflections x) - (multiple-value-bind (y1 y2 y3 y4) (reflections y) - #.(let ((form '(list))) - (dolist (x '(x1 x2 x3 x4) (reverse form)) - (dolist (y '(y1 y2 y3 y4)) - (push `(list ,x ,y r - (append (compute ,x ,y r) - (compute ,x ,y (- r)))) - form)))))))) - (declare (inline reflections compute compute-all)) - (let* ((reals '(0 1 2)) - (complexes '#.(let ((reals '(0 1 2)) - (cpx '())) - (dolist (x reals (nreverse cpx)) - (dolist (y reals) - (push (complex x y) cpx))))) - (val ())) - (declare (notinline every)) - (dolist (r reals (nreverse val)) - (dolist (x complexes) - (dolist (y complexes) - (let ((value (compute-all x y r)) - (single (compute-all (coerce x '(complex single-float)) - (coerce y '(complex single-float)) - (coerce r 'single-float))) - (double (compute-all (coerce x '(complex double-float)) - (coerce y '(complex double-float)) - (coerce r 'double-float)))) - (assert (every (lambda (pos ref single double) - (declare (ignorable pos)) - (every (lambda (ref single double) - (or (and (equal-enough ref single) - (equal-enough ref double)) - (and (not (numberp single)) ;; -ve 0s - (equal-enough single double)))) - (fourth ref) (fourth single) (fourth double))) - '((0 0) (0 1) (0 2) (0 3) - (1 0) (1 1) (1 2) (1 3) - (2 0) (2 1) (2 2) (2 3) - (3 0) (3 1) (3 2) (3 3)) - value single double))))))))) |