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 '((values-list (car (list '(1 . 2))))
 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)))))))
 196
 197 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
 198 ;;; to cause errors in the compiler.  Fixed by CSR in 0.7.8.10
 199 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x)))))
 200
 201 ;;; bug 129: insufficient syntax checking in MACROLET
 202 (multiple-value-bind (result error)
 203     (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3))))
 204   (assert (null result))
 205   (assert (typep error 'error)))
 206
 207 ;;; bug 124: environment of MACROLET-introduced macro expanders
 208 (assert (equal
 209          (macrolet ((mext (x) `(cons :mext ,x)))
 210            (macrolet ((mint (y) `'(:mint ,(mext y))))
 211              (list (mext '(1 2))
 212                    (mint (1 2)))))
 213          '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
 214
 215 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
 216 ;;; symbol is declared to be SPECIAL
 217 (multiple-value-bind (result error)
 218     (ignore-errors (funcall (lambda ()
 219                               (symbol-macrolet ((s '(1 2)))
 220                                   (declare (special s))
 221                                 s))))
 222   (assert (null result))
 223   (assert (typep error 'program-error)))
 224
 225 ;;; ECASE should treat a bare T as a literal key
 226 (multiple-value-bind (result error)
 227     (ignore-errors (ecase 1 (t 0)))
 228   (assert (null result))
 229   (assert (typep error 'type-error)))
 230
 231 (multiple-value-bind (result error)
 232     (ignore-errors (ecase 1 (t 0) (1 2)))
 233   (assert (eql result 2))
 234   (assert (null error)))
 235
 236 ;;; FTYPE should accept any functional type specifier
 237 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
 238
 239 ;;; FUNCALL of special operators and macros should signal an
 240 ;;; UNDEFINED-FUNCTION error
 241 (multiple-value-bind (result error)
 242     (ignore-errors (funcall 'quote 1))
 243   (assert (null result))
 244   (assert (typep error 'undefined-function))
 245   (assert (eq (cell-error-name error) 'quote)))
 246 (multiple-value-bind (result error)
 247     (ignore-errors (funcall 'and 1))
 248   (assert (null result))
 249   (assert (typep error 'undefined-function))
 250   (assert (eq (cell-error-name error) 'and)))
 251
 252 ;;; PSETQ should behave when given complex symbol-macro arguments
 253 (multiple-value-bind (sequence index)
 254     (symbol-macrolet ((x (aref a (incf i)))
 255                       (y (aref a (incf i))))
 256         (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
 257               (i 0))
 258           (psetq x (aref a (incf i))
 259                  y (aref a (incf i)))
 260           (values a i)))
 261   (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
 262   (assert (= index 4)))
 263
 264 (multiple-value-bind (result error)
 265     (ignore-errors
 266       (let ((x (list 1 2)))
 267         (psetq (car x) 3)
 268         x))
 269   (assert (null result))
 270   (assert (typep error 'program-error)))
 271
 272 ;;; COPY-SEQ should work on known-complex vectors:
 273 (assert (equalp #(1)
 274                 (let ((v (make-array 0 :fill-pointer 0)))
 275                   (vector-push-extend 1 v)
 276                   (copy-seq v))))
 277
 278 ;;; to support INLINE functions inside MACROLET, it is necessary for
 279 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
 280 ;;; certain circumstances, one of which is when compile is called from
 281 ;;; top-level.
 282 (assert (equal
 283          (function-lambda-expression
 284           (compile nil '(lambda (x) (block nil (print x)))))
 285          '(lambda (x) (block nil (print x)))))
 286
 287 ;;; bug 62: too cautious type inference in a loop
 288 (assert (nth-value
 289          2
 290          (compile nil
 291                   '(lambda (a)
 292                     (declare (optimize speed (safety 0)))
 293                     (typecase a
 294                       (array (loop (print (car a)))))))))
 295
 296 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
 297 ;;; failure
 298 (compile nil
 299          '(lambda (key tree collect-path-p)
 300            (let ((lessp (key-lessp tree))
 301                  (equalp (key-equalp tree)))
 302              (declare (type (function (t t) boolean) lessp equalp))
 303              (let ((path '(nil)))
 304                (loop for node = (root-node tree)
 305                   then (if (funcall lessp key (node-key node))
 306                            (left-child node)
 307                            (right-child node))
 308                   when (null node)
 309                   do (return (values nil nil nil))
 310                   do (when collect-path-p
 311                        (push node path))
 312                   (when (funcall equalp key (node-key node))
 313                     (return (values node path t))))))))
 314
 315 ;;; CONSTANTLY should return a side-effect-free function (bug caught
 316 ;;; by Paul Dietz' test suite)
 317 (let ((i 0))
 318   (let ((fn (constantly (progn (incf i) 1))))
 319     (assert (= i 1))
 320     (assert (= (funcall fn) 1))
 321     (assert (= i 1))
 322     (assert (= (funcall fn) 1))
 323     (assert (= i 1))))
 324
 325 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
 326 (loop for (fun warns-p) in
 327      '(((lambda (&optional *x*) *x*) t)
 328        ((lambda (&optional *x* &rest y) (values *x* y)) t)
 329        ((lambda (&optional *print-base*) (values *print-base*)) nil)
 330        ((lambda (&optional *print-base* &rest y) (values *print-base* y)) nil)
 331        ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
 332        ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
 333    for real-warns-p = (nth-value 1 (compile nil fun))
 334    do (assert (eq warns-p real-warns-p)))
 335
 336 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
 337 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
 338                         '(1 2))
 339                '((2) 1)))
 340
 341 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
 342 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
 343 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))