?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Make INFO's compiler-macro more forgiving.
[sbcl.git] / tests / compiler.pure.lisp
blob5c90b584c0a1e8303efe4abb94ee1be5f081fd37
1 ;;;; various compiler tests without side effects
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;;
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
13
14 (cl:in-package :cl-user)
15
16 (load "compiler-test-util.lisp")
17
18 ;; The tests in this file assume that EVAL will use the compiler
19 (when (eq sb-ext:*evaluator-mode* :interpret)
20 (invoke-restart 'run-tests::skip-file))
21
22 ;;; Exercise a compiler bug (by crashing the compiler).
23 ;;;
24 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
25 ;;; (2000-09-06 on cmucl-imp).
26 ;;;
27 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
28 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
29 (funcall (compile nil
30 '(lambda ()
31 (labels ((fun1 ()
32 (fun2))
33 (fun2 ()
34 (when nil
35 (tagbody
36 tag
37 (fun2)
38 (go tag)))
39 (when nil
40 (tagbody
41 tag
42 (fun1)
43 (go tag)))))
44
45 (fun1)
46 nil))))
47
48 ;;; Exercise a compiler bug (by crashing the compiler).
49 ;;;
50 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
51 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
52 (funcall (compile nil
53 '(lambda (x)
54 (or (integerp x)
55 (block used-by-some-y?
56 (flet ((frob (stk)
57 (dolist (y stk)
58 (unless (rejected? y)
59 (return-from used-by-some-y? t)))))
60 (declare (inline frob))
61 (frob (rstk x))
62 (frob (mrstk x)))
63 nil))))
64 13)
65
66 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
67 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
68 ;;; Alexey Dejneka 2002-01-27
69 (assert (= 1 ; (used to give 0 under bug 112)
70 (let ((x 0))
71 (declare (special x))
72 (let ((x 1))
73 (let ((y x))
74 (declare (special x)) y)))))
75 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
76 (let ((x 0))
77 (declare (special x))
78 (let ((x 1))
79 (let ((y x) (x 5))
80 (declare (special x)) y)))))
81
82 ;;; another LET-related bug fixed by Alexey Dejneka at the same
83 ;;; time as bug 112
84 (multiple-value-bind (fun warnings-p failure-p)
85 ;; should complain about duplicate variable names in LET binding
86 (compile nil
87 '(lambda ()
88 (let (x
89 (x 1))
90 (list x))))
91 (declare (ignore warnings-p))
92 (assert (functionp fun))
93 (assert failure-p))
94
95 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
96 ;;; Lichteblau 2002-05-21)
97 (progn
98 (multiple-value-bind (fun warnings-p failure-p)
99 (compile nil
100 ;; Compiling this code should cause a STYLE-WARNING
101 ;; about *X* looking like a special variable but not
102 ;; being one.
103 '(lambda (n)
104 (let ((*x* n))
105 (funcall (symbol-function 'x-getter))
106 (print *x*))))
107 (assert (functionp fun))
108 (assert warnings-p)
109 (assert (not failure-p)))
110 (multiple-value-bind (fun warnings-p failure-p)
111 (compile nil
112 ;; Compiling this code should not cause a warning
113 ;; (because the DECLARE turns *X* into a special
114 ;; variable as its name suggests it should be).
115 '(lambda (n)
116 (let ((*x* n))
117 (declare (special *x*))
118 (funcall (symbol-function 'x-getter))
119 (print *x*))))
120 (assert (functionp fun))
121 (assert (not warnings-p))
122 (assert (not failure-p))))
123
124 ;;; a bug in 0.7.4.11
125 (dolist (i '(a b 1 2 "x" "y"))
126 ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
127 ;; TYPEP here but got confused and died, doing
128 ;; (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
129 ;; *BACKEND-TYPE-PREDICATES*
130 ;; :TEST #'TYPE=)
131 ;; and blowing up because TYPE= tried to call PLUSP on the
132 ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
133 (when (typep i '(and integer (satisfies oddp)))
134 (print i)))
135 (dotimes (i 14)
136 (when (typep i '(and integer (satisfies oddp)))
137 (print i)))
138
139 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
140 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
141 ;;; interactively-compiled functions was broken by sleaziness and
142 ;;; confusion in the assault on 0.7.0, so this expression used to
143 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
144 (eval '(function-lambda-expression #'(lambda (x) x)))
145
146 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
147 ;;; variable is not optional.
148 (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12))))))
149
150 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
151 ;;; a while; fixed by CSR 2002-07-18
152 (with-test (:name :undefined-function-error)
153 (multiple-value-bind (value error)
154 (ignore-errors (some-undefined-function))
155 (assert (null value))
156 (assert (eq (cell-error-name error) 'some-undefined-function))))
157
158 (with-test (:name :unbound-variable-error)
159 (let ((foo (gensym)))
160 (assert (eq (handler-case (symbol-value foo)
161 (unbound-variable (c) (cell-error-name c)))
162 foo))
163 ;; on x86-64 the code for a literal symbol uses a slightly different path,
164 ;; so test that too
165 (assert (eq (handler-case xyzzy*%state
166 (unbound-variable (c) (cell-error-name c)))
167 'xyzzy*%state))
168 ;; And finally, also on x86-64, there was massive confusion about
169 ;; variable names that looked like names of thread slots.
170 (assert (eq (handler-case *state*
171 (unbound-variable (c) (cell-error-name c)))
172 '*state*))))
173
174 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
175 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
176 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
177 (assert (ignore-errors (eval '(lambda (foo) 12))))
178 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
179 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
180 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
181 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
182 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
183 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
184 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
185 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
186 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
187 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
188
189 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
190 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
191 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
192 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
193 17))
194
195 ;;; bug 181: bad type specifier dropped compiler into debugger
196 (assert (list (compile nil '(lambda (x)
197 (declare (type (0) x))
198 x))))
199
200 (let ((f (compile nil '(lambda (x)
201 (make-array 1 :element-type '(0))))))
202 (assert (null (ignore-errors (funcall f)))))
203
204 ;;; the following functions must not be flushable
205 (dolist (form '((make-sequence 'fixnum 10)
206 (concatenate 'fixnum nil)
207 (map 'fixnum #'identity nil)
208 (merge 'fixnum nil nil #'<)))
209 (assert (not (eval `(locally (declare (optimize (safety 0)))
210 (ignore-errors (progn ,form t)))))))
211
212 (dolist (form '((values-list (car (list '(1 . 2))))
213 (fboundp '(set bet))
214 (atan #c(1 1) (car (list #c(2 2))))
215 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
216 (nthcdr (car (list 5)) '(1 2 . 3))))
217 (assert (not (eval `(locally (declare (optimize (safety 3)))
218 (ignore-errors (progn ,form t)))))))
219
220 ;;; feature: we shall complain if functions which are only useful for
221 ;;; their result are called and their result ignored.
222 (loop for (form expected-des) in
223 '(((progn (nreverse (list 1 2)) t)
224 "The return value of NREVERSE should not be discarded.")
225 ((progn (nreconc (list 1 2) (list 3 4)) t)
226 "The return value of NRECONC should not be discarded.")
227 ((locally
228 (declare (inline sort))
229 (sort (list 1 2) #'<) t)
230 ;; FIXME: it would be nice if this warned on non-inlined sort
231 ;; but the current simple boolean function attribute
232 ;; can't express the condition that would be required.
233 "The return value of STABLE-SORT-LIST should not be discarded.")
234 ((progn (sort (vector 1 2) #'<) t)
235 ;; Apparently, SBCL (but not CL) guarantees in-place vector
236 ;; sort, so no warning.
237 nil)
238 ((progn (delete 2 (list 1 2)) t)
239 "The return value of DELETE should not be discarded.")
240 ((progn (delete-if #'evenp (list 1 2)) t)
241 ("The return value of DELETE-IF should not be discarded."))
242 ((progn (delete-if #'evenp (vector 1 2)) t)
243 ("The return value of DELETE-IF should not be discarded."))
244 ((progn (delete-if-not #'evenp (list 1 2)) t)
245 "The return value of DELETE-IF-NOT should not be discarded.")
246 ((progn (delete-duplicates (list 1 2)) t)
247 "The return value of DELETE-DUPLICATES should not be discarded.")
248 ((progn (merge 'list (list 1 3) (list 2 4) #'<) t)
249 "The return value of MERGE should not be discarded.")
250 ((progn (nreconc (list 1 3) (list 2 4)) t)
251 "The return value of NRECONC should not be discarded.")
252 ((progn (nunion (list 1 3) (list 2 4)) t)
253 "The return value of NUNION should not be discarded.")
254 ((progn (nintersection (list 1 3) (list 2 4)) t)
255 "The return value of NINTERSECTION should not be discarded.")
256 ((progn (nset-difference (list 1 3) (list 2 4)) t)
257 "The return value of NSET-DIFFERENCE should not be discarded.")
258 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t)
259 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
260 for expected = (if (listp expected-des)
261 expected-des
262 (list expected-des))
263 do
264 (multiple-value-bind (fun warnings-p failure-p)
265 (handler-bind ((style-warning (lambda (c)
266 (if expected
267 (let ((expect-one (pop expected)))
268 (assert (search expect-one
269 (with-standard-io-syntax
270 (let ((*print-right-margin* nil))
271 (princ-to-string c))))
272 ()
273 "~S should have warned ~S, but instead warned: ~A"
274 form expect-one c))
275 (error "~S shouldn't give a(nother) warning, but did: ~A" form c)))))
276 (compile nil `(lambda () ,form)))
277 (declare (ignore warnings-p))
278 (assert (functionp fun))
279 (assert (null expected)
280 ()
281 "~S should have warned ~S, but didn't."
282 form expected)
283 (assert (not failure-p))))
284
285 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
286 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
287 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x)))))
288
289 ;;; bug 129: insufficient syntax checking in MACROLET
290 (multiple-value-bind (result error)
291 (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3))))
292 (assert (null result))
293 (assert (typep error 'error)))
294
295 ;;; bug 124: environment of MACROLET-introduced macro expanders
296 (assert (equal
297 (macrolet ((mext (x) `(cons :mext ,x)))
298 (macrolet ((mint (y) `'(:mint ,(mext y))))
299 (list (mext '(1 2))
300 (mint (1 2)))))
301 '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
302
303 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
304 ;;; symbol is declared to be SPECIAL
305 (multiple-value-bind (result error)
306 (ignore-errors (funcall (lambda ()
307 (symbol-macrolet ((s '(1 2)))
308 (declare (special s))
309 s))))
310 (assert (null result))
311 (assert (typep error 'program-error)))
312
313 ;;; ECASE should treat a bare T as a literal key
314 (multiple-value-bind (result error)
315 (ignore-errors (ecase 1 (t 0)))
316 (assert (null result))
317 (assert (typep error 'type-error)))
318
319 (multiple-value-bind (result error)
320 (ignore-errors (ecase 1 (t 0) (1 2)))
321 (assert (eql result 2))
322 (assert (null error)))
323
324 ;;; FTYPE should accept any functional type specifier
325 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
326
327 ;;; FUNCALL of special operators and macros should signal an
328 ;;; UNDEFINED-FUNCTION error
329 (multiple-value-bind (result error)
330 (ignore-errors (funcall 'quote 1))
331 (assert (null result))
332 (assert (typep error 'undefined-function))
333 (assert (eq (cell-error-name error) 'quote)))
334 (multiple-value-bind (result error)
335 (ignore-errors (funcall 'and 1))
336 (assert (null result))
337 (assert (typep error 'undefined-function))
338 (assert (eq (cell-error-name error) 'and)))
339
340 ;;; PSETQ should behave when given complex symbol-macro arguments
341 (multiple-value-bind (sequence index)
342 (symbol-macrolet ((x (aref a (incf i)))
343 (y (aref a (incf i))))
344 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
345 (i 0))
346 (psetq x (aref a (incf i))
347 y (aref a (incf i)))
348 (values a i)))
349 (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
350 (assert (= index 4)))
351
352 (multiple-value-bind (result error)
353 (ignore-errors
354 (let ((x (list 1 2)))
355 (psetq (car x) 3)
356 x))
357 (assert (null result))
358 (assert (typep error 'program-error)))
359
360 ;;; COPY-SEQ should work on known-complex vectors:
361 (assert (equalp #(1)
362 (let ((v (make-array 0 :fill-pointer 0)))
363 (vector-push-extend 1 v)
364 (copy-seq v))))
365
366 ;;; to support INLINE functions inside MACROLET, it is necessary for
367 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
368 ;;; certain circumstances, one of which is when compile is called from
369 ;;; top-level.
370 (assert (equal
371 (function-lambda-expression
372 (compile nil '(lambda (x) (block nil (print x)))))
373 '(lambda (x) (block nil (print x)))))
374
375 ;;; bug 62: too cautious type inference in a loop
376 (assert (nth-value
377 2
378 (compile nil
379 '(lambda (a)
380 (declare (optimize speed (safety 0)))
381 (typecase a
382 (array (loop (print (car a)))))))))
383
384 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
385 ;;; failure
386 (compile nil
387 '(lambda (key tree collect-path-p)
388 (let ((lessp (key-lessp tree))
389 (equalp (key-equalp tree)))
390 (declare (type (function (t t) boolean) lessp equalp))
391 (let ((path '(nil)))
392 (loop for node = (root-node tree)
393 then (if (funcall lessp key (node-key node))
394 (left-child node)
395 (right-child node))
396 when (null node)
397 do (return (values nil nil nil))
398 do (when collect-path-p
399 (push node path))
400 (when (funcall equalp key (node-key node))
401 (return (values node path t))))))))
402
403 ;;; CONSTANTLY should return a side-effect-free function (bug caught
404 ;;; by Paul Dietz' test suite)
405 (let ((i 0))
406 (let ((fn (constantly (progn (incf i) 1))))
407 (assert (= i 1))
408 (assert (= (funcall fn) 1))
409 (assert (= i 1))
410 (assert (= (funcall fn) 1))
411 (assert (= i 1))))
412
413 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
414 (loop for (fun warns-p) in
415 '(((lambda (&optional *x*) *x*) t)
416 ((lambda (&optional *x* &rest y) (values *x* y)) t)
417 ((lambda (&optional *print-length*) (values *print-length*)) nil)
418 ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil)
419 ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
420 ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
421 for real-warns-p = (nth-value 1 (compile nil fun))
422 do (assert (eq warns-p real-warns-p)))
423
424 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
425 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
426 '(1 2))
427 '((2) 1)))
428
429 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
430 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
431 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
432
433 (assert-error (multiple-value-bind (a b c)
434 (eval '(truncate 3 4))
435 (declare (integer c))
436 (list a b c))
437 type-error)
438
439 (assert (equal (multiple-value-list (the (values &rest integer)
440 (eval '(values 3))))
441 '(3)))
442
443 ;;; Bug relating to confused representation for the wild function
444 ;;; type:
445 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
446
447 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
448 ;;; test suite)
449 (assert (eql (macrolet ((foo () 1))
450 (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
451 x))
452 (%f)))
453 1))
454
455 ;;; MACROLET should check for duplicated names
456 (dolist (ll '((x (z x))
457 (x y &optional z x w)
458 (x y &optional z z)
459 (x &rest x)
460 (x &rest (y x))
461 (x &optional (y nil x))
462 (x &optional (y nil y))
463 (x &key x)
464 (x &key (y nil x))
465 (&key (y nil z) (z nil w))
466 (&whole x &optional x)
467 (&environment x &whole x)))
468 (assert (nth-value 2
469 (handler-case
470 (compile nil
471 `(lambda ()
472 (macrolet ((foo ,ll nil)
473 (bar (&environment env)
474 `',(macro-function 'foo env)))
475 (bar))))
476 (error (c)
477 (values nil t t))))))
478
479 (assert (typep (eval `(the arithmetic-error
480 ',(make-condition 'arithmetic-error)))
481 'arithmetic-error))
482
483 (assert (not (nth-value
484 2 (compile nil '(lambda ()
485 (make-array nil :initial-element 11))))))
486
487 (assert-error (funcall (eval #'open) "assertoid.lisp"
488 :external-format '#:nonsense))
489 (assert-error (funcall (eval #'load) "assertoid.lisp"
490 :external-format '#:nonsense))
491
492 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
493
494 (let ((f (compile nil
495 '(lambda (v)
496 (declare (optimize (safety 3)))
497 (list (the fixnum (the (real 0) (eval v))))))))
498 (assert-error (funcall f 0.1) type-error)
499 (assert-error (funcall f -1) type-error))
500
501 ;;; the implicit block does not enclose lambda list
502 (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#))))
503 #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#))))))
504 (define-compiler-macro #3=#:foo (&optional (x (return-from #3#))))
505 (deftype #4=#:foo (&optional (x (return-from #4#))))
506 (define-setf-expander #5=#:foo (&optional (x (return-from #5#))))
507 (defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
508 (dolist (form forms)
509 (assert (nth-value 2 (compile nil `(lambda () ,form))))))
510
511 (assert (nth-value 2 (compile nil
512 '(lambda ()
513 (svref (make-array '(8 9) :adjustable t) 1)))))
514
515 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
516 (assert-error (funcall (compile nil '(lambda (x y z) (char= x y z)))
517 #\a #\b nil)
518 type-error)
519 (assert-error (funcall (compile nil
520 '(lambda (x y z)
521 (declare (optimize (speed 3) (safety 3)))
522 (char/= x y z)))
523 nil #\a #\a)
524 type-error)
525
526 ;;; Compiler lost return type of MAPCAR and friends
527 (dolist (fun '(mapcar mapc maplist mapl))
528 (assert (nth-value 2 (compile nil
529 `(lambda (x)
530 (1+ (,fun #'print x)))))))
531
532 (assert (nth-value 2 (compile nil
533 '(lambda ()
534 (declare (notinline mapcar))
535 (1+ (mapcar #'print '(1 2 3)))))))
536
537 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
538 ;;; index was effectless
539 (let ((f (compile nil '(lambda (a v)
540 (declare (type simple-bit-vector a) (type bit v))
541 (declare (optimize (speed 3) (safety 0)))
542 (setf (aref a 0) v)
543 a))))
544 (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
545 (assert (equal y #*00))
546 (funcall f y 1)
547 (assert (equal y #*10))))
548
549 ;;; use of declared array types
550 (handler-bind ((sb-ext:compiler-note #'error))
551 (compile nil '(lambda (x)
552 (declare (type (simple-array (simple-string 3) (5)) x)
553 (optimize speed))
554 (aref (aref x 0) 0))))
555
556 (handler-bind ((sb-ext:compiler-note #'error))
557 (compile nil '(lambda (x)
558 (declare (type (simple-array (simple-array bit (10)) (10)) x)
559 (optimize speed))
560 (1+ (aref (aref x 0) 0)))))
561
562 ;;; compiler failure
563 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
564 (assert (funcall f 1d0)))
565
566 (compile nil '(lambda (x)
567 (declare (double-float x))
568 (let ((y (* x pi)))
569 (atan y y))))
570
571 ;;; bogus optimization of BIT-NOT
572 (multiple-value-bind (result x)
573 (eval '(let ((x (eval #*1001)))
574 (declare (optimize (speed 2) (space 3))
575 (type (bit-vector) x))
576 (values (bit-not x nil) x)))
577 (assert (equal x #*1001))
578 (assert (equal result #*0110)))
579
580 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
581 (handler-bind ((sb-ext:compiler-note #'error))
582 (assert (equalp (funcall
583 (compile
584 nil
585 '(lambda ()
586 (let ((x (make-sequence 'vector 10 :initial-element 'a)))
587 (setf (aref x 4) 'b)
588 x))))
589 #(a a a a b a a a a a))))
590
591 ;;; this is not a check for a bug, but rather a test of compiler
592 ;;; quality
593 (dolist (type '((integer 0 *) ; upper bound
594 (real (-1) *)
595 float ; class
596 (real * (-10)) ; lower bound
597 ))
598 (assert (nth-value
599 1 (compile nil
600 `(lambda (n)
601 (declare (optimize (speed 3) (compilation-speed 0)))
602 (loop for i from 1 to (the (integer -17 10) n) by 2
603 collect (when (> (random 10) 5)
604 (the ,type (- i 11)))))))))
605
606 ;;; bug 278b
607 ;;;
608 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
609 ;;; compiler has an optimized VOP for +; so this code should cause an
610 ;;; efficiency note.
611 (assert (eq (block nil
612 (handler-case
613 (compile nil '(lambda (i)
614 (declare (optimize speed))
615 (declare (type integer i))
616 (+ i 2)))
617 (sb-ext:compiler-note (c) (return :good))))
618 :good))
619
620 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
621 ;;; symbol macros
622 (assert (not (nth-value 1 (compile nil '(lambda (u v)
623 (symbol-macrolet ((x u)
624 (y v))
625 (declare (ignore x)
626 (ignorable y))
627 (list u v)))))))
628
629 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
630 (loop for (x type) in
631 '((14 integer)
632 (14 rational)
633 (-14/3 (rational -8 11))
634 (3s0 short-float)
635 (4f0 single-float)
636 (5d0 double-float)
637 (6l0 long-float)
638 (14 real)
639 (13/2 real)
640 (2s0 real)
641 (2d0 real)
642 (#c(-3 4) (complex fixnum))
643 (#c(-3 4) (complex rational))
644 (#c(-3/7 4) (complex rational))
645 (#c(2s0 3s0) (complex short-float))
646 (#c(2f0 3f0) (complex single-float))
647 (#c(2d0 3d0) (complex double-float))
648 (#c(2l0 3l0) (complex long-float))
649 (#c(2d0 3s0) (complex float))
650 (#c(2 3f0) (complex real))
651 (#c(2 3d0) (complex real))
652 (#c(-3/7 4) (complex real))
653 (#c(-3/7 4) complex)
654 (#c(2 3l0) complex))
655 do (dolist (zero '(0 0s0 0f0 0d0 0l0))
656 (dolist (real-zero (list zero (- zero)))
657 (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
658 (fun (compile nil src))
659 (result (1+ (funcall (eval #'*) x real-zero))))
660 (assert (eql result (funcall fun x)))))))
661
662 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
663 ;;; wasn't recognized as a good type specifier.
664 (let ((fun (lambda (x y)
665 (declare (type (integer -1 0) x y) (optimize speed))
666 (logxor x y))))
667 (assert (= (funcall fun 0 0) 0))
668 (assert (= (funcall fun 0 -1) -1))
669 (assert (= (funcall fun -1 -1) 0)))
670
671 ;;; from PFD's torture test, triggering a bug in our effective address
672 ;;; treatment.
673 (compile
674 nil
675 `(lambda (a b)
676 (declare (type (integer 8 22337) b))
677 (logandc2
678 (logandc2
679 (* (logandc1 (max -29303 b) 4) b)
680 (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
681 (logeqv (max a 0) b))))
682
683 ;;; Alpha floating point modes weren't being reset after an exception,
684 ;;; leading to an exception on the second compile, below.
685 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
686 (handler-case (/ 1.0 0.0)
687 ;; provoke an exception
688 (arithmetic-error ()))
689 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
690
691 ;;; bug reported by Paul Dietz: component last block does not have
692 ;;; start ctran
693 (compile nil
694 '(lambda ()
695 (declare (notinline + logand)
696 (optimize (speed 0)))
697 (LOGAND
698 (BLOCK B5
699 (FLET ((%F1 ()
700 (RETURN-FROM B5 -220)))
701 (LET ((V7 (%F1)))
702 (+ 359749 35728422))))
703 -24076)))
704
705 (with-test (:name :ansi-misc.293a)
706 (assert (= (funcall
707 (compile
708 nil
709 '(lambda (a b c)
710 (declare (optimize (speed 2) (space 3) (safety 1)
711 (debug 2) (compilation-speed 2)))
712 (block b6
713 (multiple-value-prog1
714 0 b 0
715 (catch 'ct7
716 (return-from b6
717 (catch 'ct2
718 (complex (cl::handler-bind nil -254932942) 0))))))))
719 1 2 3)
720 -254932942)))
721
722 (with-test (:name :ansi-misc.293d)
723 (assert (= (funcall
724 (compile
725 nil
726 '(lambda ()
727 (declare (optimize (debug 3) (safety 0) (space 2)
728 (compilation-speed 2) (speed 2)))
729 (block b4
730 (multiple-value-prog1
731 0
732 (catch 'ct8
733 (return-from b4 (catch 'ct2 (progn (tagbody) 0)))))))))
734 0)))
735
736 (with-test (:name :ansi-misc.618)
737 (assert (= (funcall
738 (compile
739 nil
740 '(lambda (c)
741 (declare (optimize (space 0) (compilation-speed 2) (debug 0)
742 (speed 3) (safety 0)))
743 (block b1
744 (ignore-errors
745 (multiple-value-prog1 0
746 (apply (constantly 0)
747 c
748 (catch 'ct2 (return-from b1 0))
749 nil))))))
750 -4951)
751 0)))
752
753 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
754 (assert (= (funcall (compile nil `(lambda (b)
755 (declare (optimize (speed 3))
756 (type (integer 2 152044363) b))
757 (rem b (min -16 0))))
758 108251912)
759 8))
760
761 (assert (= (funcall (compile nil `(lambda (c)
762 (declare (optimize (speed 3))
763 (type (integer 23062188 149459656) c))
764 (mod c (min -2 0))))
765 95019853)
766 -1))
767
768 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
769 (compile nil
770 '(LAMBDA (A B C)
771 (BLOCK B6
772 (LOGEQV (REM C -6758)
773 (REM B (MAX 44 (RETURN-FROM B6 A)))))))
774
775 (compile nil '(lambda ()
776 (block nil
777 (flet ((foo (x y) (if (> x y) (print x) (print y))))
778 (foo 1 2)
779 (bar)
780 (foo (return 14) 2)))))
781
782 ;;; bug in Alpha backend: not enough sanity checking of arguments to
783 ;;; instructions
784 (assert (= (funcall (compile nil
785 '(lambda (x)
786 (declare (fixnum x))
787 (ash x -257)))
788 1024)
789 0))
790
791 ;;; bug found by WHN and pfdietz: compiler failure while referencing
792 ;;; an entry point inside a deleted lambda
793 (compile nil '(lambda ()
794 (let (r3533)
795 (flet ((bbfn ()
796 (setf r3533
797 (progn
798 (flet ((truly (fn bbd)
799 (let (r3534)
800 (let ((p3537 nil))
801 (unwind-protect
802 (multiple-value-prog1
803 (progn
804 (setf r3534
805 (progn
806 (bubf bbd t)
807 (flet ((c-3536 ()
808 (funcall fn)))
809 (cdec #'c-3536
810 (vector bbd))))))
811 (setf p3537 t))
812 (unless p3537
813 (error "j"))))
814 r3534))
815 (c (pd) (pdc pd)))
816 (let ((a (smock a))
817 (b (smock b))
818 (b (smock c)))))))))
819 (wum #'bbfn "hc3" (list)))
820 r3533)))
821 (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
822
823 ;;; the strength reduction of constant multiplication used (before
824 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
825 ;;; certain circumstances, the compiler would derive that a perfectly
826 ;;; reasonable multiplication never returned, causing chaos. Fixed by
827 ;;; explicitly doing modular arithmetic, and relying on the backends
828 ;;; being smart.
829 (assert (= (funcall
830 (compile nil
831 '(lambda (x)
832 (declare (type (integer 178956970 178956970) x)
833 (optimize speed))
834 (* x 24)))
835 178956970)
836 4294967280))
837
838 ;;; bug in modular arithmetic and type specifiers
839 (assert (= (funcall (compile nil '(lambda (x) (logand x x 0)))
840 -1)
841 0))
842
843 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
844 ;;; produced wrong result for shift >=32 on X86
845 (assert (= 0 (funcall
846 (compile nil
847 '(lambda (a)
848 (declare (type (integer 4303063 101130078) a))
849 (mask-field (byte 18 2) (ash a 77))))
850 57132532)))
851 ;;; rewrite the test case to get the unsigned-byte 32/64
852 ;;; implementation even after implementing some modular arithmetic
853 ;;; with signed-byte 30:
854 (assert (= 0 (funcall
855 (compile nil
856 '(lambda (a)
857 (declare (type (integer 4303063 101130078) a))
858 (mask-field (byte 30 2) (ash a 77))))
859 57132532)))
860 (assert (= 0 (funcall
861 (compile nil
862 '(lambda (a)
863 (declare (type (integer 4303063 101130078) a))
864 (mask-field (byte 64 2) (ash a 77))))
865 57132532)))
866 ;;; and a similar test case for the signed masking extension (not the
867 ;;; final interface, so change the call when necessary):
868 (assert (= 0 (funcall
869 (compile nil
870 '(lambda (a)
871 (declare (type (integer 4303063 101130078) a))
872 (sb-c::mask-signed-field 30 (ash a 77))))
873 57132532)))
874 (assert (= 0 (funcall
875 (compile nil
876 '(lambda (a)
877 (declare (type (integer 4303063 101130078) a))
878 (sb-c::mask-signed-field 61 (ash a 77))))
879 57132532)))
880
881 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
882 ;;; type check regeneration
883 (assert (eql (funcall
884 (compile nil '(lambda (a c)
885 (declare (type (integer 185501219873 303014665162) a))
886 (declare (type (integer -160758 255724) c))
887 (declare (optimize (speed 3)))
888 (let ((v8
889 (- -554046873252388011622614991634432
890 (ignore-errors c)
891 (unwind-protect 2791485))))
892 (max (ignore-errors a)
893 (let ((v6 (- v8 (restart-case 980))))
894 (min v8 v6))))))
895 259448422916 173715)
896 259448422916))
897 (assert (eql (funcall
898 (compile nil '(lambda (a b)
899 (min -80
900 (abs
901 (ignore-errors
902 (+
903 (logeqv b
904 (block b6
905 (return-from b6
906 (load-time-value -6876935))))
907 (if (logbitp 1 a) b (setq a -1522022182249))))))))
908 -1802767029877 -12374959963)
909 -80))
910
911 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
912 (assert (eql (funcall (compile nil '(lambda (c)
913 (declare (type (integer -3924 1001809828) c))
914 (declare (optimize (speed 3)))
915 (min 47 (if (ldb-test (byte 2 14) c)
916 -570344431
917 (ignore-errors -732893970)))))
918 705347625)
919 -570344431))
920 (assert (eql (funcall
921 (compile nil '(lambda (b)
922 (declare (type (integer -1598566306 2941) b))
923 (declare (optimize (speed 3)))
924 (max -148949 (ignore-errors b))))
925 0)
926 0))
927 (assert (eql (funcall
928 (compile nil '(lambda (b c)
929 (declare (type (integer -4 -3) c))
930 (block b7
931 (flet ((%f1 (f1-1 f1-2 f1-3)
932 (if (logbitp 0 (return-from b7
933 (- -815145138 f1-2)))
934 (return-from b7 -2611670)
935 99345)))
936 (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
937 b)))))
938 2950453607 -4)
939 -815145134))
940 (assert (eql (funcall
941 (compile nil
942 '(lambda (b c)
943 (declare (type (integer -29742055786 23602182204) b))
944 (declare (type (integer -7409 -2075) c))
945 (declare (optimize (speed 3)))
946 (floor
947 (labels ((%f2 ()
948 (block b6
949 (ignore-errors (return-from b6
950 (if (= c 8) b 82674))))))
951 (%f2)))))
952 22992834060 -5833)
953 82674))
954 (assert (equal (multiple-value-list
955 (funcall
956 (compile nil '(lambda (a)
957 (declare (type (integer -944 -472) a))
958 (declare (optimize (speed 3)))
959 (round
960 (block b3
961 (return-from b3
962 (if (= 55957 a) -117 (ignore-errors
963 (return-from b3 a))))))))
964 -589))
965 '(-589 0)))
966
967 ;;; MISC.158
968 (assert (zerop (funcall
969 (compile nil
970 '(lambda (a b c)
971 (declare (type (integer 79828 2625480458) a))
972 (declare (type (integer -4363283 8171697) b))
973 (declare (type (integer -301 0) c))
974 (if (equal 6392154 (logxor a b))
975 1706
976 (let ((v5 (abs c)))
977 (logand v5
978 (logior (logandc2 c v5)
979 (common-lisp:handler-case
980 (ash a (min 36 22477)))))))))
981 100000 0 0)))
982
983 ;;; MISC.152, 153: deleted code and iteration var type inference
984 (assert (eql (funcall
985 (compile nil
986 '(lambda (a)
987 (block b5
988 (let ((v1 (let ((v8 (unwind-protect 9365)))
989 8862008)))
990 (*
991 (return-from b5
992 (labels ((%f11 (f11-1) f11-1))
993 (%f11 87246015)))
994 (return-from b5
995 (setq v1
996 (labels ((%f6 (f6-1 f6-2 f6-3) v1))
997 (dpb (unwind-protect a)
998 (byte 18 13)
999 (labels ((%f4 () 27322826))
1000 (%f6 -2 -108626545 (%f4))))))))))))
1001 -6)
1002 87246015))
1003
1004 (assert (eql (funcall
1005 (compile nil
1006 '(lambda (a)
1007 (if (logbitp 3
1008 (case -2
1009 ((-96879 -1035 -57680 -106404 -94516 -125088)
1010 (unwind-protect 90309179))
1011 ((-20811 -86901 -9368 -98520 -71594)
1012 (let ((v9 (unwind-protect 136707)))
1013 (block b3
1014 (setq v9
1015 (let ((v4 (return-from b3 v9)))
1016 (- (ignore-errors (return-from b3 v4))))))))
1017 (t -50)))
1018 -20343
1019 a)))
1020 0)
1021 -20343))
1022
1023 ;;; MISC.165
1024 (assert (eql (funcall
1025 (compile
1026 nil
1027 '(lambda (a b c)
1028 (block b3
1029 (flet ((%f15
1030 (f15-1 f15-2 f15-3
1031 &optional
1032 (f15-4
1033 (flet ((%f17
1034 (f17-1 f17-2 f17-3
1035 &optional (f17-4 185155520) (f17-5 c)
1036 (f17-6 37))
1037 c))
1038 (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
1039 (f15-5 a) (f15-6 -40))
1040 (return-from b3 -16)))
1041 (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
1042 0 0 -5)
1043 -16))
1044
1045 ;;; MISC.172
1046 (assert (eql (funcall
1047 (compile
1048 nil
1049 '(lambda (a b c)
1050 (declare (notinline list apply))
1051 (declare (optimize (safety 3)))
1052 (declare (optimize (speed 0)))
1053 (declare (optimize (debug 0)))
1054 (labels ((%f12 (f12-1 f12-2)
1055 (labels ((%f2 (f2-1 f2-2)
1056 (flet ((%f6 ()
1057 (flet ((%f18
1058 (f18-1
1059 &optional (f18-2 a)
1060 (f18-3 -207465075)
1061 (f18-4 a))
1062 (return-from %f12 b)))
1063 (%f18 -3489553
1064 -7
1065 (%f18 (%f18 150 -64 f12-1)
1066 (%f18 (%f18 -8531)
1067 11410)
1068 b)
1069 56362666))))
1070 (labels ((%f7
1071 (f7-1 f7-2
1072 &optional (f7-3 (%f6)))
1073 7767415))
1074 f12-1))))
1075 (%f2 b -36582571))))
1076 (apply #'%f12 (list 774 -4413)))))
1077 0 1 2)
1078 774))
1079
1080 ;;; MISC.173
1081 (assert (eql (funcall
1082 (compile
1083 nil
1084 '(lambda (a b c)
1085 (declare (notinline values))
1086 (declare (optimize (safety 3)))
1087 (declare (optimize (speed 0)))
1088 (declare (optimize (debug 0)))
1089 (flet ((%f11
1090 (f11-1 f11-2
1091 &optional (f11-3 c) (f11-4 7947114)
1092 (f11-5
1093 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
1094 8134))
1095 (multiple-value-call #'%f3
1096 (values (%f3 -30637724 b) c)))))
1097 (setq c 555910)))
1098 (if (and nil (%f11 a a))
1099 (if (%f11 a 421778 4030 1)
1100 (labels ((%f7
1101 (f7-1 f7-2
1102 &optional
1103 (f7-3
1104 (%f11 -79192293
1105 (%f11 c a c -4 214720)
1106 b
1107 b
1108 (%f11 b 985)))
1109 (f7-4 a))
1110 b))
1111 (%f11 c b -25644))
1112 54)
1113 -32326608))))
1114 1 2 3)
1115 -32326608))
1116
1117 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1118 ;;; local lambda argument
1119 (assert
1120 (equal
1121 (funcall
1122 (compile nil
1123 '(lambda (a b c)
1124 (declare (type (integer 804561 7640697) a))
1125 (declare (type (integer -1 10441401) b))
1126 (declare (type (integer -864634669 55189745) c))
1127 (declare (ignorable a b c))
1128 (declare (optimize (speed 3)))
1129 (declare (optimize (safety 1)))
1130 (declare (optimize (debug 1)))
1131 (flet ((%f11
1132 (f11-1 f11-2)
1133 (labels ((%f4 () (round 200048 (max 99 c))))
1134 (logand
1135 f11-1
1136 (labels ((%f3 (f3-1) -162967612))
1137 (%f3 (let* ((v8 (%f4)))
1138 (setq f11-1 (%f4)))))))))
1139 (%f11 -120429363 (%f11 62362 b)))))
1140 6714367 9645616 -637681868)
1141 -264223548))
1142
1143 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1144 ;;; transform
1145 (assert (equal (multiple-value-list
1146 (funcall
1147 (compile nil '(lambda ()
1148 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1149 (ceiling
1150 (ceiling
1151 (flet ((%f16 () 0)) (%f16))))))))
1152 '(0 0)))
1153
1154 ;;; MISC.184
1155 (assert (zerop
1156 (funcall
1157 (compile
1158 nil
1159 '(lambda (a b c)
1160 (declare (type (integer 867934833 3293695878) a))
1161 (declare (type (integer -82111 1776797) b))
1162 (declare (type (integer -1432413516 54121964) c))
1163 (declare (optimize (speed 3)))
1164 (declare (optimize (safety 1)))
1165 (declare (optimize (debug 1)))
1166 (if nil
1167 (flet ((%f15 (f15-1 &optional (f15-2 c))
1168 (labels ((%f1 (f1-1 f1-2) 0))
1169 (%f1 a 0))))
1170 (flet ((%f4 ()
1171 (multiple-value-call #'%f15
1172 (values (%f15 c 0) (%f15 0)))))
1173 (if nil (%f4)
1174 (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
1175 f8-3))
1176 0))))
1177 0)))
1178 3040851270 1664281 -1340106197)))
1179
1180 ;;; MISC.249
1181 (assert (zerop
1182 (funcall
1183 (compile
1184 nil
1185 '(lambda (a b)
1186 (declare (notinline <=))
1187 (declare (optimize (speed 2) (space 3) (safety 0)
1188 (debug 1) (compilation-speed 3)))
1189 (if (if (<= 0) nil nil)
1190 (labels ((%f9 (f9-1 f9-2 f9-3)
1191 (ignore-errors 0)))
1192 (dotimes (iv4 5 a) (%f9 0 0 b)))
1193 0)))
1194 1 2)))
1195
1196 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1197 (assert
1198 (= (funcall
1199 (compile
1200 nil
1201 '(lambda (a)
1202 (declare (type (integer 177547470 226026978) a))
1203 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1204 (compilation-speed 1)))
1205 (logand a (* a 438810))))
1206 215067723)
1207 13739018))
1208
1209 \f
1210 ;;;; Bugs in stack analysis
1211 ;;; bug 299 (reported by PFD)
1212 (assert
1213 (equal (funcall
1214 (compile
1215 nil
1216 '(lambda ()
1217 (declare (optimize (debug 1)))
1218 (multiple-value-call #'list
1219 (if (eval t) (eval '(values :a :b :c)) nil)
1220 (catch 'foo (throw 'foo (values :x :y)))))))
1221 '(:a :b :c :x :y)))
1222 ;;; bug 298 (= MISC.183)
1223 (assert (zerop (funcall
1224 (compile
1225 nil
1226 '(lambda (a b c)
1227 (declare (type (integer -368154 377964) a))
1228 (declare (type (integer 5044 14959) b))
1229 (declare (type (integer -184859815 -8066427) c))
1230 (declare (ignorable a b c))
1231 (declare (optimize (speed 3)))
1232 (declare (optimize (safety 1)))
1233 (declare (optimize (debug 1)))
1234 (block b7
1235 (flet ((%f3 (f3-1 f3-2 f3-3) 0))
1236 (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
1237 0 6000 -9000000)))
1238 (assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
1239 '(1 2)))
1240 (let ((f (compile
1241 nil
1242 '(lambda (x)
1243 (block foo
1244 (multiple-value-call #'list
1245 :a
1246 (block bar
1247 (return-from foo
1248 (multiple-value-call #'list
1249 :b
1250 (block quux
1251 (return-from bar
1252 (catch 'baz
1253 (if x
1254 (return-from quux 1)
1255 (throw 'baz 2))))))))))))))
1256 (assert (equal (funcall f t) '(:b 1)))
1257 (assert (equal (funcall f nil) '(:a 2))))
1258
1259 ;;; MISC.185
1260 (assert (equal
1261 (funcall
1262 (compile
1263 nil
1264 '(lambda (a b c)
1265 (declare (type (integer 5 155656586618) a))
1266 (declare (type (integer -15492 196529) b))
1267 (declare (type (integer 7 10) c))
1268 (declare (optimize (speed 3)))
1269 (declare (optimize (safety 1)))
1270 (declare (optimize (debug 1)))
1271 (flet ((%f3
1272 (f3-1 f3-2 f3-3
1273 &optional (f3-4 a) (f3-5 0)
1274 (f3-6
1275 (labels ((%f10 (f10-1 f10-2 f10-3)
1276 0))
1277 (apply #'%f10
1278 0
1279 a
1280 (- (if (equal a b) b (%f10 c a 0))
1281 (catch 'ct2 (throw 'ct2 c)))
1282 nil))))
1283 0))
1284 (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
1285 0))
1286 ;;; MISC.186
1287 (assert (eq
1288 (eval
1289 '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
1290 (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
1291 (vars '(b c))
1292 (fn1 `(lambda ,vars
1293 (declare (type (integer -2 19) b)
1294 (type (integer -1520 218978) c)
1295 (optimize (speed 3) (safety 1) (debug 1)))
1296 ,form))
1297 (fn2 `(lambda ,vars
1298 (declare (notinline logeqv apply)
1299 (optimize (safety 3) (speed 0) (debug 0)))
1300 ,form))
1301 (cf1 (compile nil fn1))
1302 (cf2 (compile nil fn2))
1303 (result1 (multiple-value-list (funcall cf1 2 18886)))
1304 (result2 (multiple-value-list (funcall cf2 2 18886))))
1305 (if (equal result1 result2)
1306 :good
1307 (values result1 result2))))
1308 :good))
1309
1310 ;;; MISC.290
1311 (assert (zerop
1312 (funcall
1313 (compile
1314 nil
1315 '(lambda ()
1316 (declare
1317 (optimize (speed 3) (space 3) (safety 1)
1318 (debug 2) (compilation-speed 0)))
1319 (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
1320
1321 ;;; MISC.292
1322 (assert (zerop (funcall
1323 (compile
1324 nil
1325 '(lambda (a b)
1326 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1327 (compilation-speed 2)))
1328 (apply (constantly 0)
1329 a
1330 0
1331 (catch 'ct6
1332 (apply (constantly 0)
1333 0
1334 0
1335 (let* ((v1
1336 (let ((*s7* 0))
1337 b)))
1338 0)
1339 0
1340 nil))
1341 0
1342 nil)))
1343 1 2)))
1344
1345 ;;; misc.295
1346 (assert (eql
1347 (funcall
1348 (compile
1349 nil
1350 '(lambda ()
1351 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1352 (multiple-value-prog1
1353 (the integer (catch 'ct8 (catch 'ct7 15867134)))
1354 (catch 'ct1 (throw 'ct1 0))))))
1355 15867134))
1356
1357 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1358 ;;; could transform known-values LVAR to UVL
1359 (assert (zerop (funcall
1360 (compile
1361 nil
1362 '(lambda (a b c)
1363 (declare (notinline boole values denominator list))
1364 (declare
1365 (optimize (speed 2)
1366 (space 0)
1367 (safety 1)
1368 (debug 0)
1369 (compilation-speed 2)))
1370 (catch 'ct6
1371 (progv
1372 '(*s8*)
1373 (list 0)
1374 (let ((v9 (ignore-errors (throw 'ct6 0))))
1375 (denominator
1376 (progv nil nil (values (boole boole-and 0 v9)))))))))
1377 1 2 3)))
1378
1379 ;;; non-continuous dead UVL blocks
1380 (defun non-continuous-stack-test (x)
1381 (multiple-value-call #'list
1382 (eval '(values 11 12))
1383 (eval '(values 13 14))
1384 (block ext
1385 (return-from non-continuous-stack-test
1386 (multiple-value-call #'list
1387 (eval '(values :b1 :b2))
1388 (eval '(values :b3 :b4))
1389 (block int
1390 (return-from ext
1391 (multiple-value-call (eval #'values)
1392 (eval '(values 1 2))
1393 (eval '(values 3 4))
1394 (block ext
1395 (return-from int
1396 (multiple-value-call (eval #'values)
1397 (eval '(values :a1 :a2))
1398 (eval '(values :a3 :a4))
1399 (block int
1400 (return-from ext
1401 (multiple-value-call (eval #'values)
1402 (eval '(values 5 6))
1403 (eval '(values 7 8))
1404 (if x
1405 :ext
1406 (return-from int :int))))))))))))))))
1407 (assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
1408 (assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
1409
1410 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1411 ;;; if ENTRY.
1412 (assert (equal (multiple-value-list (funcall
1413 (compile
1414 nil
1415 '(lambda (b g h)
1416 (declare (optimize (speed 3) (space 3) (safety 2)
1417 (debug 2) (compilation-speed 3)))
1418 (catch 'ct5
1419 (unwind-protect
1420 (labels ((%f15 (f15-1 f15-2 f15-3)
1421 (rational (throw 'ct5 0))))
1422 (%f15 0
1423 (apply #'%f15
1424 0
1425 h
1426 (progn
1427 (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
1428 0)
1429 nil)
1430 0))
1431 (common-lisp:handler-case 0)))))
1432 1 2 3))
1433 '(0)))
1434
1435 \f
1436 ;;; MISC.275
1437 (assert
1438 (zerop
1439 (funcall
1440 (compile
1441 nil
1442 '(lambda (b)
1443 (declare (notinline funcall min coerce))
1444 (declare
1445 (optimize (speed 1)
1446 (space 2)
1447 (safety 2)
1448 (debug 1)
1449 (compilation-speed 1)))
1450 (flet ((%f12 (f12-1)
1451 (coerce
1452 (min
1453 (if f12-1 (multiple-value-prog1
1454 b (return-from %f12 0))
1455 0))
1456 'integer)))
1457 (funcall #'%f12 0))))
1458 -33)))
1459
1460 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1461 ;;; potential problem: optimizers and type derivers for MAX and MIN
1462 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1463 (dolist (f '(min max))
1464 (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
1465 for complex-arg = `(if x ,@complex-arg-args)
1466 do
1467 (loop for args in `((1 ,complex-arg)
1468 (,complex-arg 1))
1469 for form = `(,f ,@args)
1470 for f1 = (compile nil `(lambda (x) ,form))
1471 and f2 = (compile nil `(lambda (x) (declare (notinline min max))
1472 ,form))
1473 do
1474 (dolist (x '(nil t))
1475 (assert (eql (funcall f1 x) (funcall f2 x)))))))
1476
1477 ;;;
1478 (handler-case (compile nil '(lambda (x)
1479 (declare (optimize (speed 3) (safety 0)))
1480 (the double-float (sqrt (the double-float x)))))
1481 (sb-ext:compiler-note (c)
1482 ;; Ignore the note for the float -> pointer conversion of the
1483 ;; return value.
1484 (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
1485 "<return value>")
1486 (error "Compiler does not trust result type assertion."))))
1487
1488 (let ((f (compile nil '(lambda (x)
1489 (declare (optimize speed (safety 0)))
1490 (block nil
1491 (the double-float
1492 (multiple-value-prog1
1493 (sqrt (the double-float x))
1494 (when (< x 0)
1495 (return :minus)))))))))
1496 (assert (eql (funcall f -1d0) :minus))
1497 (assert (eql (funcall f 4d0) 2d0)))
1498
1499 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1500 (handler-case
1501 (compile nil '(lambda (a i)
1502 (locally
1503 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1504 (inhibit-warnings 0)))
1505 (declare (type (alien (* (unsigned 8))) a)
1506 (type (unsigned-byte 32) i))
1507 (deref a i))))
1508 (compiler-note (c)
1509 (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c)))
1510 (error "The code is not optimized."))))
1511
1512 (handler-case
1513 (compile nil '(lambda (x)
1514 (declare (type (integer -100 100) x))
1515 (declare (optimize speed))
1516 (declare (notinline identity))
1517 (1+ (identity x))))
1518 (compiler-note () (error "IDENTITY derive-type not applied.")))
1519
1520 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
1521
1522 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1523 ;;; LVAR; here the first write may be cleared before the second is
1524 ;;; made.
1525 (assert
1526 (zerop
1527 (funcall
1528 (compile
1529 nil
1530 '(lambda ()
1531 (declare (notinline complex))
1532 (declare (optimize (speed 1) (space 0) (safety 1)
1533 (debug 3) (compilation-speed 3)))
1534 (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
1535 (complex (%f) 0)))))))
1536
1537 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1538 (assert (zerop (funcall
1539 (compile
1540 nil
1541 '(lambda (a c)
1542 (declare (type (integer -1294746569 1640996137) a))
1543 (declare (type (integer -807801310 3) c))
1544 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1545 (catch 'ct7
1546 (if
1547 (logbitp 0
1548 (if (/= 0 a)
1549 c
1550 (ignore-errors
1551 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
1552 0 0))))
1553 391833530 -32785211)))
1554
1555 ;;; efficiency notes for ordinary code
1556 (macrolet ((frob (arglist &body body)
1557 `(progn
1558 (handler-case
1559 (compile nil '(lambda ,arglist ,@body))
1560 (sb-ext:compiler-note (e)
1561 (error "bad compiler note for ~S:~% ~A" ',body e)))
1562 (let ((gotit nil))
1563 (handler-bind ((compiler-note
1564 (lambda (c)
1565 (setq gotit t) (muffle-warning c))))
1566 (compile nil '(lambda ,arglist (declare (optimize speed))
1567 ,@body)))
1568 (unless gotit
1569 (error "missing compiler note for ~S" ',body))))))
1570 (frob (x) (funcall x))
1571 (frob (x y) (find x y))
1572 (frob (x y) (find-if x y))
1573 (frob (x y) (find-if-not x y))
1574 (frob (x y) (position x y))
1575 (frob (x y) (position-if x y))
1576 (frob (x y) (position-if-not x y))
1577 (frob (x) (aref x 0)))
1578
1579 (macrolet ((frob (style-warn-p form)
1580 (if style-warn-p
1581 `(let ((gotit nil))
1582 (handler-bind ((style-warning
1583 (lambda (c)
1584 (setq gotit t) (muffle-warning c))))
1585 (eval ',form))
1586 (unless gotit
1587 (error "missing style-warning for ~S" ',form)))
1588 `(handler-case
1589 (eval ',form)
1590 (style-warning (e)
1591 (error "bad style-warning for ~S: ~A" ',form e))))))
1592 (frob t (lambda (x &optional y &key z) (list x y z)))
1593 (frob nil (lambda (x &optional y z) (list x y z)))
1594 (frob nil (lambda (x &key y z) (list x y z)))
1595 (frob t (defgeneric #:foo (x &optional y &key z)))
1596 (frob nil (defgeneric #:foo (x &optional y z)))
1597 (frob nil (defgeneric #:foo (x &key y z)))
1598 (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
1599
1600 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1601 ;;; note, because the system failed to derive the fact that the return
1602 ;;; from LOGXOR was small and negative, though the bottom one worked.
1603 (handler-bind ((sb-ext:compiler-note #'error))
1604 (compile nil '(lambda ()
1605 (declare (optimize speed (safety 0)))
1606 (lambda (x y)
1607 (declare (type (integer 3 6) x)
1608 (type (integer -6 -3) y))
1609 (+ (logxor x y) most-positive-fixnum)))))
1610 (handler-bind ((sb-ext:compiler-note #'error))
1611 (compile nil '(lambda ()
1612 (declare (optimize speed (safety 0)))
1613 (lambda (x y)
1614 (declare (type (integer 3 6) y)
1615 (type (integer -6 -3) x))
1616 (+ (logxor x y) most-positive-fixnum)))))
1617
1618 ;;; check that modular ash gives the right answer, to protect against
1619 ;;; possible misunderstandings about the hardware shift instruction.
1620 (assert (zerop (funcall
1621 (compile nil '(lambda (x y)
1622 (declare (optimize speed)
1623 (type (unsigned-byte 32) x y))
1624 (logand #xffffffff (ash x y))))
1625 1 257)))
1626
1627 ;;; code instrumenting problems
1628 (compile nil
1629 '(lambda ()
1630 (declare (optimize (debug 3)))
1631 (list (the integer (if nil 14 t)))))
1632
1633 (compile nil
1634 '(LAMBDA (A B C D)
1635 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
1636 (DECLARE
1637 (OPTIMIZE (SPEED 1)
1638 (SPACE 1)
1639 (SAFETY 1)
1640 (DEBUG 3)
1641 (COMPILATION-SPEED 0)))
1642 (MASK-FIELD (BYTE 7 26)
1643 (PROGN
1644 (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
1645 B))))
1646
1647 (compile nil
1648 '(lambda (buffer i end)
1649 (declare (optimize (debug 3)))
1650 (loop (when (not (eql 0 end)) (return)))
1651 (let ((s (make-string end)))
1652 (setf (schar s i) (schar buffer i))
1653 s)))
1654
1655 ;;; check that constant string prefix and suffix don't cause the
1656 ;;; compiler to emit code deletion notes.
1657 (handler-bind ((sb-ext:code-deletion-note #'error))
1658 (compile nil '(lambda (s x)
1659 (pprint-logical-block (s x :prefix "(")
1660 (print x s))))
1661 (compile nil '(lambda (s x)
1662 (pprint-logical-block (s x :per-line-prefix ";")
1663 (print x s))))
1664 (compile nil '(lambda (s x)
1665 (pprint-logical-block (s x :suffix ">")
1666 (print x s)))))
1667
1668 ;;; MISC.427: loop analysis requires complete DFO structure
1669 (assert (eql 17 (funcall
1670 (compile
1671 nil
1672 '(lambda (a)
1673 (declare (notinline list reduce logior))
1674 (declare (optimize (safety 2) (compilation-speed 1)
1675 (speed 3) (space 2) (debug 2)))
1676 (logior
1677 (let* ((v5 (reduce #'+ (list 0 a))))
1678 (declare (dynamic-extent v5))
1679 v5))))
1680 17)))
1681
1682 ;;; MISC.434
1683 (assert (zerop (funcall
1684 (compile
1685 nil
1686 '(lambda (a b)
1687 (declare (type (integer -8431780939320 1571817471932) a))
1688 (declare (type (integer -4085 0) b))
1689 (declare (ignorable a b))
1690 (declare
1691 (optimize (space 2)
1692 (compilation-speed 0)
1693 #+sbcl (sb-c:insert-step-conditions 0)
1694 (debug 2)
1695 (safety 0)
1696 (speed 3)))
1697 (let ((*s5* 0))
1698 (dotimes (iv1 2 0)
1699 (let ((*s5*
1700 (elt '(1954479092053)
1701 (min 0
1702 (max 0
1703 (if (< iv1 iv1)
1704 (lognand iv1 (ash iv1 (min 53 iv1)))
1705 iv1))))))
1706 0)))))
1707 -7639589303599 -1368)))
1708
1709 (compile
1710 nil
1711 '(lambda (a b)
1712 (declare (type (integer) a))
1713 (declare (type (integer) b))
1714 (declare (ignorable a b))
1715 (declare (optimize (space 2) (compilation-speed 0)
1716 (debug 0) (safety 0) (speed 3)))
1717 (dotimes (iv1 2 0)
1718 (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
1719 (print (if (< iv1 iv1)
1720 (logand (ash iv1 iv1) 1)
1721 iv1)))))
1722
1723 ;;; MISC.435: lambda var substitution in a deleted code.
1724 (assert (zerop (funcall
1725 (compile
1726 nil
1727 '(lambda (a b c d)
1728 (declare (notinline aref logandc2 gcd make-array))
1729 (declare
1730 (optimize (space 0) (safety 0) (compilation-speed 3)
1731 (speed 3) (debug 1)))
1732 (progn
1733 (tagbody
1734 (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
1735 (declare (dynamic-extent v2))
1736 (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
1737 tag2)
1738 0)))
1739 3021871717588 -866608 -2 -17194)))
1740
1741 ;;; MISC.436, 438: lost reoptimization
1742 (assert (zerop (funcall
1743 (compile
1744 nil
1745 '(lambda (a b)
1746 (declare (type (integer -2917822 2783884) a))
1747 (declare (type (integer 0 160159) b))
1748 (declare (ignorable a b))
1749 (declare
1750 (optimize (compilation-speed 1)
1751 (speed 3)
1752 (safety 3)
1753 (space 0)
1754 ; #+sbcl (sb-c:insert-step-conditions 0)
1755 (debug 0)))
1756 (if
1757 (oddp
1758 (loop for
1759 lv1
1760 below
1761 2
1762 count
1763 (logbitp 0
1764 (1-
1765 (ash b
1766 (min 8
1767 (count 0
1768 '(-10197561 486 430631291
1769 9674068))))))))
1770 b
1771 0)))
1772 1265797 110757)))
1773
1774 (assert (zerop (funcall
1775 (compile
1776 nil
1777 ' (lambda (a)
1778 (declare (type (integer 0 1696) a))
1779 ; (declare (ignorable a))
1780 (declare (optimize (space 2) (debug 0) (safety 1)
1781 (compilation-speed 0) (speed 1)))
1782 (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
1783 805)))
1784
1785 ;;; bug #302
1786 (assert (compile
1787 nil
1788 '(lambda (s ei x y)
1789 (declare (type (simple-array function (2)) s) (type ei ei))
1790 (funcall (aref s ei) x y))))
1791
1792 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1793 ;;; a DEFINED-FUN.
1794 (assert (eql 102 (funcall
1795 (compile
1796 nil
1797 '(lambda ()
1798 (declare (optimize (speed 3) (space 0) (safety 2)
1799 (debug 2) (compilation-speed 0)))
1800 (catch 'ct2
1801 (elt '(102)
1802 (flet ((%f12 () (rem 0 -43)))
1803 (multiple-value-call #'%f12 (values))))))))))
1804
1805 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1806 (assert (zerop (funcall
1807 (compile
1808 nil
1809 '(lambda (a b c d e)
1810 (declare (notinline values complex eql))
1811 (declare
1812 (optimize (compilation-speed 3)
1813 (speed 3)
1814 (debug 1)
1815 (safety 1)
1816 (space 0)))
1817 (flet ((%f10
1818 (f10-1 f10-2 f10-3
1819 &optional (f10-4 (ignore-errors 0)) (f10-5 0)
1820 &key &allow-other-keys)
1821 (if (or (eql 0 0) t) 0 (if f10-1 0 0))))
1822 (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0))))
1823 80043 74953652306 33658947 -63099937105 -27842393)))
1824
1825 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1826 ;;; resulting from SETF of LET.
1827 (with-test (:name :bug-351)
1828 (dolist (fun (list (compile nil '(lambda (x) (let :bogus-let :oops)))
1829 (compile nil '(lambda (x) (let* :bogus-let* :oops)))
1830 (compile nil '(lambda (x) (push x (let ((y 0)) y))))))
1831 (assert (functionp fun))
1832 (multiple-value-bind (res err) (ignore-errors (funcall fun t))
1833 (princ err) (terpri)
1834 (assert (not res))
1835 (assert (typep err 'program-error)))))
1836
1837 (let ((fun (compile nil '(lambda (x) (random (if x 10 20))))))
1838 (dotimes (i 100 (error "bad RANDOM distribution"))
1839 (when (> (funcall fun nil) 9)
1840 (return t)))
1841 (dotimes (i 100)
1842 (when (> (funcall fun t) 9)
1843 (error "bad RANDOM event"))))
1844
1845 ;;; 0.8.17.28-sma.1 lost derived type information.
1846 (with-test (:name :0.8.17.28-sma.1 :fails-on :sparc)
1847 (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
1848 (compile nil
1849 '(lambda (x y v)
1850 (declare (optimize (speed 3) (safety 0)))
1851 (declare (type (integer 0 80) x)
1852 (type (integer 0 11) y)
1853 (type (simple-array (unsigned-byte 32) (*)) v))
1854 (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
1855 nil))))
1856
1857 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1858 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1859 (let ((f (compile nil '(lambda ()
1860 (declare (optimize (debug 3)))
1861 (with-simple-restart (blah "blah") (error "blah"))))))
1862 (handler-bind ((error (lambda (c) (invoke-restart 'blah))))
1863 (assert (equal (multiple-value-list (funcall f)) '(nil t)))))
1864
1865 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1866 ;;; constant index and value.
1867 (loop for n-bits = 1 then (* n-bits 2)
1868 for type = `(unsigned-byte ,n-bits)
1869 and v-max = (1- (ash 1 n-bits))
1870 while (<= n-bits sb-vm:n-word-bits)
1871 do
1872 (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
1873 (array1 (make-array n :element-type type))
1874 (array2 (make-array n :element-type type)))
1875 (dotimes (i n)
1876 (dolist (v (list 0 v-max))
1877 (let ((f (compile nil `(lambda (a)
1878 (declare (type (simple-array ,type (,n)) a))
1879 (setf (aref a ,i) ,v)))))
1880 (fill array1 (- v-max v))
1881 (fill array2 (- v-max v))
1882 (funcall f array1)
1883 (setf (aref array2 i) v)
1884 (assert (every #'= array1 array2)))))))
1885
1886 (let ((fn (compile nil '(lambda (x)
1887 (declare (type bit x))
1888 (declare (optimize speed))
1889 (let ((b (make-array 64 :element-type 'bit
1890 :initial-element 0)))
1891 (count x b))))))
1892 (assert (= (funcall fn 0) 64))
1893 (assert (= (funcall fn 1) 0)))
1894
1895 (let ((fn (compile nil '(lambda (x y)
1896 (declare (type simple-bit-vector x y))
1897 (declare (optimize speed))
1898 (equal x y)))))
1899 (assert (funcall
1900 fn
1901 (make-array 64 :element-type 'bit :initial-element 0)
1902 (make-array 64 :element-type 'bit :initial-element 0)))
1903 (assert (not
1904 (funcall
1905 fn
1906 (make-array 64 :element-type 'bit :initial-element 0)
1907 (let ((b (make-array 64 :element-type 'bit :initial-element 0)))
1908 (setf (sbit b 63) 1)
1909 b)))))
1910
1911 ;;; MISC.535: compiler failure
1912 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
1913 (assert (not (funcall
1914 (compile
1915 nil
1916 `(lambda (p1 p2)
1917 (declare (optimize speed (safety 1))
1918 (type (eql ,c0) p1)
1919 (type number p2))
1920 (eql (the (complex double-float) p1) p2)))
1921 c0 #c(12 612/979)))))
1922
1923 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1924 ;;; simple-bit-vector functions.
1925 (handler-bind ((sb-ext:compiler-note #'error))
1926 (compile nil '(lambda (x)
1927 (declare (type simple-bit-vector x))
1928 (count 1 x))))
1929 (handler-bind ((sb-ext:compiler-note #'error))
1930 (compile nil '(lambda (x y)
1931 (declare (type simple-bit-vector x y))
1932 (equal x y))))
1933
1934 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1935 ;;; code transformations.
1936 (assert (eql (funcall
1937 (compile
1938 nil
1939 '(lambda (p1 p2)
1940 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1941 (type atom p1)
1942 (type symbol p2))
1943 (or p1 (the (eql t) p2))))
1944 nil t)
1945 t))
1946
1947 ;;; MISC.548: type check weakening converts required type into
1948 ;;; optional
1949 (assert (eql t
1950 (funcall
1951 (compile
1952 nil
1953 '(lambda (p1)
1954 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1955 (atom (the (member f assoc-if write-line t w) p1))))
1956 t)))
1957
1958 ;;; Free special bindings only apply to the body of the binding form, not
1959 ;;; the initialization forms.
1960 (assert (eq :good
1961 (funcall (compile 'nil
1962 '(lambda ()
1963 (let ((x :bad))
1964 (declare (special x))
1965 (let ((x :good))
1966 ((lambda (&optional (y x))
1967 (declare (special x)) y)))))))))
1968
1969 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1970 ;;; a rational was zero, but didn't do the substitution, leading to a
1971 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1972 ;;; machine's ASH instruction's immediate field) that the compiler
1973 ;;; thought was legitimate.
1974 (with-test (:name :overlarge-immediate-in-ash-vop)
1975 (compile 'nil
1976 '(LAMBDA (B)
1977 (DECLARE (TYPE (INTEGER -2 14) B))
1978 (DECLARE (IGNORABLE B))
1979 (ASH (IMAGPART B) 57))))
1980
1981 ;;; bug reported by Eduardo Mu\~noz
1982 (multiple-value-bind (fun warnings failure)
1983 (compile nil '(lambda (struct first)
1984 (declare (optimize speed))
1985 (let* ((nodes (nodes struct))
1986 (bars (bars struct))
1987 (length (length nodes))
1988 (new (make-array length :fill-pointer 0)))
1989 (vector-push first new)
1990 (loop with i fixnum = 0
1991 for newl fixnum = (length new)
1992 while (< newl length) do
1993 (let ((oldl (length new)))
1994 (loop for j fixnum from i below newl do
1995 (dolist (n (node-neighbours (aref new j) bars))
1996 (unless (find n new)
1997 (vector-push n new))))
1998 (setq i oldl)))
1999 new)))
2000 (declare (ignore fun warnings failure))
2001 (assert (not failure)))
2002
2003 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
2004 ;;; sbcl-devel)
2005 (compile nil '(lambda (x y a b c)
2006 (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
2007
2008 ;;; Type inference from CHECK-TYPE
2009 (let ((count0 0) (count1 0))
2010 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0))))
2011 (compile nil '(lambda (x)
2012 (declare (optimize (speed 3)))
2013 (1+ x))))
2014 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
2015 (assert (> count0 1))
2016 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
2017 (compile nil '(lambda (x)
2018 (declare (optimize (speed 3)))
2019 (check-type x fixnum)
2020 (1+ x))))
2021 ;; Only the posssible word -> bignum conversion note
2022 (assert (= count1 1)))
2023
2024 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
2025 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
2026 (with-test (:name :sap-ref-float)
2027 (compile nil '(lambda (sap)
2028 (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0)))
2029 (1+ x))))
2030 (compile nil '(lambda (sap)
2031 (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
2032 (1+ x)))))
2033
2034 ;;; bug #399
2035 (with-test (:name :string-union-types)
2036 (compile nil '(lambda (x)
2037 (declare (type (or (simple-array character (6))
2038 (simple-array character (5))) x))
2039 (aref x 0))))
2040
2041 ;;; MISC.623: missing functions for constant-folding
2042 (assert (eql 0
2043 (funcall
2044 (compile
2045 nil
2046 '(lambda ()
2047 (declare (optimize (space 2) (speed 0) (debug 2)
2048 (compilation-speed 3) (safety 0)))
2049 (loop for lv3 below 1
2050 count (minusp
2051 (loop for lv2 below 2
2052 count (logbitp 0
2053 (bit #*1001101001001
2054 (min 12 (max 0 lv3))))))))))))
2055
2056 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
2057 (assert (eql 0
2058 (funcall
2059 (compile
2060 nil
2061 '(lambda (a)
2062 (declare (type (integer 21 28) a))
2063 (declare (optimize (compilation-speed 1) (safety 2)
2064 (speed 0) (debug 0) (space 1)))
2065 (let* ((v7 (flet ((%f3 (f3-1 f3-2)
2066 (loop for lv2 below 1
2067 count
2068 (logbitp 29
2069 (sbit #*10101111
2070 (min 7 (max 0 (eval '0))))))))
2071 (%f3 0 a))))
2072 0)))
2073 22)))
2074
2075 ;;; MISC.626: bandaged AVER was still wrong
2076 (assert (eql -829253
2077 (funcall
2078 (compile
2079 nil
2080 '(lambda (a)
2081 (declare (type (integer -902970 2) a))
2082 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2083 (speed 0) (safety 3)))
2084 (prog2 (if (logbitp 30 a) 0 (block b3 0)) a)))
2085 -829253)))
2086
2087 ;; MISC.628: constant-folding %LOGBITP was buggy
2088 (assert (eql t
2089 (funcall
2090 (compile
2091 nil
2092 '(lambda ()
2093 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2094 (speed 0) (debug 1)))
2095 (not (not (logbitp 0 (floor 2147483651 (min -23 0))))))))))
2096
2097 ;; mistyping found by random-tester
2098 (assert (zerop
2099 (funcall
2100 (compile
2101 nil
2102 '(lambda ()
2103 (declare (optimize (speed 1) (debug 0)
2104 (space 2) (safety 0) (compilation-speed 0)))
2105 (unwind-protect 0
2106 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
2107
2108 ;; aggressive constant folding (bug #400)
2109 (assert
2110 (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
2111
2112 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
2113 (assert
2114 (handler-case
2115 (compile nil '(lambda (x y)
2116 (when (eql x (length y))
2117 (locally
2118 (declare (optimize (speed 3)))
2119 (1+ x)))))
2120 (compiler-note () (error "The code is not optimized.")))))
2121
2122 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
2123 (assert
2124 (handler-case
2125 (compile nil '(lambda (x y)
2126 (when (eql (length y) x)
2127 (locally
2128 (declare (optimize (speed 3)))
2129 (1+ x)))))
2130 (compiler-note () (error "The code is not optimized.")))))
2131
2132 (with-test (:name (:compiler :constraint-propagation :float-bounds-1))
2133 (handler-case
2134 (compile nil '(lambda (x)
2135 (declare (type (single-float * (3.0)) x))
2136 (when (<= x 2.0)
2137 (when (<= 2.0 x)
2138 x))))
2139 (compiler-note () (error "Deleted reachable code."))))
2140
2141 (defun assert-code-deletion-note (lambda &optional (howmany 1))
2142 (let ((n 0))
2143 (handler-bind ((code-deletion-note
2144 (lambda (c)
2145 (incf n)
2146 ;; even though notes are not warnings,
2147 ;; compiler-notify provides the MUFFLE-WARNING restart.
2148 (muffle-warning c))))
2149 (compile nil lambda)
2150 (assert (eql n howmany)))))
2151
2152 (with-test (:name (:compiler :constraint-propagation :float-bounds-2))
2153 (assert-code-deletion-note
2154 '(lambda (x)
2155 (declare (type single-float x))
2156 (when (< 1.0 x)
2157 (when (<= x 1.0)
2158 (error "This is unreachable."))))))
2159
2160 (with-test (:name (:compiler :constraint-propagation :float-bounds-3
2161 :LP-894498))
2162 (assert-code-deletion-note
2163 '(lambda (x)
2164 (declare (type (single-float 0.0) x))
2165 (when (> x 0.0)
2166 (when (zerop x)
2167 (error "This is unreachable."))))))
2168
2169 (with-test (:name (:compiler :constraint-propagation :float-bounds-4
2170 :LP-894498))
2171 (assert-code-deletion-note
2172 '(lambda (x y)
2173 (declare (type (single-float 0.0) x)
2174 (type (single-float (0.0)) y))
2175 (when (> x y)
2176 (when (zerop x)
2177 (error "This is unreachable."))))))
2178
2179 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
2180 (assert-code-deletion-note
2181 '(lambda (x y)
2182 (when (typep y 'fixnum)
2183 (when (eql x y)
2184 (unless (typep x 'fixnum)
2185 (error "This is unreachable"))
2186 (setq y nil))))))
2187
2188 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
2189 (assert-code-deletion-note
2190 '(lambda (x y)
2191 (when (typep y 'fixnum)
2192 (when (eql y x)
2193 (unless (typep x 'fixnum)
2194 (error "This is unreachable"))
2195 (setq y nil))))))
2196
2197 ;; Reported by John Wiseman, sbcl-devel
2198 ;; Subject: [Sbcl-devel] float type derivation bug?
2199 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2200 (with-test (:name (:type-derivation :float-bounds))
2201 (compile nil '(lambda (bits)
2202 (let* ((s (if (= (ash bits -31) 0) 1 -1))
2203 (e (logand (ash bits -23) #xff))
2204 (m (if (= e 0)
2205 (ash (logand bits #x7fffff) 1)
2206 (logior (logand bits #x7fffff) #x800000))))
2207 (float (* s m (expt 2 (- e 150))))))))
2208
2209 ;; Reported by James Knight
2210 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2211 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2212 (with-test (:name :logbitp-vop)
2213 (compile nil
2214 '(lambda (days shift)
2215 (declare (type fixnum shift days))
2216 (let* ((result 0)
2217 (canonicalized-shift (+ shift 1))
2218 (first-wrapping-day (- 1 canonicalized-shift)))
2219 (declare (type fixnum result))
2220 (dotimes (source-day 7)
2221 (declare (type (integer 0 6) source-day))
2222 (when (logbitp source-day days)
2223 (setf result
2224 (logior result
2225 (the fixnum
2226 (if (< source-day first-wrapping-day)
2227 (+ source-day canonicalized-shift)
2228 (- (+ source-day
2229 canonicalized-shift) 7)))))))
2230 result))))
2231
2232 ;;; MISC.637: incorrect delaying of conversion of optional entries
2233 ;;; with hairy constant defaults
2234 (let ((f '(lambda ()
2235 (labels ((%f11 (f11-2 &key key1)
2236 (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0)))
2237 :bad1))
2238 (%f8 (%f8 0)))
2239 :bad2))
2240 :good))))
2241 (assert (eq (funcall (compile nil f)) :good)))
2242
2243 ;;; MISC.555: new reference to an already-optimized local function
2244 (let* ((l '(lambda (p1)
2245 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1))
2246 (keywordp p1)))
2247 (f (compile nil l)))
2248 (assert (funcall f :good))
2249 (assert (nth-value 1 (ignore-errors (funcall f 42)))))
2250
2251 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2252 (let* ((state (make-random-state))
2253 (*random-state* (make-random-state state))
2254 (a (random most-positive-fixnum)))
2255 (setf *random-state* state)
2256 (compile nil `(lambda (x a)
2257 (declare (single-float x)
2258 (type (simple-array double-float) a))
2259 (+ (loop for i across a
2260 summing i)
2261 x)))
2262 (assert (= a (random most-positive-fixnum))))
2263
2264 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2265 (let ((form '(lambda ()
2266 (declare (optimize (speed 1) (space 0) (debug 2)
2267 (compilation-speed 0) (safety 1)))
2268 (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #())))
2269 0))
2270 (apply #'%f3 0 nil)))))
2271 (assert (zerop (funcall (compile nil form)))))
2272
2273 ;;; 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
2274 (compile nil '(lambda ()
2275 (let ((x (make-array '(1) :element-type '(signed-byte 32))))
2276 (setf (aref x 0) 1))))
2277
2278 ;;; step instrumentation confusing the compiler, reported by Faré
2279 (handler-bind ((warning #'error))
2280 (compile nil '(lambda ()
2281 (declare (optimize (debug 2))) ; not debug 3!
2282 (let ((val "foobar"))
2283 (map-into (make-array (list (length val))
2284 :element-type '(unsigned-byte 8))
2285 #'char-code val)))))
2286
2287 ;;; overconfident primitive type computation leading to bogus type
2288 ;;; checking.
2289 (let* ((form1 '(lambda (x)
2290 (declare (type (and condition function) x))
2291 x))
2292 (fun1 (compile nil form1))
2293 (form2 '(lambda (x)
2294 (declare (type (and standard-object function) x))
2295 x))
2296 (fun2 (compile nil form2)))
2297 (assert-error (funcall fun1 (make-condition 'error)))
2298 (assert-error (funcall fun1 fun1))
2299 (assert-error (funcall fun2 fun2))
2300 (assert (eq (funcall fun2 #'print-object) #'print-object)))
2301
2302 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2303 ;;; and possibly a non-conforming extension, as long as we do support
2304 ;;; it, we might as well get it right.
2305 ;;;
2306 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2307 (compile nil '(lambda () (let* () (declare (values list)))))
2308
2309
2310 ;;; test for some problems with too large immediates in x86-64 modular
2311 ;;; arithmetic vops
2312 (compile nil '(lambda (x) (declare (fixnum x))
2313 (logand most-positive-fixnum (logxor x most-positive-fixnum))))
2314
2315 (compile nil '(lambda (x) (declare (fixnum x))
2316 (logand most-positive-fixnum (+ x most-positive-fixnum))))
2317
2318 (compile nil '(lambda (x) (declare (fixnum x))
2319 (logand most-positive-fixnum (* x most-positive-fixnum))))
2320
2321 ;;; bug 256.b
2322 (with-test (:name :propagate-type-through-error-and-binding)
2323 (assert (let (warned-p)
2324 (handler-bind ((warning (lambda (w) (setf warned-p t))))
2325 (compile nil
2326 '(lambda (x)
2327 (list (let ((y (the real x)))
2328 (unless (floatp y) (error ""))
2329 y)
2330 (integer-length x)))))
2331 warned-p)))
2332
2333 ;; Dead / in safe code
2334 (with-test (:name :safe-dead-/)
2335 (assert (eq :error
2336 (handler-case
2337 (funcall (compile nil
2338 '(lambda (x y)
2339 (declare (optimize (safety 3)))
2340 (/ x y)
2341 (+ x y)))
2342 1
2343 0)
2344 (division-by-zero ()
2345 :error)))))
2346
2347 ;;; Dead unbound variable (bug 412)
2348 (with-test (:name :dead-unbound)
2349 (assert (eq :error
2350 (handler-case
2351 (funcall (compile nil
2352 '(lambda ()
2353 #:unbound
2354 42)))
2355 (unbound-variable ()
2356 :error)))))
2357
2358 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2359 (handler-bind ((sb-ext:compiler-note 'error))
2360 (assert
2361 (equalp #(2 3)
2362 (funcall (compile nil `(lambda (s p e)
2363 (declare (optimize speed)
2364 (simple-vector s))
2365 (subseq s p e)))
2366 (vector 1 2 3 4)
2367 1
2368 3))))
2369
2370 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2371 (handler-bind ((sb-ext:compiler-note 'error))
2372 (assert
2373 (equalp #(1 2 3 4)
2374 (funcall (compile nil `(lambda (s)
2375 (declare (optimize speed)
2376 (simple-vector s))
2377 (copy-seq s)))
2378 (vector 1 2 3 4)))))
2379
2380 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2381 (assert (not (mismatch #(1.0f0 2.0f0) (make-array 2 :element-type 'single-float :initial-contents (list 1.0f0 2.0f0)))))
2382
2383 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2384 ;;; large bignums to floats
2385 (dolist (op '(* / + -))
2386 (let ((fun (compile
2387 nil
2388 `(lambda (x)
2389 (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x))
2390 (,op 0.0d0 x)))))
2391 (loop repeat 10
2392 do (let ((arg (random (truncate most-positive-double-float))))
2393 (assert (eql (funcall fun arg)
2394 (funcall op 0.0d0 arg)))))))
2395
2396 (with-test (:name :high-debug-known-function-inlining)
2397 (let ((fun (compile nil
2398 '(lambda ()
2399 (declare (optimize (debug 3)) (inline append))
2400 (let ((fun (lambda (body)
2401 (append
2402 (first body)
2403 nil))))
2404 (funcall fun
2405 '((foo (bar)))))))))
2406 (funcall fun)))
2407
2408 (with-test (:name :high-debug-known-function-transform-with-optional-arguments)
2409 (compile nil '(lambda (x y)
2410 (declare (optimize sb-c::preserve-single-use-debug-variables))
2411 (if (block nil
2412 (some-unknown-function
2413 (lambda ()
2414 (return (member x y))))
2415 t)
2416 t
2417 (error "~a" y)))))
2418
2419 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2420 ;;; or characters.
2421 (compile nil '(lambda (x y)
2422 (declare (fixnum y) (character x))
2423 (sb-sys:with-pinned-objects (x y)
2424 (some-random-function))))
2425
2426 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2427
2428 (with-test (:name :bug-423)
2429 (let ((sb-c::*check-consistency* t))
2430 (handler-bind ((warning #'error))
2431 (flet ((make-lambda (type)
2432 `(lambda (x)
2433 ((lambda (z)
2434 (if (listp z)
2435 (let ((q (truly-the list z)))
2436 (length q))
2437 (if (arrayp z)
2438 (let ((q (truly-the vector z)))
2439 (length q))
2440 (error "oops"))))
2441 (the ,type x)))))
2442 (compile nil (make-lambda 'list))
2443 (compile nil (make-lambda 'vector))))))
2444
2445 ;;; this caused a momentary regression when an ill-adviced fix to
2446 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2447 ;;;
2448 ;;; 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)
2449 ;;; [Condition of type SIMPLE-ERROR]
2450 (compile nil
2451 '(lambda (frob)
2452 (labels
2453 ((%zig (frob)
2454 (typecase frob
2455 (double-float
2456 (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char))
2457 (* double-float))) frob))
2458 (hash-table
2459 (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2)))
2460 nil))))
2461 (%zig))))
2462
2463 ;;; non-required arguments in HANDLER-BIND
2464 (assert (eq :oops (car (funcall (compile nil
2465 '(lambda (x)
2466 (block nil
2467 (handler-bind ((error (lambda (&rest args) (return (cons :oops args)))))
2468 (/ 2 x)))))
2469 0))))
2470
2471 ;;; NIL is a legal function name
2472 (assert (eq 'a (flet ((nil () 'a)) (nil))))
2473
2474 ;;; misc.528
2475 (assert (null (let* ((x 296.3066f0)
2476 (y 22717067)
2477 (form `(lambda (r p2)
2478 (declare (optimize speed (safety 1))
2479 (type (simple-array single-float nil) r)
2480 (type (integer -9369756340 22717335) p2))
2481 (setf (aref r) (* ,x (the (eql 22717067) p2)))
2482 (values)))
2483 (r (make-array nil :element-type 'single-float))
2484 (expected (* x y)))
2485 (funcall (compile nil form) r y)
2486 (let ((actual (aref r)))
2487 (unless (eql expected actual)
2488 (list expected actual))))))
2489 ;;; misc.529
2490 (assert (null (let* ((x -2367.3296f0)
2491 (y 46790178)
2492 (form `(lambda (r p2)
2493 (declare (optimize speed (safety 1))
2494 (type (simple-array single-float nil) r)
2495 (type (eql 46790178) p2))
2496 (setf (aref r) (+ ,x (the (integer 45893897) p2)))
2497 (values)))
2498 (r (make-array nil :element-type 'single-float))
2499 (expected (+ x y)))
2500 (funcall (compile nil form) r y)
2501 (let ((actual (aref r)))
2502 (unless (eql expected actual)
2503 (list expected actual))))))
2504
2505 ;;; misc.556
2506 (assert (eql -1
2507 (funcall
2508 (compile nil '(lambda (p1 p2)
2509 (declare
2510 (optimize (speed 1) (safety 0)
2511 (debug 0) (space 0))
2512 (type (member 8174.8604) p1)
2513 (type (member -95195347) p2))
2514 (floor p1 p2)))
2515 8174.8604 -95195347)))
2516
2517 ;;; misc.557
2518 (assert (eql -1
2519 (funcall
2520 (compile
2521 nil
2522 '(lambda (p1)
2523 (declare (optimize (speed 3) (safety 0) (debug 3) (space 1))
2524 (type (member -94430.086f0) p1))
2525 (floor (the single-float p1) 19311235)))
2526 -94430.086f0)))
2527
2528 ;;; misc.558
2529 (assert (eql -1.0f0
2530 (funcall
2531 (compile
2532 nil
2533 '(lambda (p1)
2534 (declare (optimize (speed 1) (safety 2)
2535 (debug 2) (space 3))
2536 (type (eql -39466.56f0) p1))
2537 (ffloor p1 305598613)))
2538 -39466.56f0)))
2539
2540 ;;; misc.559
2541 (assert (eql 1
2542 (funcall
2543 (compile
2544 nil
2545 '(lambda (p1)
2546 (declare (optimize (speed 1) (safety 1) (debug 1) (space 2))
2547 (type (eql -83232.09f0) p1))
2548 (ceiling p1 -83381228)))
2549 -83232.09f0)))
2550
2551 ;;; misc.560
2552 (assert (eql 1
2553 (funcall
2554 (compile
2555 nil
2556 '(lambda (p1)
2557 (declare (optimize (speed 1) (safety 1)
2558 (debug 1) (space 0))
2559 (type (member -66414.414f0) p1))
2560 (ceiling p1 -63019173f0)))
2561 -66414.414f0)))
2562
2563 ;;; misc.561
2564 (assert (eql 1.0f0
2565 (funcall
2566 (compile
2567 nil
2568 '(lambda (p1)
2569 (declare (optimize (speed 0) (safety 1)
2570 (debug 0) (space 1))
2571 (type (eql 20851.398f0) p1))
2572 (fceiling p1 80839863)))
2573 20851.398f0)))
2574
2575 ;;; misc.581
2576 (assert (floatp
2577 (funcall
2578 (compile nil '(lambda (x)
2579 (declare (type (eql -5067.2056) x))
2580 (+ 213734822 x)))
2581 -5067.2056)))
2582
2583 ;;; misc.581a
2584 (assert (typep
2585 (funcall
2586 (compile nil '(lambda (x) (declare (type (eql -1.0) x))
2587 (+ #x1000001 x)))
2588 -1.0f0)
2589 'single-float))
2590
2591 ;;; misc.582
2592 (assert (plusp (funcall
2593 (compile
2594 nil
2595 ' (lambda (p1)
2596 (declare (optimize (speed 0) (safety 1) (debug 1) (space 1))
2597 (type (eql -39887.645) p1))
2598 (mod p1 382352925)))
2599 -39887.645)))
2600
2601 ;;; misc.587
2602 (assert (let ((result (funcall
2603 (compile
2604 nil
2605 '(lambda (p2)
2606 (declare (optimize (speed 0) (safety 3) (debug 1) (space 0))
2607 (type (eql 33558541) p2))
2608 (- 92215.266 p2)))
2609 33558541)))
2610 (typep result 'single-float)))
2611
2612 ;;; misc.635
2613 (assert (eql 1
2614 (let* ((form '(lambda (p2)
2615 (declare (optimize (speed 0) (safety 1)
2616 (debug 2) (space 2))
2617 (type (member -19261719) p2))
2618 (ceiling -46022.094 p2))))
2619 (values (funcall (compile nil form) -19261719)))))
2620
2621 ;;; misc.636
2622 (assert (let* ((x 26899.875)
2623 (form `(lambda (p2)
2624 (declare (optimize (speed 3) (safety 1) (debug 3) (space 1))
2625 (type (member ,x #:g5437 char-code #:g5438) p2))
2626 (* 104102267 p2))))
2627 (floatp (funcall (compile nil form) x))))
2628
2629 ;;; misc.622
2630 (assert (eql
2631 (funcall
2632 (compile
2633 nil
2634 '(lambda (p2)
2635 (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
2636 (type real p2))
2637 (+ 81535869 (the (member 17549.955 #:g35917) p2))))
2638 17549.955)
2639 (+ 81535869 17549.955)))
2640
2641 ;;; misc.654
2642 (assert (eql 2
2643 (let ((form '(lambda (p2)
2644 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2645 (type (member integer eql) p2))
2646 (coerce 2 p2))))
2647 (funcall (compile nil form) 'integer))))
2648
2649 ;;; misc.656
2650 (assert (eql 2
2651 (let ((form '(lambda (p2)
2652 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2653 (type (member integer mod) p2))
2654 (coerce 2 p2))))
2655 (funcall (compile nil form) 'integer))))
2656
2657 ;;; misc.657
2658 (assert (eql 2
2659 (let ((form '(lambda (p2)
2660 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2661 (type (member integer values) p2))
2662 (coerce 2 p2))))
2663 (funcall (compile nil form) 'integer))))
2664
2665 (with-test (:name :string-aref-type)
2666 (assert (eq 'character
2667 (funcall (compile nil
2668 '(lambda (s)
2669 (ctu:compiler-derived-type (aref (the string s) 0))))
2670 "foo"))))
2671
2672 (with-test (:name :base-string-aref-type)
2673 (assert (eq #+sb-unicode 'base-char
2674 #-sb-unicode 'character
2675 (funcall (compile nil
2676 '(lambda (s)
2677 (ctu:compiler-derived-type (aref (the base-string s) 0))))
2678 (coerce "foo" 'base-string)))))
2679
2680 (with-test (:name :dolist-constant-type-derivation)
2681 (assert (equal '(integer 1 3)
2682 (funcall (compile nil
2683 '(lambda (x)
2684 (dolist (y '(1 2 3))
2685 (when x
2686 (return (ctu:compiler-derived-type y))))))
2687 t))))
2688
2689 (with-test (:name :dolist-simple-list-type-derivation)
2690 (assert (equal '(integer 1 3)
2691 (funcall (compile nil
2692 '(lambda (x)
2693 (dolist (y (list 1 2 3))
2694 (when x
2695 (return (ctu:compiler-derived-type y))))))
2696 t))))
2697
2698 (with-test (:name :dolist-dotted-constant-list-type-derivation)
2699 (let* ((warned nil)
2700 (fun (handler-bind ((style-warning (lambda (c) (push c warned))))
2701 (compile nil
2702 '(lambda (x)
2703 (dolist (y '(1 2 3 . 4) :foo)
2704 (when x
2705 (return (ctu:compiler-derived-type y)))))))))
2706 (assert (equal '(integer 1 3) (funcall fun t)))
2707 (assert (= 1 (length warned)))
2708 (multiple-value-bind (res err) (ignore-errors (funcall fun nil))
2709 (assert (not res))
2710 (assert (typep err 'type-error)))))
2711
2712 (with-test (:name :constant-list-destructuring)
2713 (handler-bind ((sb-ext:compiler-note #'error))
2714 (progn
2715 (assert (= 10
2716 (funcall
2717 (compile nil
2718 '(lambda ()
2719 (destructuring-bind (a (b c) d) '(1 (2 3) 4)
2720 (+ a b c d)))))))
2721 (assert (eq :feh
2722 (funcall
2723 (compile nil
2724 '(lambda (x)
2725 (or x
2726 (destructuring-bind (a (b c) d) '(1 "foo" 4)
2727 (+ a b c d)))))
2728 :feh))))))
2729
2730 ;;; Functions with non-required arguments used to end up with
2731 ;;; (&OPTIONAL-DISPATCH ...) as their names.
2732 (with-test (:name :hairy-function-name)
2733 (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line))))
2734 (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line))))
2735
2736 ;;; PROGV + RESTRICT-COMPILER-POLICY
2737 (with-test (:name :progv-and-restrict-compiler-policy)
2738 (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
2739 (restrict-compiler-policy 'debug 3)
2740 (let ((fun (compile nil '(lambda (x)
2741 (let ((i x))
2742 (declare (special i))
2743 (list i
2744 (progv '(i) (list (+ i 1))
2745 i)
2746 i))))))
2747 (assert (equal '(1 2 1) (funcall fun 1))))))
2748
2749 ;;; It used to be possible to confuse the compiler into
2750 ;;; IR2-converting such a call to CONS
2751 (with-test (:name :late-bound-primitive)
2752 (compile nil `(lambda ()
2753 (funcall 'cons 1))))
2754
2755 (with-test (:name :hairy-array-element-type-derivation)
2756 (compile nil '(lambda (x)
2757 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
2758 (array-element-type x))))
2759
2760 (with-test (:name :rest-list-type-derivation)
2761 (multiple-value-bind (type derivedp)
2762 (funcall (compile nil `(lambda (&rest args)
2763 (ctu:compiler-derived-type args)))
2764 nil)
2765 (assert (eq 'list type))
2766 (assert derivedp)))
2767
2768 (with-test (:name :rest-list-type-derivation2)
2769 (multiple-value-bind (type derivedp)
2770 (funcall (funcall (compile nil `(lambda ()
2771 (lambda (&rest args)
2772 (ctu:compiler-derived-type args))))))
2773 (assert (eq 'list type))
2774 (assert derivedp)))
2775
2776 (with-test (:name :rest-list-type-derivation3)
2777 (multiple-value-bind (type derivedp)
2778 (funcall (funcall (compile nil `(lambda ()
2779 (lambda (&optional x &rest args)
2780 (unless x (error "oops"))
2781 (ctu:compiler-derived-type args)))))
2782 t)
2783 (assert (eq 'list type))
2784 (assert derivedp)))
2785
2786 (with-test (:name :rest-list-type-derivation4)
2787 (multiple-value-bind (type derivedp)
2788 (funcall (funcall (compile nil `(lambda ()
2789 (lambda (&optional x &rest args)
2790 (declare (type (or null integer) x))
2791 (when x (setf args x))
2792 (ctu:compiler-derived-type args)))))
2793 42)
2794 (assert (equal '(or cons null integer) type))
2795 (assert derivedp)))
2796
2797 (with-test (:name :base-char-typep-elimination)
2798 (assert (eq (funcall (compile nil
2799 `(lambda (ch)
2800 (declare (type base-char ch) (optimize (speed 3) (safety 0)))
2801 (typep ch 'base-char)))
2802 t)
2803 t)))
2804
2805 (with-test (:name :regression-1.0.24.37)
2806 (compile nil '(lambda (&key (test (constantly t)))
2807 (when (funcall test)
2808 :quux))))
2809
2810 ;;; Attempt to test a decent cross section of conditions
2811 ;;; and values types to move conditionally.
2812 (macrolet
2813 ((test-comparison (comparator type x y)
2814 `(progn
2815 ,@(loop for (result-type a b)
2816 in '((nil t nil)
2817 (nil 0 1)
2818 (nil 0.0 1.0)
2819 (nil 0d0 0d0)
2820 (nil 0.0 0d0)
2821 (nil #c(1.0 1.0) #c(2.0 2.0))
2822
2823 (t t nil)
2824 (fixnum 0 1)
2825 ((unsigned-byte #.sb-vm:n-word-bits)
2826 (1+ most-positive-fixnum)
2827 (+ 2 most-positive-fixnum))
2828 ((signed-byte #.sb-vm:n-word-bits)
2829 -1 (* 2 most-negative-fixnum))
2830 (single-float 0.0 1.0)
2831 (double-float 0d0 1d0))
2832 for lambda = (if result-type
2833 `(lambda (x y a b)
2834 (declare (,type x y)
2835 (,result-type a b))
2836 (if (,comparator x y)
2837 a b))
2838 `(lambda (x y)
2839 (declare (,type x y))
2840 (if (,comparator x y)
2841 ,a ,b)))
2842 for args = `(,x ,y ,@(and result-type
2843 `(,a ,b)))
2844 collect
2845 `(progn
2846 (eql (funcall (compile nil ',lambda)
2847 ,@args)
2848 (eval '(,lambda ,@args))))))))
2849 (sb-vm::with-float-traps-masked
2850 (:divide-by-zero :overflow :inexact :invalid)
2851 (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret))
2852 (declare (sb-ext:muffle-conditions style-warning))
2853 (test-comparison eql t t nil)
2854 (test-comparison eql t t t)
2855
2856 (test-comparison = t 1 0)
2857 (test-comparison = t 1 1)
2858 (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2859 (test-comparison = fixnum 1 0)
2860 (test-comparison = fixnum 0 0)
2861 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2862 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2863 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0)
2864 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1)
2865
2866 (test-comparison = single-float 0.0 1.0)
2867 (test-comparison = single-float 1.0 1.0)
2868 (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0))
2869 (test-comparison = single-float (/ 1.0 0.0) 1.0)
2870 (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0))
2871 (test-comparison = single-float (/ 0.0 0.0) 0.0)
2872
2873 (test-comparison = double-float 0d0 1d0)
2874 (test-comparison = double-float 1d0 1d0)
2875 (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0))
2876 (test-comparison = double-float (/ 1d0 0d0) 1d0)
2877 (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0))
2878 (test-comparison = double-float (/ 0d0 0d0) 0d0)
2879
2880 (test-comparison < t 1 0)
2881 (test-comparison < t 0 1)
2882 (test-comparison < t 1 1)
2883 (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2884 (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2885 (test-comparison < fixnum 1 0)
2886 (test-comparison < fixnum 0 1)
2887 (test-comparison < fixnum 0 0)
2888 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2889 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2890 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2891 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0)
2892 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1)
2893 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1)
2894
2895 (test-comparison < single-float 0.0 1.0)
2896 (test-comparison < single-float 1.0 0.0)
2897 (test-comparison < single-float 1.0 1.0)
2898 (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0))
2899 (test-comparison < single-float (/ 1.0 0.0) 1.0)
2900 (test-comparison < single-float 1.0 (/ 1.0 0.0))
2901 (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0))
2902 (test-comparison < single-float (/ 0.0 0.0) 0.0)
2903
2904 (test-comparison < double-float 0d0 1d0)
2905 (test-comparison < double-float 1d0 0d0)
2906 (test-comparison < double-float 1d0 1d0)
2907 (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0))
2908 (test-comparison < double-float (/ 1d0 0d0) 1d0)
2909 (test-comparison < double-float 1d0 (/ 1d0 0d0))
2910 (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0))
2911 (test-comparison < double-float (/ 0d0 0d0) 0d0)
2912 (test-comparison < double-float 0d0 (/ 0d0 0d0))
2913
2914 (test-comparison > t 1 0)
2915 (test-comparison > t 0 1)
2916 (test-comparison > t 1 1)
2917 (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2918 (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2919 (test-comparison > fixnum 1 0)
2920 (test-comparison > fixnum 0 1)
2921 (test-comparison > fixnum 0 0)
2922 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2923 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2924 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2925 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0)
2926 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1)
2927 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1)
2928
2929 (test-comparison > single-float 0.0 1.0)
2930 (test-comparison > single-float 1.0 0.0)
2931 (test-comparison > single-float 1.0 1.0)
2932 (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0))
2933 (test-comparison > single-float (/ 1.0 0.0) 1.0)
2934 (test-comparison > single-float 1.0 (/ 1.0 0.0))
2935 (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0))
2936 (test-comparison > single-float (/ 0.0 0.0) 0.0)
2937
2938 (test-comparison > double-float 0d0 1d0)
2939 (test-comparison > double-float 1d0 0d0)
2940 (test-comparison > double-float 1d0 1d0)
2941 (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0))
2942 (test-comparison > double-float (/ 1d0 0d0) 1d0)
2943 (test-comparison > double-float 1d0 (/ 1d0 0d0))
2944 (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0))
2945 (test-comparison > double-float (/ 0d0 0d0) 0d0)
2946 (test-comparison > double-float 0d0 (/ 0d0 0d0)))))
2947
2948 (with-test (:name :car-and-cdr-type-derivation-conservative)
2949 (let ((f1 (compile nil
2950 `(lambda (y)
2951 (declare (optimize speed))
2952 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2953 (declare (type (cons t fixnum) x))
2954 (rplaca x y)
2955 (+ (car x) (cdr x))))))
2956 (f2 (compile nil
2957 `(lambda (y)
2958 (declare (optimize speed))
2959 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2960 (setf (cdr x) y)
2961 (+ (car x) (cdr x)))))))
2962 (flet ((test-error (e value)
2963 (assert (typep e 'type-error))
2964 (assert (eq 'number (type-error-expected-type e)))
2965 (assert (eq value (type-error-datum e)))))
2966 (let ((v1 "foo")
2967 (v2 "bar"))
2968 (multiple-value-bind (res err) (ignore-errors (funcall f1 v1))
2969 (assert (not res))
2970 (test-error err v1))
2971 (multiple-value-bind (res err) (ignore-errors (funcall f2 v2))
2972 (assert (not res))
2973 (test-error err v2))))))
2974
2975 (with-test (:name :array-dimension-derivation-conservative)
2976 (let ((f (compile nil
2977 `(lambda (x)
2978 (declare (optimize speed))
2979 (declare (type (array * (4 4)) x))
2980 (let ((y x))
2981 (setq x (make-array '(4 4)))
2982 (adjust-array y '(3 5))
2983 (array-dimension y 0))))))
2984 (assert (= 3 (funcall f (make-array '(4 4) :adjustable t))))))
2985
2986 (with-test (:name :with-timeout-code-deletion-note)
2987 (handler-bind ((sb-ext:code-deletion-note #'error))
2988 (compile nil `(lambda ()
2989 (sb-ext:with-timeout 0
2990 (sleep 1))))))
2991
2992 (with-test (:name :full-warning-for-undefined-type-in-cl)
2993 (assert (eq :full
2994 (handler-case
2995 (compile nil `(lambda (x) (the replace x)))
2996 (style-warning ()
2997 :style)
2998 (warning ()
2999 :full)))))
3000
3001 (with-test (:name :single-warning-for-single-undefined-type)
3002 (let ((n 0))
3003 (handler-bind ((warning (lambda (c)
3004 (declare (ignore c))
3005 (incf n))))
3006 (compile nil `(lambda (x) (the #:no-type x)))
3007 (assert (= 1 n))
3008 (compile nil `(lambda (x) (the 'fixnum x)))
3009 (assert (= 2 n)))))
3010
3011 (with-test (:name :complex-subtype-dumping-in-xc)
3012 (assert
3013 (= sb-vm:complex-single-float-widetag
3014 (sb-kernel:widetag-of
3015 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float))))))
3016 (assert
3017 (= sb-vm:complex-double-float-widetag
3018 (sb-kernel:widetag-of
3019 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
3020
3021 (with-test (:name :complex-single-float-fill)
3022 (assert (every (lambda (x) (= #c(1.0 2.0) x))
3023 (funcall
3024 (compile nil
3025 `(lambda (n x)
3026 (make-array (list n)
3027 :element-type '(complex single-float)
3028 :initial-element x)))
3029 10
3030 #c(1.0 2.0)))))
3031
3032 (with-test (:name :regression-1.0.28.21)
3033 (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1))))))
3034 (assert (funcall fun (vector 1 2 3)))
3035 (assert (funcall fun "abc"))
3036 (assert (not (funcall fun (make-array '(2 2)))))))
3037
3038 (with-test (:name :no-silly-compiler-notes-from-character-function)
3039 (let (current)
3040 (handler-bind ((compiler-note (lambda (e) (error "~S: ~A" current e))))
3041 (dolist (name '(char-code char-int character char-name standard-char-p
3042 graphic-char-p alpha-char-p upper-case-p lower-case-p
3043 both-case-p digit-char-p alphanumericp digit-char-p))
3044 (setf current name)
3045 (compile nil `(lambda (x)
3046 (declare (character x) (optimize speed))
3047 (,name x))))
3048 (dolist (name '(char= char/= char< char> char<= char>=
3049 char-lessp char-greaterp char-not-greaterp
3050 char-not-lessp))
3051 (setf current name)
3052 (compile nil `(lambda (x y)
3053 (declare (character x y) (optimize speed))
3054 (,name x y)))))))
3055
3056 ;;; optimizing make-array
3057 (with-test (:name (make-array :open-code-initial-contents))
3058 (assert (not (ctu:find-named-callees
3059 (compile nil
3060 `(lambda (x y z)
3061 (make-array '(3) :initial-contents (list x y z)))))))
3062 (assert (not (ctu:find-named-callees
3063 (compile nil
3064 `(lambda (x y z)
3065 (make-array '3 :initial-contents (vector x y z)))))))
3066 (assert (not (ctu:find-named-callees
3067 (compile nil
3068 `(lambda (x y z)
3069 (make-array '3 :initial-contents `(,x ,y ,z))))))))
3070
3071 ;;; optimizing array-in-bounds-p
3072 (with-test (:name :optimize-array-in-bounds-p)
3073 (locally
3074 (macrolet ((find-callees (&body body)
3075 `(ctu:find-named-callees
3076 (compile nil
3077 '(lambda ()
3078 ,@body))
3079 :name 'array-in-bounds-p))
3080 (must-optimize (&body exprs)
3081 `(progn
3082 ,@(loop for expr in exprs
3083 collect `(assert (not (find-callees
3084 ,expr))))))
3085 (must-not-optimize (&body exprs)
3086 `(progn
3087 ,@(loop for expr in exprs
3088 collect `(assert (find-callees
3089 ,expr))))))
3090 (must-optimize
3091 ;; in bounds
3092 (let ((a (make-array '(1))))
3093 (array-in-bounds-p a 0))
3094 ;; exceeds upper bound (constant)
3095 (let ((a (make-array '(1))))
3096 (array-in-bounds-p a 1))
3097 ;; exceeds upper bound (interval)
3098 (let ((a (make-array '(1))))
3099 (array-in-bounds-p a (+ 1 (random 2))))
3100 ;; negative lower bound (constant)
3101 (let ((a (make-array '(1))))
3102 (array-in-bounds-p a -1))
3103 ;; negative lower bound (interval)
3104 (let ((a (make-array 3))
3105 (i (- (random 1) 20)))
3106 (array-in-bounds-p a i))
3107 ;; multiple known dimensions
3108 (let ((a (make-array '(1 1))))
3109 (array-in-bounds-p a 0 0))
3110 ;; union types
3111 (let ((s (the (simple-string 10) (eval "0123456789"))))
3112 (array-in-bounds-p s 9)))
3113 (must-not-optimize
3114 ;; don't trust non-simple array length in safety=1
3115 (let ((a (the (array * (10)) (make-array 10 :adjustable t))))
3116 (eval `(adjust-array ,a 0))
3117 (array-in-bounds-p a 9))
3118 ;; same for a union type
3119 (let ((s (the (string 10) (make-array 10
3120 :element-type 'character
3121 :adjustable t))))
3122 (eval `(adjust-array ,s 0))
3123 (array-in-bounds-p s 9))
3124 ;; single unknown dimension
3125 (let ((a (make-array (random 20))))
3126 (array-in-bounds-p a 10))
3127 ;; multiple unknown dimensions
3128 (let ((a (make-array (list (random 20) (random 5)))))
3129 (array-in-bounds-p a 5 2))
3130 ;; some other known dimensions
3131 (let ((a (make-array (list 1 (random 5)))))
3132 (array-in-bounds-p a 0 2))
3133 ;; subscript might be negative
3134 (let ((a (make-array 5)))
3135 (array-in-bounds-p a (- (random 3) 2)))
3136 ;; subscript might be too large
3137 (let ((a (make-array 5)))
3138 (array-in-bounds-p a (random 6)))
3139 ;; unknown upper bound
3140 (let ((a (make-array 5)))
3141 (array-in-bounds-p a (get-universal-time)))
3142 ;; unknown lower bound
3143 (let ((a (make-array 5)))
3144 (array-in-bounds-p a (- (get-universal-time))))
3145 ;; in theory we should be able to optimize
3146 ;; the following but the current implementation
3147 ;; doesn't cut it because the array type's
3148 ;; dimensions get reported as (* *).
3149 (let ((a (make-array (list (random 20) 1))))
3150 (array-in-bounds-p a 5 2))))))
3151
3152 ;;; optimizing (EXPT -1 INTEGER)
3153 (with-test (:name (expt -1 integer))
3154 (dolist (x '(-1 -1.0 -1.0d0))
3155 (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
3156 (assert (not (ctu:find-named-callees fun)))
3157 (dotimes (i 12)
3158 (if (oddp i)
3159 (assert (eql x (funcall fun i)))
3160 (assert (eql (- x) (funcall fun i))))))))
3161
3162 (with-test (:name :float-division-using-exact-reciprocal)
3163 (flet ((test (lambda-form arg res &key (check-insts t))
3164 (let* ((fun (compile nil lambda-form))
3165 (disassembly (with-output-to-string (s)
3166 (disassemble fun :stream s))))
3167 ;; Let's make sure there is no division at runtime: for x86 and
3168 ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
3169 ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
3170 ;; it works.
3171 #+(or x86 x86-64)
3172 (when check-insts
3173 (assert (not (search "DIV" disassembly))))
3174 ;; No generic arithmetic!
3175 (assert (not (search "GENERIC" disassembly)))
3176 (assert (eql res (funcall fun arg))))))
3177 (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
3178 (dolist (type '(single-float double-float))
3179 (let* ((cf (coerce c type))
3180 (arg (- (random (* 2 cf)) cf))
3181 (r1 (eval `(/ ,arg ,cf)))
3182 (r2 (eval `(/ ,arg ,(- cf)))))
3183 (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1)
3184 (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2)
3185 ;; rational args should get optimized as well
3186 (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1)
3187 (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2))))
3188 ;; Also check that inexact reciprocals (1) are not used by default (2) are
3189 ;; used with FLOAT-ACCURACY=0.
3190 (dolist (type '(single-float double-float))
3191 (let ((trey (coerce 3 type))
3192 (one (coerce 1 type)))
3193 (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one
3194 :check-insts nil)
3195 (test `(lambda (x)
3196 (declare (,type x)
3197 (optimize (sb-c::float-accuracy 0)))
3198 (/ x 3))
3199 trey (eval `(* ,trey (/ ,trey))))))))
3200
3201 (with-test (:name :float-multiplication-by-one)
3202 (flet ((test (lambda-form arg &optional (result arg))
3203 (let* ((fun1 (compile nil lambda-form))
3204 (fun2 (funcall (compile nil `(lambda ()
3205 (declare (optimize (sb-c::float-accuracy 0)))
3206 ,lambda-form))))
3207 (disassembly1 (with-output-to-string (s)
3208 (disassemble fun1 :stream s)))
3209 (disassembly2 (with-output-to-string (s)
3210 (disassemble fun2 :stream s))))
3211 ;; Multiplication at runtime should be eliminated only with
3212 ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
3213 #+(or x86 x86-64)
3214 (assert (and (search "MUL" disassembly1)
3215 (not (search "MUL" disassembly2))))
3216 ;; Not generic arithmetic, please!
3217 (assert (and (not (search "GENERIC" disassembly1))
3218 (not (search "GENERIC" disassembly2))))
3219 (assert (eql result (funcall fun1 arg)))
3220 (assert (eql result (funcall fun2 arg))))))
3221 (dolist (type '(single-float double-float))
3222 (let* ((one (coerce 1 type))
3223 (arg (random (* 2 one)))
3224 (-r (- arg)))
3225 (test `(lambda (x) (declare (,type x)) (* x 1)) arg)
3226 (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r)
3227 (test `(lambda (x) (declare (,type x)) (* x ,one)) arg)
3228 (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r)))))
3229
3230 (with-test (:name :float-addition-of-zero)
3231 (flet ((test (lambda-form arg &optional (result arg))
3232 (let* ((fun1 (compile nil lambda-form))
3233 (fun2 (funcall (compile nil `(lambda ()
3234 (declare (optimize (sb-c::float-accuracy 0)))
3235 ,lambda-form))))
3236 (disassembly1 (with-output-to-string (s)
3237 (disassemble fun1 :stream s)))
3238 (disassembly2 (with-output-to-string (s)
3239 (disassemble fun2 :stream s))))
3240 ;; Let's make sure there is no addition at runtime: for x86 and
3241 ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
3242 ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
3243 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3244 ;; addition in to catch SNaNs.
3245 #+x86
3246 (assert (and (search "FADD" disassembly1)
3247 (not (search "FADD" disassembly2))))
3248 #+x86-64
3249 (let ((inst (if (typep result 'double-float)
3250 "ADDSD" "ADDSS")))
3251 (assert (and (search inst disassembly1)
3252 (not (search inst disassembly2)))))
3253 (assert (eql result (funcall fun1 arg)))
3254 (assert (eql result (funcall fun2 arg))))))
3255 (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45)
3256 (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21)
3257 (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0)
3258 (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0)
3259 (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0)
3260 (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0)))
3261
3262 (with-test (:name :float-substraction-of-zero)
3263 (flet ((test (lambda-form arg &optional (result arg))
3264 (let* ((fun1 (compile nil lambda-form))
3265 (fun2 (funcall (compile nil `(lambda ()
3266 (declare (optimize (sb-c::float-accuracy 0)))
3267 ,lambda-form))))
3268 (disassembly1 (with-output-to-string (s)
3269 (disassemble fun1 :stream s)))
3270 (disassembly2 (with-output-to-string (s)
3271 (disassemble fun2 :stream s))))
3272 ;; Let's make sure there is no substraction at runtime: for x86
3273 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
3274 ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
3275 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3276 ;; substraction in in to catch SNaNs.
3277 #+x86
3278 (assert (and (search "FSUB" disassembly1)
3279 (not (search "FSUB" disassembly2))))
3280 #+x86-64
3281 (let ((inst (if (typep result 'double-float)
3282 "SUBSD" "SUBSS")))
3283 (assert (and (search inst disassembly1)
3284 (not (search inst disassembly2)))))
3285 (assert (eql result (funcall fun1 arg)))
3286 (assert (eql result (funcall fun2 arg))))))
3287 (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45)
3288 (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21)
3289 (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0)
3290 (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0)
3291 (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0)
3292 (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0)))
3293
3294 (with-test (:name :float-multiplication-by-two)
3295 (flet ((test (lambda-form arg &optional (result arg))
3296 (let* ((fun1 (compile nil lambda-form))
3297 (fun2 (funcall (compile nil `(lambda ()
3298 (declare (optimize (sb-c::float-accuracy 0)))
3299 ,lambda-form))))
3300 (disassembly1 (with-output-to-string (s)
3301 (disassemble fun1 :stream s)))
3302 (disassembly2 (with-output-to-string (s)
3303 (disassemble fun2 :stream s))))
3304 ;; Let's make sure there is no multiplication at runtime: for x86
3305 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
3306 ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
3307 ;; but it works.
3308 #+(or x86 x86-64)
3309 (assert (and (not (search "MUL" disassembly1))
3310 (not (search "MUL" disassembly2))))
3311 (assert (eql result (funcall fun1 arg)))
3312 (assert (eql result (funcall fun2 arg))))))
3313 (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9)
3314 (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42)
3315 (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0)
3316 (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0)
3317 (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0)
3318 (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0)))
3319
3320 (with-test (:name :bug-392203)
3321 ;; Used to hit an AVER in COMVERT-MV-CALL.
3322 (assert (zerop
3323 (funcall
3324 (compile nil
3325 `(lambda ()
3326 (flet ((k (&rest x) (declare (ignore x)) 0))
3327 (multiple-value-call #'k #'k))))))))
3328
3329 (with-test (:name :allocate-closures-failing-aver)
3330 (let ((f (compile nil `(lambda ()
3331 (labels ((k (&optional x) #'k)))))))
3332 (assert (null (funcall f)))))
3333
3334 (with-test (:name :flush-vector-creation)
3335 (let ((f (compile nil `(lambda ()
3336 (dotimes (i 1024)
3337 (vector i i i))
3338 t))))
3339 (ctu:assert-no-consing (funcall f))))
3340
3341 (with-test (:name :array-type-predicates)
3342 (dolist (et (list* '(integer -1 200) '(integer -256 1)
3343 '(integer 0 128)
3344 '(integer 0 (128))
3345 '(double-float 0d0 (1d0))
3346 '(single-float (0s0) (1s0))
3347 '(or (eql 1d0) (eql 10d0))
3348 '(member 1 2 10)
3349 '(complex (member 10 20))
3350 '(complex (member 10d0 20d0))
3351 '(complex (member 10s0 20s0))
3352 '(or integer double-float)
3353 '(mod 1)
3354 '(member #\a #\b)
3355 '(eql #\a)
3356 #+sb-unicode 'extended-char
3357 #+sb-unicode '(eql #\cyrillic_small_letter_yu)
3358 sb-kernel::*specialized-array-element-types*))
3359 (when et
3360 (let* ((v (make-array 3 :element-type et))
3361 (fun (compile nil `(lambda ()
3362 (list
3363 (if (typep ,v '(simple-array ,et (*)))
3364 :good
3365 :bad)
3366 (if (typep (elt ,v 0) '(simple-array ,et (*)))
3367 :bad
3368 :good))))))
3369 (assert (equal '(:good :good) (funcall fun)))))))
3370
3371 (with-test (:name :truncate-float)
3372 (let ((s (compile nil `(lambda (x)
3373 (declare (single-float x))
3374 (truncate x))))
3375 (d (compile nil `(lambda (x)
3376 (declare (double-float x))
3377 (truncate x))))
3378 (s-inlined (compile nil '(lambda (x)
3379 (declare (type (single-float 0.0s0 1.0s0) x))
3380 (truncate x))))
3381 (d-inlined (compile nil '(lambda (x)
3382 (declare (type (double-float 0.0d0 1.0d0) x))
3383 (truncate x)))))
3384 ;; Check that there is no generic arithmetic
3385 (assert (not (search "GENERIC"
3386 (with-output-to-string (out)
3387 (disassemble s :stream out)))))
3388 (assert (not (search "GENERIC"
3389 (with-output-to-string (out)
3390 (disassemble d :stream out)))))
3391 ;; Check that we actually inlined the call when we were supposed to.
3392 (assert (not (search "UNARY-TRUNCATE"
3393 (with-output-to-string (out)
3394 (disassemble s-inlined :stream out)))))
3395 (assert (not (search "UNARY-TRUNCATE"
3396 (with-output-to-string (out)
3397 (disassemble d-inlined :stream out)))))))
3398
3399 (with-test (:name :make-array-unnamed-dimension-leaf)
3400 (let ((fun (compile nil `(lambda (stuff)
3401 (make-array (map 'list 'length stuff))))))
3402 (assert (equalp #2A((0 0 0) (0 0 0))
3403 (funcall fun '((1 2) (1 2 3)))))))
3404
3405 (with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
3406 (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3407 integer-decode-float))
3408 (let ((fun (compile nil `(lambda (x)
3409 (declare (optimize safety))
3410 (,name x)
3411 nil))))
3412 (flet ((test (arg)
3413 (unless (eq :error
3414 (handler-case
3415 (funcall fun arg)
3416 (error () :error)))
3417 (error "(~S ~S) did not error"
3418 name arg))))
3419 ;; No error
3420 (funcall fun 1.0)
3421 ;; Error
3422 (test 'not-a-float)
3423 (when (member name '(decode-float integer-decode-float))
3424 (test sb-ext:single-float-positive-infinity))))))
3425
3426 (with-test (:name :sap-ref-16)
3427 (let* ((fun (compile nil `(lambda (x y)
3428 (declare (type sb-sys:system-area-pointer x)
3429 (type (integer 0 100) y))
3430 (sb-sys:sap-ref-16 x (+ 4 y)))))
3431 (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3432 '(simple-array (unsigned-byte 8) (*))))
3433 (sap (sb-sys:vector-sap vector))
3434 (ret (funcall fun sap 0)))
3435 ;; test for either endianness
3436 (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
3437
3438 (with-test (:name :coerce-type-warning)
3439 (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3440 (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3441 (multiple-value-bind (fun warningsp failurep)
3442 (compile nil `(lambda (x)
3443 (declare (type simple-vector x))
3444 (coerce x '(vector ,type))))
3445 (assert (null warningsp))
3446 (assert (null failurep))
3447 (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
3448
3449 (with-test (:name :truncate-double-float)
3450 (let ((fun (compile nil `(lambda (x)
3451 (multiple-value-bind (q r)
3452 (truncate (coerce x 'double-float))
3453 (declare (type unsigned-byte q)
3454 (type double-float r))
3455 (list q r))))))
3456 (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
3457
3458 (with-test (:name :set-slot-value-no-warning)
3459 (let ((notes 0))
3460 (handler-bind ((warning #'error)
3461 (sb-ext:compiler-note (lambda (c)
3462 (declare (ignore c))
3463 (incf notes))))
3464 (compile nil `(lambda (x y)
3465 (declare (optimize speed safety))
3466 (setf (slot-value x 'bar) y))))
3467 (assert (= 1 notes))))
3468
3469 (with-test (:name :concatenate-string-opt)
3470 (flet ((test (type grep)
3471 (let* ((fun (compile nil `(lambda (a b c d e)
3472 (concatenate ',type a b c d e))))
3473 (args '("foo" #(#\.) "bar" (#\-) "quux"))
3474 (res (apply fun args)))
3475 (assert (search grep (with-output-to-string (out)
3476 (disassemble fun :stream out))))
3477 (assert (equal (apply #'concatenate type args)
3478 res))
3479 (assert (typep res type)))))
3480 (test 'string "%CONCATENATE-TO-STRING")
3481 (test 'simple-string "%CONCATENATE-TO-STRING")
3482 (test 'base-string "%CONCATENATE-TO-BASE-STRING")
3483 (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
3484
3485 (with-test (:name :satisfies-no-local-fun)
3486 (let ((fun (compile nil `(lambda (arg)
3487 (labels ((local-not-global-bug (x)
3488 t)
3489 (bar (x)
3490 (typep x '(satisfies local-not-global-bug))))
3491 (bar arg))))))
3492 (assert (eq 'local-not-global-bug
3493 (handler-case
3494 (funcall fun 42)
3495 (undefined-function (c)
3496 (cell-error-name c)))))))
3497
3498 ;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
3499 ;;; argument that is a complex structure (needing make-load-form
3500 ;;; processing) failed an AVER. The first attempt at a fix caused
3501 ;;; doing the same in-core to break.
3502 (with-test (:name :bug-310132)
3503 (compile nil '(lambda (&optional (foo #p"foo/bar")))))
3504
3505 (with-test (:name :bug-309129)
3506 (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
3507 (warningp nil)
3508 (fun (handler-bind ((warning (lambda (c)
3509 (setf warningp t) (muffle-warning c))))
3510 (compile nil src))))
3511 (assert warningp)
3512 (handler-case (funcall fun #(1))
3513 (type-error (c)
3514 ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
3515 ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
3516 (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
3517 (:no-error (&rest values)
3518 (declare (ignore values))
3519 (error "no error")))))
3520
3521 (with-test (:name :unary-round-type-derivation)
3522 (let* ((src '(lambda (zone)
3523 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
3524 (declare (ignore h))
3525 (round (* 60.0 m)))))
3526 (fun (compile nil src)))
3527 (assert (= (funcall fun 0.5) 30))))
3528
3529 (with-test (:name :bug-525949)
3530 (let* ((src '(lambda ()
3531 (labels ((always-one () 1)
3532 (f (z)
3533 (let ((n (funcall z)))
3534 (declare (fixnum n))
3535 (the double-float (expt n 1.0d0)))))
3536 (f #'always-one))))
3537 (warningp nil)
3538 (fun (handler-bind ((warning (lambda (c)
3539 (setf warningp t) (muffle-warning c))))
3540 (compile nil src))))
3541 (assert (not warningp))
3542 (assert (= 1.0d0 (funcall fun)))))
3543
3544 (with-test (:name :%array-data-vector-type-derivation)
3545 (let* ((f (compile nil
3546 `(lambda (ary)
3547 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3548 (setf (aref ary 0 0) 0))))
3549 (text (with-output-to-string (s)
3550 (disassemble f :stream s))))
3551 (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
3552
3553 (with-test (:name :array-storage-vector-type-derivation)
3554 (let ((f (compile nil
3555 `(lambda (ary)
3556 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3557 (ctu:compiler-derived-type (array-storage-vector ary))))))
3558 (assert (equal '(simple-array (unsigned-byte 32) (9))
3559 (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
3560
3561 (with-test (:name :bug-523612)
3562 (let ((fun
3563 (compile nil
3564 `(lambda (&key toff)
3565 (make-array 3 :element-type 'double-float
3566 :initial-contents
3567 (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
3568 (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
3569 (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
3570
3571 (with-test (:name :bug-309788)
3572 (let ((fun
3573 (compile nil
3574 `(lambda (x)
3575 (declare (optimize speed))
3576 (let ((env nil))
3577 (typep x 'fixnum env))))))
3578 (assert (not (ctu:find-named-callees fun)))))
3579
3580 (with-test (:name :bug-309124)
3581 (let ((fun
3582 (compile nil
3583 `(lambda (x)
3584 (declare (integer x))
3585 (declare (optimize speed))
3586 (cond ((typep x 'fixnum)
3587 "hala")
3588 ((typep x 'fixnum)
3589 "buba")
3590 ((typep x 'bignum)
3591 "hip")
3592 (t
3593 "zuz"))))))
3594 (assert (equal (list "hala" "hip")
3595 (sort (ctu:find-code-constants fun :type 'string)
3596 #'string<)))))
3597
3598 (with-test (:name :bug-316078)
3599 (let ((fun
3600 (compile nil
3601 `(lambda (x)
3602 (declare (type (and simple-bit-vector (satisfies bar)) x)
3603 (optimize speed))
3604 (elt x 5)))))
3605 (assert (not (ctu:find-named-callees fun)))
3606 (assert (= 1 (funcall fun #*000001)))
3607 (assert (= 0 (funcall fun #*000010)))))
3608
3609 (with-test (:name :mult-by-one-in-float-acc-zero)
3610 (assert (eql 1.0 (funcall (compile nil `(lambda (x)
3611 (declare (optimize (sb-c::float-accuracy 0)))
3612 (* x 1.0)))
3613 1)))
3614 (assert (eql -1.0 (funcall (compile nil `(lambda (x)
3615 (declare (optimize (sb-c::float-accuracy 0)))
3616 (* x -1.0)))
3617 1)))
3618 (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
3619 (declare (optimize (sb-c::float-accuracy 0)))
3620 (* x 1.0d0)))
3621 1)))
3622 (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
3623 (declare (optimize (sb-c::float-accuracy 0)))
3624 (* x -1.0d0)))
3625 1))))
3626
3627 (with-test (:name :dotimes-non-integer-counter-value)
3628 (assert-error (dotimes (i 8.6)) type-error))
3629
3630 (with-test (:name :bug-454681)
3631 ;; This used to break due to reference to a dead lambda-var during
3632 ;; inline expansion.
3633 (assert (compile nil
3634 `(lambda ()
3635 (multiple-value-bind (iterator+977 getter+978)
3636 (does-not-exist-but-does-not-matter)
3637 (flet ((iterator+976 ()
3638 (funcall iterator+977)))
3639 (declare (inline iterator+976))
3640 (let ((iterator+976 #'iterator+976))
3641 (funcall iterator+976))))))))
3642
3643 (with-test (:name :complex-float-local-fun-args)
3644 ;; As of 1.0.27.14, the lambda below failed to compile due to the
3645 ;; compiler attempting to pass unboxed complex floats to Z and the
3646 ;; MOVE-ARG method not expecting the register being used as a
3647 ;; temporary frame pointer. Reported by sykopomp in #lispgames,
3648 ;; reduced test case provided by _3b`.
3649 (compile nil '(lambda (a)
3650 (labels ((z (b c)
3651 (declare ((complex double-float) b c))
3652 (* b (z b c))))
3653 (loop for i below 10 do
3654 (setf a (z a a)))))))
3655
3656 (with-test (:name :bug-309130)
3657 (assert (eq :warning
3658 (handler-case
3659 (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
3660 ((and warning (not style-warning)) ()
3661 :warning))))
3662 (assert (eq :warning
3663 (handler-case
3664 (compile nil `(lambda (x)
3665 (declare (optimize (debug 0)))
3666 (declare (type vector x))
3667 (list (fill-pointer x) (svref x 1))))
3668 ((and warning (not style-warning)) ()
3669 :warning))))
3670 (assert (eq :warning
3671 (handler-case
3672 (compile nil `(lambda (x)
3673 (list (vector-push (svref x 0) x))))
3674 ((and warning (not style-warning)) ()
3675 :warning))))
3676 (assert (eq :warning
3677 (handler-case
3678 (compile nil `(lambda (x)
3679 (list (vector-push-extend (svref x 0) x))))
3680 ((and warning (not style-warning)) ()
3681 :warning)))))
3682
3683 (with-test (:name :bug-646796)
3684 (assert 42
3685 (funcall
3686 (compile nil
3687 `(lambda ()
3688 (load-time-value (the (values fixnum) 42)))))))
3689
3690 (with-test (:name :bug-654289)
3691 ;; Test that compile-times don't explode when quoted constants
3692 ;; get big.
3693 (labels ((time-n (n)
3694 (gc :full t) ; Let's not confuse the issue with GC
3695 (let* ((tree (make-tree (expt 10 n) nil))
3696 (t0 (get-internal-run-time))
3697 (f (compile nil `(lambda (x) (eq x (quote ,tree)))))
3698 (t1 (get-internal-run-time)))
3699 (assert (funcall f tree))
3700 (- t1 t0)))
3701 (make-tree (n acc)
3702 (cond ((zerop n) acc)
3703 (t (make-tree (1- n) (cons acc acc))))))
3704 (let* ((times (loop for i from 0 upto 4
3705 collect (time-n i)))
3706 (max-small (reduce #'max times :end 3))
3707 (max-big (reduce #'max times :start 3)))
3708 ;; This way is hopefully fairly CPU-performance insensitive.
3709 (unless (> (+ (truncate internal-time-units-per-second 10)
3710 (* 2 max-small))
3711 max-big)
3712 (error "Bad scaling or test? ~S" times)))))
3713
3714 (with-test (:name :bug-309063)
3715 (let ((fun (compile nil `(lambda (x)
3716 (declare (type (integer 0 0) x))
3717 (ash x 100)))))
3718 (assert (zerop (funcall fun 0)))))
3719
3720 (with-test (:name :bug-655872)
3721 (let ((f (compile nil `(lambda (x)
3722 (declare (optimize (safety 3)))
3723 (aref (locally (declare (optimize (safety 0)))
3724 (coerce x '(simple-vector 128)))
3725 60))))
3726 (long (make-array 100 :element-type 'fixnum)))
3727 (dotimes (i 100)
3728 (setf (aref long i) i))
3729 ;; 1. COERCE doesn't check the length in unsafe code.
3730 (assert (eql 60 (funcall f long)))
3731 ;; 2. The compiler doesn't trust the length from COERCE
3732 (assert (eq :caught
3733 (handler-case
3734 (funcall f (list 1 2 3))
3735 (sb-int:invalid-array-index-error (e)
3736 (assert (eql 60 (type-error-datum e)))
3737 (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
3738 :caught))))))
3739
3740 (with-test (:name :bug-655203-regression)
3741 (let ((fun (compile nil
3742 `(LAMBDA (VARIABLE)
3743 (LET ((CONTINUATION
3744 (LAMBDA
3745 (&OPTIONAL DUMMY &REST OTHER)
3746 (DECLARE (IGNORE OTHER))
3747 (PRIN1 DUMMY)
3748 (PRIN1 VARIABLE))))
3749 (FUNCALL CONTINUATION (LIST 1 2)))))))
3750 ;; This used to signal a bogus type-error.
3751 (assert (equal (with-output-to-string (*standard-output*)
3752 (funcall fun t))
3753 "(1 2)T"))))
3754
3755 (with-test (:name :constant-concatenate-compile-time)
3756 (flet ((make-lambda (n)
3757 `(lambda (x)
3758 (declare (optimize (speed 3) (space 0)))
3759 (concatenate 'string x ,(make-string n)))))
3760 (let* ((l0 (make-lambda 1))
3761 (l1 (make-lambda 10))
3762 (l2 (make-lambda 100))
3763 (l3 (make-lambda 1000))
3764 (t0 (get-internal-run-time))
3765 (f0 (compile nil l0))
3766 (t1 (get-internal-run-time))
3767 (f1 (compile nil l1))
3768 (t2 (get-internal-run-time))
3769 (f2 (compile nil l2))
3770 (t3 (get-internal-run-time))
3771 (f3 (compile nil l3))
3772 (t4 (get-internal-run-time))
3773 (d0 (- t1 t0))
3774 (d1 (- t2 t1))
3775 (d2 (- t3 t2))
3776 (d3 (- t4 t3))
3777 (short-avg (/ (+ d0 d1 d2) 3)))
3778 (assert (and f1 f2 f3))
3779 (assert (< d3 (* 10 short-avg))))))
3780
3781 (with-test (:name :bug-384892)
3782 (assert (equal
3783 ;; The assertion that BOOLEAN becomes (MEMBER T NIL)
3784 ;; is slightly brittle, but the rest of the
3785 ;; assertion is ok.
3786 '(function (fixnum fixnum &key (:k1 (member t nil)))
3787 (values (member t) &optional))
3788 (sb-kernel:%simple-fun-type
3789 (compile nil `(lambda (x y &key k1)
3790 (declare (fixnum x y))
3791 (declare (boolean k1))
3792 (declare (ignore x y k1))
3793 t))))))
3794
3795 (with-test (:name :bug-309448)
3796 ;; Like all tests trying to verify that something doesn't blow up
3797 ;; compile-times this is bound to be a bit brittle, but at least
3798 ;; here we try to establish a decent baseline.
3799 (labels ((time-it (lambda want &optional times)
3800 (gc :full t) ; let's keep GCs coming from other code out...
3801 (let* ((start (get-internal-run-time))
3802 (iterations 0)
3803 (fun (if times
3804 (loop repeat times
3805 for result = (compile nil lambda)
3806 finally (return result))
3807 (loop for result = (compile nil lambda)
3808 do (incf iterations)
3809 until (> (get-internal-run-time) (+ start 10))
3810 finally (return result))))
3811 (end (get-internal-run-time))
3812 (got (funcall fun)))
3813 (unless (eql want got)
3814 (error "wanted ~S, got ~S" want got))
3815 (values (- end start) iterations)))
3816 (test-it (simple result1 complex result2)
3817 (multiple-value-bind (time-simple iterations)
3818 (time-it simple result1)
3819 (assert (>= (* 10 (1+ time-simple))
3820 (time-it complex result2 iterations))))))
3821 ;; This is mostly identical as the next one, but doesn't create
3822 ;; hairy unions of numeric types.
3823 (test-it `(lambda ()
3824 (labels ((bar (baz bim)
3825 (let ((n (+ baz bim)))
3826 (* n (+ n 1) bim))))
3827 (let ((a (bar 1 1))
3828 (b (bar 1 1))
3829 (c (bar 1 1)))
3830 (- (+ a b) c))))
3831 6
3832 `(lambda ()
3833 (labels ((bar (baz bim)
3834 (let ((n (+ baz bim)))
3835 (* n (+ n 1) bim))))
3836 (let ((a (bar 1 1))
3837 (b (bar 1 5))
3838 (c (bar 1 15)))
3839 (- (+ a b) c))))
3840 -3864)
3841 (test-it `(lambda ()
3842 (labels ((sum-d (n)
3843 (let ((m (truncate 999 n)))
3844 (/ (* n m (1+ m)) 2))))
3845 (- (+ (sum-d 3)
3846 (sum-d 3))
3847 (sum-d 3))))
3848 166833
3849 `(lambda ()
3850 (labels ((sum-d (n)
3851 (let ((m (truncate 999 n)))
3852 (/ (* n m (1+ m)) 2))))
3853 (- (+ (sum-d 3)
3854 (sum-d 5))
3855 (sum-d 15))))
3856 233168)))
3857
3858 (with-test (:name :regression-1.0.44.34)
3859 (compile nil '(lambda (z &rest args)
3860 (declare (dynamic-extent args))
3861 (flet ((foo (w v) (list v w)))
3862 (setq z 0)
3863 (flet ((foo ()
3864 (foo z args)))
3865 (declare (sb-int:truly-dynamic-extent #'foo))
3866 (call #'foo nil))))))
3867
3868 (with-test (:name :bug-713626)
3869 (let ((f (eval '(constantly 42))))
3870 (handler-bind ((warning #'error))
3871 (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
3872
3873 (with-test (:name :known-fun-allows-other-keys)
3874 (handler-bind ((warning #'error))
3875 (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
3876 (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
3877
3878 (with-test (:name :bug-551227)
3879 ;; This function causes constraint analysis to perform a
3880 ;; ref-substitution that alters the A referred to in (G A) at in the
3881 ;; consequent of the IF to refer to be NUMBER, from the
3882 ;; LET-converted inline-expansion of MOD. This leads to attempting
3883 ;; to CLOSE-OVER a variable that simply isn't in scope when it is
3884 ;; referenced.
3885 (compile nil '(lambda (a)
3886 (if (let ((s a))
3887 (block :block
3888 (map nil
3889 (lambda (e)
3890 (return-from :block
3891 (f (mod a e))))
3892 s)))
3893 (g a)))))
3894
3895 (with-test (:name :funcall-lambda-inlined)
3896 (assert (not
3897 (ctu:find-code-constants
3898 (compile nil
3899 `(lambda (x y)
3900 (+ x (funcall (lambda (z) z) y))))
3901 :type 'function))))
3902
3903 (with-test (:name :bug-720382)
3904 (let ((w 0))
3905 (let ((f
3906 (handler-bind (((and warning (not style-warning))
3907 (lambda (c) (incf w))))
3908 (compile nil `(lambda (b) ((lambda () b) 1))))))
3909 (assert (= w 1))
3910 (assert (eq :error
3911 (handler-case (funcall f 0)
3912 (error () :error)))))))
3913
3914 (with-test (:name :multiple-args-to-function)
3915 (let ((form `(flet ((foo (&optional (x 13)) x))
3916 (funcall (function foo 42))))
3917 #+sb-eval (*evaluator-mode* :interpret))
3918 #+sb-eval
3919 (assert (eq :error
3920 (handler-case (eval form)
3921 (error () :error))))
3922 (multiple-value-bind (fun warn fail)
3923 (compile nil `(lambda () ,form))
3924 (assert (and warn fail))
3925 (assert (eq :error
3926 (handler-case (funcall fun)
3927 (error () :error)))))))
3928
3929 ;;; This doesn't test LVAR-FUN-IS directly, but captures it
3930 ;;; pretty accurately anyways.
3931 (with-test (:name :lvar-fun-is)
3932 (dolist (fun (list
3933 (lambda (x) (member x x :test #'eq))
3934 (lambda (x) (member x x :test 'eq))
3935 (lambda (x) (member x x :test #.#'eq))))
3936 (assert (equal (list #'sb-kernel:%member-eq)
3937 (ctu:find-named-callees fun))))
3938 (dolist (fun (list
3939 (lambda (x)
3940 (declare (notinline eq))
3941 (member x x :test #'eq))
3942 (lambda (x)
3943 (declare (notinline eq))
3944 (member x x :test 'eq))
3945 (lambda (x)
3946 (declare (notinline eq))
3947 (member x x :test #.#'eq))))
3948 (assert (member #'sb-kernel:%member-test
3949 (ctu:find-named-callees fun)))))
3950
3951 (with-test (:name :delete-to-delq-opt)
3952 (dolist (fun (list (lambda (x y)
3953 (declare (list y))
3954 (delete x y :test #'eq))
3955 (lambda (x y)
3956 (declare (fixnum x) (list y))
3957 (delete x y))
3958 (lambda (x y)
3959 (declare (symbol x) (list y))
3960 (delete x y :test #'eql))))
3961 (assert (equal (list #'sb-int:delq)
3962 (ctu:find-named-callees fun)))))
3963
3964 (with-test (:name :bug-767959)
3965 ;; This used to signal an error.
3966 (compile nil `(lambda ()
3967 (declare (optimize sb-c:store-coverage-data))
3968 (assoc
3969 nil
3970 '((:ordinary . ordinary-lambda-list))))))
3971
3972 ;; This test failed formerly because the source transform of TYPEP would be
3973 ;; disabled when storing coverage data, thus giving no semantics to
3974 ;; expressions such as (TYPEP x 'INTEGER). The compiler could therefore not
3975 ;; prove that the else clause of the IF is unreachable - which it must be
3976 ;; since X is asserted to be fixnum. The conflicting requirement on X
3977 ;; that it be acceptable to LENGTH signaled a full warning.
3978 ;; Nobody on sbcl-devel could remember why the source transform was disabled,
3979 ;; but nobody disagreed with undoing the disabling.
3980 (with-test (:name :sb-cover-and-typep)
3981 (multiple-value-bind (fun warnings-p failure-p)
3982 (compile nil '(lambda (x)
3983 (declare (fixnum x) (optimize sb-c:store-coverage-data))
3984 (if (typep x 'integer) x (length x))))
3985 (assert (and fun (not warnings-p) (not failure-p)))))
3986
3987 (with-test (:name :member-on-long-constant-list)
3988 ;; This used to blow stack with a sufficiently long list.
3989 (let ((cycle (list t)))
3990 (nconc cycle cycle)
3991 (compile nil `(lambda (x)
3992 (member x ',cycle)))))
3993
3994 (with-test (:name :bug-722734)
3995 (assert-error
3996 (funcall (compile
3997 nil
3998 '(lambda ()
3999 (eql (make-array 6)
4000 (list unbound-variable-1 unbound-variable-2)))))))
4001
4002 (with-test (:name :bug-771673)
4003 (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar))))
4004 ;; Make sure the compiler doesn't use THE, and check that setf-expansions
4005 ;; work.
4006 (let ((f (compile nil `(lambda (x y)
4007 (setf (truly-the fixnum (car x)) y)))))
4008 (let* ((cell (cons t t)))
4009 (funcall f cell :ok)
4010 (assert (equal '(:ok . t) cell)))))
4011
4012 (with-test (:name (:bug-793771 +))
4013 (let ((f (compile nil `(lambda (x y)
4014 (declare (type (single-float 2.0) x)
4015 (type (single-float (0.0)) y))
4016 (+ x y)))))
4017 (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
4018 (values (single-float 2.0) &optional))
4019 (sb-kernel:%simple-fun-type f)))))
4020
4021 (with-test (:name (:bug-793771 -))
4022 (let ((f (compile nil `(lambda (x y)
4023 (declare (type (single-float * 2.0) x)
4024 (type (single-float (0.0)) y))
4025 (- x y)))))
4026 (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
4027 (values (single-float * 2.0) &optional))
4028 (sb-kernel:%simple-fun-type f)))))
4029
4030 (with-test (:name (:bug-793771 *))
4031 (let ((f (compile nil `(lambda (x)
4032 (declare (type (single-float (0.0)) x))
4033 (* x 0.1)))))
4034 (assert (equal `(function ((single-float (0.0)))
4035 (values (or (member 0.0) (single-float (0.0))) &optional))
4036 (sb-kernel:%simple-fun-type f)))))
4037
4038 (with-test (:name (:bug-793771 /))
4039 (let ((f (compile nil `(lambda (x)
4040 (declare (type (single-float (0.0)) x))
4041 (/ x 3.0)))))
4042 (assert (equal `(function ((single-float (0.0)))
4043 (values (or (member 0.0) (single-float (0.0))) &optional))
4044 (sb-kernel:%simple-fun-type f)))))
4045
4046 (with-test (:name (:bug-486812 single-float))
4047 (compile nil `(lambda ()
4048 (sb-kernel:make-single-float -1))))
4049
4050 (with-test (:name (:bug-486812 double-float))
4051 (compile nil `(lambda ()
4052 (sb-kernel:make-double-float -1 0))))
4053
4054 (with-test (:name :bug-729765)
4055 (compile nil `(lambda (a b)
4056 (declare ((integer 1 1) a)
4057 ((integer 0 1) b)
4058 (optimize debug))
4059 (lambda () (< b a)))))
4060
4061 ;; Actually tests the assembly of RIP-relative operands to comparison
4062 ;; functions (one of the few x86 instructions that have extra bytes
4063 ;; *after* the mem operand's effective address, resulting in a wrong
4064 ;; offset).
4065 (with-test (:name :cmpps)
4066 (let ((foo (compile nil `(lambda (x)
4067 (= #C(2.0 3.0) (the (complex single-float) x))))))
4068 (assert (funcall foo #C(2.0 3.0)))
4069 (assert (not (funcall foo #C(1.0 2.0))))))
4070
4071 (with-test (:name :cmppd)
4072 (let ((foo (compile nil `(lambda (x)
4073 (= #C(2d0 3d0) (the (complex double-float) x))))))
4074 (assert (funcall foo #C(2d0 3d0)))
4075 (assert (not (funcall foo #C(1d0 2d0))))))
4076
4077 (with-test (:name :lvar-externally-checkable-type-nil)
4078 ;; Used to signal a BUG during compilation.
4079 (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
4080 (multiple-value-bind (i p) (funcall fun :start)
4081 (assert (= 2321321 i))
4082 (assert (= 8 p)))
4083 (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
4084 (assert (not i))
4085 (assert (typep e 'type-error)))))
4086
4087 (with-test (:name :simple-type-error-in-bound-propagation-a)
4088 (compile nil `(lambda (i)
4089 (declare (unsigned-byte i))
4090 (expt 10 (expt 7 (- 2 i))))))
4091
4092 (with-test (:name :simple-type-error-in-bound-propagation-b)
4093 (assert (equal `(FUNCTION (UNSIGNED-BYTE)
4094 (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
4095 (sb-kernel:%simple-fun-type
4096 (compile nil `(lambda (i)
4097 (declare (unsigned-byte i))
4098 (cos (expt 10 (+ 4096 i)))))))))
4099
4100 (with-test (:name :fixed-%more-arg-values)
4101 (let ((fun (compile nil `(lambda (&rest rest)
4102 (declare (optimize (safety 0)))
4103 (apply #'cons rest)))))
4104 (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
4105
4106 (with-test (:name :bug-826970)
4107 (let ((fun (compile nil `(lambda (a b c)
4108 (declare (type (member -2 1) b))
4109 (array-in-bounds-p a 4 b c)))))
4110 (assert (funcall fun (make-array '(5 2 2)) 1 1))))
4111
4112 (with-test (:name :bug-826971)
4113 (let* ((foo "foo")
4114 (fun (compile nil `(lambda (p1 p2)
4115 (schar (the (eql ,foo) p1) p2)))))
4116 (assert (eql #\f (funcall fun foo 0)))))
4117
4118 (with-test (:name :bug-738464)
4119 (multiple-value-bind (fun warn fail)
4120 (compile nil `(lambda ()
4121 (flet ((foo () 42))
4122 (declare (ftype non-function-type foo))
4123 (foo))))
4124 (assert (eql 42 (funcall fun)))
4125 (assert (and warn (not fail)))))
4126
4127 (with-test (:name :bug-832005)
4128 (let ((fun (compile nil `(lambda (x)
4129 (declare (type (complex single-float) x))
4130 (+ #C(0.0 1.0) x)))))
4131 (assert (= (funcall fun #C(1.0 2.0))
4132 #C(1.0 3.0)))))
4133
4134 ;; A refactoring 1.0.12.18 caused lossy computation of primitive
4135 ;; types for member types.
4136 (with-test (:name :member-type-primitive-type)
4137 (let ((fun (compile nil `(lambda (p1 p2 p3)
4138 (if p1
4139 (the (member #c(1.2d0 1d0)) p2)
4140 (the (eql #c(1.0 1.0)) p3))))))
4141 (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
4142 #c(1.2d0 1.0d0)))))
4143
4144 ;; Fall-through jump elimination made control flow fall through to trampolines.
4145 ;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
4146 ;; reproduced below (triggered a corruption warning and a memory fault).
4147 (with-test (:name :bug-883500)
4148 (funcall (compile nil `(lambda (a)
4149 (declare (type (integer -50 50) a))
4150 (declare (optimize (speed 0)))
4151 (mod (mod a (min -5 a)) 5)))
4152 1))
4153
4154 ;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
4155 #+sb-unicode
4156 (with-test (:name :bug-883519)
4157 (compile nil `(lambda (x)
4158 (declare (type character x))
4159 (eql x #\U0010FFFF))))
4160
4161 ;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
4162 (with-test (:name :bug-887220)
4163 (let ((incfer (compile
4164 nil
4165 `(lambda (vector index)
4166 (declare (type (simple-array sb-ext:word (4))
4167 vector)
4168 (type (mod 4) index))
4169 (sb-ext:atomic-incf (aref vector index) 1)
4170 vector))))
4171 (assert (equalp (funcall incfer
4172 (make-array 4 :element-type 'sb-ext:word
4173 :initial-element 0)
4174 1)
4175 #(0 1 0 0)))))
4176
4177 (with-test (:name :catch-interferes-with-debug-names)
4178 (let ((fun (funcall
4179 (compile nil
4180 `(lambda ()
4181 (catch 'out
4182 (flet ((foo ()
4183 (throw 'out (lambda () t))))
4184 (foo))))))))
4185 (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
4186
4187 (with-test (:name :interval-div-signed-zero)
4188 (let ((fun (compile nil
4189 `(Lambda (a)
4190 (declare (type (member 0 -272413371076) a))
4191 (ffloor (the number a) -63243.127451934015d0)))))
4192 (multiple-value-bind (q r) (funcall fun 0)
4193 (assert (eql -0d0 q))
4194 (assert (eql 0d0 r)))))
4195
4196 (with-test (:name :non-constant-keyword-typecheck)
4197 (let ((fun (compile nil
4198 `(lambda (p1 p3 p4)
4199 (declare (type keyword p3))
4200 (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
4201 (assert (funcall fun (cons 1.0 2.0) :test '=))))
4202
4203 (with-test (:name :truncate-wild-values)
4204 (multiple-value-bind (q r)
4205 (handler-bind ((warning #'error))
4206 (let ((sb-c::*check-consistency* t))
4207 (funcall (compile nil
4208 `(lambda (a)
4209 (declare (type (member 1d0 2d0) a))
4210 (block return-value-tag
4211 (funcall
4212 (the function
4213 (catch 'debug-catch-tag
4214 (return-from return-value-tag
4215 (progn (truncate a)))))))))
4216 2d0)))
4217 (assert (eql 2 q))
4218 (assert (eql 0d0 r))))
4219
4220 (with-test (:name :boxed-fp-constant-for-full-call)
4221 (let ((fun (compile nil
4222 `(lambda (x)
4223 (declare (double-float x))
4224 (unknown-fun 1.0d0 (+ 1.0d0 x))))))
4225 (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
4226
4227 (with-test (:name :only-one-boxed-constant-for-multiple-uses)
4228 (let* ((big (1+ most-positive-fixnum))
4229 (fun (compile nil
4230 `(lambda (x)
4231 (unknown-fun ,big (+ ,big x))))))
4232 (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
4233
4234 (with-test (:name :fixnum+float-coerces-fixnum
4235 :skipped-on :x86)
4236 (let ((fun (compile nil
4237 `(lambda (x y)
4238 (declare (fixnum x)
4239 (single-float y))
4240 (+ x y)))))
4241 (assert (not (ctu:find-named-callees fun)))
4242 (assert (not (search "GENERIC"
4243 (with-output-to-string (s)
4244 (disassemble fun :stream s)))))))
4245
4246 (with-test (:name :bug-803508)
4247 (compile nil `(lambda ()
4248 (print
4249 (lambda (bar)
4250 (declare (dynamic-extent bar))
4251 (foo bar))))))
4252
4253 (with-test (:name :bug-803508-b)
4254 (compile nil `(lambda ()
4255 (list
4256 (lambda (bar)
4257 (declare (dynamic-extent bar))
4258 (foo bar))))))
4259
4260 (with-test (:name :bug-803508-c)
4261 (compile nil `(lambda ()
4262 (list
4263 (lambda (bar &optional quux)
4264 (declare (dynamic-extent bar quux))
4265 (foo bar quux))))))
4266
4267 (with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
4268 (compile nil `(lambda (b c d)
4269 (declare (type (integer -20545789 207590862) c))
4270 (declare (type (integer -1 -1) d))
4271 (let ((i (unwind-protect 32 (shiftf d -1))))
4272 (or (if (= d c) 2 (= 3 b)) 4)))))
4273
4274 (with-test (:name :bug-913232)
4275 (compile nil `(lambda (x)
4276 (declare (optimize speed)
4277 (type (or (and (or (integer -100 -50)
4278 (integer 100 200)) (satisfies foo))
4279 (and (or (integer 0 10) (integer 20 30)) a)) x))
4280 x))
4281 (compile nil `(lambda (x)
4282 (declare (optimize speed)
4283 (type (and fixnum a) x))
4284 x)))
4285
4286 (with-test (:name :bug-959687)
4287 (multiple-value-bind (fun warn fail)
4288 (compile nil `(lambda (x)
4289 (case x
4290 (t
4291 :its-a-t)
4292 (otherwise
4293 :somethign-else))))
4294 (assert (and warn fail))
4295 (assert (not (ignore-errors (funcall fun t)))))
4296 (multiple-value-bind (fun warn fail)
4297 (compile nil `(lambda (x)
4298 (case x
4299 (otherwise
4300 :its-an-otherwise)
4301 (t
4302 :somethign-else))))
4303 (assert (and warn fail))
4304 (assert (not (ignore-errors (funcall fun t))))))
4305
4306 (with-test (:name :bug-924276)
4307 (assert (eq :style-warning
4308 (handler-case
4309 (compile nil `(lambda (a)
4310 (cons a (symbol-macrolet ((b 1))
4311 (declare (ignorable a))
4312 :c))))
4313 (style-warning ()
4314 :style-warning)))))
4315
4316 (with-test (:name :bug-974406)
4317 (let ((fun32 (compile nil `(lambda (x)
4318 (declare (optimize speed (safety 0)))
4319 (declare (type (integer 53 86) x))
4320 (logand (+ x 1032791128) 11007078467))))
4321 (fun64 (compile nil `(lambda (x)
4322 (declare (optimize speed (safety 0)))
4323 (declare (type (integer 53 86) x))
4324 (logand (+ x 1152921504606846975)
4325 38046409652025950207)))))
4326 (assert (= (funcall fun32 61) 268574721))
4327 (assert (= (funcall fun64 61) 60)))
4328 (let (result)
4329 (do ((width 5 (1+ width)))
4330 ((= width 130))
4331 (dotimes (extra 4)
4332 (let ((fun (compile nil `(lambda (x)
4333 (declare (optimize speed (safety 0)))
4334 (declare (type (integer 1 16) x))
4335 (logand
4336 (+ x ,(1- (ash 1 width)))
4337 ,(logior (ash 1 (+ width 1 extra))
4338 (1- (ash 1 width))))))))
4339 (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
4340 (push (cons width extra) result)))))
4341 (assert (null result))))
4342
4343 ;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
4344 ;; uses a MOV into memory or goes through a temporary register if the
4345 ;; value is larger than a certain number of bits. Check that it respects
4346 ;; the limits of immediate arguments to the MOV instruction (if not, the
4347 ;; assembler will fail an assertion) and doesn't have sign-extension
4348 ;; problems. (The test passes fixnum constants through the MOVE VOP
4349 ;; which calls MOVE-IMMEDIATE.)
4350 (with-test (:name :constant-fixnum-move)
4351 (let ((f (compile nil `(lambda (g)
4352 (funcall g
4353 ;; The first three args are
4354 ;; uninteresting as they are
4355 ;; passed in registers.
4356 1 2 3
4357 ,@(loop for i from 27 to 32
4358 collect (expt 2 i)))))))
4359 (assert (every #'plusp (funcall f #'list)))))
4360
4361 (with-test (:name (:malformed-ignore :lp-1000239))
4362 (assert-error
4363 (eval '(lambda () (declare (ignore (function . a)))))
4364 sb-int:simple-program-error)
4365 (assert-error
4366 (eval '(lambda () (declare (ignore (function a b)))))
4367 sb-int:simple-program-error)
4368 (assert-error
4369 (eval '(lambda () (declare (ignore (function)))))
4370 sb-int:simple-program-error)
4371 (assert-error
4372 (eval '(lambda () (declare (ignore (a)))))
4373 sb-int:simple-program-error)
4374 (assert-error
4375 (eval '(lambda () (declare (ignorable (a b)))))
4376 sb-int:simple-program-error))
4377
4378 (with-test (:name :malformed-type-declaraions)
4379 (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
4380
4381 (with-test (:name :compiled-program-error-escaped-source)
4382 (assert
4383 (handler-case
4384 (funcall (compile nil `(lambda () (lambda ("foo")))))
4385 (sb-int:compiled-program-error (e)
4386 (let ((source (read-from-string (sb-kernel::program-error-source e))))
4387 (equal source '#'(lambda ("foo"))))))))
4388
4389 (with-test (:name :escape-analysis-for-nlxs)
4390 (flet ((test (check lambda &rest args)
4391 (let* ((cell-note nil)
4392 (fun (handler-bind ((compiler-note
4393 (lambda (note)
4394 (when (search
4395 "Allocating a value-cell at runtime for"
4396 (princ-to-string note))
4397 (setf cell-note t)))))
4398 (compile nil lambda))))
4399 (assert (eql check cell-note))
4400 (if check
4401 (assert
4402 (eq :ok
4403 (handler-case
4404 (dolist (arg args nil)
4405 (setf fun (funcall fun arg)))
4406 (sb-int:simple-control-error (e)
4407 (when (equal
4408 (simple-condition-format-control e)
4409 "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
4410 :ok)))))
4411 (ctu:assert-no-consing (apply fun args))))))
4412 (test nil `(lambda (x)
4413 (declare (optimize speed))
4414 (block out
4415 (flet ((ex () (return-from out 'out!)))
4416 (typecase x
4417 (cons (or (car x) (ex)))
4418 (t (ex)))))) :foo)
4419 (test t `(lambda (x)
4420 (declare (optimize speed))
4421 (funcall
4422 (block nasty
4423 (flet ((oops () (return-from nasty t)))
4424 #'oops)))) t)
4425 (test t `(lambda (r)
4426 (declare (optimize speed))
4427 (block out
4428 (flet ((ex () (return-from out r)))
4429 (lambda (x)
4430 (typecase x
4431 (cons (or (car x) (ex)))
4432 (t (ex))))))) t t)
4433 (test t `(lambda (x)
4434 (declare (optimize speed))
4435 (flet ((eh (x)
4436 (flet ((meh () (return-from eh 'meh)))
4437 (lambda ()
4438 (typecase x
4439 (cons (or (car x) (meh)))
4440 (t (meh)))))))
4441 (funcall (eh x)))) t t)))
4442
4443 (with-test (:name (:bug-1050768 :symptom))
4444 ;; Used to signal an error.
4445 (compile nil
4446 `(lambda (string position)
4447 (char string position)
4448 (array-in-bounds-p string (1+ position)))))
4449
4450 (with-test (:name (:bug-1050768 :cause))
4451 (let ((types `((string string)
4452 ((or (simple-array character 24) (vector t 24))
4453 (or (simple-array character 24) (vector t))))))
4454 (dolist (pair types)
4455 (destructuring-bind (orig conservative) pair
4456 (assert sb-c::(type= (specifier-type cl-user::conservative)
4457 (conservative-type (specifier-type cl-user::orig))))))))
4458
4459 (with-test (:name (:smodular64 :wrong-width))
4460 (let ((fun (compile nil
4461 '(lambda (x)
4462 (declare (type (signed-byte 64) x))
4463 (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
4464 (assert (= (funcall fun 10038) -7033717698976955535))))
4465
4466 (with-test (:name (:smodular32 :wrong-width))
4467 (let ((fun (compile nil '(lambda (x)
4468 (declare (type (signed-byte 31) x))
4469 (sb-c::mask-signed-field 31 (- x 1055131947))))))
4470 (assert (= (funcall fun 10038) -1055121909))))
4471
4472 (with-test (:name :first-open-coded)
4473 (let ((fun (compile nil `(lambda (x) (first x)))))
4474 (assert (not (ctu:find-named-callees fun)))))
4475
4476 (with-test (:name :second-open-coded)
4477 (let ((fun (compile nil `(lambda (x) (second x)))))
4478 (assert (not (ctu:find-named-callees fun)))))
4479
4480 (with-test (:name :svref-of-symbol-macro)
4481 (compile nil `(lambda (x)
4482 (symbol-macrolet ((sv x))
4483 (values (svref sv 0) (setf (svref sv 0) 99))))))
4484
4485 ;; The compiler used to update the receiving LVAR's type too
4486 ;; aggressively when converting a large constant to a smaller
4487 ;; (potentially signed) one, causing other branches to be
4488 ;; inferred as dead.
4489 (with-test (:name :modular-cut-constant-to-width)
4490 (let ((test (compile nil
4491 `(lambda (x)
4492 (logand 254
4493 (case x
4494 ((3) x)
4495 ((2 2 0 -2 -1 2) 9223372036854775803)
4496 (t 358458651)))))))
4497 (assert (= (funcall test -10470605025) 26))))
4498
4499 (with-test (:name :append-type-derivation)
4500 (let ((test-cases
4501 '((lambda () (append 10)) (integer 10 10)
4502 (lambda () (append nil 10)) (integer 10 10)
4503 (lambda (x) (append x 10)) (or (integer 10 10) cons)
4504 (lambda (x) (append x (cons 1 2))) cons
4505 (lambda (x y) (append x (cons 1 2) y)) cons
4506 (lambda (x y) (nconc x (the list y) x)) t
4507 (lambda (x y) (nconc (the atom x) y)) t
4508 (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
4509 (lambda (x y) (nconc (the (or cons vector) x) y)) cons
4510 (lambda (x y) (nconc (the sequence x) y)) t
4511 (lambda (x y) (print (length y)) (append x y)) sequence
4512 (lambda (x y) (print (length y)) (append x y)) sequence
4513 (lambda (x y) (append (the (member (a) (b)) x) y)) cons
4514 (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
4515 (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
4516 (loop for (function result-type) on test-cases by #'cddr
4517 do (assert (sb-kernel:type= (sb-kernel:specifier-type
4518 (car (cdaddr (sb-kernel:%simple-fun-type
4519 (compile nil function)))))
4520 (sb-kernel:specifier-type result-type))))))
4521
4522 (with-test (:name :bug-504121)
4523 (compile nil `(lambda (s)
4524 (let ((p1 #'upper-case-p))
4525 (funcall
4526 (lambda (g)
4527 (funcall p1 g))))
4528 (let ((p2 #'(lambda (char) (upper-case-p char))))
4529 (funcall p2 s)))))
4530
4531 (with-test (:name (:bug-504121 :optional-missing))
4532 (compile nil `(lambda (s)
4533 (let ((p1 #'upper-case-p))
4534 (funcall
4535 (lambda (g &optional x)
4536 (funcall p1 g))))
4537 (let ((p2 #'(lambda (char) (upper-case-p char))))
4538 (funcall p2 s)))))
4539
4540 (with-test (:name (:bug-504121 :optional-superfluous))
4541 (compile nil `(lambda (s)
4542 (let ((p1 #'upper-case-p))
4543 (funcall
4544 (lambda (g &optional x)
4545 (funcall p1 g))
4546 #\1 2 3))
4547 (let ((p2 #'(lambda (char) (upper-case-p char))))
4548 (funcall p2 s)))))
4549
4550 (with-test (:name (:bug-504121 :key-odd))
4551 (compile nil `(lambda (s)
4552 (let ((p1 #'upper-case-p))
4553 (funcall
4554 (lambda (g &key x)
4555 (funcall p1 g))
4556 #\1 :x))
4557 (let ((p2 #'(lambda (char) (upper-case-p char))))
4558 (funcall p2 s)))))
4559
4560 (with-test (:name (:bug-504121 :key-unknown))
4561 (compile nil `(lambda (s)
4562 (let ((p1 #'upper-case-p))
4563 (funcall
4564 (lambda (g &key x)
4565 (funcall p1 g))
4566 #\1 :y 2))
4567 (let ((p2 #'(lambda (char) (upper-case-p char))))
4568 (funcall p2 s)))))
4569
4570 (with-test (:name :bug-1181684)
4571 (compile nil `(lambda ()
4572 (let ((hash #xD13CCD13))
4573 (setf hash (logand most-positive-word
4574 (ash hash 5)))))))
4575
4576 (with-test (:name (:local-&optional-recursive-inline :bug-1180992))
4577 (compile nil
4578 `(lambda ()
4579 (labels ((called (&optional a))
4580 (recursed (&optional b)
4581 (called)
4582 (recursed)))
4583 (declare (inline recursed called))
4584 (recursed)))))
4585
4586 (with-test (:name :constant-fold-logtest)
4587 (assert (equal (sb-kernel:%simple-fun-type
4588 (compile nil `(lambda (x)
4589 (declare (type (mod 1024) x)
4590 (optimize speed))
4591 (logtest x 2048))))
4592 '(function ((unsigned-byte 10)) (values null &optional)))))
4593
4594 ;; type mismatches on LVARs with multiple potential sources used to
4595 ;; be reported as mismatches with the value NIL. Make sure we get
4596 ;; a warning, but that it doesn't complain about a constant NIL ...
4597 ;; of type FIXNUM.
4598 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
4599 (block nil
4600 (handler-bind ((sb-int:type-warning
4601 (lambda (c)
4602 (assert
4603 (not (search "Constant "
4604 (simple-condition-format-control
4605 c))))
4606 (return))))
4607 (compile nil `(lambda (x y z)
4608 (declare (type fixnum y z))
4609 (aref (if x y z) 0))))
4610 (error "Where's my warning?")))
4611
4612 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
4613 (block nil
4614 (handler-bind ((style-warning
4615 (lambda (c)
4616 (assert
4617 (not (position
4618 nil
4619 (simple-condition-format-arguments c))))
4620 (return))))
4621 (compile nil `(lambda (x y z f)
4622 (declare (type fixnum y z))
4623 (catch (if x y z) (funcall f)))))
4624 (error "Where's my style-warning?")))
4625
4626 ;; Smoke test for rightward shifts
4627 (with-test (:name (:ash/right-signed))
4628 (let* ((f (compile nil `(lambda (x y)
4629 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4630 (type sb-vm:signed-word x)
4631 (optimize speed))
4632 (ash x (- y)))))
4633 (max (ash most-positive-word -1))
4634 (min (- -1 max)))
4635 (flet ((test (x y)
4636 (assert (= (ash x (- y))
4637 (funcall f x y)))))
4638 (dotimes (x 32)
4639 (dotimes (y (* 2 sb-vm:n-word-bits))
4640 (test x y)
4641 (test (- x) y)
4642 (test (- max x) y)
4643 (test (+ min x) y))))))
4644
4645 (with-test (:name (:ash/right-unsigned))
4646 (let ((f (compile nil `(lambda (x y)
4647 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4648 (type word x)
4649 (optimize speed))
4650 (ash x (- y)))))
4651 (max most-positive-word))
4652 (flet ((test (x y)
4653 (assert (= (ash x (- y))
4654 (funcall f x y)))))
4655 (dotimes (x 32)
4656 (dotimes (y (* 2 sb-vm:n-word-bits))
4657 (test x y)
4658 (test (- max x) y))))))
4659
4660 (with-test (:name (:ash/right-fixnum))
4661 (let ((f (compile nil `(lambda (x y)
4662 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4663 (type fixnum x)
4664 (optimize speed))
4665 (ash x (- y))))))
4666 (flet ((test (x y)
4667 (assert (= (ash x (- y))
4668 (funcall f x y)))))
4669 (dotimes (x 32)
4670 (dotimes (y (* 2 sb-vm:n-word-bits))
4671 (test x y)
4672 (test (- x) y)
4673 (test (- most-positive-fixnum x) y)
4674 (test (+ most-negative-fixnum x) y))))))
4675
4676 ;; expected failure
4677 (with-test (:name :fold-index-addressing-positive-offset)
4678 (let ((f (compile nil `(lambda (i)
4679 (if (typep i '(integer -31 31))
4680 (aref #. (make-array 63) (+ i 31))
4681 (error "foo"))))))
4682 (funcall f -31)))
4683
4684 ;; 5d3a728 broke something like this in CL-PPCRE
4685 (with-test (:name :fold-index-addressing-potentially-negative-index)
4686 (compile nil `(lambda (index vector)
4687 (declare (optimize speed (safety 0))
4688 ((simple-array character (*)) vector)
4689 ((unsigned-byte 24) index))
4690 (aref vector (1+ (mod index (1- (length vector))))))))
4691
4692 (with-test (:name :constant-fold-ash/right-fixnum)
4693 (compile nil `(lambda (a b)
4694 (declare (type fixnum a)
4695 (type (integer * -84) b))
4696 (ash a b))))
4697
4698 (with-test (:name :constant-fold-ash/right-word)
4699 (compile nil `(lambda (a b)
4700 (declare (type word a)
4701 (type (integer * -84) b))
4702 (ash a b))))
4703
4704 (with-test (:name :nconc-derive-type)
4705 (let ((function (compile nil `(lambda (x y)
4706 (declare (type (or cons fixnum) x))
4707 (nconc x y)))))
4708 (assert (equal (sb-kernel:%simple-fun-type function)
4709 '(function ((or cons fixnum) t) (values cons &optional))))))
4710
4711 ;; make sure that all data-vector-ref-with-offset VOPs are either
4712 ;; specialised on a 0 offset or accept signed indices
4713 (with-test (:name :data-vector-ref-with-offset-signed-index)
4714 (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
4715 (when dvr
4716 (assert
4717 (null
4718 (loop for info in (sb-c::fun-info-templates
4719 (sb-c::fun-info-or-lose dvr))
4720 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4721 unless (or (typep second-arg '(cons (eql :constant)))
4722 (find '(integer 0 0) third-arg :test 'equal)
4723 (equal second-arg
4724 `(:or ,(sb-c::primitive-type-or-lose
4725 'sb-vm::positive-fixnum)
4726 ,(sb-c::primitive-type-or-lose
4727 'fixnum))))
4728 collect info))))))
4729
4730 (with-test (:name :data-vector-set-with-offset-signed-index)
4731 (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
4732 (when dvr
4733 (assert
4734 (null
4735 (loop for info in (sb-c::fun-info-templates
4736 (sb-c::fun-info-or-lose dvr))
4737 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4738 unless (or (typep second-arg '(cons (eql :constant)))
4739 (find '(integer 0 0) third-arg :test 'equal)
4740 (equal second-arg
4741 `(:or ,(sb-c::primitive-type-or-lose
4742 'sb-vm::positive-fixnum)
4743 ,(sb-c::primitive-type-or-lose
4744 'fixnum))))
4745 collect info))))))
4746
4747 (with-test (:name :maybe-inline-ref-to-dead-lambda)
4748 (compile nil `(lambda (string)
4749 (declare (optimize speed (space 0)))
4750 (cond ((every #'digit-char-p string)
4751 nil)
4752 ((some (lambda (c)
4753 (digit-char-p c))
4754 string))))))
4755
4756 ;; the x87 backend used to sometimes signal FP errors during boxing,
4757 ;; because converting between double and single float values was a
4758 ;; noop (fixed), and no doubt many remaining issues. We now store
4759 ;; the value outside pseudo-atomic, so any SIGFPE should be handled
4760 ;; corrrectly.
4761 ;;
4762 ;; When it fails, this test lands into ldb.
4763 (with-test (:name :no-overflow-during-allocation)
4764 (handler-case (eval '(cosh 90))
4765 (floating-point-overflow ()
4766 t)))
4767
4768 ;; unbounded integer types could break integer arithmetic.
4769 (with-test (:name :bug-1199127)
4770 (compile nil `(lambda (b)
4771 (declare (type (integer -1225923945345 -832450738898) b))
4772 (declare (optimize (speed 3) (space 3) (safety 2)
4773 (debug 0) (compilation-speed 1)))
4774 (loop for lv1 below 3
4775 sum (logorc2
4776 (if (>= 0 lv1)
4777 (ash b (min 25 lv1))
4778 0)
4779 -2)))))
4780
4781 ;; non-trivial modular arithmetic operations would evaluate to wider results
4782 ;; than expected, and never be cut to the right final bitwidth.
4783 (with-test (:name :bug-1199428-1)
4784 (let ((f1 (compile nil `(lambda (a c)
4785 (declare (type (integer -2 1217810089) a))
4786 (declare (type (integer -6895591104928 -561736648588) c))
4787 (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
4788 (compilation-speed 3)))
4789 (logandc1 (gcd c)
4790 (+ (- a c)
4791 (loop for lv2 below 1 count t))))))
4792 (f2 (compile nil `(lambda (a c)
4793 (declare (notinline - + gcd logandc1))
4794 (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
4795 (compilation-speed 3)))
4796 (logandc1 (gcd c)
4797 (+ (- a c)
4798 (loop for lv2 below 1 count t)))))))
4799 (let ((a 530436387)
4800 (c -4890629672277))
4801 (assert (eql (funcall f1 a c)
4802 (funcall f2 a c))))))
4803
4804 (with-test (:name :bug-1199428-2)
4805 (let ((f1 (compile nil `(lambda (a b)
4806 (declare (type (integer -1869232508 -6939151) a))
4807 (declare (type (integer -11466348357 -2645644006) b))
4808 (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
4809 (compilation-speed 2)))
4810 (logand (lognand a -6) (* b -502823994)))))
4811 (f2 (compile nil `(lambda (a b)
4812 (logand (lognand a -6) (* b -502823994))))))
4813 (let ((a -1491588365)
4814 (b -3745511761))
4815 (assert (eql (funcall f1 a b)
4816 (funcall f2 a b))))))
4817
4818 ;; win32 is very specific about the order in which catch blocks
4819 ;; must be allocated on the stack
4820 (with-test (:name :bug-1072739)
4821 (let ((f (compile nil
4822 `(lambda ()
4823 (STRING=
4824 (LET ((% 23))
4825 (WITH-OUTPUT-TO-STRING (G13908)
4826 (PRINC
4827 (LET ()
4828 (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
4829 (HANDLER-CASE
4830 (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
4831 (UNBOUND-VARIABLE NIL
4832 (HANDLER-CASE
4833 (WITH-OUTPUT-TO-STRING (G13914)
4834 (PRINC %A%B% G13914)
4835 (PRINC "" G13914)
4836 G13914)
4837 (UNBOUND-VARIABLE NIL
4838 (HANDLER-CASE
4839 (WITH-OUTPUT-TO-STRING (G13913)
4840 (PRINC %A%B G13913)
4841 (PRINC "%" G13913)
4842 G13913)
4843 (UNBOUND-VARIABLE NIL
4844 (HANDLER-CASE
4845 (WITH-OUTPUT-TO-STRING (G13912)
4846 (PRINC %A% G13912)
4847 (PRINC "b%" G13912)
4848 G13912)
4849 (UNBOUND-VARIABLE NIL
4850 (HANDLER-CASE
4851 (WITH-OUTPUT-TO-STRING (G13911)
4852 (PRINC %A G13911)
4853 (PRINC "%b%" G13911)
4854 G13911)
4855 (UNBOUND-VARIABLE NIL
4856 (HANDLER-CASE
4857 (WITH-OUTPUT-TO-STRING (G13910)
4858 (PRINC % G13910)
4859 (PRINC "a%b%" G13910)
4860 G13910)
4861 (UNBOUND-VARIABLE NIL
4862 (ERROR "Interpolation error in \"%a%b%\"
4863 "))))))))))))))
4864 G13908)))
4865 "23a%b%")))))
4866 (assert (funcall f))))
4867
4868 (with-test (:name :equal-equalp-transforms)
4869 (let* ((s "foo")
4870 (bit-vector #*11001100)
4871 (values `(nil 1 2 "test"
4872 ;; Floats duplicated here to ensure we get newly created instances
4873 (read-from-string "1.1") (read-from-string "1.2d0")
4874 (read-from-string "1.1") (read-from-string "1.2d0")
4875 1.1 1.2d0 '("foo" "bar" "test")
4876 #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
4877 ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
4878 ,(make-hash-table) #\a #\b #\A #\C
4879 ,(make-random-state) 1/2 2/3)))
4880 ;; Test all permutations of different types
4881 (assert
4882 (loop
4883 for x in values
4884 always (loop
4885 for y in values
4886 always
4887 (and (eq (funcall (compile nil `(lambda (x y)
4888 (equal (the ,(type-of x) x)
4889 (the ,(type-of y) y))))
4890 x y)
4891 (equal x y))
4892 (eq (funcall (compile nil `(lambda (x y)
4893 (equalp (the ,(type-of x) x)
4894 (the ,(type-of y) y))))
4895 x y)
4896 (equalp x y))))))
4897 (assert
4898 (funcall (compile
4899 nil
4900 `(lambda (x y)
4901 (equal (the (cons (or simple-bit-vector simple-base-string))
4902 x)
4903 (the (cons (or (and bit-vector (not simple-array))
4904 (simple-array character (*))))
4905 y))))
4906 (list (string 'list))
4907 (list "LIST")))
4908 (assert
4909 (funcall (compile
4910 nil
4911 `(lambda (x y)
4912 (equalp (the (cons (or simple-bit-vector simple-base-string))
4913 x)
4914 (the (cons (or (and bit-vector (not simple-array))
4915 (simple-array character (*))))
4916 y))))
4917 (list (string 'list))
4918 (list "lisT")))))
4919
4920 (with-test (:name (restart-case optimize speed compiler-note))
4921 (handler-bind ((compiler-note #'error))
4922 (compile nil '(lambda ()
4923 (declare (optimize speed))
4924 (restart-case () (c ()))))
4925 (compile nil '(lambda ()
4926 (declare (optimize speed))
4927 (let (x)
4928 (restart-case (setf x (car (compute-restarts)))
4929 (c ()))
4930 x)))))
4931
4932 (with-test (:name :copy-more-arg
4933 :fails-on '(not (or :x86 :x86-64 :arm)))
4934 ;; copy-more-arg might not copy in the right direction
4935 ;; when there are more fixed args than stack frame slots,
4936 ;; and thus end up splatting a single argument everywhere.
4937 ;; Failing platforms still start their stack frames at 8 slots, so
4938 ;; this is less likely to happen.
4939 (let ((limit 33))
4940 (labels ((iota (n)
4941 (loop for i below n collect i))
4942 (test-function (function skip)
4943 ;; function should just be (subseq x skip)
4944 (loop for i from skip below (+ skip limit) do
4945 (let* ((values (iota i))
4946 (f (apply function values))
4947 (subseq (subseq values skip)))
4948 (assert (equal f subseq)))))
4949 (make-function (n)
4950 (let ((gensyms (loop for i below n collect (gensym))))
4951 (compile nil `(lambda (,@gensyms &rest rest)
4952 (declare (ignore ,@gensyms))
4953 rest)))))
4954 (dotimes (i limit)
4955 (test-function (make-function i) i)))))
4956
4957 (with-test (:name :apply-aref)
4958 (flet ((test (form)
4959 (let (warning)
4960 (handler-bind ((warning (lambda (c) (setf warning c))))
4961 (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
4962 (assert (not warning)))))
4963 (test `(lambda (x y) (setf (apply #'aref x y) 21)))
4964 (test `(lambda (x y) (setf (apply #'bit x y) 1)))
4965 (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
4966
4967 (with-test (:name :warn-on-the-values-constant)
4968 (multiple-value-bind (fun warnings-p failure-p)
4969 (compile nil
4970 ;; The compiler used to elide this test without
4971 ;; noting that the type demands multiple values.
4972 '(lambda () (the (values fixnum fixnum) 1)))
4973 (declare (ignore warnings-p))
4974 (assert (functionp fun))
4975 (assert failure-p)))
4976
4977 ;; quantifiers shouldn't cons themselves.
4978 (with-test (:name :quantifiers-no-consing)
4979 (let ((constantly-t (lambda (x) x t))
4980 (constantly-nil (lambda (x) x nil))
4981 (list (make-list 1000 :initial-element nil))
4982 (vector (make-array 1000 :initial-element nil)))
4983 (macrolet ((test (quantifier)
4984 (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
4985 `(flet ((,function (function sequence)
4986 (,quantifier function sequence)))
4987 (ctu:assert-no-consing (,function constantly-t list))
4988 (ctu:assert-no-consing (,function constantly-nil vector))))))
4989 (test some)
4990 (test every)
4991 (test notany)
4992 (test notevery))))
4993
4994 (with-test (:name :propagate-complex-type-tests)
4995 (flet ((test (type value)
4996 (let ((ftype (sb-kernel:%simple-fun-type
4997 (compile nil `(lambda (x)
4998 (if (typep x ',type)
4999 x
5000 ',value))))))
5001 (assert (typep ftype `(cons (eql function))))
5002 (assert (= 3 (length ftype)))
5003 (let* ((return (third ftype))
5004 (rtype (second return)))
5005 (assert (typep return `(cons (eql values)
5006 (cons t
5007 (cons (eql &optional)
5008 null)))))
5009 (assert (and (subtypep rtype type)
5010 (subtypep type rtype)))))))
5011 (mapc (lambda (params)
5012 (apply #'test params))
5013 `(((unsigned-byte 17) 0)
5014 ((member 1 3 5 7) 5)
5015 ((or symbol (eql 42)) t)))))
5016
5017 (with-test (:name :constant-fold-complex-type-tests)
5018 (assert (equal (sb-kernel:%simple-fun-type
5019 (compile nil `(lambda (x)
5020 (if (typep x '(member 1 3))
5021 (typep x '(member 1 3 15))
5022 t))))
5023 `(function (t) (values (member t) &optional))))
5024 (assert (equal (sb-kernel:%simple-fun-type
5025 (compile nil `(lambda (x)
5026 (declare (type (member 1 3) x))
5027 (typep x '(member 1 3 15)))))
5028 `(function ((or (integer 1 1) (integer 3 3)))
5029 (values (member t) &optional)))))
5030
5031 (with-test (:name :quietly-row-major-index-no-dimensions)
5032 (assert (handler-case
5033 (compile nil `(lambda (x) (array-row-major-index x)))
5034 (warning () nil))))
5035
5036 (with-test (:name :array-rank-transform)
5037 (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
5038
5039 (with-test (:name (:array-rank-fold :bug-1252108))
5040 (let (noted)
5041 (handler-bind ((sb-ext::code-deletion-note
5042 (lambda (x)
5043 (setf noted x))))
5044 (compile nil
5045 `(lambda (a)
5046 (typecase a
5047 ((array t 2)
5048 (when (= (array-rank a) 3)
5049 (array-dimension a 2)))))))
5050 (assert noted)))
5051
5052 (assert-error (upgraded-array-element-type 'an-undefined-type))
5053
5054 (with-test (:name :xchg-misencoding)
5055 (assert (eql (funcall (compile nil '(lambda (a b)
5056 (declare (optimize (speed 3) (safety 2))
5057 (type single-float a))
5058 (unless (eql b 1/2)
5059 (min a -1f0))))
5060 0f0 1)
5061 -1f0)))
5062
5063 (with-test (:name :malformed-declare)
5064 (multiple-value-bind (fun warnings-p failure-p)
5065 (compile nil '(lambda (x)
5066 (declare (unsigned-byte (x)))
5067 x))
5068 (assert (and fun warnings-p failure-p))))
5069
5070 (with-test (:name :no-dubious-asterisk-warning)
5071 (multiple-value-bind (fun warnings-p failure-p)
5072 (compile
5073 nil
5074 '(lambda (foo)
5075 (macrolet ((frob-some-stuff (&rest exprs)
5076 (let ((temps
5077 (mapcar
5078 (lambda (x)
5079 (if (symbolp x) (copy-symbol x) (gensym)))
5080 exprs)))
5081 `(let ,(mapcar #'list temps exprs)
5082 (if (and ,@temps)
5083 (format t "Got~@{ ~S~^ and~}~%" ,@temps))))))
5084 (frob-some-stuff *print-base* (car foo)))))
5085 (assert (and fun (not warnings-p) (not failure-p)))))
5086
5087 (with-test (:name :interr-type-specifier-hashing)
5088 (let ((specifiers
5089 (remove
5090 'simple-vector
5091 (map 'list
5092 (lambda (saetp)
5093 (sb-c::type-specifier
5094 (sb-c::specifier-type
5095 `(simple-array ,(sb-vm:saetp-specifier saetp) (*)))))
5096 sb-vm:*specialized-array-element-type-properties*))))
5097 (assert (sb-c::%interr-symbol-for-type-spec `(or ,@specifiers)))
5098 (assert (sb-c::%interr-symbol-for-type-spec
5099 `(or ,@specifiers system-area-pointer)))))
5100
5101 (with-test (:name :simple-rank-1-array-*-p-works)
5102 (assert (funcall (compile nil
5103 '(lambda () (typep #() '(simple-array * (*)))))))
5104 (loop for saetp across sb-vm:*specialized-array-element-type-properties*
5105 do
5106 (dotimes (n-dimensions 3) ; test ranks 0, 1, and 2.
5107 (let ((dims (make-list n-dimensions :initial-element 2)))
5108 (dolist (adjustable-p '(nil t))
5109 (let ((a (make-array dims :element-type (sb-vm:saetp-specifier saetp)
5110 :adjustable adjustable-p)))
5111 (assert (eq (and (= n-dimensions 1) (not adjustable-p))
5112 (typep a '(simple-array * (*)))))))))))
5113
5114 (with-test (:name :array-subtype-tests
5115 :skipped-on '(:not (:or :x86 :x86-64)))
5116 (assert (funcall (compile nil
5117 '(lambda ()
5118 (typep #() '(or simple-vector simple-string))))))
5119 (flet ((approx-lines-of-assembly-code (type-expr)
5120 (count #\Newline
5121 (with-output-to-string (s)
5122 (disassemble
5123 `(lambda (x)
5124 (declare (optimize (sb-c::verify-arg-count 0)))
5125 (typep x ',type-expr))
5126 :stream s)))))
5127 ;; These are fragile, but less bad than the possibility of messing up
5128 ;; any vops, especially since the generic code in 'vm-type' checks for
5129 ;; a vop by its name in a place that would otherwise be agnostic of the
5130 ;; backend were it not for my inability to test all platforms.
5131 (assert (< (approx-lines-of-assembly-code
5132 '(simple-array * (*))) 25))
5133 ;; this tested all possible widetags one at a time, e.g. in VECTOR-SAP
5134 (assert (< (approx-lines-of-assembly-code
5135 '(sb-kernel:simple-unboxed-array (*))) 25))
5136 ;; This is actually a strange type but it's what ANSI-STREAM-READ-N-BYTES
5137 ;; declares as its buffer, which would choke in %BYTE-BLT if you gave it
5138 ;; (simple-array t (*)). But that's a different problem.
5139 (assert (< (approx-lines-of-assembly-code
5140 '(or system-area-pointer (simple-array * (*)))) 29))
5141 ;; And this was used by %BYTE-BLT which tested widetags one-at-a-time.
5142 (assert (< (approx-lines-of-assembly-code
5143 '(or system-area-pointer (sb-kernel:simple-unboxed-array (*))))
5144 29))))
5145
5146 (with-test (:name :local-argument-mismatch-error-string)
5147 (let ((f (compile nil `(lambda (x)
5148 (flet ((foo ()))
5149 (foo x))))))
5150 (multiple-value-bind (ok err) (ignore-errors (funcall f 42))
5151 (assert (not ok))
5152 (assert (search "FLET FOO" (princ-to-string err))))))
5153
5154 (with-test (:name :bug-1310574-0)
5155 (multiple-value-bind (function warning failure)
5156 (compile nil `(lambda (a)
5157 (typecase a
5158 ((or (array * (* * 3)) (array * (* * 4)))
5159 (case (array-rank a)
5160 (2 (aref a 1 2)))))))
5161 (declare (ignore function))
5162 (assert (not warning))
5163 (assert (not failure))))
5164
5165 (with-test (:name :bug-1310574-1)
5166 (multiple-value-bind (function warning failure)
5167 (compile nil `(lambda (a)
5168 (typecase a
5169 ((or (array * ()) (array * (1)) (array * (1 2)))
5170 (case (array-rank a)
5171 (3 (aref a 1 2 3)))))))
5172 (declare (ignore function))
5173 (assert (not warning))
5174 (assert (not failure))))
5175
5176 (with-test (:name :bug-573747)
5177 (multiple-value-bind (function warnings-p failure-p)
5178 (compile nil '(lambda (x) (progn (declare (integer x)) (* x 6))))
5179 (assert warnings-p)
5180 (assert failure-p)))
5181
5182 ;; Something in this function used to confuse lifetime analysis into
5183 ;; recording multiple conflicts for a single TNs in the dolist block.
5184 (with-test (:name :bug-1327008)
5185 (handler-bind (((or style-warning compiler-note)
5186 (lambda (c)
5187 (muffle-warning c))))
5188 (compile nil
5189 `(lambda (scheduler-spec
5190 schedule-generation-method
5191 utc-earliest-time utc-latest-time
5192 utc-other-earliest-time utc-other-latest-time
5193 &rest keys
5194 &key queue
5195 maximum-mileage
5196 maximum-extra-legs
5197 maximum-connection-time
5198 slice-number
5199 scheduler-hints
5200 permitted-route-locations prohibited-route-locations
5201 preferred-connection-locations disfavored-connection-locations
5202 origins destinations
5203 permitted-carriers prohibited-carriers
5204 permitted-operating-carriers prohibited-operating-carriers
5205 start-airports end-airports
5206 circuity-limit
5207 specified-circuity-limit-extra-miles
5208 (preferred-carriers :unspecified)
5209 &allow-other-keys)
5210 (declare (optimize speed))
5211 (let ((table1 (list nil))
5212 (table2 (list nil))
5213 (skip-flifo-checks (getf scheduler-spec :skip-flifo-checks))
5214 (construct-gaps-p (getf scheduler-spec :construct-gaps-p))
5215 (gap-locations (getf scheduler-spec :gap-locations))
5216 (result-array (make-array 100))
5217 (number-dequeued 0)
5218 (n-new 0)
5219 (n-calcs 0)
5220 (exit-reason 0)
5221 (prev-start-airports origins)
5222 (prev-end-airports destinations)
5223 (prev-permitted-carriers permitted-carriers))
5224 (flet ((run-with-hint (hint random-magic other-randomness
5225 maximum-extra-legs
5226 preferred-origins
5227 preferred-destinations
5228 same-pass-p)
5229 (let* ((hint-permitted-carriers (first hint))
5230 (preferred-end-airports
5231 (ecase schedule-generation-method
5232 (:DEPARTURE preferred-destinations)
5233 (:ARRIVAL preferred-origins)))
5234 (revised-permitted-carriers
5235 (cond ((and hint-permitted-carriers
5236 (not (eq permitted-carriers :ANY)))
5237 (intersection permitted-carriers
5238 hint-permitted-carriers))
5239 (hint-permitted-carriers)
5240 (permitted-carriers)))
5241 (revised-maximum-mileage
5242 (min (let ((maximum-mileage 0))
5243 (dolist (o start-airports)
5244 (dolist (d end-airports)
5245 (setf maximum-mileage
5246 (max maximum-mileage (mileage o d)))))
5247 (round (+ (* circuity-limit maximum-mileage)
5248 (or specified-circuity-limit-extra-miles
5249 (hairy-calculation slice-number)))))
5250 maximum-mileage)))
5251 (when (or (not (equal start-airports prev-start-airports))
5252 (not (equal end-airports prev-end-airports))
5253 (and (not (equal revised-permitted-carriers
5254 prev-permitted-carriers))))
5255 (incf n-calcs)
5256 (calculate-vectors
5257 prohibited-carriers
5258 permitted-operating-carriers
5259 prohibited-operating-carriers
5260 permitted-route-locations
5261 prohibited-route-locations
5262 construct-gaps-p
5263 gap-locations
5264 preferred-carriers)
5265 (setf prev-permitted-carriers revised-permitted-carriers))
5266 (multiple-value-bind (this-number-dequeued
5267 this-exit-reason
5268 this-n-new)
5269 (apply #'schedule-loop
5270 utc-earliest-time utc-other-earliest-time
5271 utc-latest-time utc-other-latest-time
5272 scheduler-spec schedule-generation-method
5273 queue
5274 :maximum-mileage revised-maximum-mileage
5275 :maximum-extra-legs maximum-extra-legs
5276 :maximum-connection-time maximum-connection-time
5277 :same-pass-p same-pass-p
5278 :preferred-end-airports preferred-end-airports
5279 :maximum-blah random-magic
5280 :skip-flifo-checks skip-flifo-checks
5281 :magic1 table1
5282 :magic2 table2
5283 :preferred-connection-locations preferred-connection-locations
5284 :disfavored-connection-locations disfavored-connection-locations
5285 keys)
5286 (when other-randomness
5287 (loop for i fixnum from n-new to (+ n-new (1- this-n-new))
5288 do (hairy-calculation i result-array)))
5289 (incf number-dequeued this-number-dequeued)
5290 (incf n-new this-n-new)
5291 (setq exit-reason (logior exit-reason this-exit-reason))))))
5292 (let ((n-hints-processed 0))
5293 (dolist (hint scheduler-hints)
5294 (run-with-hint hint n-hints-processed t 0
5295 nil nil nil)
5296 (incf n-hints-processed)))
5297 (run-with-hint nil 42 nil maximum-extra-legs
5298 '(yyy) '(xxx) t))
5299 exit-reason)))))
5300
5301 (with-test (:name :dead-code-in-optional-dispatch)
5302 (multiple-value-bind (f warningp)
5303 ;; the translation of each optional entry is
5304 ;; (let ((#:g (error "nope"))) (funcall #<clambda> ...))
5305 ;; but the funcall is unreachable. Since this is an artifact of how the
5306 ;; lambda is converted, it should not generate a note as if in user code.
5307 (compile nil '(lambda (a &optional (b (error "nope")) (c (error "nope")))
5308 (values c b a)))
5309 (assert (and f (not warningp)))))
5310
5311 (with-test (:name :nth-value-of-non-constant-N)
5312 (labels ((foo (n f) (nth-value n (funcall f)))
5313 (bar () (values 0 1 2 3 4 5 6 7 8 9)))
5314 (assert (= (foo 5 #'bar) 5)) ; basic correctness
5315 (assert (eq (foo 12 #'bar) nil))
5316 (ctu:assert-no-consing (eql (foo 953 #'bar) 953))))
5317
5318 (with-test (:name :position-derive-type-optimizer)
5319 (assert-code-deletion-note
5320 '(lambda (x) ; the call to POSITION can't return 4
5321 (let ((i (position x #(a b c d) :test 'eq)))
5322 (case i (4 'nope) (t 'okeydokey))))))
5323
5324 ;; Assert that DO-PACKED-TNS has unsurprising behavior if the body RETURNs.
5325 ;; This isn't a test in the problem domain of CL - it's of an internal macro,
5326 ;; and x86-64-specific not because of broken-ness, but because it uses
5327 ;; known random TNs to play with. Printing "skipped on" for other backends
5328 ;; would be somewhat misleading in as much as it means nothing about
5329 ;; the correctness of the test on other architectures.
5330 #+x86-64
5331 (with-test (:name :do-packed-tn-iterator)
5332 (dotimes (i (ash 1 6))
5333 (labels ((make-tns (n)
5334 (mapcar 'copy-structure
5335 (subseq `sb-vm::(,rax-tn ,rbx-tn ,rcx-tn) 0 n)))
5336 (link (list)
5337 (when list
5338 (setf (sb-c::tn-next (car list)) (link (cdr list)))
5339 (car list))))
5340 (let* ((normal (make-tns (ldb (byte 2 0) i)))
5341 (restricted (make-tns (ldb (byte 2 2) i)))
5342 (wired (make-tns (ldb (byte 2 4) i)))
5343 (expect (append normal restricted wired))
5344 (comp (sb-c::make-empty-component))
5345 (ir2-comp (sb-c::make-ir2-component)))
5346 (setf (sb-c::component-info comp) ir2-comp
5347 (sb-c::ir2-component-normal-tns ir2-comp) (link normal)
5348 (sb-c::ir2-component-restricted-tns ir2-comp) (link restricted)
5349 (sb-c::ir2-component-wired-tns ir2-comp) (link wired))
5350 (let* ((list)
5351 (result (sb-c::do-packed-tns (tn comp 42) (push tn list))))
5352 (assert (eq result 42))
5353 (assert (equal expect (nreverse list))))
5354 (let* ((n 0) (list)
5355 (result (sb-c::do-packed-tns (tn comp 'bar)
5356 (push tn list)
5357 (if (= (incf n) 4) (return 'foo)))))
5358 (assert (eq result (if (>= (length expect) 4) 'foo 'bar)))
5359 (assert (equal (subseq expect 0 (min 4 (length expect)))
5360 (nreverse list))))))))
5361
5362 ;; lp# 310267
5363 (with-test (:name :optimize-quality-multiply-specified)
5364 (let ((*error-output* (make-broadcast-stream)))
5365 (let ((sb-c::*policy* sb-c::*policy*)) ; to keep this test pure
5366 (assert-signal (proclaim '(optimize space debug (space 0)))
5367 style-warning))
5368 (assert-signal
5369 (compile nil '(lambda () (declare (optimize speed (speed 0))) 5))
5370 style-warning)
5371 (assert-signal
5372 (compile nil '(lambda () (declare (optimize speed) (optimize (speed 0))) 5))
5373 style-warning)
5374 (assert-signal
5375 (compile nil '(lambda ()
5376 (declare (optimize speed)) (declare (optimize (speed 0)))
5377 5))
5378 style-warning))
5379
5380 ;; these are OK
5381 (assert-no-signal (proclaim '(optimize (space 3) space)))
5382 (assert-no-signal
5383 (compile nil '(lambda () (declare (optimize speed (speed 3))) 5)))
5384 (assert-no-signal
5385 (compile nil '(lambda () (declare (optimize speed) (optimize (speed 3))) 5)))
5386 (assert-no-signal
5387 (compile nil '(lambda ()
5388 (declare (optimize speed)) (declare (optimize (speed 3)))
5389 5))))
5390
5391 (with-test (:name :truncate-type-derivation)
5392 (assert (=
5393 4
5394 (funcall
5395 (compile nil
5396 '(lambda (a b)
5397 (truncate a
5398 (the (rational (1) (3)) b))))
5399 10 5/2))))
5400
5401 (with-test (:name :constantp-on-a-literal-function-works)
5402 (assert (constantp `(the (function (list) t) ,#'car))))
5403
5404 (with-test (:name :arg-count-error)
5405 (assert (eq :win (handler-case (funcall (intern "CONS") 1 2 3)
5406 (sb-int:simple-program-error () :win)
5407 (condition () :lose)))))
5408
5409 (with-test (:name :mv-conversion)
5410 (compile nil '(lambda (a)
5411 (tagbody (go 0)
5412 (list (unwind-protect a))
5413 (multiple-value-call #'list
5414 (values (catch 'ct5 (go 0))))
5415 0))))
5416
5417 (with-test (:name (:null-cleanups-1 :bug-1416704 :bug-404441))
5418 (let ((x (funcall
5419 (compile nil `(lambda ()
5420 (lambda (x)
5421 (declare (optimize speed))
5422 (if x
5423 (funcall (flet ((bar () 10)) #'bar))
5424 (funcall (flet ((fez ()
5425 (funcall (flet ((foo () 20)) #'foo))))
5426 #'fez)))))))))
5427 (assert (= (funcall x t) 10))
5428 (assert (= (funcall x nil) 20))))
5429
5430 (with-test (:name (:null-cleanups-2 :bug-1416704 :bug-404441))
5431 (let ((fun (funcall
5432 (compile nil `(lambda ()
5433 (lambda (x)
5434 (declare (optimize speed))
5435 (let* ((a2 (lambda () 20))
5436 (a4 (lambda ()))
5437 (a0 (flet ((f () (funcall a2)))
5438 #'f))
5439 (a3 (lambda ()
5440 (if x
5441 (if x
5442 (throw 'x 10)
5443 (let ((a5 (lambda () (funcall a4))))
5444 (funcall a5)))
5445 (funcall a0)))))
5446 (funcall a3))))))))
5447 (assert (= (catch 'x (funcall fun t)) 10))
5448 (assert (= (catch 'x (funcall fun nil)) 20))))
5449
5450
5451 (with-test (:name :locall-already-let-converted)
5452 (assert (eq (funcall
5453 (funcall
5454 (compile
5455 nil
5456 '(lambda ()
5457 (flet ((call (ff)
5458 (flet ((f () (return-from f ff)))
5459 (declare (inline f))
5460 (f)
5461 (f))))
5462 (declare (inline call))
5463 (call 1)
5464 (call (lambda () 'result)))))))
5465 'result)))
5466
5467 (with-test (:name :debug-dump-elsewhere)
5468 (assert
5469 (eql
5470 (catch 'x
5471 (funcall
5472 (compile nil
5473 '(lambda ()
5474 (declare (optimize debug))
5475 (throw 'x *)))))
5476 *)))
5477
5478 (with-test (:name :typep-quasiquoted-constant)
5479 (assert (null (ctu:find-named-callees
5480 (compile nil
5481 '(lambda (x)
5482 (typep x `(signed-byte ,sb-vm:n-word-bits))))))))
5483 (with-test (:name :logior-transform)
5484 (let ((function (compile nil '(lambda (c)
5485 (flet ((f (x)
5486 (the integer x)))
5487 (logior c (f nil)))))))
5488 (assert-error (funcall function 10)
5489 type-error)))
5490
5491 (with-test (:name :eql/integer-folding)
5492 (multiple-value-bind (f warning)
5493 (compile nil
5494 '(lambda (a)
5495 (fceiling (the (member 2.3 21672589639883401935) a))))
5496 (assert (and f (not warning)))))
5497
5498 (with-test (:name :position-derive-type)
5499 (let ((f (compile nil
5500 '(lambda (x)
5501 (declare (type (simple-string 90) x))
5502 (declare (muffle-conditions code-deletion-note))
5503 (let ((b (position #\i x)))
5504 (if (and (integerp b) (> b 100))
5505 'yikes 'okey-dokey))))))
5506 ;; The function can not return YIKES
5507 (assert (not (ctu:find-code-constants f :type '(eql yikes))))))
5508
5509 (with-test (:name :compile-file-error-position-reporting)
5510 (dolist (input '("data/wonky1.lisp" "data/wonky2.lisp" "data/wonky3.lisp"))
5511 (let ((expect (with-open-file (f input) (read f))))
5512 (assert (stringp expect))
5513 (let ((err-string (with-output-to-string (*error-output*)
5514 (compile-file input :print nil))))
5515 (assert (search expect err-string))))))
Common Lisp compiler and runtime