?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
1.0.23.41: fix DX-COMBINATION-P
[sbcl/tcr.git] / tests / compiler.pure.lisp
blob16eeee447aca4727e96bb9ac66443d7fece1ec03
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 :sb-c)
15
16 (defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
17
18 (deftransform compiler-derived-type ((x))
19 `(values ',(type-specifier (lvar-type x)) t))
20
21 (defun compiler-derived-type (x)
22 (values t nil))
23
24 (cl:in-package :cl-user)
25
26 ;; The tests in this file assume that EVAL will use the compiler
27 (when (eq sb-ext:*evaluator-mode* :interpret)
28 (invoke-restart 'run-tests::skip-file))
29
30 ;;; Exercise a compiler bug (by crashing the compiler).
31 ;;;
32 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
33 ;;; (2000-09-06 on cmucl-imp).
34 ;;;
35 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
36 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
37 (funcall (compile nil
38 '(lambda ()
39 (labels ((fun1 ()
40 (fun2))
41 (fun2 ()
42 (when nil
43 (tagbody
44 tag
45 (fun2)
46 (go tag)))
47 (when nil
48 (tagbody
49 tag
50 (fun1)
51 (go tag)))))
52
53 (fun1)
54 nil))))
55
56 ;;; Exercise a compiler bug (by crashing the compiler).
57 ;;;
58 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
59 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
60 (funcall (compile nil
61 '(lambda (x)
62 (or (integerp x)
63 (block used-by-some-y?
64 (flet ((frob (stk)
65 (dolist (y stk)
66 (unless (rejected? y)
67 (return-from used-by-some-y? t)))))
68 (declare (inline frob))
69 (frob (rstk x))
70 (frob (mrstk x)))
71 nil))))
72 13)
73
74 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
75 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
76 ;;; Alexey Dejneka 2002-01-27
77 (assert (= 1 ; (used to give 0 under bug 112)
78 (let ((x 0))
79 (declare (special x))
80 (let ((x 1))
81 (let ((y x))
82 (declare (special x)) y)))))
83 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
84 (let ((x 0))
85 (declare (special x))
86 (let ((x 1))
87 (let ((y x) (x 5))
88 (declare (special x)) y)))))
89
90 ;;; another LET-related bug fixed by Alexey Dejneka at the same
91 ;;; time as bug 112
92 (multiple-value-bind (fun warnings-p failure-p)
93 ;; should complain about duplicate variable names in LET binding
94 (compile nil
95 '(lambda ()
96 (let (x
97 (x 1))
98 (list x))))
99 (declare (ignore warnings-p))
100 (assert (functionp fun))
101 (assert failure-p))
102
103 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
104 ;;; Lichteblau 2002-05-21)
105 (progn
106 (multiple-value-bind (fun warnings-p failure-p)
107 (compile nil
108 ;; Compiling this code should cause a STYLE-WARNING
109 ;; about *X* looking like a special variable but not
110 ;; being one.
111 '(lambda (n)
112 (let ((*x* n))
113 (funcall (symbol-function 'x-getter))
114 (print *x*))))
115 (assert (functionp fun))
116 (assert warnings-p)
117 (assert (not failure-p)))
118 (multiple-value-bind (fun warnings-p failure-p)
119 (compile nil
120 ;; Compiling this code should not cause a warning
121 ;; (because the DECLARE turns *X* into a special
122 ;; variable as its name suggests it should be).
123 '(lambda (n)
124 (let ((*x* n))
125 (declare (special *x*))
126 (funcall (symbol-function 'x-getter))
127 (print *x*))))
128 (assert (functionp fun))
129 (assert (not warnings-p))
130 (assert (not failure-p))))
131
132 ;;; a bug in 0.7.4.11
133 (dolist (i '(a b 1 2 "x" "y"))
134 ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
135 ;; TYPEP here but got confused and died, doing
136 ;; (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
137 ;; *BACKEND-TYPE-PREDICATES*
138 ;; :TEST #'TYPE=)
139 ;; and blowing up because TYPE= tried to call PLUSP on the
140 ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
141 (when (typep i '(and integer (satisfies oddp)))
142 (print i)))
143 (dotimes (i 14)
144 (when (typep i '(and integer (satisfies oddp)))
145 (print i)))
146
147 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
148 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
149 ;;; interactively-compiled functions was broken by sleaziness and
150 ;;; confusion in the assault on 0.7.0, so this expression used to
151 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
152 (eval '(function-lambda-expression #'(lambda (x) x)))
153
154 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
155 ;;; variable is not optional.
156 (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12))))))
157
158 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
159 ;;; a while; fixed by CSR 2002-07-18
160 (multiple-value-bind (value error)
161 (ignore-errors (some-undefined-function))
162 (assert (null value))
163 (assert (eq (cell-error-name error) 'some-undefined-function)))
164
165 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
166 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
167 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
168 (assert (ignore-errors (eval '(lambda (foo) 12))))
169 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
170 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
171 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
172 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
173 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
174 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
175 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
176 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
177 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
178 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
179
180 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
181 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
182 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
183 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
184 17))
185
186 ;;; bug 181: bad type specifier dropped compiler into debugger
187 (assert (list (compile nil '(lambda (x)
188 (declare (type (0) x))
189 x))))
190
191 (let ((f (compile nil '(lambda (x)
192 (make-array 1 :element-type '(0))))))
193 (assert (null (ignore-errors (funcall f)))))
194
195 ;;; the following functions must not be flushable
196 (dolist (form '((make-sequence 'fixnum 10)
197 (concatenate 'fixnum nil)
198 (map 'fixnum #'identity nil)
199 (merge 'fixnum nil nil #'<)))
200 (assert (not (eval `(locally (declare (optimize (safety 0)))
201 (ignore-errors (progn ,form t)))))))
202
203 (dolist (form '((values-list (car (list '(1 . 2))))
204 (fboundp '(set bet))
205 (atan #c(1 1) (car (list #c(2 2))))
206 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
207 (nthcdr (car (list 5)) '(1 2 . 3))))
208 (assert (not (eval `(locally (declare (optimize (safety 3)))
209 (ignore-errors (progn ,form t)))))))
210
211 ;;; feature: we shall complain if functions which are only useful for
212 ;;; their result are called and their result ignored.
213 (loop for (form expected-des) in
214 '(((progn (nreverse (list 1 2)) t)
215 "The return value of NREVERSE should not be discarded.")
216 ((progn (nreconc (list 1 2) (list 3 4)) t)
217 "The return value of NRECONC should not be discarded.")
218 ((locally
219 (declare (inline sort))
220 (sort (list 1 2) #'<) t)
221 ;; FIXME: it would be nice if this warned on non-inlined sort
222 ;; but the current simple boolean function attribute
223 ;; can't express the condition that would be required.
224 "The return value of STABLE-SORT-LIST should not be discarded.")
225 ((progn (sort (vector 1 2) #'<) t)
226 ;; Apparently, SBCL (but not CL) guarantees in-place vector
227 ;; sort, so no warning.
228 nil)
229 ((progn (delete 2 (list 1 2)) t)
230 "The return value of DELETE should not be discarded.")
231 ((progn (delete-if #'evenp (list 1 2)) t)
232 ("The return value of DELETE-IF should not be discarded."))
233 ((progn (delete-if #'evenp (vector 1 2)) t)
234 ("The return value of DELETE-IF should not be discarded."))
235 ((progn (delete-if-not #'evenp (list 1 2)) t)
236 "The return value of DELETE-IF-NOT should not be discarded.")
237 ((progn (delete-duplicates (list 1 2)) t)
238 "The return value of DELETE-DUPLICATES should not be discarded.")
239 ((progn (merge 'list (list 1 3) (list 2 4) #'<) t)
240 "The return value of MERGE should not be discarded.")
241 ((progn (nreconc (list 1 3) (list 2 4)) t)
242 "The return value of NRECONC should not be discarded.")
243 ((progn (nunion (list 1 3) (list 2 4)) t)
244 "The return value of NUNION should not be discarded.")
245 ((progn (nintersection (list 1 3) (list 2 4)) t)
246 "The return value of NINTERSECTION should not be discarded.")
247 ((progn (nset-difference (list 1 3) (list 2 4)) t)
248 "The return value of NSET-DIFFERENCE should not be discarded.")
249 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t)
250 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
251 for expected = (if (listp expected-des)
252 expected-des
253 (list expected-des))
254 do
255 (multiple-value-bind (fun warnings-p failure-p)
256 (handler-bind ((style-warning (lambda (c)
257 (if expected
258 (let ((expect-one (pop expected)))
259 (assert (search expect-one
260 (with-standard-io-syntax
261 (let ((*print-right-margin* nil))
262 (princ-to-string c))))
263 ()
264 "~S should have warned ~S, but instead warned: ~A"
265 form expect-one c))
266 (error "~S shouldn't give a(nother) warning, but did: ~A" form c)))))
267 (compile nil `(lambda () ,form)))
268 (declare (ignore warnings-p))
269 (assert (functionp fun))
270 (assert (null expected)
271 ()
272 "~S should have warned ~S, but didn't."
273 form expected)
274 (assert (not failure-p))))
275
276 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
277 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
278 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x)))))
279
280 ;;; bug 129: insufficient syntax checking in MACROLET
281 (multiple-value-bind (result error)
282 (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3))))
283 (assert (null result))
284 (assert (typep error 'error)))
285
286 ;;; bug 124: environment of MACROLET-introduced macro expanders
287 (assert (equal
288 (macrolet ((mext (x) `(cons :mext ,x)))
289 (macrolet ((mint (y) `'(:mint ,(mext y))))
290 (list (mext '(1 2))
291 (mint (1 2)))))
292 '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
293
294 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
295 ;;; symbol is declared to be SPECIAL
296 (multiple-value-bind (result error)
297 (ignore-errors (funcall (lambda ()
298 (symbol-macrolet ((s '(1 2)))
299 (declare (special s))
300 s))))
301 (assert (null result))
302 (assert (typep error 'program-error)))
303
304 ;;; ECASE should treat a bare T as a literal key
305 (multiple-value-bind (result error)
306 (ignore-errors (ecase 1 (t 0)))
307 (assert (null result))
308 (assert (typep error 'type-error)))
309
310 (multiple-value-bind (result error)
311 (ignore-errors (ecase 1 (t 0) (1 2)))
312 (assert (eql result 2))
313 (assert (null error)))
314
315 ;;; FTYPE should accept any functional type specifier
316 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
317
318 ;;; FUNCALL of special operators and macros should signal an
319 ;;; UNDEFINED-FUNCTION error
320 (multiple-value-bind (result error)
321 (ignore-errors (funcall 'quote 1))
322 (assert (null result))
323 (assert (typep error 'undefined-function))
324 (assert (eq (cell-error-name error) 'quote)))
325 (multiple-value-bind (result error)
326 (ignore-errors (funcall 'and 1))
327 (assert (null result))
328 (assert (typep error 'undefined-function))
329 (assert (eq (cell-error-name error) 'and)))
330
331 ;;; PSETQ should behave when given complex symbol-macro arguments
332 (multiple-value-bind (sequence index)
333 (symbol-macrolet ((x (aref a (incf i)))
334 (y (aref a (incf i))))
335 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
336 (i 0))
337 (psetq x (aref a (incf i))
338 y (aref a (incf i)))
339 (values a i)))
340 (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
341 (assert (= index 4)))
342
343 (multiple-value-bind (result error)
344 (ignore-errors
345 (let ((x (list 1 2)))
346 (psetq (car x) 3)
347 x))
348 (assert (null result))
349 (assert (typep error 'program-error)))
350
351 ;;; COPY-SEQ should work on known-complex vectors:
352 (assert (equalp #(1)
353 (let ((v (make-array 0 :fill-pointer 0)))
354 (vector-push-extend 1 v)
355 (copy-seq v))))
356
357 ;;; to support INLINE functions inside MACROLET, it is necessary for
358 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
359 ;;; certain circumstances, one of which is when compile is called from
360 ;;; top-level.
361 (assert (equal
362 (function-lambda-expression
363 (compile nil '(lambda (x) (block nil (print x)))))
364 '(lambda (x) (block nil (print x)))))
365
366 ;;; bug 62: too cautious type inference in a loop
367 (assert (nth-value
368 2
369 (compile nil
370 '(lambda (a)
371 (declare (optimize speed (safety 0)))
372 (typecase a
373 (array (loop (print (car a)))))))))
374
375 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
376 ;;; failure
377 (compile nil
378 '(lambda (key tree collect-path-p)
379 (let ((lessp (key-lessp tree))
380 (equalp (key-equalp tree)))
381 (declare (type (function (t t) boolean) lessp equalp))
382 (let ((path '(nil)))
383 (loop for node = (root-node tree)
384 then (if (funcall lessp key (node-key node))
385 (left-child node)
386 (right-child node))
387 when (null node)
388 do (return (values nil nil nil))
389 do (when collect-path-p
390 (push node path))
391 (when (funcall equalp key (node-key node))
392 (return (values node path t))))))))
393
394 ;;; CONSTANTLY should return a side-effect-free function (bug caught
395 ;;; by Paul Dietz' test suite)
396 (let ((i 0))
397 (let ((fn (constantly (progn (incf i) 1))))
398 (assert (= i 1))
399 (assert (= (funcall fn) 1))
400 (assert (= i 1))
401 (assert (= (funcall fn) 1))
402 (assert (= i 1))))
403
404 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
405 (loop for (fun warns-p) in
406 '(((lambda (&optional *x*) *x*) t)
407 ((lambda (&optional *x* &rest y) (values *x* y)) t)
408 ((lambda (&optional *print-length*) (values *print-length*)) nil)
409 ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil)
410 ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
411 ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
412 for real-warns-p = (nth-value 1 (compile nil fun))
413 do (assert (eq warns-p real-warns-p)))
414
415 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
416 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
417 '(1 2))
418 '((2) 1)))
419
420 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
421 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
422 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
423
424 (assert
425 (raises-error? (multiple-value-bind (a b c)
426 (eval '(truncate 3 4))
427 (declare (integer c))
428 (list a b c))
429 type-error))
430
431 (assert (equal (multiple-value-list (the (values &rest integer)
432 (eval '(values 3))))
433 '(3)))
434
435 ;;; Bug relating to confused representation for the wild function
436 ;;; type:
437 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
438
439 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
440 ;;; test suite)
441 (assert (eql (macrolet ((foo () 1))
442 (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
443 x))
444 (%f)))
445 1))
446
447 ;;; MACROLET should check for duplicated names
448 (dolist (ll '((x (z x))
449 (x y &optional z x w)
450 (x y &optional z z)
451 (x &rest x)
452 (x &rest (y x))
453 (x &optional (y nil x))
454 (x &optional (y nil y))
455 (x &key x)
456 (x &key (y nil x))
457 (&key (y nil z) (z nil w))
458 (&whole x &optional x)
459 (&environment x &whole x)))
460 (assert (nth-value 2
461 (handler-case
462 (compile nil
463 `(lambda ()
464 (macrolet ((foo ,ll nil)
465 (bar (&environment env)
466 `',(macro-function 'foo env)))
467 (bar))))
468 (error (c)
469 (values nil t t))))))
470
471 (assert (typep (eval `(the arithmetic-error
472 ',(make-condition 'arithmetic-error)))
473 'arithmetic-error))
474
475 (assert (not (nth-value
476 2 (compile nil '(lambda ()
477 (make-array nil :initial-element 11))))))
478
479 (assert (raises-error? (funcall (eval #'open) "assertoid.lisp"
480 :external-format '#:nonsense)))
481 (assert (raises-error? (funcall (eval #'load) "assertoid.lisp"
482 :external-format '#:nonsense)))
483
484 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
485
486 (let ((f (compile nil
487 '(lambda (v)
488 (declare (optimize (safety 3)))
489 (list (the fixnum (the (real 0) (eval v))))))))
490 (assert (raises-error? (funcall f 0.1) type-error))
491 (assert (raises-error? (funcall f -1) type-error)))
492
493 ;;; the implicit block does not enclose lambda list
494 (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#))))
495 #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#))))))
496 (define-compiler-macro #3=#:foo (&optional (x (return-from #3#))))
497 (deftype #4=#:foo (&optional (x (return-from #4#))))
498 (define-setf-expander #5=#:foo (&optional (x (return-from #5#))))
499 (defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
500 (dolist (form forms)
501 (assert (nth-value 2 (compile nil `(lambda () ,form))))))
502
503 (assert (nth-value 2 (compile nil
504 '(lambda ()
505 (svref (make-array '(8 9) :adjustable t) 1)))))
506
507 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
508 (raises-error? (funcall (compile nil '(lambda (x y z) (char= x y z)))
509 #\a #\b nil)
510 type-error)
511 (raises-error? (funcall (compile nil
512 '(lambda (x y z)
513 (declare (optimize (speed 3) (safety 3)))
514 (char/= x y z)))
515 nil #\a #\a)
516 type-error)
517
518 ;;; Compiler lost return type of MAPCAR and friends
519 (dolist (fun '(mapcar mapc maplist mapl))
520 (assert (nth-value 2 (compile nil
521 `(lambda (x)
522 (1+ (,fun #'print x)))))))
523
524 (assert (nth-value 2 (compile nil
525 '(lambda ()
526 (declare (notinline mapcar))
527 (1+ (mapcar #'print '(1 2 3)))))))
528
529 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
530 ;;; index was effectless
531 (let ((f (compile nil '(lambda (a v)
532 (declare (type simple-bit-vector a) (type bit v))
533 (declare (optimize (speed 3) (safety 0)))
534 (setf (aref a 0) v)
535 a))))
536 (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
537 (assert (equal y #*00))
538 (funcall f y 1)
539 (assert (equal y #*10))))
540
541 ;;; use of declared array types
542 (handler-bind ((sb-ext:compiler-note #'error))
543 (compile nil '(lambda (x)
544 (declare (type (simple-array (simple-string 3) (5)) x)
545 (optimize speed))
546 (aref (aref x 0) 0))))
547
548 (handler-bind ((sb-ext:compiler-note #'error))
549 (compile nil '(lambda (x)
550 (declare (type (simple-array (simple-array bit (10)) (10)) x)
551 (optimize speed))
552 (1+ (aref (aref x 0) 0)))))
553
554 ;;; compiler failure
555 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
556 (assert (funcall f 1d0)))
557
558 (compile nil '(lambda (x)
559 (declare (double-float x))
560 (let ((y (* x pi)))
561 (atan y y))))
562
563 ;;; bogus optimization of BIT-NOT
564 (multiple-value-bind (result x)
565 (eval '(let ((x (eval #*1001)))
566 (declare (optimize (speed 2) (space 3))
567 (type (bit-vector) x))
568 (values (bit-not x nil) x)))
569 (assert (equal x #*1001))
570 (assert (equal result #*0110)))
571
572 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
573 (handler-bind ((sb-ext:compiler-note #'error))
574 (assert (equalp (funcall
575 (compile
576 nil
577 '(lambda ()
578 (let ((x (make-sequence 'vector 10 :initial-element 'a)))
579 (setf (aref x 4) 'b)
580 x))))
581 #(a a a a b a a a a a))))
582
583 ;;; this is not a check for a bug, but rather a test of compiler
584 ;;; quality
585 (dolist (type '((integer 0 *) ; upper bound
586 (real (-1) *)
587 float ; class
588 (real * (-10)) ; lower bound
589 ))
590 (assert (nth-value
591 1 (compile nil
592 `(lambda (n)
593 (declare (optimize (speed 3) (compilation-speed 0)))
594 (loop for i from 1 to (the (integer -17 10) n) by 2
595 collect (when (> (random 10) 5)
596 (the ,type (- i 11)))))))))
597
598 ;;; bug 278b
599 ;;;
600 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
601 ;;; compiler has an optimized VOP for +; so this code should cause an
602 ;;; efficiency note.
603 (assert (eq (block nil
604 (handler-case
605 (compile nil '(lambda (i)
606 (declare (optimize speed))
607 (declare (type integer i))
608 (+ i 2)))
609 (sb-ext:compiler-note (c) (return :good))))
610 :good))
611
612 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
613 ;;; symbol macros
614 (assert (not (nth-value 1 (compile nil '(lambda (u v)
615 (symbol-macrolet ((x u)
616 (y v))
617 (declare (ignore x)
618 (ignorable y))
619 (list u v)))))))
620
621 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
622 (loop for (x type) in
623 '((14 integer)
624 (14 rational)
625 (-14/3 (rational -8 11))
626 (3s0 short-float)
627 (4f0 single-float)
628 (5d0 double-float)
629 (6l0 long-float)
630 (14 real)
631 (13/2 real)
632 (2s0 real)
633 (2d0 real)
634 (#c(-3 4) (complex fixnum))
635 (#c(-3 4) (complex rational))
636 (#c(-3/7 4) (complex rational))
637 (#c(2s0 3s0) (complex short-float))
638 (#c(2f0 3f0) (complex single-float))
639 (#c(2d0 3d0) (complex double-float))
640 (#c(2l0 3l0) (complex long-float))
641 (#c(2d0 3s0) (complex float))
642 (#c(2 3f0) (complex real))
643 (#c(2 3d0) (complex real))
644 (#c(-3/7 4) (complex real))
645 (#c(-3/7 4) complex)
646 (#c(2 3l0) complex))
647 do (dolist (zero '(0 0s0 0f0 0d0 0l0))
648 (dolist (real-zero (list zero (- zero)))
649 (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
650 (fun (compile nil src))
651 (result (1+ (funcall (eval #'*) x real-zero))))
652 (assert (eql result (funcall fun x)))))))
653
654 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
655 ;;; wasn't recognized as a good type specifier.
656 (let ((fun (lambda (x y)
657 (declare (type (integer -1 0) x y) (optimize speed))
658 (logxor x y))))
659 (assert (= (funcall fun 0 0) 0))
660 (assert (= (funcall fun 0 -1) -1))
661 (assert (= (funcall fun -1 -1) 0)))
662
663 ;;; from PFD's torture test, triggering a bug in our effective address
664 ;;; treatment.
665 (compile
666 nil
667 `(lambda (a b)
668 (declare (type (integer 8 22337) b))
669 (logandc2
670 (logandc2
671 (* (logandc1 (max -29303 b) 4) b)
672 (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
673 (logeqv (max a 0) b))))
674
675 ;;; Alpha floating point modes weren't being reset after an exception,
676 ;;; leading to an exception on the second compile, below.
677 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
678 (handler-case (/ 1.0 0.0)
679 ;; provoke an exception
680 (arithmetic-error ()))
681 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
682
683 ;;; bug reported by Paul Dietz: component last block does not have
684 ;;; start ctran
685 (compile nil
686 '(lambda ()
687 (declare (notinline + logand)
688 (optimize (speed 0)))
689 (LOGAND
690 (BLOCK B5
691 (FLET ((%F1 ()
692 (RETURN-FROM B5 -220)))
693 (LET ((V7 (%F1)))
694 (+ 359749 35728422))))
695 -24076)))
696
697 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
698 (assert (= (funcall (compile nil `(lambda (b)
699 (declare (optimize (speed 3))
700 (type (integer 2 152044363) b))
701 (rem b (min -16 0))))
702 108251912)
703 8))
704
705 (assert (= (funcall (compile nil `(lambda (c)
706 (declare (optimize (speed 3))
707 (type (integer 23062188 149459656) c))
708 (mod c (min -2 0))))
709 95019853)
710 -1))
711
712 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
713 (compile nil
714 '(LAMBDA (A B C)
715 (BLOCK B6
716 (LOGEQV (REM C -6758)
717 (REM B (MAX 44 (RETURN-FROM B6 A)))))))
718
719 (compile nil '(lambda ()
720 (block nil
721 (flet ((foo (x y) (if (> x y) (print x) (print y))))
722 (foo 1 2)
723 (bar)
724 (foo (return 14) 2)))))
725
726 ;;; bug in Alpha backend: not enough sanity checking of arguments to
727 ;;; instructions
728 (assert (= (funcall (compile nil
729 '(lambda (x)
730 (declare (fixnum x))
731 (ash x -257)))
732 1024)
733 0))
734
735 ;;; bug found by WHN and pfdietz: compiler failure while referencing
736 ;;; an entry point inside a deleted lambda
737 (compile nil '(lambda ()
738 (let (r3533)
739 (flet ((bbfn ()
740 (setf r3533
741 (progn
742 (flet ((truly (fn bbd)
743 (let (r3534)
744 (let ((p3537 nil))
745 (unwind-protect
746 (multiple-value-prog1
747 (progn
748 (setf r3534
749 (progn
750 (bubf bbd t)
751 (flet ((c-3536 ()
752 (funcall fn)))
753 (cdec #'c-3536
754 (vector bbd))))))
755 (setf p3537 t))
756 (unless p3537
757 (error "j"))))
758 r3534))
759 (c (pd) (pdc pd)))
760 (let ((a (smock a))
761 (b (smock b))
762 (b (smock c)))))))))
763 (wum #'bbfn "hc3" (list)))
764 r3533)))
765 (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
766
767 ;;; the strength reduction of constant multiplication used (before
768 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
769 ;;; certain circumstances, the compiler would derive that a perfectly
770 ;;; reasonable multiplication never returned, causing chaos. Fixed by
771 ;;; explicitly doing modular arithmetic, and relying on the backends
772 ;;; being smart.
773 (assert (= (funcall
774 (compile nil
775 '(lambda (x)
776 (declare (type (integer 178956970 178956970) x)
777 (optimize speed))
778 (* x 24)))
779 178956970)
780 4294967280))
781
782 ;;; bug in modular arithmetic and type specifiers
783 (assert (= (funcall (compile nil (lambda (x) (logand x x 0)))
784 -1)
785 0))
786
787 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
788 ;;; produced wrong result for shift >=32 on X86
789 (assert (= 0 (funcall
790 (compile nil
791 '(lambda (a)
792 (declare (type (integer 4303063 101130078) a))
793 (mask-field (byte 18 2) (ash a 77))))
794 57132532)))
795 ;;; rewrite the test case to get the unsigned-byte 32/64
796 ;;; implementation even after implementing some modular arithmetic
797 ;;; with signed-byte 30:
798 (assert (= 0 (funcall
799 (compile nil
800 '(lambda (a)
801 (declare (type (integer 4303063 101130078) a))
802 (mask-field (byte 30 2) (ash a 77))))
803 57132532)))
804 (assert (= 0 (funcall
805 (compile nil
806 '(lambda (a)
807 (declare (type (integer 4303063 101130078) a))
808 (mask-field (byte 64 2) (ash a 77))))
809 57132532)))
810 ;;; and a similar test case for the signed masking extension (not the
811 ;;; final interface, so change the call when necessary):
812 (assert (= 0 (funcall
813 (compile nil
814 '(lambda (a)
815 (declare (type (integer 4303063 101130078) a))
816 (sb-c::mask-signed-field 30 (ash a 77))))
817 57132532)))
818 (assert (= 0 (funcall
819 (compile nil
820 '(lambda (a)
821 (declare (type (integer 4303063 101130078) a))
822 (sb-c::mask-signed-field 61 (ash a 77))))
823 57132532)))
824
825 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
826 ;;; type check regeneration
827 (assert (eql (funcall
828 (compile nil '(lambda (a c)
829 (declare (type (integer 185501219873 303014665162) a))
830 (declare (type (integer -160758 255724) c))
831 (declare (optimize (speed 3)))
832 (let ((v8
833 (- -554046873252388011622614991634432
834 (ignore-errors c)
835 (unwind-protect 2791485))))
836 (max (ignore-errors a)
837 (let ((v6 (- v8 (restart-case 980))))
838 (min v8 v6))))))
839 259448422916 173715)
840 259448422916))
841 (assert (eql (funcall
842 (compile nil '(lambda (a b)
843 (min -80
844 (abs
845 (ignore-errors
846 (+
847 (logeqv b
848 (block b6
849 (return-from b6
850 (load-time-value -6876935))))
851 (if (logbitp 1 a) b (setq a -1522022182249))))))))
852 -1802767029877 -12374959963)
853 -80))
854
855 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
856 (assert (eql (funcall (compile nil '(lambda (c)
857 (declare (type (integer -3924 1001809828) c))
858 (declare (optimize (speed 3)))
859 (min 47 (if (ldb-test (byte 2 14) c)
860 -570344431
861 (ignore-errors -732893970)))))
862 705347625)
863 -570344431))
864 (assert (eql (funcall
865 (compile nil '(lambda (b)
866 (declare (type (integer -1598566306 2941) b))
867 (declare (optimize (speed 3)))
868 (max -148949 (ignore-errors b))))
869 0)
870 0))
871 (assert (eql (funcall
872 (compile nil '(lambda (b c)
873 (declare (type (integer -4 -3) c))
874 (block b7
875 (flet ((%f1 (f1-1 f1-2 f1-3)
876 (if (logbitp 0 (return-from b7
877 (- -815145138 f1-2)))
878 (return-from b7 -2611670)
879 99345)))
880 (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
881 b)))))
882 2950453607 -4)
883 -815145134))
884 (assert (eql (funcall
885 (compile nil
886 '(lambda (b c)
887 (declare (type (integer -29742055786 23602182204) b))
888 (declare (type (integer -7409 -2075) c))
889 (declare (optimize (speed 3)))
890 (floor
891 (labels ((%f2 ()
892 (block b6
893 (ignore-errors (return-from b6
894 (if (= c 8) b 82674))))))
895 (%f2)))))
896 22992834060 -5833)
897 82674))
898 (assert (equal (multiple-value-list
899 (funcall
900 (compile nil '(lambda (a)
901 (declare (type (integer -944 -472) a))
902 (declare (optimize (speed 3)))
903 (round
904 (block b3
905 (return-from b3
906 (if (= 55957 a) -117 (ignore-errors
907 (return-from b3 a))))))))
908 -589))
909 '(-589 0)))
910
911 ;;; MISC.158
912 (assert (zerop (funcall
913 (compile nil
914 '(lambda (a b c)
915 (declare (type (integer 79828 2625480458) a))
916 (declare (type (integer -4363283 8171697) b))
917 (declare (type (integer -301 0) c))
918 (if (equal 6392154 (logxor a b))
919 1706
920 (let ((v5 (abs c)))
921 (logand v5
922 (logior (logandc2 c v5)
923 (common-lisp:handler-case
924 (ash a (min 36 22477)))))))))
925 100000 0 0)))
926
927 ;;; MISC.152, 153: deleted code and iteration var type inference
928 (assert (eql (funcall
929 (compile nil
930 '(lambda (a)
931 (block b5
932 (let ((v1 (let ((v8 (unwind-protect 9365)))
933 8862008)))
934 (*
935 (return-from b5
936 (labels ((%f11 (f11-1) f11-1))
937 (%f11 87246015)))
938 (return-from b5
939 (setq v1
940 (labels ((%f6 (f6-1 f6-2 f6-3) v1))
941 (dpb (unwind-protect a)
942 (byte 18 13)
943 (labels ((%f4 () 27322826))
944 (%f6 -2 -108626545 (%f4))))))))))))
945 -6)
946 87246015))
947
948 (assert (eql (funcall
949 (compile nil
950 '(lambda (a)
951 (if (logbitp 3
952 (case -2
953 ((-96879 -1035 -57680 -106404 -94516 -125088)
954 (unwind-protect 90309179))
955 ((-20811 -86901 -9368 -98520 -71594)
956 (let ((v9 (unwind-protect 136707)))
957 (block b3
958 (setq v9
959 (let ((v4 (return-from b3 v9)))
960 (- (ignore-errors (return-from b3 v4))))))))
961 (t -50)))
962 -20343
963 a)))
964 0)
965 -20343))
966
967 ;;; MISC.165
968 (assert (eql (funcall
969 (compile
970 nil
971 '(lambda (a b c)
972 (block b3
973 (flet ((%f15
974 (f15-1 f15-2 f15-3
975 &optional
976 (f15-4
977 (flet ((%f17
978 (f17-1 f17-2 f17-3
979 &optional (f17-4 185155520) (f17-5 c)
980 (f17-6 37))
981 c))
982 (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
983 (f15-5 a) (f15-6 -40))
984 (return-from b3 -16)))
985 (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
986 0 0 -5)
987 -16))
988
989 ;;; MISC.172
990 (assert (eql (funcall
991 (compile
992 nil
993 '(lambda (a b c)
994 (declare (notinline list apply))
995 (declare (optimize (safety 3)))
996 (declare (optimize (speed 0)))
997 (declare (optimize (debug 0)))
998 (labels ((%f12 (f12-1 f12-2)
999 (labels ((%f2 (f2-1 f2-2)
1000 (flet ((%f6 ()
1001 (flet ((%f18
1002 (f18-1
1003 &optional (f18-2 a)
1004 (f18-3 -207465075)
1005 (f18-4 a))
1006 (return-from %f12 b)))
1007 (%f18 -3489553
1008 -7
1009 (%f18 (%f18 150 -64 f12-1)
1010 (%f18 (%f18 -8531)
1011 11410)
1012 b)
1013 56362666))))
1014 (labels ((%f7
1015 (f7-1 f7-2
1016 &optional (f7-3 (%f6)))
1017 7767415))
1018 f12-1))))
1019 (%f2 b -36582571))))
1020 (apply #'%f12 (list 774 -4413)))))
1021 0 1 2)
1022 774))
1023
1024 ;;; MISC.173
1025 (assert (eql (funcall
1026 (compile
1027 nil
1028 '(lambda (a b c)
1029 (declare (notinline values))
1030 (declare (optimize (safety 3)))
1031 (declare (optimize (speed 0)))
1032 (declare (optimize (debug 0)))
1033 (flet ((%f11
1034 (f11-1 f11-2
1035 &optional (f11-3 c) (f11-4 7947114)
1036 (f11-5
1037 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
1038 8134))
1039 (multiple-value-call #'%f3
1040 (values (%f3 -30637724 b) c)))))
1041 (setq c 555910)))
1042 (if (and nil (%f11 a a))
1043 (if (%f11 a 421778 4030 1)
1044 (labels ((%f7
1045 (f7-1 f7-2
1046 &optional
1047 (f7-3
1048 (%f11 -79192293
1049 (%f11 c a c -4 214720)
1050 b
1051 b
1052 (%f11 b 985)))
1053 (f7-4 a))
1054 b))
1055 (%f11 c b -25644))
1056 54)
1057 -32326608))))
1058 1 2 3)
1059 -32326608))
1060
1061 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1062 ;;; local lambda argument
1063 (assert
1064 (equal
1065 (funcall
1066 (compile nil
1067 '(lambda (a b c)
1068 (declare (type (integer 804561 7640697) a))
1069 (declare (type (integer -1 10441401) b))
1070 (declare (type (integer -864634669 55189745) c))
1071 (declare (ignorable a b c))
1072 (declare (optimize (speed 3)))
1073 (declare (optimize (safety 1)))
1074 (declare (optimize (debug 1)))
1075 (flet ((%f11
1076 (f11-1 f11-2)
1077 (labels ((%f4 () (round 200048 (max 99 c))))
1078 (logand
1079 f11-1
1080 (labels ((%f3 (f3-1) -162967612))
1081 (%f3 (let* ((v8 (%f4)))
1082 (setq f11-1 (%f4)))))))))
1083 (%f11 -120429363 (%f11 62362 b)))))
1084 6714367 9645616 -637681868)
1085 -264223548))
1086
1087 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1088 ;;; transform
1089 (assert (equal (multiple-value-list
1090 (funcall
1091 (compile nil '(lambda ()
1092 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1093 (ceiling
1094 (ceiling
1095 (flet ((%f16 () 0)) (%f16))))))))
1096 '(0 0)))
1097
1098 ;;; MISC.184
1099 (assert (zerop
1100 (funcall
1101 (compile
1102 nil
1103 '(lambda (a b c)
1104 (declare (type (integer 867934833 3293695878) a))
1105 (declare (type (integer -82111 1776797) b))
1106 (declare (type (integer -1432413516 54121964) c))
1107 (declare (optimize (speed 3)))
1108 (declare (optimize (safety 1)))
1109 (declare (optimize (debug 1)))
1110 (if nil
1111 (flet ((%f15 (f15-1 &optional (f15-2 c))
1112 (labels ((%f1 (f1-1 f1-2) 0))
1113 (%f1 a 0))))
1114 (flet ((%f4 ()
1115 (multiple-value-call #'%f15
1116 (values (%f15 c 0) (%f15 0)))))
1117 (if nil (%f4)
1118 (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
1119 f8-3))
1120 0))))
1121 0)))
1122 3040851270 1664281 -1340106197)))
1123
1124 ;;; MISC.249
1125 (assert (zerop
1126 (funcall
1127 (compile
1128 nil
1129 '(lambda (a b)
1130 (declare (notinline <=))
1131 (declare (optimize (speed 2) (space 3) (safety 0)
1132 (debug 1) (compilation-speed 3)))
1133 (if (if (<= 0) nil nil)
1134 (labels ((%f9 (f9-1 f9-2 f9-3)
1135 (ignore-errors 0)))
1136 (dotimes (iv4 5 a) (%f9 0 0 b)))
1137 0)))
1138 1 2)))
1139
1140 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1141 (assert
1142 (= (funcall
1143 (compile
1144 nil
1145 '(lambda (a)
1146 (declare (type (integer 177547470 226026978) a))
1147 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1148 (compilation-speed 1)))
1149 (logand a (* a 438810))))
1150 215067723)
1151 13739018))
1152
1153 \f
1154 ;;;; Bugs in stack analysis
1155 ;;; bug 299 (reported by PFD)
1156 (assert
1157 (equal (funcall
1158 (compile
1159 nil
1160 '(lambda ()
1161 (declare (optimize (debug 1)))
1162 (multiple-value-call #'list
1163 (if (eval t) (eval '(values :a :b :c)) nil)
1164 (catch 'foo (throw 'foo (values :x :y)))))))
1165 '(:a :b :c :x :y)))
1166 ;;; bug 298 (= MISC.183)
1167 (assert (zerop (funcall
1168 (compile
1169 nil
1170 '(lambda (a b c)
1171 (declare (type (integer -368154 377964) a))
1172 (declare (type (integer 5044 14959) b))
1173 (declare (type (integer -184859815 -8066427) c))
1174 (declare (ignorable a b c))
1175 (declare (optimize (speed 3)))
1176 (declare (optimize (safety 1)))
1177 (declare (optimize (debug 1)))
1178 (block b7
1179 (flet ((%f3 (f3-1 f3-2 f3-3) 0))
1180 (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
1181 0 6000 -9000000)))
1182 (assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
1183 '(1 2)))
1184 (let ((f (compile
1185 nil
1186 '(lambda (x)
1187 (block foo
1188 (multiple-value-call #'list
1189 :a
1190 (block bar
1191 (return-from foo
1192 (multiple-value-call #'list
1193 :b
1194 (block quux
1195 (return-from bar
1196 (catch 'baz
1197 (if x
1198 (return-from quux 1)
1199 (throw 'baz 2))))))))))))))
1200 (assert (equal (funcall f t) '(:b 1)))
1201 (assert (equal (funcall f nil) '(:a 2))))
1202
1203 ;;; MISC.185
1204 (assert (equal
1205 (funcall
1206 (compile
1207 nil
1208 '(lambda (a b c)
1209 (declare (type (integer 5 155656586618) a))
1210 (declare (type (integer -15492 196529) b))
1211 (declare (type (integer 7 10) c))
1212 (declare (optimize (speed 3)))
1213 (declare (optimize (safety 1)))
1214 (declare (optimize (debug 1)))
1215 (flet ((%f3
1216 (f3-1 f3-2 f3-3
1217 &optional (f3-4 a) (f3-5 0)
1218 (f3-6
1219 (labels ((%f10 (f10-1 f10-2 f10-3)
1220 0))
1221 (apply #'%f10
1222 0
1223 a
1224 (- (if (equal a b) b (%f10 c a 0))
1225 (catch 'ct2 (throw 'ct2 c)))
1226 nil))))
1227 0))
1228 (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
1229 0))
1230 ;;; MISC.186
1231 (assert (eq
1232 (eval
1233 '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
1234 (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
1235 (vars '(b c))
1236 (fn1 `(lambda ,vars
1237 (declare (type (integer -2 19) b)
1238 (type (integer -1520 218978) c)
1239 (optimize (speed 3) (safety 1) (debug 1)))
1240 ,form))
1241 (fn2 `(lambda ,vars
1242 (declare (notinline logeqv apply)
1243 (optimize (safety 3) (speed 0) (debug 0)))
1244 ,form))
1245 (cf1 (compile nil fn1))
1246 (cf2 (compile nil fn2))
1247 (result1 (multiple-value-list (funcall cf1 2 18886)))
1248 (result2 (multiple-value-list (funcall cf2 2 18886))))
1249 (if (equal result1 result2)
1250 :good
1251 (values result1 result2))))
1252 :good))
1253
1254 ;;; MISC.290
1255 (assert (zerop
1256 (funcall
1257 (compile
1258 nil
1259 '(lambda ()
1260 (declare
1261 (optimize (speed 3) (space 3) (safety 1)
1262 (debug 2) (compilation-speed 0)))
1263 (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
1264
1265 ;;; MISC.292
1266 (assert (zerop (funcall
1267 (compile
1268 nil
1269 '(lambda (a b)
1270 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1271 (compilation-speed 2)))
1272 (apply (constantly 0)
1273 a
1274 0
1275 (catch 'ct6
1276 (apply (constantly 0)
1277 0
1278 0
1279 (let* ((v1
1280 (let ((*s7* 0))
1281 b)))
1282 0)
1283 0
1284 nil))
1285 0
1286 nil)))
1287 1 2)))
1288
1289 ;;; misc.295
1290 (assert (eql
1291 (funcall
1292 (compile
1293 nil
1294 '(lambda ()
1295 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1296 (multiple-value-prog1
1297 (the integer (catch 'ct8 (catch 'ct7 15867134)))
1298 (catch 'ct1 (throw 'ct1 0))))))
1299 15867134))
1300
1301 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1302 ;;; could transform known-values LVAR to UVL
1303 (assert (zerop (funcall
1304 (compile
1305 nil
1306 '(lambda (a b c)
1307 (declare (notinline boole values denominator list))
1308 (declare
1309 (optimize (speed 2)
1310 (space 0)
1311 (safety 1)
1312 (debug 0)
1313 (compilation-speed 2)))
1314 (catch 'ct6
1315 (progv
1316 '(*s8*)
1317 (list 0)
1318 (let ((v9 (ignore-errors (throw 'ct6 0))))
1319 (denominator
1320 (progv nil nil (values (boole boole-and 0 v9)))))))))
1321 1 2 3)))
1322
1323 ;;; non-continuous dead UVL blocks
1324 (defun non-continuous-stack-test (x)
1325 (multiple-value-call #'list
1326 (eval '(values 11 12))
1327 (eval '(values 13 14))
1328 (block ext
1329 (return-from non-continuous-stack-test
1330 (multiple-value-call #'list
1331 (eval '(values :b1 :b2))
1332 (eval '(values :b3 :b4))
1333 (block int
1334 (return-from ext
1335 (multiple-value-call (eval #'values)
1336 (eval '(values 1 2))
1337 (eval '(values 3 4))
1338 (block ext
1339 (return-from int
1340 (multiple-value-call (eval #'values)
1341 (eval '(values :a1 :a2))
1342 (eval '(values :a3 :a4))
1343 (block int
1344 (return-from ext
1345 (multiple-value-call (eval #'values)
1346 (eval '(values 5 6))
1347 (eval '(values 7 8))
1348 (if x
1349 :ext
1350 (return-from int :int))))))))))))))))
1351 (assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
1352 (assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
1353
1354 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1355 ;;; if ENTRY.
1356 (assert (equal (multiple-value-list (funcall
1357 (compile
1358 nil
1359 '(lambda (b g h)
1360 (declare (optimize (speed 3) (space 3) (safety 2)
1361 (debug 2) (compilation-speed 3)))
1362 (catch 'ct5
1363 (unwind-protect
1364 (labels ((%f15 (f15-1 f15-2 f15-3)
1365 (rational (throw 'ct5 0))))
1366 (%f15 0
1367 (apply #'%f15
1368 0
1369 h
1370 (progn
1371 (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
1372 0)
1373 nil)
1374 0))
1375 (common-lisp:handler-case 0)))))
1376 1 2 3))
1377 '(0)))
1378
1379 \f
1380 ;;; MISC.275
1381 (assert
1382 (zerop
1383 (funcall
1384 (compile
1385 nil
1386 '(lambda (b)
1387 (declare (notinline funcall min coerce))
1388 (declare
1389 (optimize (speed 1)
1390 (space 2)
1391 (safety 2)
1392 (debug 1)
1393 (compilation-speed 1)))
1394 (flet ((%f12 (f12-1)
1395 (coerce
1396 (min
1397 (if f12-1 (multiple-value-prog1
1398 b (return-from %f12 0))
1399 0))
1400 'integer)))
1401 (funcall #'%f12 0))))
1402 -33)))
1403
1404 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1405 ;;; potential problem: optimizers and type derivers for MAX and MIN
1406 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1407 (dolist (f '(min max))
1408 (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
1409 for complex-arg = `(if x ,@complex-arg-args)
1410 do
1411 (loop for args in `((1 ,complex-arg)
1412 (,complex-arg 1))
1413 for form = `(,f ,@args)
1414 for f1 = (compile nil `(lambda (x) ,form))
1415 and f2 = (compile nil `(lambda (x) (declare (notinline min max))
1416 ,form))
1417 do
1418 (dolist (x '(nil t))
1419 (assert (eql (funcall f1 x) (funcall f2 x)))))))
1420
1421 ;;;
1422 (handler-case (compile nil '(lambda (x)
1423 (declare (optimize (speed 3) (safety 0)))
1424 (the double-float (sqrt (the double-float x)))))
1425 (sb-ext:compiler-note (c)
1426 ;; Ignore the note for the float -> pointer conversion of the
1427 ;; return value.
1428 (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
1429 "<return value>")
1430 (error "Compiler does not trust result type assertion."))))
1431
1432 (let ((f (compile nil '(lambda (x)
1433 (declare (optimize speed (safety 0)))
1434 (block nil
1435 (the double-float
1436 (multiple-value-prog1
1437 (sqrt (the double-float x))
1438 (when (< x 0)
1439 (return :minus)))))))))
1440 (assert (eql (funcall f -1d0) :minus))
1441 (assert (eql (funcall f 4d0) 2d0)))
1442
1443 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1444 (handler-case
1445 (compile nil '(lambda (a i)
1446 (locally
1447 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1448 (inhibit-warnings 0)))
1449 (declare (type (alien (* (unsigned 8))) a)
1450 (type (unsigned-byte 32) i))
1451 (deref a i))))
1452 (compiler-note () (error "The code is not optimized.")))
1453
1454 (handler-case
1455 (compile nil '(lambda (x)
1456 (declare (type (integer -100 100) x))
1457 (declare (optimize speed))
1458 (declare (notinline identity))
1459 (1+ (identity x))))
1460 (compiler-note () (error "IDENTITY derive-type not applied.")))
1461
1462 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
1463
1464 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1465 ;;; LVAR; here the first write may be cleared before the second is
1466 ;;; made.
1467 (assert
1468 (zerop
1469 (funcall
1470 (compile
1471 nil
1472 '(lambda ()
1473 (declare (notinline complex))
1474 (declare (optimize (speed 1) (space 0) (safety 1)
1475 (debug 3) (compilation-speed 3)))
1476 (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
1477 (complex (%f) 0)))))))
1478
1479 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1480 (assert (zerop (funcall
1481 (compile
1482 nil
1483 '(lambda (a c)
1484 (declare (type (integer -1294746569 1640996137) a))
1485 (declare (type (integer -807801310 3) c))
1486 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1487 (catch 'ct7
1488 (if
1489 (logbitp 0
1490 (if (/= 0 a)
1491 c
1492 (ignore-errors
1493 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
1494 0 0))))
1495 391833530 -32785211)))
1496
1497 ;;; efficiency notes for ordinary code
1498 (macrolet ((frob (arglist &body body)
1499 `(progn
1500 (handler-case
1501 (compile nil '(lambda ,arglist ,@body))
1502 (sb-ext:compiler-note (e)
1503 (error "bad compiler note for ~S:~% ~A" ',body e)))
1504 (catch :got-note
1505 (handler-case
1506 (compile nil '(lambda ,arglist (declare (optimize speed))
1507 ,@body))
1508 (sb-ext:compiler-note (e) (throw :got-note nil)))
1509 (error "missing compiler note for ~S" ',body)))))
1510 (frob (x) (funcall x))
1511 (frob (x y) (find x y))
1512 (frob (x y) (find-if x y))
1513 (frob (x y) (find-if-not x y))
1514 (frob (x y) (position x y))
1515 (frob (x y) (position-if x y))
1516 (frob (x y) (position-if-not x y))
1517 (frob (x) (aref x 0)))
1518
1519 (macrolet ((frob (style-warn-p form)
1520 (if style-warn-p
1521 `(catch :got-style-warning
1522 (handler-case
1523 (eval ',form)
1524 (style-warning (e) (throw :got-style-warning nil)))
1525 (error "missing style-warning for ~S" ',form))
1526 `(handler-case
1527 (eval ',form)
1528 (style-warning (e)
1529 (error "bad style-warning for ~S: ~A" ',form e))))))
1530 (frob t (lambda (x &optional y &key z) (list x y z)))
1531 (frob nil (lambda (x &optional y z) (list x y z)))
1532 (frob nil (lambda (x &key y z) (list x y z)))
1533 (frob t (defgeneric #:foo (x &optional y &key z)))
1534 (frob nil (defgeneric #:foo (x &optional y z)))
1535 (frob nil (defgeneric #:foo (x &key y z)))
1536 (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
1537
1538 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1539 ;;; note, because the system failed to derive the fact that the return
1540 ;;; from LOGXOR was small and negative, though the bottom one worked.
1541 (handler-bind ((sb-ext:compiler-note #'error))
1542 (compile nil '(lambda ()
1543 (declare (optimize speed (safety 0)))
1544 (lambda (x y)
1545 (declare (type (integer 3 6) x)
1546 (type (integer -6 -3) y))
1547 (+ (logxor x y) most-positive-fixnum)))))
1548 (handler-bind ((sb-ext:compiler-note #'error))
1549 (compile nil '(lambda ()
1550 (declare (optimize speed (safety 0)))
1551 (lambda (x y)
1552 (declare (type (integer 3 6) y)
1553 (type (integer -6 -3) x))
1554 (+ (logxor x y) most-positive-fixnum)))))
1555
1556 ;;; check that modular ash gives the right answer, to protect against
1557 ;;; possible misunderstandings about the hardware shift instruction.
1558 (assert (zerop (funcall
1559 (compile nil '(lambda (x y)
1560 (declare (optimize speed)
1561 (type (unsigned-byte 32) x y))
1562 (logand #xffffffff (ash x y))))
1563 1 257)))
1564
1565 ;;; code instrumenting problems
1566 (compile nil
1567 '(lambda ()
1568 (declare (optimize (debug 3)))
1569 (list (the integer (if nil 14 t)))))
1570
1571 (compile nil
1572 '(LAMBDA (A B C D)
1573 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
1574 (DECLARE
1575 (OPTIMIZE (SPEED 1)
1576 (SPACE 1)
1577 (SAFETY 1)
1578 (DEBUG 3)
1579 (COMPILATION-SPEED 0)))
1580 (MASK-FIELD (BYTE 7 26)
1581 (PROGN
1582 (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
1583 B))))
1584
1585 (compile nil
1586 '(lambda (buffer i end)
1587 (declare (optimize (debug 3)))
1588 (loop (when (not (eql 0 end)) (return)))
1589 (let ((s (make-string end)))
1590 (setf (schar s i) (schar buffer i))
1591 s)))
1592
1593 ;;; check that constant string prefix and suffix don't cause the
1594 ;;; compiler to emit code deletion notes.
1595 (handler-bind ((sb-ext:code-deletion-note #'error))
1596 (compile nil '(lambda (s x)
1597 (pprint-logical-block (s x :prefix "(")
1598 (print x s))))
1599 (compile nil '(lambda (s x)
1600 (pprint-logical-block (s x :per-line-prefix ";")
1601 (print x s))))
1602 (compile nil '(lambda (s x)
1603 (pprint-logical-block (s x :suffix ">")
1604 (print x s)))))
1605
1606 ;;; MISC.427: loop analysis requires complete DFO structure
1607 (assert (eql 17 (funcall
1608 (compile
1609 nil
1610 '(lambda (a)
1611 (declare (notinline list reduce logior))
1612 (declare (optimize (safety 2) (compilation-speed 1)
1613 (speed 3) (space 2) (debug 2)))
1614 (logior
1615 (let* ((v5 (reduce #'+ (list 0 a))))
1616 (declare (dynamic-extent v5))
1617 v5))))
1618 17)))
1619
1620 ;;; MISC.434
1621 (assert (zerop (funcall
1622 (compile
1623 nil
1624 '(lambda (a b)
1625 (declare (type (integer -8431780939320 1571817471932) a))
1626 (declare (type (integer -4085 0) b))
1627 (declare (ignorable a b))
1628 (declare
1629 (optimize (space 2)
1630 (compilation-speed 0)
1631 #+sbcl (sb-c:insert-step-conditions 0)
1632 (debug 2)
1633 (safety 0)
1634 (speed 3)))
1635 (let ((*s5* 0))
1636 (dotimes (iv1 2 0)
1637 (let ((*s5*
1638 (elt '(1954479092053)
1639 (min 0
1640 (max 0
1641 (if (< iv1 iv1)
1642 (lognand iv1 (ash iv1 (min 53 iv1)))
1643 iv1))))))
1644 0)))))
1645 -7639589303599 -1368)))
1646
1647 (compile
1648 nil
1649 '(lambda (a b)
1650 (declare (type (integer) a))
1651 (declare (type (integer) b))
1652 (declare (ignorable a b))
1653 (declare (optimize (space 2) (compilation-speed 0)
1654 (debug 0) (safety 0) (speed 3)))
1655 (dotimes (iv1 2 0)
1656 (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
1657 (print (if (< iv1 iv1)
1658 (logand (ash iv1 iv1) 1)
1659 iv1)))))
1660
1661 ;;; MISC.435: lambda var substitution in a deleted code.
1662 (assert (zerop (funcall
1663 (compile
1664 nil
1665 '(lambda (a b c d)
1666 (declare (notinline aref logandc2 gcd make-array))
1667 (declare
1668 (optimize (space 0) (safety 0) (compilation-speed 3)
1669 (speed 3) (debug 1)))
1670 (progn
1671 (tagbody
1672 (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
1673 (declare (dynamic-extent v2))
1674 (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
1675 tag2)
1676 0)))
1677 3021871717588 -866608 -2 -17194)))
1678
1679 ;;; MISC.436, 438: lost reoptimization
1680 (assert (zerop (funcall
1681 (compile
1682 nil
1683 '(lambda (a b)
1684 (declare (type (integer -2917822 2783884) a))
1685 (declare (type (integer 0 160159) b))
1686 (declare (ignorable a b))
1687 (declare
1688 (optimize (compilation-speed 1)
1689 (speed 3)
1690 (safety 3)
1691 (space 0)
1692 ; #+sbcl (sb-c:insert-step-conditions 0)
1693 (debug 0)))
1694 (if
1695 (oddp
1696 (loop for
1697 lv1
1698 below
1699 2
1700 count
1701 (logbitp 0
1702 (1-
1703 (ash b
1704 (min 8
1705 (count 0
1706 '(-10197561 486 430631291
1707 9674068))))))))
1708 b
1709 0)))
1710 1265797 110757)))
1711
1712 (assert (zerop (funcall
1713 (compile
1714 nil
1715 ' (lambda (a)
1716 (declare (type (integer 0 1696) a))
1717 ; (declare (ignorable a))
1718 (declare (optimize (space 2) (debug 0) (safety 1)
1719 (compilation-speed 0) (speed 1)))
1720 (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
1721 805)))
1722
1723 ;;; bug #302
1724 (assert (compile
1725 nil
1726 '(lambda (s ei x y)
1727 (declare (type (simple-array function (2)) s) (type ei ei))
1728 (funcall (aref s ei) x y))))
1729
1730 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1731 ;;; a DEFINED-FUN.
1732 (assert (eql 102 (funcall
1733 (compile
1734 nil
1735 '(lambda ()
1736 (declare (optimize (speed 3) (space 0) (safety 2)
1737 (debug 2) (compilation-speed 0)))
1738 (catch 'ct2
1739 (elt '(102)
1740 (flet ((%f12 () (rem 0 -43)))
1741 (multiple-value-call #'%f12 (values))))))))))
1742
1743 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1744 (assert (zerop (funcall
1745 (compile
1746 nil
1747 '(lambda (a b c d e)
1748 (declare (notinline values complex eql))
1749 (declare
1750 (optimize (compilation-speed 3)
1751 (speed 3)
1752 (debug 1)
1753 (safety 1)
1754 (space 0)))
1755 (flet ((%f10
1756 (f10-1 f10-2 f10-3
1757 &optional (f10-4 (ignore-errors 0)) (f10-5 0)
1758 &key &allow-other-keys)
1759 (if (or (eql 0 0) t) 0 (if f10-1 0 0))))
1760 (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0))))
1761 80043 74953652306 33658947 -63099937105 -27842393)))
1762
1763 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1764 ;;; resulting from SETF of LET.
1765 (dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops)))
1766 (compile nil '(lambda () (let* :bogus-let* :oops)))
1767 (compile nil '(lambda (x) (push x (let ((y 0)) y))))))
1768 (assert (functionp fun))
1769 (multiple-value-bind (res err) (ignore-errors (funcall fun))
1770 (assert (not res))
1771 (assert (typep err 'program-error))))
1772
1773 (let ((fun (compile nil '(lambda (x) (random (if x 10 20))))))
1774 (dotimes (i 100 (error "bad RANDOM distribution"))
1775 (when (> (funcall fun nil) 9)
1776 (return t)))
1777 (dotimes (i 100)
1778 (when (> (funcall fun t) 9)
1779 (error "bad RANDOM event"))))
1780
1781 ;;; 0.8.17.28-sma.1 lost derived type information.
1782 (with-test (:name "0.8.17.28-sma.1" :fails-on :sparc)
1783 (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
1784 (compile nil
1785 '(lambda (x y v)
1786 (declare (optimize (speed 3) (safety 0)))
1787 (declare (type (integer 0 80) x)
1788 (type (integer 0 11) y)
1789 (type (simple-array (unsigned-byte 32) (*)) v))
1790 (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
1791 nil))))
1792
1793 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1794 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1795 (let ((f (compile nil '(lambda ()
1796 (declare (optimize (debug 3)))
1797 (with-simple-restart (blah "blah") (error "blah"))))))
1798 (handler-bind ((error (lambda (c) (invoke-restart 'blah))))
1799 (assert (equal (multiple-value-list (funcall f)) '(nil t)))))
1800
1801 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1802 ;;; constant index and value.
1803 (loop for n-bits = 1 then (* n-bits 2)
1804 for type = `(unsigned-byte ,n-bits)
1805 and v-max = (1- (ash 1 n-bits))
1806 while (<= n-bits sb-vm:n-word-bits)
1807 do
1808 (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
1809 (array1 (make-array n :element-type type))
1810 (array2 (make-array n :element-type type)))
1811 (dotimes (i n)
1812 (dolist (v (list 0 v-max))
1813 (let ((f (compile nil `(lambda (a)
1814 (declare (type (simple-array ,type (,n)) a))
1815 (setf (aref a ,i) ,v)))))
1816 (fill array1 (- v-max v))
1817 (fill array2 (- v-max v))
1818 (funcall f array1)
1819 (setf (aref array2 i) v)
1820 (assert (every #'= array1 array2)))))))
1821
1822 (let ((fn (compile nil '(lambda (x)
1823 (declare (type bit x))
1824 (declare (optimize speed))
1825 (let ((b (make-array 64 :element-type 'bit
1826 :initial-element 0)))
1827 (count x b))))))
1828 (assert (= (funcall fn 0) 64))
1829 (assert (= (funcall fn 1) 0)))
1830
1831 (let ((fn (compile nil '(lambda (x y)
1832 (declare (type simple-bit-vector x y))
1833 (declare (optimize speed))
1834 (equal x y)))))
1835 (assert (funcall
1836 fn
1837 (make-array 64 :element-type 'bit :initial-element 0)
1838 (make-array 64 :element-type 'bit :initial-element 0)))
1839 (assert (not
1840 (funcall
1841 fn
1842 (make-array 64 :element-type 'bit :initial-element 0)
1843 (let ((b (make-array 64 :element-type 'bit :initial-element 0)))
1844 (setf (sbit b 63) 1)
1845 b)))))
1846
1847 ;;; MISC.535: compiler failure
1848 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
1849 (assert (not (funcall
1850 (compile
1851 nil
1852 `(lambda (p1 p2)
1853 (declare (optimize speed (safety 1))
1854 (type (eql ,c0) p1)
1855 (type number p2))
1856 (eql (the (complex double-float) p1) p2)))
1857 c0 #c(12 612/979)))))
1858
1859 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1860 ;;; simple-bit-vector functions.
1861 (handler-bind ((sb-ext:compiler-note #'error))
1862 (compile nil '(lambda (x)
1863 (declare (type simple-bit-vector x))
1864 (count 1 x))))
1865 (handler-bind ((sb-ext:compiler-note #'error))
1866 (compile nil '(lambda (x y)
1867 (declare (type simple-bit-vector x y))
1868 (equal x y))))
1869
1870 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1871 ;;; code transformations.
1872 (assert (eql (funcall
1873 (compile
1874 nil
1875 '(lambda (p1 p2)
1876 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1877 (type atom p1)
1878 (type symbol p2))
1879 (or p1 (the (eql t) p2))))
1880 nil t)
1881 t))
1882
1883 ;;; MISC.548: type check weakening converts required type into
1884 ;;; optional
1885 (assert (eql t
1886 (funcall
1887 (compile
1888 nil
1889 '(lambda (p1)
1890 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1891 (atom (the (member f assoc-if write-line t w) p1))))
1892 t)))
1893
1894 ;;; Free special bindings only apply to the body of the binding form, not
1895 ;;; the initialization forms.
1896 (assert (eq :good
1897 (funcall (compile 'nil
1898 (lambda ()
1899 (let ((x :bad))
1900 (declare (special x))
1901 (let ((x :good))
1902 ((lambda (&optional (y x))
1903 (declare (special x)) y)))))))))
1904
1905 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1906 ;;; a rational was zero, but didn't do the substitution, leading to a
1907 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1908 ;;; machine's ASH instruction's immediate field) that the compiler
1909 ;;; thought was legitimate.
1910 ;;;
1911 ;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl
1912 ;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil
1913 ;;; exist and this test case serves as a reminder of the problem.
1914 ;;; --njf, 2005-07-05
1915 #+nil
1916 (compile 'nil
1917 (LAMBDA (B)
1918 (DECLARE (TYPE (INTEGER -2 14) B))
1919 (DECLARE (IGNORABLE B))
1920 (ASH (IMAGPART B) 57)))
1921
1922 ;;; bug reported by Eduardo Mu\~noz
1923 (multiple-value-bind (fun warnings failure)
1924 (compile nil '(lambda (struct first)
1925 (declare (optimize speed))
1926 (let* ((nodes (nodes struct))
1927 (bars (bars struct))
1928 (length (length nodes))
1929 (new (make-array length :fill-pointer 0)))
1930 (vector-push first new)
1931 (loop with i fixnum = 0
1932 for newl fixnum = (length new)
1933 while (< newl length) do
1934 (let ((oldl (length new)))
1935 (loop for j fixnum from i below newl do
1936 (dolist (n (node-neighbours (aref new j) bars))
1937 (unless (find n new)
1938 (vector-push n new))))
1939 (setq i oldl)))
1940 new)))
1941 (declare (ignore fun warnings failure))
1942 (assert (not failure)))
1943
1944 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
1945 ;;; sbcl-devel)
1946 (compile nil '(lambda (x y a b c)
1947 (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
1948
1949 ;;; Type inference from CHECK-TYPE
1950 (let ((count0 0) (count1 0))
1951 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0))))
1952 (compile nil '(lambda (x)
1953 (declare (optimize (speed 3)))
1954 (1+ x))))
1955 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
1956 (assert (> count0 1))
1957 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
1958 (compile nil '(lambda (x)
1959 (declare (optimize (speed 3)))
1960 (check-type x fixnum)
1961 (1+ x))))
1962 ;; Only the posssible word -> bignum conversion note
1963 (assert (= count1 1)))
1964
1965 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
1966 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
1967 (with-test (:name :sap-ref-float)
1968 (compile nil '(lambda (sap)
1969 (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0)))
1970 (1+ x))))
1971 (compile nil '(lambda (sap)
1972 (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
1973 (1+ x)))))
1974
1975 ;;; bug #399
1976 (with-test (:name :string-union-types)
1977 (compile nil '(lambda (x)
1978 (declare (type (or (simple-array character (6))
1979 (simple-array character (5))) x))
1980 (aref x 0))))
1981
1982 ;;; MISC.623: missing functions for constant-folding
1983 (assert (eql 0
1984 (funcall
1985 (compile
1986 nil
1987 '(lambda ()
1988 (declare (optimize (space 2) (speed 0) (debug 2)
1989 (compilation-speed 3) (safety 0)))
1990 (loop for lv3 below 1
1991 count (minusp
1992 (loop for lv2 below 2
1993 count (logbitp 0
1994 (bit #*1001101001001
1995 (min 12 (max 0 lv3))))))))))))
1996
1997 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
1998 (assert (eql 0
1999 (funcall
2000 (compile
2001 nil
2002 '(lambda (a)
2003 (declare (type (integer 21 28) a))
2004 (declare (optimize (compilation-speed 1) (safety 2)
2005 (speed 0) (debug 0) (space 1)))
2006 (let* ((v7 (flet ((%f3 (f3-1 f3-2)
2007 (loop for lv2 below 1
2008 count
2009 (logbitp 29
2010 (sbit #*10101111
2011 (min 7 (max 0 (eval '0))))))))
2012 (%f3 0 a))))
2013 0)))
2014 22)))
2015
2016 ;;; MISC.626: bandaged AVER was still wrong
2017 (assert (eql -829253
2018 (funcall
2019 (compile
2020 nil
2021 '(lambda (a)
2022 (declare (type (integer -902970 2) a))
2023 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2024 (speed 0) (safety 3)))
2025 (prog2 (if (logbitp 30 a) 0 (block b3 0)) a)))
2026 -829253)))
2027
2028 ;; MISC.628: constant-folding %LOGBITP was buggy
2029 (assert (eql t
2030 (funcall
2031 (compile
2032 nil
2033 '(lambda ()
2034 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2035 (speed 0) (debug 1)))
2036 (not (not (logbitp 0 (floor 2147483651 (min -23 0))))))))))
2037
2038 ;; mistyping found by random-tester
2039 (assert (zerop
2040 (funcall
2041 (compile
2042 nil
2043 '(lambda ()
2044 (declare (optimize (speed 1) (debug 0)
2045 (space 2) (safety 0) (compilation-speed 0)))
2046 (unwind-protect 0
2047 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
2048
2049 ;; aggressive constant folding (bug #400)
2050 (assert
2051 (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
2052
2053 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
2054 (assert
2055 (handler-case
2056 (compile nil '(lambda (x y)
2057 (when (eql x (length y))
2058 (locally
2059 (declare (optimize (speed 3)))
2060 (1+ x)))))
2061 (compiler-note () (error "The code is not optimized.")))))
2062
2063 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
2064 (assert
2065 (handler-case
2066 (compile nil '(lambda (x y)
2067 (when (eql (length y) x)
2068 (locally
2069 (declare (optimize (speed 3)))
2070 (1+ x)))))
2071 (compiler-note () (error "The code is not optimized.")))))
2072
2073 (with-test (:name (:compiler :constraint-propagation :float-bounds-1))
2074 (handler-case
2075 (compile nil '(lambda (x)
2076 (declare (type (single-float * (3.0)) x))
2077 (when (<= x 2.0)
2078 (when (<= 2.0 x)
2079 x))))
2080 (compiler-note () (error "Deleted reachable code."))))
2081
2082 (with-test (:name (:compiler :constraint-propagation :float-bounds-2))
2083 (catch :note
2084 (handler-case
2085 (compile nil '(lambda (x)
2086 (declare (type single-float x))
2087 (when (< 1.0 x)
2088 (when (<= x 1.0)
2089 (error "This is unreachable.")))))
2090 (compiler-note () (throw :note nil)))
2091 (error "Unreachable code undetected.")))
2092
2093 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
2094 (catch :note
2095 (handler-case
2096 (compile nil '(lambda (x y)
2097 (when (typep y 'fixnum)
2098 (when (eql x y)
2099 (unless (typep x 'fixnum)
2100 (error "This is unreachable"))
2101 (setq y nil)))))
2102 (compiler-note () (throw :note nil)))
2103 (error "Unreachable code undetected.")))
2104
2105 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
2106 (catch :note
2107 (handler-case
2108 (compile nil '(lambda (x y)
2109 (when (typep y 'fixnum)
2110 (when (eql y x)
2111 (unless (typep x 'fixnum)
2112 (error "This is unreachable"))
2113 (setq y nil)))))
2114 (compiler-note () (throw :note nil)))
2115 (error "Unreachable code undetected.")))
2116
2117 ;; Reported by John Wiseman, sbcl-devel
2118 ;; Subject: [Sbcl-devel] float type derivation bug?
2119 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2120 (with-test (:name (:type-derivation :float-bounds))
2121 (compile nil '(lambda (bits)
2122 (let* ((s (if (= (ash bits -31) 0) 1 -1))
2123 (e (logand (ash bits -23) #xff))
2124 (m (if (= e 0)
2125 (ash (logand bits #x7fffff) 1)
2126 (logior (logand bits #x7fffff) #x800000))))
2127 (float (* s m (expt 2 (- e 150))))))))
2128
2129 ;; Reported by James Knight
2130 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2131 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2132 (with-test (:name :logbitp-vop)
2133 (compile nil
2134 '(lambda (days shift)
2135 (declare (type fixnum shift days))
2136 (let* ((result 0)
2137 (canonicalized-shift (+ shift 1))
2138 (first-wrapping-day (- 1 canonicalized-shift)))
2139 (declare (type fixnum result))
2140 (dotimes (source-day 7)
2141 (declare (type (integer 0 6) source-day))
2142 (when (logbitp source-day days)
2143 (setf result
2144 (logior result
2145 (the fixnum
2146 (if (< source-day first-wrapping-day)
2147 (+ source-day canonicalized-shift)
2148 (- (+ source-day
2149 canonicalized-shift) 7)))))))
2150 result))))
2151
2152 ;;; MISC.637: incorrect delaying of conversion of optional entries
2153 ;;; with hairy constant defaults
2154 (let ((f '(lambda ()
2155 (labels ((%f11 (f11-2 &key key1)
2156 (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0)))
2157 :bad1))
2158 (%f8 (%f8 0)))
2159 :bad2))
2160 :good))))
2161 (assert (eq (funcall (compile nil f)) :good)))
2162
2163 ;;; MISC.555: new reference to an already-optimized local function
2164 (let* ((l '(lambda (p1)
2165 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1))
2166 (keywordp p1)))
2167 (f (compile nil l)))
2168 (assert (funcall f :good))
2169 (assert (nth-value 1 (ignore-errors (funcall f 42)))))
2170
2171 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2172 (let* ((state (make-random-state))
2173 (*random-state* (make-random-state state))
2174 (a (random most-positive-fixnum)))
2175 (setf *random-state* state)
2176 (compile nil `(lambda (x a)
2177 (declare (single-float x)
2178 (type (simple-array double-float) a))
2179 (+ (loop for i across a
2180 summing i)
2181 x)))
2182 (assert (= a (random most-positive-fixnum))))
2183
2184 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2185 (let ((form '(lambda ()
2186 (declare (optimize (speed 1) (space 0) (debug 2)
2187 (compilation-speed 0) (safety 1)))
2188 (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #())))
2189 0))
2190 (apply #'%f3 0 nil)))))
2191 (assert (zerop (funcall (compile nil form)))))
2192
2193 ;;; size mismatch: #<SB-VM::EA :DWORD base=#<SB-C:TN t1[RDX]> disp=1> is a :DWORD and #<SB-C:TN t2[RAX]> is a :QWORD. on x86-64
2194 (compile nil '(lambda ()
2195 (let ((x (make-array '(1) :element-type '(signed-byte 32))))
2196 (setf (aref x 0) 1))))
2197
2198 ;;; step instrumentation confusing the compiler, reported by Faré
2199 (handler-bind ((warning #'error))
2200 (compile nil '(lambda ()
2201 (declare (optimize (debug 2))) ; not debug 3!
2202 (let ((val "foobar"))
2203 (map-into (make-array (list (length val))
2204 :element-type '(unsigned-byte 8))
2205 #'char-code val)))))
2206
2207 ;;; overconfident primitive type computation leading to bogus type
2208 ;;; checking.
2209 (let* ((form1 '(lambda (x)
2210 (declare (type (and condition function) x))
2211 x))
2212 (fun1 (compile nil form1))
2213 (form2 '(lambda (x)
2214 (declare (type (and standard-object function) x))
2215 x))
2216 (fun2 (compile nil form2)))
2217 (assert (raises-error? (funcall fun1 (make-condition 'error))))
2218 (assert (raises-error? (funcall fun1 fun1)))
2219 (assert (raises-error? (funcall fun2 fun2)))
2220 (assert (eq (funcall fun2 #'print-object) #'print-object)))
2221
2222 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2223 ;;; and possibly a non-conforming extension, as long as we do support
2224 ;;; it, we might as well get it right.
2225 ;;;
2226 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2227 (compile nil '(lambda () (let* () (declare (values list)))))
2228
2229
2230 ;;; test for some problems with too large immediates in x86-64 modular
2231 ;;; arithmetic vops
2232 (compile nil '(lambda (x) (declare (fixnum x))
2233 (logand most-positive-fixnum (logxor x most-positive-fixnum))))
2234
2235 (compile nil '(lambda (x) (declare (fixnum x))
2236 (logand most-positive-fixnum (+ x most-positive-fixnum))))
2237
2238 (compile nil '(lambda (x) (declare (fixnum x))
2239 (logand most-positive-fixnum (* x most-positive-fixnum))))
2240
2241 ;;; bug 256.b
2242 (assert (let (warned-p)
2243 (handler-bind ((warning (lambda (w) (setf warned-p t))))
2244 (compile nil
2245 '(lambda (x)
2246 (list (let ((y (the real x)))
2247 (unless (floatp y) (error ""))
2248 y)
2249 (integer-length x)))))
2250 warned-p))
2251
2252 ;; Dead / in safe code
2253 (with-test (:name :safe-dead-/)
2254 (assert (eq :error
2255 (handler-case
2256 (funcall (compile nil
2257 '(lambda (x y)
2258 (declare (optimize (safety 3)))
2259 (/ x y)
2260 (+ x y)))
2261 1
2262 0)
2263 (division-by-zero ()
2264 :error)))))
2265
2266 ;;; Dead unbound variable (bug 412)
2267 (with-test (:name :dead-unbound)
2268 (assert (eq :error
2269 (handler-case
2270 (funcall (compile nil
2271 '(lambda ()
2272 #:unbound
2273 42)))
2274 (unbound-variable ()
2275 :error)))))
2276
2277 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2278 (handler-bind ((sb-ext:compiler-note 'error))
2279 (assert
2280 (equalp #(2 3)
2281 (funcall (compile nil `(lambda (s p e)
2282 (declare (optimize speed)
2283 (simple-vector s))
2284 (subseq s p e)))
2285 (vector 1 2 3 4)
2286 1
2287 3))))
2288
2289 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2290 (handler-bind ((sb-ext:compiler-note 'error))
2291 (assert
2292 (equalp #(1 2 3 4)
2293 (funcall (compile nil `(lambda (s)
2294 (declare (optimize speed)
2295 (simple-vector s))
2296 (copy-seq s)))
2297 (vector 1 2 3 4)))))
2298
2299 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2300 (assert (not (mismatch #(1.0f0 2.0f0) (make-array 2 :element-type 'single-float :initial-contents (list 1.0f0 2.0f0)))))
2301
2302 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2303 ;;; large bignums to floats
2304 (dolist (op '(* / + -))
2305 (let ((fun (compile
2306 nil
2307 `(lambda (x)
2308 (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x))
2309 (,op 0.0d0 x)))))
2310 (loop repeat 10
2311 do (let ((arg (random (truncate most-positive-double-float))))
2312 (assert (eql (funcall fun arg)
2313 (funcall op 0.0d0 arg)))))))
2314
2315 (with-test (:name :high-debug-known-function-inlining)
2316 (let ((fun (compile nil
2317 '(lambda ()
2318 (declare (optimize (debug 3)) (inline append))
2319 (let ((fun (lambda (body)
2320 (append
2321 (first body)
2322 nil))))
2323 (funcall fun
2324 '((foo (bar)))))))))
2325 (funcall fun)))
2326
2327 (with-test (:name :high-debug-known-function-transform-with-optional-arguments)
2328 (compile nil '(lambda (x y)
2329 (declare (optimize sb-c::preserve-single-use-debug-variables))
2330 (if (block nil
2331 (some-unknown-function
2332 (lambda ()
2333 (return (member x y))))
2334 t)
2335 t
2336 (error "~a" y)))))
2337
2338 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2339 ;;; or characters.
2340 (compile nil '(lambda (x y)
2341 (declare (fixnum y) (character x))
2342 (sb-sys:with-pinned-objects (x y)
2343 (some-random-function))))
2344
2345 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2346
2347 (with-test (:name :bug-423)
2348 (let ((sb-c::*check-consistency* t))
2349 (handler-bind ((warning #'error))
2350 (flet ((make-lambda (type)
2351 `(lambda (x)
2352 ((lambda (z)
2353 (if (listp z)
2354 (let ((q (truly-the list z)))
2355 (length q))
2356 (if (arrayp z)
2357 (let ((q (truly-the vector z)))
2358 (length q))
2359 (error "oops"))))
2360 (the ,type x)))))
2361 (compile nil (make-lambda 'list))
2362 (compile nil (make-lambda 'vector))))))
2363
2364 ;;; this caused a momentary regression when an ill-adviced fix to
2365 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2366 ;;;
2367 ;;; no :MOVE-ARG VOP defined to move #<SB-C:TN t1> (SC SB-VM::SINGLE-REG) to #<SB-C:TN t2> (SC SB-VM::ANY-REG)
2368 ;;; [Condition of type SIMPLE-ERROR]
2369 (compile nil
2370 '(lambda (frob)
2371 (labels
2372 ((%zig (frob)
2373 (typecase frob
2374 (double-float
2375 (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char))
2376 (* double-float))) frob))
2377 (hash-table
2378 (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2)))
2379 nil))))
2380 (%zig))))
2381
2382 ;;; non-required arguments in HANDLER-BIND
2383 (assert (eq :oops (car (funcall (compile nil
2384 '(lambda (x)
2385 (block nil
2386 (handler-bind ((error (lambda (&rest args) (return (cons :oops args)))))
2387 (/ 2 x)))))
2388 0))))
2389
2390 ;;; NIL is a legal function name
2391 (assert (eq 'a (flet ((nil () 'a)) (nil))))
2392
2393 ;;; misc.528
2394 (assert (null (let* ((x 296.3066f0)
2395 (y 22717067)
2396 (form `(lambda (r p2)
2397 (declare (optimize speed (safety 1))
2398 (type (simple-array single-float nil) r)
2399 (type (integer -9369756340 22717335) p2))
2400 (setf (aref r) (* ,x (the (eql 22717067) p2)))
2401 (values)))
2402 (r (make-array nil :element-type 'single-float))
2403 (expected (* x y)))
2404 (funcall (compile nil form) r y)
2405 (let ((actual (aref r)))
2406 (unless (eql expected actual)
2407 (list expected actual))))))
2408 ;;; misc.529
2409 (assert (null (let* ((x -2367.3296f0)
2410 (y 46790178)
2411 (form `(lambda (r p2)
2412 (declare (optimize speed (safety 1))
2413 (type (simple-array single-float nil) r)
2414 (type (eql 46790178) p2))
2415 (setf (aref r) (+ ,x (the (integer 45893897) p2)))
2416 (values)))
2417 (r (make-array nil :element-type 'single-float))
2418 (expected (+ x y)))
2419 (funcall (compile nil form) r y)
2420 (let ((actual (aref r)))
2421 (unless (eql expected actual)
2422 (list expected actual))))))
2423
2424 ;;; misc.556
2425 (assert (eql -1
2426 (funcall
2427 (compile nil '(lambda (p1 p2)
2428 (declare
2429 (optimize (speed 1) (safety 0)
2430 (debug 0) (space 0))
2431 (type (member 8174.8604) p1)
2432 (type (member -95195347) p2))
2433 (floor p1 p2)))
2434 8174.8604 -95195347)))
2435
2436 ;;; misc.557
2437 (assert (eql -1
2438 (funcall
2439 (compile
2440 nil
2441 '(lambda (p1)
2442 (declare (optimize (speed 3) (safety 0) (debug 3) (space 1))
2443 (type (member -94430.086f0) p1))
2444 (floor (the single-float p1) 19311235)))
2445 -94430.086f0)))
2446
2447 ;;; misc.558
2448 (assert (eql -1.0f0
2449 (funcall
2450 (compile
2451 nil
2452 '(lambda (p1)
2453 (declare (optimize (speed 1) (safety 2)
2454 (debug 2) (space 3))
2455 (type (eql -39466.56f0) p1))
2456 (ffloor p1 305598613)))
2457 -39466.56f0)))
2458
2459 ;;; misc.559
2460 (assert (eql 1
2461 (funcall
2462 (compile
2463 nil
2464 '(lambda (p1)
2465 (declare (optimize (speed 1) (safety 1) (debug 1) (space 2))
2466 (type (eql -83232.09f0) p1))
2467 (ceiling p1 -83381228)))
2468 -83232.09f0)))
2469
2470 ;;; misc.560
2471 (assert (eql 1
2472 (funcall
2473 (compile
2474 nil
2475 '(lambda (p1)
2476 (declare (optimize (speed 1) (safety 1)
2477 (debug 1) (space 0))
2478 (type (member -66414.414f0) p1))
2479 (ceiling p1 -63019173f0)))
2480 -66414.414f0)))
2481
2482 ;;; misc.561
2483 (assert (eql 1.0f0
2484 (funcall
2485 (compile
2486 nil
2487 '(lambda (p1)
2488 (declare (optimize (speed 0) (safety 1)
2489 (debug 0) (space 1))
2490 (type (eql 20851.398f0) p1))
2491 (fceiling p1 80839863)))
2492 20851.398f0)))
2493
2494 ;;; misc.581
2495 (assert (floatp
2496 (funcall
2497 (compile nil '(lambda (x)
2498 (declare (type (eql -5067.2056) x))
2499 (+ 213734822 x)))
2500 -5067.2056)))
2501
2502 ;;; misc.581a
2503 (assert (typep
2504 (funcall
2505 (compile nil '(lambda (x) (declare (type (eql -1.0) x))
2506 (+ #x1000001 x)))
2507 -1.0f0)
2508 'single-float))
2509
2510 ;;; misc.582
2511 (assert (plusp (funcall
2512 (compile
2513 nil
2514 ' (lambda (p1)
2515 (declare (optimize (speed 0) (safety 1) (debug 1) (space 1))
2516 (type (eql -39887.645) p1))
2517 (mod p1 382352925)))
2518 -39887.645)))
2519
2520 ;;; misc.587
2521 (assert (let ((result (funcall
2522 (compile
2523 nil
2524 '(lambda (p2)
2525 (declare (optimize (speed 0) (safety 3) (debug 1) (space 0))
2526 (type (eql 33558541) p2))
2527 (- 92215.266 p2)))
2528 33558541)))
2529 (typep result 'single-float)))
2530
2531 ;;; misc.635
2532 (assert (eql 1
2533 (let* ((form '(lambda (p2)
2534 (declare (optimize (speed 0) (safety 1)
2535 (debug 2) (space 2))
2536 (type (member -19261719) p2))
2537 (ceiling -46022.094 p2))))
2538 (values (funcall (compile nil form) -19261719)))))
2539
2540 ;;; misc.636
2541 (assert (let* ((x 26899.875)
2542 (form `(lambda (p2)
2543 (declare (optimize (speed 3) (safety 1) (debug 3) (space 1))
2544 (type (member ,x #:g5437 char-code #:g5438) p2))
2545 (* 104102267 p2))))
2546 (floatp (funcall (compile nil form) x))))
2547
2548 ;;; misc.622
2549 (assert (eql
2550 (funcall
2551 (compile
2552 nil
2553 '(lambda (p2)
2554 (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
2555 (type real p2))
2556 (+ 81535869 (the (member 17549.955 #:g35917) p2))))
2557 17549.955)
2558 (+ 81535869 17549.955)))
2559
2560 ;;; misc.654
2561 (assert (eql 2
2562 (let ((form '(lambda (p2)
2563 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2564 (type (member integer eql) p2))
2565 (coerce 2 p2))))
2566 (funcall (compile nil form) 'integer))))
2567
2568 ;;; misc.656
2569 (assert (eql 2
2570 (let ((form '(lambda (p2)
2571 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2572 (type (member integer mod) p2))
2573 (coerce 2 p2))))
2574 (funcall (compile nil form) 'integer))))
2575
2576 ;;; misc.657
2577 (assert (eql 2
2578 (let ((form '(lambda (p2)
2579 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2580 (type (member integer values) p2))
2581 (coerce 2 p2))))
2582 (funcall (compile nil form) 'integer))))
2583
2584 (with-test (:name :string-aref-type)
2585 (assert (eq 'character
2586 (funcall (compile nil
2587 '(lambda (s)
2588 (sb-c::compiler-derived-type (aref (the string s) 0))))
2589 "foo"))))
2590
2591 (with-test (:name :base-string-aref-type)
2592 (assert (eq #+sb-unicode 'base-char
2593 #-sb-unicode 'character
2594 (funcall (compile nil
2595 '(lambda (s)
2596 (sb-c::compiler-derived-type (aref (the base-string s) 0))))
2597 (coerce "foo" 'base-string)))))
2598
2599 (with-test (:name :dolist-constant-type-derivation)
2600 (assert (equal '(integer 1 3)
2601 (funcall (compile nil
2602 '(lambda (x)
2603 (dolist (y '(1 2 3))
2604 (when x
2605 (return (sb-c::compiler-derived-type y))))))
2606 t))))
2607
2608 (with-test (:name :dolist-simple-list-type-derivation)
2609 (assert (equal '(integer 1 3)
2610 (funcall (compile nil
2611 '(lambda (x)
2612 (dolist (y (list 1 2 3))
2613 (when x
2614 (return (sb-c::compiler-derived-type y))))))
2615 t))))
2616
2617 (with-test (:name :dolist-dotted-constant-list-type-derivation)
2618 (let* ((warned nil)
2619 (fun (handler-bind ((style-warning (lambda (c) (push c warned))))
2620 (compile nil
2621 '(lambda (x)
2622 (dolist (y '(1 2 3 . 4) :foo)
2623 (when x
2624 (return (sb-c::compiler-derived-type y)))))))))
2625 (assert (equal '(integer 1 3) (funcall fun t)))
2626 (assert (= 1 (length warned)))
2627 (multiple-value-bind (res err) (ignore-errors (funcall fun nil))
2628 (assert (not res))
2629 (assert (typep err 'type-error)))))
2630
2631 (with-test (:name :constant-list-destructuring)
2632 (handler-bind ((sb-ext:compiler-note #'error))
2633 (progn
2634 (assert (= 10
2635 (funcall
2636 (compile nil
2637 '(lambda ()
2638 (destructuring-bind (a (b c) d) '(1 (2 3) 4)
2639 (+ a b c d)))))))
2640 (assert (eq :feh
2641 (funcall
2642 (compile nil
2643 '(lambda (x)
2644 (or x
2645 (destructuring-bind (a (b c) d) '(1 "foo" 4)
2646 (+ a b c d)))))
2647 :feh))))))
2648
2649 ;;; Functions with non-required arguments used to end up with
2650 ;;; (&OPTIONAL-DISPATCH ...) as their names.
2651 (with-test (:name :hairy-function-name)
2652 (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line))))
2653 (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line))))
2654
2655 ;;; PROGV + RESTRICT-COMPILER-POLICY
2656 (with-test (:name :progv-and-restrict-compiler-policy)
2657 (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
2658 (restrict-compiler-policy 'debug 3)
2659 (let ((fun (compile nil '(lambda (x)
2660 (let ((i x))
2661 (declare (special i))
2662 (list i
2663 (progv '(i) (list (+ i 1))
2664 i)
2665 i))))))
2666 (assert (equal '(1 2 1) (funcall fun 1))))))
2667
2668 ;;; It used to be possible to confuse the compiler into
2669 ;;; IR2-converting such a call to CONS
2670 (with-test (:name :late-bound-primitive)
2671 (compile nil `(lambda ()
2672 (funcall 'cons 1))))
tcr's SBCL random hacking branch.