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 ;;; success
  58 (quit :unix-status 104)