tests/float.impure.lisp

   1 ;;;; This file is for floating-point-related tests which have side
   2 ;;;; effects (e.g. executing DEFUN).
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 (cl:in-package :cl-user)
  16
  17 ;;; Hannu Rummukainen reported a CMU CL bug on cmucl-imp@cons.org 26
  18 ;;; Jun 2000. This is the test case for it.
  19 ;;;
  20 ;;; The bug was listed as "39: .. Probably the same bug exists in
  21 ;;; SBCL" for a while until Martin Atzmueller showed that it's not
  22 ;;; present after all, presumably because the bug was introduced into
  23 ;;; CMU CL after the fork. But we'll test for it anyway, in case
  24 ;;; e.g. someone inadvertently ports the bad code.
  25 (defun point39 (x y)
  26   (make-array 2
  27               :element-type 'double-float
  28               :initial-contents (list x y)))
  29
  30 (declaim (inline point39-x point39-y))
  31 (defun point39-x (p)
  32   (declare (type (simple-array double-float (2)) p))
  33   (aref p 0))
  34 (defun point39-y (p)
  35   (declare (type (simple-array double-float (2)) p))
  36   (aref p 1))
  37 (defun order39 (points)
  38   (sort points  (lambda (p1 p2)
  39                   (let* ((y1 (point39-y p1))
  40                          (y2 (point39-y p2)))
  41                     (if (= y1 y2)
  42                         (< (point39-x p1)
  43                            (point39-x p2))
  44                         (< y1 y2))))))
  45 (defun test39 ()
  46   (order39 (make-array 4
  47                        :initial-contents (list (point39 0.0d0 0.0d0)
  48                                                (point39 1.0d0 1.0d0)
  49                                                (point39 2.0d0 2.0d0)
  50                                                (point39 3.0d0 3.0d0)))))
  51 (assert (equalp (test39)
  52                 #(#(0.0d0 0.0d0)
  53                   #(1.0d0 1.0d0)
  54                   #(2.0d0 2.0d0)
  55                   #(3.0d0 3.0d0))))
  56
  57 (defun complex-double-float-ppc (x y)
  58   (declare (type (complex double-float) x y))
  59   (declare (optimize speed))
  60   (+ x y))
  61 (compile 'complex-double-float-ppc)
  62 (assert (= (complex-double-float-ppc #c(0.0d0 1.0d0) #c(2.0d0 3.0d0))
  63            #c(2.0d0 4.0d0)))
  64
  65 (defun single-float-ppc (x)
  66   (declare (type (signed-byte 32) x) (optimize speed))
  67   (float x 1f0))
  68 (compile 'single-float-ppc)
  69 (assert (= (single-float-ppc -30) -30f0))
  70
  71 ;;; constant-folding irrational functions
  72 (declaim (inline df))
  73 (defun df (x)
  74   ;; do not remove the ECASE here: the bug this checks for indeed
  75   ;; depended on this configuration
  76   (ecase x (1 least-positive-double-float)))
  77 (macrolet ((test (fun)
  78              (let ((name (intern (format nil "TEST-CONSTANT-~A" fun))))
  79                `(progn
  80                   (defun ,name () (,fun (df 1)))
  81                   (,name)))))
  82   (test sqrt)
  83   (test log)
  84   (test sin)
  85   (test cos)
  86   (test tan)
  87   (test asin)
  88   (test acos)
  89   (test atan)
  90   (test sinh)
  91   (test cosh)
  92   (test tanh)
  93   (test asinh)
  94   (test acosh)
  95   (test atanh)
  96   (test exp))
  97
  98 ;;; Broken move-arg-double-float for non-rsp frame pointers on x86-64
  99 (defun test (y)
 100   (declare (optimize speed))
 101   (multiple-value-bind (x)
 102       (labels ((aux (x)
 103                  (declare (double-float x))
 104                  (etypecase y
 105                    (double-float
 106                     nil)
 107                    (fixnum
 108                     (aux x))
 109                    (complex
 110                     (format t "y=~s~%" y)))
 111                  (values x)))
 112         (aux 2.0d0))
 113     x))
 114
 115 (assert (= (test 1.0d0) 2.0d0))
 116
 117 (deftype myarraytype (&optional (length '*))
 118   `(simple-array double-float (,length)))
 119 (defun new-pu-label-from-pu-labels (array)
 120   (setf (aref (the myarraytype array) 0)
 121         sb-ext:double-float-positive-infinity))
 122
 123 ;;; bug 407
 124 ;;;
 125 ;;; FIXME: it may be that TYPE-ERROR is wrong, and we should
 126 ;;; instead signal an overflow or coerce into an infinity.
 127 (defun bug-407a ()
 128   (loop for n from (expt 2 1024) upto (+ 10 (expt 2 1024))
 129         do (handler-case
 130                (coerce n 'single-float)
 131              (simple-type-error ()
 132                (return-from bug-407a :type-error)))))
 133 (assert (eq :type-error (bug-407a)))
 134 (defun bug-407b ()
 135   (loop for n from (expt 2 1024) upto (+ 10 (expt 2 1024))
 136         do (handler-case
 137                (format t "~E~%" (coerce n 'single-float))
 138              (simple-type-error ()
 139                (return-from bug-407b :type-error)))))
 140 (assert (eq :type-error (bug-407b)))