tests/compiler.pure.lisp

   1 ;;;; various compiler tests without side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (cl:in-package :cl-user)
  15
  16 ;;; Exercise a compiler bug (by crashing the compiler).
  17 ;;;
  18 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
  19 ;;; (2000-09-06 on cmucl-imp).
  20 ;;;
  21 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
  22 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
  23 (funcall (compile nil
  24                   '(lambda ()
  25                      (labels ((fun1 ()
  26                                 (fun2))
  27                               (fun2 ()
  28                                 (when nil
  29                                   (tagbody
  30                                    tag
  31                                    (fun2)
  32                                    (go tag)))
  33                                 (when nil
  34                                   (tagbody
  35                                    tag
  36                                    (fun1)
  37                                    (go tag)))))
  38
  39                        (fun1)
  40                        nil))))
  41
  42 ;;; Exercise a compiler bug (by crashing the compiler).
  43 ;;;
  44 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
  45 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
  46 (funcall (compile nil
  47                   '(lambda (x)
  48                      (or (integerp x)
  49                          (block used-by-some-y?
  50                            (flet ((frob (stk)
  51                                     (dolist (y stk)
  52                                       (unless (rejected? y)
  53                                         (return-from used-by-some-y? t)))))
  54                              (declare (inline frob))
  55                              (frob (rstk x))
  56                              (frob (mrstk x)))
  57                            nil))))
  58          13)
  59
  60 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
  61 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
  62 ;;; Alexey Dejneka 2002-01-27
  63 (assert (= 1 ; (used to give 0 under bug 112)
  64            (let ((x 0))
  65              (declare (special x))
  66              (let ((x 1))
  67                (let ((y x))
  68                  (declare (special x)) y)))))
  69 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
  70            (let ((x 0))
  71              (declare (special x))
  72              (let ((x 1))
  73                (let ((y x) (x 5))
  74                  (declare (special x)) y)))))
  75
  76 ;;; another LET-related bug fixed by Alexey Dejneka at the same
  77 ;;; time as bug 112
  78 (multiple-value-bind (value error)
  79     (ignore-errors
  80       ;; should complain about duplicate variable names in LET binding
  81       (compile nil
  82                '(lambda ()
  83                   (let (x
  84                         (x 1))
  85                     (list x)))))
  86   (assert (null value))
  87   (assert (typep error 'error)))
  88
  89 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
  90 ;;; Lichteblau 2002-05-21)
  91 (progn
  92   (multiple-value-bind (fun warnings-p failure-p)
  93       (compile nil
  94                ;; Compiling this code should cause a STYLE-WARNING
  95                ;; about *X* looking like a special variable but not
  96                ;; being one.
  97                '(lambda (n)
  98                   (let ((*x* n))
  99                     (funcall (symbol-function 'x-getter))
 100                     (print *x*))))
 101     (assert (functionp fun))
 102     (assert warnings-p)
 103     (assert (not failure-p)))
 104   (multiple-value-bind (fun warnings-p failure-p)
 105       (compile nil
 106                ;; Compiling this code should not cause a warning
 107                ;; (because the DECLARE turns *X* into a special
 108                ;; variable as its name suggests it should be).
 109                '(lambda (n)
 110                   (let ((*x* n))
 111                     (declare (special *x*))
 112                     (funcall (symbol-function 'x-getter))
 113                     (print *x*))))
 114     (assert (functionp fun))
 115     (assert (not warnings-p))
 116     (assert (not failure-p))))
 117
 118 ;;; a bug in 0.7.4.11
 119 (dolist (i '(a b 1 2 "x" "y"))
 120   ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
 121   ;; TYPEP here but got confused and died, doing
 122   ;;   (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
 123   ;;          *BACKEND-TYPE-PREDICATES*
 124   ;;          :TEST #'TYPE=)
 125   ;; and blowing up because TYPE= tried to call PLUSP on the
 126   ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
 127   (when (typep i '(and integer (satisfies oddp)))
 128     (print i)))
 129 (dotimes (i 14)
 130   (when (typep i '(and integer (satisfies oddp)))
 131     (print i)))
 132
 133 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
 134 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
 135 ;;; interactively-compiled functions was broken by sleaziness and
 136 ;;; confusion in the assault on 0.7.0, so this expression used to
 137 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
 138 (eval '(function-lambda-expression #'(lambda (x) x)))
 139
 140 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
 141 ;;; variable is not optional.
 142 (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12))))))
 143
 144 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
 145 ;;; a while; fixed by CSR 2002-07-18
 146 (multiple-value-bind (value error)
 147     (ignore-errors (some-undefined-function))
 148   (assert (null value))
 149   (assert (eq (cell-error-name error) 'some-undefined-function)))
 150
 151 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
 152 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
 153 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
 154 (assert (ignore-errors (eval '(lambda (foo) 12))))
 155 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
 156 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
 157 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
 158 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
 159 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
 160 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
 161 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
 162 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
 163 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
 164 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
 165
 166 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
 167 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
 168 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
 169 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
 170            17))
 171
 172 ;;; bug 181: bad type specifier dropped compiler into debugger
 173 (assert (list (compile nil '(lambda (x)
 174                              (declare (type (0) x))
 175                              x))))
 176
 177 (let ((f (compile nil '(lambda (x)
 178                         (make-array 1 :element-type '(0))))))
 179   (assert (null (ignore-errors (funcall f)))))
 180
 181 ;;; the following functions must not be flushable
 182 (dolist (form '((make-sequence 'fixnum 10)
 183                 (concatenate 'fixnum nil)
 184                 (map 'fixnum #'identity nil)
 185                 (merge 'fixnum nil nil #'<)))
 186   (assert (not (eval `(locally (declare (optimize (safety 0)))
 187                         (ignore-errors (progn ,form t)))))))
 188
 189 (dolist (form '(#+nil(values-list '(1 . 2)) ; This case still fails
 190                 (fboundp '(set bet))
 191                 (atan #c(1 1) (car (list #c(2 2))))
 192                 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
 193                 (nthcdr (car (list 5)) '(1 2 . 3))))
 194   (assert (not (eval `(locally (declare (optimize (safety 3)))
 195                         (ignore-errors (progn ,form t)))))))