1 ;;;; various compiler tests without side effects
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (cl:in-package :cl-user)
16 ;;; Exercise a compiler bug (by crashing the compiler).
18 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
19 ;;; (2000-09-06 on cmucl-imp).
21 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
22 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
42 ;;; Exercise a compiler bug (by crashing the compiler).
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.
49 (block used-by-some-y?
53 (return-from used-by-some-y? t)))))
54 (declare (inline frob))
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)
68 (declare (special x)) y)))))
69 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
74 (declare (special x)) y)))))
76 ;;; another LET-related bug fixed by Alexey Dejneka at the same
78 (multiple-value-bind (fun warnings-p failure-p)
79 ;; should complain about duplicate variable names in LET binding
85 (declare (ignore warnings-p))
86 (assert (functionp fun))
89 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
90 ;;; Lichteblau 2002-05-21)
92 (multiple-value-bind (fun warnings-p failure-p)
94 ;; Compiling this code should cause a STYLE-WARNING
95 ;; about *X* looking like a special variable but not
99 (funcall (symbol-function 'x-getter))
101 (assert (functionp fun))
103 (assert (not failure-p)))
104 (multiple-value-bind (fun warnings-p failure-p)
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).
111 (declare (special *x*))
112 (funcall (symbol-function 'x-getter))
114 (assert (functionp fun))
115 (assert (not warnings-p))
116 (assert (not failure-p))))
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*
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)))
130 (when (typep i '(and integer (satisfies oddp)))
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)))
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))))))
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)))
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"))))
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)
172 ;;; bug 181: bad type specifier dropped compiler into debugger
173 (assert (list (compile nil '(lambda (x)
174 (declare (type (0) x))
177 (let ((f (compile nil '(lambda (x)
178 (make-array 1 :element-type '(0))))))
179 (assert (null (ignore-errors (funcall f)))))
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)))))))
189 (dolist (form '((values-list (car (list '(1 . 2))))
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)))))))
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)))))
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)))
207 ;;; bug 124: environment of MACROLET-introduced macro expanders
209 (macrolet ((mext (x) `(cons :mext ,x)))
210 (macrolet ((mint (y) `'(:mint ,(mext y))))
213 '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
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))
222 (assert (null result))
223 (assert (typep error 'program-error)))
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)))
231 (multiple-value-bind (result error)
232 (ignore-errors (ecase 1 (t 0) (1 2)))
233 (assert (eql result 2))
234 (assert (null error)))
236 ;;; FTYPE should accept any functional type specifier
237 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
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)))
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)))
258 (psetq x (aref a (incf i))
261 (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
262 (assert (= index 4)))
264 (multiple-value-bind (result error)
266 (let ((x (list 1 2)))
269 (assert (null result))
270 (assert (typep error 'program-error)))
272 ;;; COPY-SEQ should work on known-complex vectors:
274 (let ((v (make-array 0 :fill-pointer 0)))
275 (vector-push-extend 1 v)
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
283 (function-lambda-expression
284 (compile nil '(lambda (x) (block nil (print x)))))
285 '(lambda (x) (block nil (print x)))))
287 ;;; bug 62: too cautious type inference in a loop
292 (declare (optimize speed (safety 0)))
294 (array (loop (print (car a)))))))))
296 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
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))
304 (loop for node = (root-node tree)
305 then (if (funcall lessp key (node-key node))
309 do (return (values nil nil nil))
310 do (when collect-path-p
312 (when (funcall equalp key (node-key node))
313 (return (values node path t))))))))
315 ;;; CONSTANTLY should return a side-effect-free function (bug caught
316 ;;; by Paul Dietz' test suite)
318 (let ((fn (constantly (progn (incf i) 1))))
320 (assert (= (funcall fn) 1))
322 (assert (= (funcall fn) 1))
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-length*) (values *print-length*)) nil)
330 ((lambda (&optional *print-length* &rest y) (values *print-length* 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)))
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)))
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))
345 (raises-error? (multiple-value-bind (a b c)
346 (eval '(truncate 3 4))
347 (declare (integer c))
351 (assert (equal (multiple-value-list (the (values &rest integer)
355 ;;; Bug relating to confused representation for the wild function
357 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
359 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
361 (assert (eql (macrolet ((foo () 1))
362 (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
367 ;;; MACROLET should check for duplicated names
368 (dolist (ll '((x (z x))
369 (x y &optional z x w)
373 (x &optional (y nil x))
374 (x &optional (y nil y))
377 (&key (y nil z) (z nil w))
378 (&whole x &optional x)
379 (&environment x &whole x)))
384 (macrolet ((foo ,ll nil)
385 (bar (&environment env)
386 `',(macro-function 'foo env)))
389 (values nil t t))))))
391 (assert (typep (eval `(the arithmetic-error
392 ',(make-condition 'arithmetic-error)))
395 (assert (not (nth-value
396 2 (compile nil '(lambda ()
397 (make-array nil :initial-element 11))))))
399 (assert (raises-error? (funcall (eval #'open) "assertoid.lisp"
400 :external-format '#:nonsense)))
401 (assert (raises-error? (funcall (eval #'load) "assertoid.lisp"
402 :external-format '#:nonsense)))
404 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
406 (let ((f (compile nil
408 (declare (optimize (safety 3)))
409 (list (the fixnum (the (real 0) (eval v))))))))
410 (assert (raises-error? (funcall f 0.1) type-error))
411 (assert (raises-error? (funcall f -1) type-error)))
413 ;;; the implicit block does not enclose lambda list
414 (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#))))
415 #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#))))))
416 (define-compiler-macro #3=#:foo (&optional (x (return-from #3#))))
417 (deftype #4=#:foo (&optional (x (return-from #4#))))
418 (define-setf-expander #5=#:foo (&optional (x (return-from #5#))))
419 (defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
421 (assert (nth-value 2 (compile nil `(lambda () ,form))))))
423 (assert (nth-value 2 (compile nil
425 (svref (make-array '(8 9) :adjustable t) 1)))))
427 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
428 (raises-error? (funcall (compile nil '(lambda (x y z) (char= x y z)))
431 (raises-error? (funcall (compile nil
433 (declare (optimize (speed 3) (safety 3)))
438 ;;; Compiler lost return type of MAPCAR and friends
439 (dolist (fun '(mapcar mapc maplist mapl))
440 (assert (nth-value 2 (compile nil
442 (1+ (,fun #'print x)))))))
444 (assert (nth-value 2 (compile nil
446 (declare (notinline mapcar))
447 (1+ (mapcar #'print '(1 2 3)))))))
449 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
450 ;;; index was effectless
451 (let ((f (compile nil '(lambda (a v)
452 (declare (type simple-bit-vector a) (type bit v))
453 (declare (optimize (speed 3) (safety 0)))
456 (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
457 (assert (equal y #*00))
459 (assert (equal y #*10))))
461 (handler-bind ((sb-ext:compiler-note #'error))
462 (compile nil '(lambda (x)
463 (declare (type (simple-array (simple-string 3) (5)) x))
464 (aref (aref x 0) 0))))
467 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
468 (assert (funcall f 1d0)))
470 (compile nil '(lambda (x)
471 (declare (double-float x))
475 ;;; bogus optimization of BIT-NOT
476 (multiple-value-bind (result x)
477 (eval '(let ((x (eval #*1001)))
478 (declare (optimize (speed 2) (space 3))
479 (type (bit-vector) x))
480 (values (bit-not x nil) x)))
481 (assert (equal x #*1001))
482 (assert (equal result #*0110)))
484 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
485 (handler-bind ((sb-ext:compiler-note #'error))
486 (assert (equalp (funcall
490 (let ((x (make-sequence 'vector 10 :initial-element 'a)))
493 #(a a a a b a a a a a))))
495 ;;; this is not a check for a bug, but rather a test of compiler
497 (dolist (type '((integer 0 *) ; upper bound
500 (real * (-10)) ; lower bound
505 (declare (optimize (speed 3) (compilation-speed 0)))
506 (loop for i from 1 to (the (integer -17 10) n) by 2
507 collect (when (> (random 10) 5)
508 (the ,type (- i 11)))))))))
512 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
513 ;;; compiler has an optimized VOP for +; so this code should cause an
515 (assert (eq (block nil
517 (compile nil '(lambda (i)
518 (declare (optimize speed))
519 (declare (type integer i))
521 (sb-ext:compiler-note (c) (return :good))))
524 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
526 (assert (not (nth-value 1 (compile nil '(lambda (u v)
527 (symbol-macrolet ((x u)
533 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
534 (loop for (x type) in
537 (-14/3 (rational -8 11))
546 (#c(-3 4) (complex fixnum))
547 (#c(-3 4) (complex rational))
548 (#c(-3/7 4) (complex rational))
549 (#c(2s0 3s0) (complex short-float))
550 (#c(2f0 3f0) (complex single-float))
551 (#c(2d0 3d0) (complex double-float))
552 (#c(2l0 3l0) (complex long-float))
553 (#c(2d0 3s0) (complex float))
554 (#c(2 3f0) (complex real))
555 (#c(2 3d0) (complex real))
556 (#c(-3/7 4) (complex real))
559 do (dolist (zero '(0 0s0 0f0 0d0 0l0))
560 (dolist (real-zero (list zero (- zero)))
561 (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
562 (fun (compile nil src))
563 (result (1+ (funcall (eval #'*) x real-zero))))
564 (assert (eql result (funcall fun x)))))))
566 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
567 ;;; wasn't recognized as a good type specifier.
568 (let ((fun (lambda (x y)
569 (declare (type (integer -1 0) x y) (optimize speed))
571 (assert (= (funcall fun 0 0) 0))
572 (assert (= (funcall fun 0 -1) -1))
573 (assert (= (funcall fun -1 -1) 0)))
575 ;;; from PFD's torture test, triggering a bug in our effective address
580 (declare (type (integer 8 22337) b))
583 (* (logandc1 (max -29303 b) 4) b)
584 (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
585 (logeqv (max a 0) b))))