?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix transitive arithmetic transforms.
[sbcl.git] / tests / compiler.pure.lisp
blobbd7d2e9cea7b79cef244f197983de9f73b731196
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 ;; META: there's a test in compiler.impure.lisp that also tests
2738 ;; interaction of PROGV with (debug 3). These tests should be together.
2739 (with-test (:name :progv-and-restrict-compiler-policy)
2740 (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
2741 (restrict-compiler-policy 'debug 3)
2742 (let ((fun (compile nil '(lambda (x)
2743 (let ((i x))
2744 (declare (special i))
2745 (list i
2746 (progv '(i) (list (+ i 1))
2747 i)
2748 i))))))
2749 (assert (equal '(1 2 1) (funcall fun 1))))))
2750
2751 ;;; It used to be possible to confuse the compiler into
2752 ;;; IR2-converting such a call to CONS
2753 (with-test (:name :late-bound-primitive)
2754 (compile nil `(lambda ()
2755 (funcall 'cons 1))))
2756
2757 (with-test (:name :hairy-array-element-type-derivation)
2758 (compile nil '(lambda (x)
2759 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
2760 (array-element-type x))))
2761
2762 (with-test (:name :rest-list-type-derivation)
2763 (multiple-value-bind (type derivedp)
2764 (funcall (compile nil `(lambda (&rest args)
2765 (ctu:compiler-derived-type args)))
2766 nil)
2767 (assert (eq 'list type))
2768 (assert derivedp)))
2769
2770 (with-test (:name :rest-list-type-derivation2)
2771 (multiple-value-bind (type derivedp)
2772 (funcall (funcall (compile nil `(lambda ()
2773 (lambda (&rest args)
2774 (ctu:compiler-derived-type args))))))
2775 (assert (eq 'list type))
2776 (assert derivedp)))
2777
2778 (with-test (:name :rest-list-type-derivation3)
2779 (multiple-value-bind (type derivedp)
2780 (funcall (funcall (compile nil `(lambda ()
2781 (lambda (&optional x &rest args)
2782 (unless x (error "oops"))
2783 (ctu:compiler-derived-type args)))))
2784 t)
2785 (assert (eq 'list type))
2786 (assert derivedp)))
2787
2788 (with-test (:name :rest-list-type-derivation4)
2789 (multiple-value-bind (type derivedp)
2790 (funcall (funcall (compile nil `(lambda ()
2791 (lambda (&optional x &rest args)
2792 (declare (type (or null integer) x))
2793 (when x (setf args x))
2794 (ctu:compiler-derived-type args)))))
2795 42)
2796 (assert (equal '(or cons null integer) type))
2797 (assert derivedp)))
2798
2799 (with-test (:name :base-char-typep-elimination)
2800 (assert (eq (funcall (compile nil
2801 `(lambda (ch)
2802 (declare (type base-char ch) (optimize (speed 3) (safety 0)))
2803 (typep ch 'base-char)))
2804 t)
2805 t)))
2806
2807 (with-test (:name :regression-1.0.24.37)
2808 (compile nil '(lambda (&key (test (constantly t)))
2809 (when (funcall test)
2810 :quux))))
2811
2812 ;;; Attempt to test a decent cross section of conditions
2813 ;;; and values types to move conditionally.
2814 (macrolet
2815 ((test-comparison (comparator type x y)
2816 `(progn
2817 ,@(loop for (result-type a b)
2818 in '((nil t nil)
2819 (nil 0 1)
2820 (nil 0.0 1.0)
2821 (nil 0d0 0d0)
2822 (nil 0.0 0d0)
2823 (nil #c(1.0 1.0) #c(2.0 2.0))
2824
2825 (t t nil)
2826 (fixnum 0 1)
2827 ((unsigned-byte #.sb-vm:n-word-bits)
2828 (1+ most-positive-fixnum)
2829 (+ 2 most-positive-fixnum))
2830 ((signed-byte #.sb-vm:n-word-bits)
2831 -1 (* 2 most-negative-fixnum))
2832 (single-float 0.0 1.0)
2833 (double-float 0d0 1d0))
2834 for lambda = (if result-type
2835 `(lambda (x y a b)
2836 (declare (,type x y)
2837 (,result-type a b))
2838 (if (,comparator x y)
2839 a b))
2840 `(lambda (x y)
2841 (declare (,type x y))
2842 (if (,comparator x y)
2843 ,a ,b)))
2844 for args = `(,x ,y ,@(and result-type
2845 `(,a ,b)))
2846 collect
2847 `(progn
2848 (eql (funcall (compile nil ',lambda)
2849 ,@args)
2850 (eval '(,lambda ,@args))))))))
2851 (sb-vm::with-float-traps-masked
2852 (:divide-by-zero :overflow :inexact :invalid)
2853 (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret))
2854 (declare (sb-ext:muffle-conditions style-warning))
2855 (test-comparison eql t t nil)
2856 (test-comparison eql t t t)
2857
2858 (test-comparison = t 1 0)
2859 (test-comparison = t 1 1)
2860 (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2861 (test-comparison = fixnum 1 0)
2862 (test-comparison = fixnum 0 0)
2863 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2864 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2865 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0)
2866 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1)
2867
2868 (test-comparison = single-float 0.0 1.0)
2869 (test-comparison = single-float 1.0 1.0)
2870 (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0))
2871 (test-comparison = single-float (/ 1.0 0.0) 1.0)
2872 (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0))
2873 (test-comparison = single-float (/ 0.0 0.0) 0.0)
2874
2875 (test-comparison = double-float 0d0 1d0)
2876 (test-comparison = double-float 1d0 1d0)
2877 (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0))
2878 (test-comparison = double-float (/ 1d0 0d0) 1d0)
2879 (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0))
2880 (test-comparison = double-float (/ 0d0 0d0) 0d0)
2881
2882 (test-comparison < t 1 0)
2883 (test-comparison < t 0 1)
2884 (test-comparison < t 1 1)
2885 (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2886 (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2887 (test-comparison < fixnum 1 0)
2888 (test-comparison < fixnum 0 1)
2889 (test-comparison < fixnum 0 0)
2890 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2891 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2892 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2893 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0)
2894 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1)
2895 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1)
2896
2897 (test-comparison < single-float 0.0 1.0)
2898 (test-comparison < single-float 1.0 0.0)
2899 (test-comparison < single-float 1.0 1.0)
2900 (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0))
2901 (test-comparison < single-float (/ 1.0 0.0) 1.0)
2902 (test-comparison < single-float 1.0 (/ 1.0 0.0))
2903 (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0))
2904 (test-comparison < single-float (/ 0.0 0.0) 0.0)
2905
2906 (test-comparison < double-float 0d0 1d0)
2907 (test-comparison < double-float 1d0 0d0)
2908 (test-comparison < double-float 1d0 1d0)
2909 (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0))
2910 (test-comparison < double-float (/ 1d0 0d0) 1d0)
2911 (test-comparison < double-float 1d0 (/ 1d0 0d0))
2912 (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0))
2913 (test-comparison < double-float (/ 0d0 0d0) 0d0)
2914 (test-comparison < double-float 0d0 (/ 0d0 0d0))
2915
2916 (test-comparison > t 1 0)
2917 (test-comparison > t 0 1)
2918 (test-comparison > t 1 1)
2919 (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2920 (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2921 (test-comparison > fixnum 1 0)
2922 (test-comparison > fixnum 0 1)
2923 (test-comparison > fixnum 0 0)
2924 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2925 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2926 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2927 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0)
2928 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1)
2929 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1)
2930
2931 (test-comparison > single-float 0.0 1.0)
2932 (test-comparison > single-float 1.0 0.0)
2933 (test-comparison > single-float 1.0 1.0)
2934 (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0))
2935 (test-comparison > single-float (/ 1.0 0.0) 1.0)
2936 (test-comparison > single-float 1.0 (/ 1.0 0.0))
2937 (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0))
2938 (test-comparison > single-float (/ 0.0 0.0) 0.0)
2939
2940 (test-comparison > double-float 0d0 1d0)
2941 (test-comparison > double-float 1d0 0d0)
2942 (test-comparison > double-float 1d0 1d0)
2943 (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0))
2944 (test-comparison > double-float (/ 1d0 0d0) 1d0)
2945 (test-comparison > double-float 1d0 (/ 1d0 0d0))
2946 (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0))
2947 (test-comparison > double-float (/ 0d0 0d0) 0d0)
2948 (test-comparison > double-float 0d0 (/ 0d0 0d0)))))
2949
2950 (with-test (:name :car-and-cdr-type-derivation-conservative)
2951 (let ((f1 (compile nil
2952 `(lambda (y)
2953 (declare (optimize speed))
2954 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2955 (declare (type (cons t fixnum) x))
2956 (rplaca x y)
2957 (+ (car x) (cdr x))))))
2958 (f2 (compile nil
2959 `(lambda (y)
2960 (declare (optimize speed))
2961 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2962 (setf (cdr x) y)
2963 (+ (car x) (cdr x)))))))
2964 (flet ((test-error (e value)
2965 (assert (typep e 'type-error))
2966 (assert (eq 'number (type-error-expected-type e)))
2967 (assert (eq value (type-error-datum e)))))
2968 (let ((v1 "foo")
2969 (v2 "bar"))
2970 (multiple-value-bind (res err) (ignore-errors (funcall f1 v1))
2971 (assert (not res))
2972 (test-error err v1))
2973 (multiple-value-bind (res err) (ignore-errors (funcall f2 v2))
2974 (assert (not res))
2975 (test-error err v2))))))
2976
2977 (with-test (:name :array-dimension-derivation-conservative)
2978 (let ((f (compile nil
2979 `(lambda (x)
2980 (declare (optimize speed))
2981 (declare (type (array * (4 4)) x))
2982 (let ((y x))
2983 (setq x (make-array '(4 4)))
2984 (adjust-array y '(3 5))
2985 (array-dimension y 0))))))
2986 (assert (= 3 (funcall f (make-array '(4 4) :adjustable t))))))
2987
2988 (with-test (:name :with-timeout-code-deletion-note)
2989 (handler-bind ((sb-ext:code-deletion-note #'error))
2990 (compile nil `(lambda ()
2991 (sb-ext:with-timeout 0
2992 (sleep 1))))))
2993
2994 (with-test (:name :full-warning-for-undefined-type-in-cl)
2995 (assert (eq :full
2996 (handler-case
2997 (compile nil `(lambda (x) (the replace x)))
2998 (style-warning ()
2999 :style)
3000 (warning ()
3001 :full)))))
3002
3003 (with-test (:name :single-warning-for-single-undefined-type)
3004 (let ((n 0))
3005 (handler-bind ((warning (lambda (c)
3006 (declare (ignore c))
3007 (incf n))))
3008 (compile nil `(lambda (x) (the #:no-type x)))
3009 (assert (= 1 n))
3010 (compile nil `(lambda (x) (the 'fixnum x)))
3011 (assert (= 2 n)))))
3012
3013 (with-test (:name :complex-subtype-dumping-in-xc)
3014 (assert
3015 (= sb-vm:complex-single-float-widetag
3016 (sb-kernel:widetag-of
3017 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float))))))
3018 (assert
3019 (= sb-vm:complex-double-float-widetag
3020 (sb-kernel:widetag-of
3021 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
3022
3023 (with-test (:name :complex-single-float-fill)
3024 (assert (every (lambda (x) (= #c(1.0 2.0) x))
3025 (funcall
3026 (compile nil
3027 `(lambda (n x)
3028 (make-array (list n)
3029 :element-type '(complex single-float)
3030 :initial-element x)))
3031 10
3032 #c(1.0 2.0)))))
3033
3034 (with-test (:name :regression-1.0.28.21)
3035 (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1))))))
3036 (assert (funcall fun (vector 1 2 3)))
3037 (assert (funcall fun "abc"))
3038 (assert (not (funcall fun (make-array '(2 2)))))))
3039
3040 (with-test (:name :no-silly-compiler-notes-from-character-function)
3041 (let (current)
3042 (handler-bind ((compiler-note (lambda (e) (error "~S: ~A" current e))))
3043 (dolist (name '(char-code char-int character char-name standard-char-p
3044 graphic-char-p alpha-char-p upper-case-p lower-case-p
3045 both-case-p digit-char-p alphanumericp digit-char-p))
3046 (setf current name)
3047 (compile nil `(lambda (x)
3048 (declare (character x) (optimize speed))
3049 (,name x))))
3050 (dolist (name '(char= char/= char< char> char<= char>=
3051 char-lessp char-greaterp char-not-greaterp
3052 char-not-lessp))
3053 (setf current name)
3054 (compile nil `(lambda (x y)
3055 (declare (character x y) (optimize speed))
3056 (,name x y)))))))
3057
3058 ;;; optimizing make-array
3059 (with-test (:name (make-array :open-code-initial-contents))
3060 (assert (not (ctu:find-named-callees
3061 (compile nil
3062 `(lambda (x y z)
3063 (make-array '(3) :initial-contents (list x y z)))))))
3064 (assert (not (ctu:find-named-callees
3065 (compile nil
3066 `(lambda (x y z)
3067 (make-array '3 :initial-contents (vector x y z)))))))
3068 (assert (not (ctu:find-named-callees
3069 (compile nil
3070 `(lambda (x y z)
3071 (make-array '3 :initial-contents `(,x ,y ,z))))))))
3072
3073 ;;; optimizing array-in-bounds-p
3074 (with-test (:name :optimize-array-in-bounds-p)
3075 (locally
3076 (macrolet ((find-callees (&body body)
3077 `(ctu:find-named-callees
3078 (compile nil
3079 '(lambda ()
3080 ,@body))
3081 :name 'array-in-bounds-p))
3082 (must-optimize (&body exprs)
3083 `(progn
3084 ,@(loop for expr in exprs
3085 collect `(assert (not (find-callees
3086 ,expr))))))
3087 (must-not-optimize (&body exprs)
3088 `(progn
3089 ,@(loop for expr in exprs
3090 collect `(assert (find-callees
3091 ,expr))))))
3092 (must-optimize
3093 ;; in bounds
3094 (let ((a (make-array '(1))))
3095 (array-in-bounds-p a 0))
3096 ;; exceeds upper bound (constant)
3097 (let ((a (make-array '(1))))
3098 (array-in-bounds-p a 1))
3099 ;; exceeds upper bound (interval)
3100 (let ((a (make-array '(1))))
3101 (array-in-bounds-p a (+ 1 (random 2))))
3102 ;; negative lower bound (constant)
3103 (let ((a (make-array '(1))))
3104 (array-in-bounds-p a -1))
3105 ;; negative lower bound (interval)
3106 (let ((a (make-array 3))
3107 (i (- (random 1) 20)))
3108 (array-in-bounds-p a i))
3109 ;; multiple known dimensions
3110 (let ((a (make-array '(1 1))))
3111 (array-in-bounds-p a 0 0))
3112 ;; union types
3113 (let ((s (the (simple-string 10) (eval "0123456789"))))
3114 (array-in-bounds-p s 9)))
3115 (must-not-optimize
3116 ;; don't trust non-simple array length in safety=1
3117 (let ((a (the (array * (10)) (make-array 10 :adjustable t))))
3118 (eval `(adjust-array ,a 0))
3119 (array-in-bounds-p a 9))
3120 ;; same for a union type
3121 (let ((s (the (string 10) (make-array 10
3122 :element-type 'character
3123 :adjustable t))))
3124 (eval `(adjust-array ,s 0))
3125 (array-in-bounds-p s 9))
3126 ;; single unknown dimension
3127 (let ((a (make-array (random 20))))
3128 (array-in-bounds-p a 10))
3129 ;; multiple unknown dimensions
3130 (let ((a (make-array (list (random 20) (random 5)))))
3131 (array-in-bounds-p a 5 2))
3132 ;; some other known dimensions
3133 (let ((a (make-array (list 1 (random 5)))))
3134 (array-in-bounds-p a 0 2))
3135 ;; subscript might be negative
3136 (let ((a (make-array 5)))
3137 (array-in-bounds-p a (- (random 3) 2)))
3138 ;; subscript might be too large
3139 (let ((a (make-array 5)))
3140 (array-in-bounds-p a (random 6)))
3141 ;; unknown upper bound
3142 (let ((a (make-array 5)))
3143 (array-in-bounds-p a (get-universal-time)))
3144 ;; unknown lower bound
3145 (let ((a (make-array 5)))
3146 (array-in-bounds-p a (- (get-universal-time))))
3147 ;; in theory we should be able to optimize
3148 ;; the following but the current implementation
3149 ;; doesn't cut it because the array type's
3150 ;; dimensions get reported as (* *).
3151 (let ((a (make-array (list (random 20) 1))))
3152 (array-in-bounds-p a 5 2))))))
3153
3154 ;;; optimizing (EXPT -1 INTEGER)
3155 (with-test (:name (expt -1 integer))
3156 (dolist (x '(-1 -1.0 -1.0d0))
3157 (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
3158 (assert (not (ctu:find-named-callees fun)))
3159 (dotimes (i 12)
3160 (if (oddp i)
3161 (assert (eql x (funcall fun i)))
3162 (assert (eql (- x) (funcall fun i))))))))
3163
3164 (with-test (:name :float-division-using-exact-reciprocal)
3165 (flet ((test (lambda-form arg res &key (check-insts t))
3166 (let* ((fun (compile nil lambda-form))
3167 (disassembly (with-output-to-string (s)
3168 (disassemble fun :stream s))))
3169 ;; Let's make sure there is no division at runtime: for x86 and
3170 ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
3171 ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
3172 ;; it works.
3173 #+(or x86 x86-64)
3174 (when check-insts
3175 (assert (not (search "DIV" disassembly))))
3176 ;; No generic arithmetic!
3177 (assert (not (search "GENERIC" disassembly)))
3178 (assert (eql res (funcall fun arg))))))
3179 (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
3180 (dolist (type '(single-float double-float))
3181 (let* ((cf (coerce c type))
3182 (arg (- (random (* 2 cf)) cf))
3183 (r1 (eval `(/ ,arg ,cf)))
3184 (r2 (eval `(/ ,arg ,(- cf)))))
3185 (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1)
3186 (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2)
3187 ;; rational args should get optimized as well
3188 (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1)
3189 (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2))))
3190 ;; Also check that inexact reciprocals (1) are not used by default (2) are
3191 ;; used with FLOAT-ACCURACY=0.
3192 (dolist (type '(single-float double-float))
3193 (let ((trey (coerce 3 type))
3194 (one (coerce 1 type)))
3195 (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one
3196 :check-insts nil)
3197 (test `(lambda (x)
3198 (declare (,type x)
3199 (optimize (sb-c::float-accuracy 0)))
3200 (/ x 3))
3201 trey (eval `(* ,trey (/ ,trey))))))))
3202
3203 (with-test (:name :float-multiplication-by-one)
3204 (flet ((test (lambda-form arg &optional (result arg))
3205 (let* ((fun1 (compile nil lambda-form))
3206 (fun2 (funcall (compile nil `(lambda ()
3207 (declare (optimize (sb-c::float-accuracy 0)))
3208 ,lambda-form))))
3209 (disassembly1 (with-output-to-string (s)
3210 (disassemble fun1 :stream s)))
3211 (disassembly2 (with-output-to-string (s)
3212 (disassemble fun2 :stream s))))
3213 ;; Multiplication at runtime should be eliminated only with
3214 ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
3215 #+(or x86 x86-64)
3216 (assert (and (search "MUL" disassembly1)
3217 (not (search "MUL" disassembly2))))
3218 ;; Not generic arithmetic, please!
3219 (assert (and (not (search "GENERIC" disassembly1))
3220 (not (search "GENERIC" disassembly2))))
3221 (assert (eql result (funcall fun1 arg)))
3222 (assert (eql result (funcall fun2 arg))))))
3223 (dolist (type '(single-float double-float))
3224 (let* ((one (coerce 1 type))
3225 (arg (random (* 2 one)))
3226 (-r (- arg)))
3227 (test `(lambda (x) (declare (,type x)) (* x 1)) arg)
3228 (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r)
3229 (test `(lambda (x) (declare (,type x)) (* x ,one)) arg)
3230 (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r)))))
3231
3232 (with-test (:name :float-addition-of-zero)
3233 (flet ((test (lambda-form arg &optional (result arg))
3234 (let* ((fun1 (compile nil lambda-form))
3235 (fun2 (funcall (compile nil `(lambda ()
3236 (declare (optimize (sb-c::float-accuracy 0)))
3237 ,lambda-form))))
3238 (disassembly1 (with-output-to-string (s)
3239 (disassemble fun1 :stream s)))
3240 (disassembly2 (with-output-to-string (s)
3241 (disassemble fun2 :stream s))))
3242 ;; Let's make sure there is no addition at runtime: for x86 and
3243 ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
3244 ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
3245 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3246 ;; addition in to catch SNaNs.
3247 #+x86
3248 (assert (and (search "FADD" disassembly1)
3249 (not (search "FADD" disassembly2))))
3250 #+x86-64
3251 (let ((inst (if (typep result 'double-float)
3252 "ADDSD" "ADDSS")))
3253 (assert (and (search inst disassembly1)
3254 (not (search inst disassembly2)))))
3255 (assert (eql result (funcall fun1 arg)))
3256 (assert (eql result (funcall fun2 arg))))))
3257 (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45)
3258 (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21)
3259 (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0)
3260 (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0)
3261 (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0)
3262 (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0)))
3263
3264 (with-test (:name :float-substraction-of-zero)
3265 (flet ((test (lambda-form arg &optional (result arg))
3266 (let* ((fun1 (compile nil lambda-form))
3267 (fun2 (funcall (compile nil `(lambda ()
3268 (declare (optimize (sb-c::float-accuracy 0)))
3269 ,lambda-form))))
3270 (disassembly1 (with-output-to-string (s)
3271 (disassemble fun1 :stream s)))
3272 (disassembly2 (with-output-to-string (s)
3273 (disassemble fun2 :stream s))))
3274 ;; Let's make sure there is no substraction at runtime: for x86
3275 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
3276 ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
3277 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3278 ;; substraction in in to catch SNaNs.
3279 #+x86
3280 (assert (and (search "FSUB" disassembly1)
3281 (not (search "FSUB" disassembly2))))
3282 #+x86-64
3283 (let ((inst (if (typep result 'double-float)
3284 "SUBSD" "SUBSS")))
3285 (assert (and (search inst disassembly1)
3286 (not (search inst disassembly2)))))
3287 (assert (eql result (funcall fun1 arg)))
3288 (assert (eql result (funcall fun2 arg))))))
3289 (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45)
3290 (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21)
3291 (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0)
3292 (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0)
3293 (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0)
3294 (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0)))
3295
3296 (with-test (:name :float-multiplication-by-two)
3297 (flet ((test (lambda-form arg &optional (result arg))
3298 (let* ((fun1 (compile nil lambda-form))
3299 (fun2 (funcall (compile nil `(lambda ()
3300 (declare (optimize (sb-c::float-accuracy 0)))
3301 ,lambda-form))))
3302 (disassembly1 (with-output-to-string (s)
3303 (disassemble fun1 :stream s)))
3304 (disassembly2 (with-output-to-string (s)
3305 (disassemble fun2 :stream s))))
3306 ;; Let's make sure there is no multiplication at runtime: for x86
3307 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
3308 ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
3309 ;; but it works.
3310 #+(or x86 x86-64)
3311 (assert (and (not (search "MUL" disassembly1))
3312 (not (search "MUL" disassembly2))))
3313 (assert (eql result (funcall fun1 arg)))
3314 (assert (eql result (funcall fun2 arg))))))
3315 (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9)
3316 (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42)
3317 (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0)
3318 (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0)
3319 (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0)
3320 (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0)))
3321
3322 (with-test (:name :bug-392203)
3323 ;; Used to hit an AVER in COMVERT-MV-CALL.
3324 (assert (zerop
3325 (funcall
3326 (compile nil
3327 `(lambda ()
3328 (flet ((k (&rest x) (declare (ignore x)) 0))
3329 (multiple-value-call #'k #'k))))))))
3330
3331 (with-test (:name :allocate-closures-failing-aver)
3332 (let ((f (compile nil `(lambda ()
3333 (labels ((k (&optional x) #'k)))))))
3334 (assert (null (funcall f)))))
3335
3336 (with-test (:name :flush-vector-creation)
3337 (let ((f (compile nil `(lambda ()
3338 (dotimes (i 1024)
3339 (vector i i i))
3340 t))))
3341 (ctu:assert-no-consing (funcall f))))
3342
3343 (with-test (:name :array-type-predicates)
3344 (dolist (et (list* '(integer -1 200) '(integer -256 1)
3345 '(integer 0 128)
3346 '(integer 0 (128))
3347 '(double-float 0d0 (1d0))
3348 '(single-float (0s0) (1s0))
3349 '(or (eql 1d0) (eql 10d0))
3350 '(member 1 2 10)
3351 '(complex (member 10 20))
3352 '(complex (member 10d0 20d0))
3353 '(complex (member 10s0 20s0))
3354 '(or integer double-float)
3355 '(mod 1)
3356 '(member #\a #\b)
3357 '(eql #\a)
3358 #+sb-unicode 'extended-char
3359 #+sb-unicode '(eql #\cyrillic_small_letter_yu)
3360 sb-kernel::*specialized-array-element-types*))
3361 (when et
3362 (let* ((v (make-array 3 :element-type et))
3363 (fun (compile nil `(lambda ()
3364 (list
3365 (if (typep ,v '(simple-array ,et (*)))
3366 :good
3367 :bad)
3368 (if (typep (elt ,v 0) '(simple-array ,et (*)))
3369 :bad
3370 :good))))))
3371 (assert (equal '(:good :good) (funcall fun)))))))
3372
3373 (with-test (:name :truncate-float)
3374 (let ((s (compile nil `(lambda (x)
3375 (declare (single-float x))
3376 (truncate x))))
3377 (d (compile nil `(lambda (x)
3378 (declare (double-float x))
3379 (truncate x))))
3380 (s-inlined (compile nil '(lambda (x)
3381 (declare (type (single-float 0.0s0 1.0s0) x))
3382 (truncate x))))
3383 (d-inlined (compile nil '(lambda (x)
3384 (declare (type (double-float 0.0d0 1.0d0) x))
3385 (truncate x)))))
3386 ;; Check that there is no generic arithmetic
3387 (assert (not (search "GENERIC"
3388 (with-output-to-string (out)
3389 (disassemble s :stream out)))))
3390 (assert (not (search "GENERIC"
3391 (with-output-to-string (out)
3392 (disassemble d :stream out)))))
3393 ;; Check that we actually inlined the call when we were supposed to.
3394 (assert (not (search "UNARY-TRUNCATE"
3395 (with-output-to-string (out)
3396 (disassemble s-inlined :stream out)))))
3397 (assert (not (search "UNARY-TRUNCATE"
3398 (with-output-to-string (out)
3399 (disassemble d-inlined :stream out)))))))
3400
3401 (with-test (:name :make-array-unnamed-dimension-leaf)
3402 (let ((fun (compile nil `(lambda (stuff)
3403 (make-array (map 'list 'length stuff))))))
3404 (assert (equalp #2A((0 0 0) (0 0 0))
3405 (funcall fun '((1 2) (1 2 3)))))))
3406
3407 (with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
3408 (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3409 integer-decode-float))
3410 (let ((fun (compile nil `(lambda (x)
3411 (declare (optimize safety))
3412 (,name x)
3413 nil))))
3414 (flet ((test (arg)
3415 (unless (eq :error
3416 (handler-case
3417 (funcall fun arg)
3418 (error () :error)))
3419 (error "(~S ~S) did not error"
3420 name arg))))
3421 ;; No error
3422 (funcall fun 1.0)
3423 ;; Error
3424 (test 'not-a-float)
3425 (when (member name '(decode-float integer-decode-float))
3426 (test sb-ext:single-float-positive-infinity))))))
3427
3428 (with-test (:name :sap-ref-16)
3429 (let* ((fun (compile nil `(lambda (x y)
3430 (declare (type sb-sys:system-area-pointer x)
3431 (type (integer 0 100) y))
3432 (sb-sys:sap-ref-16 x (+ 4 y)))))
3433 (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3434 '(simple-array (unsigned-byte 8) (*))))
3435 (sap (sb-sys:vector-sap vector))
3436 (ret (funcall fun sap 0)))
3437 ;; test for either endianness
3438 (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
3439
3440 (with-test (:name :coerce-type-warning)
3441 (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3442 (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3443 (multiple-value-bind (fun warningsp failurep)
3444 (compile nil `(lambda (x)
3445 (declare (type simple-vector x))
3446 (coerce x '(vector ,type))))
3447 (assert (null warningsp))
3448 (assert (null failurep))
3449 (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
3450
3451 (with-test (:name :truncate-double-float)
3452 (let ((fun (compile nil `(lambda (x)
3453 (multiple-value-bind (q r)
3454 (truncate (coerce x 'double-float))
3455 (declare (type unsigned-byte q)
3456 (type double-float r))
3457 (list q r))))))
3458 (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
3459
3460 (with-test (:name :set-slot-value-no-warning)
3461 (let ((notes 0))
3462 (handler-bind ((warning #'error)
3463 (sb-ext:compiler-note (lambda (c)
3464 (declare (ignore c))
3465 (incf notes))))
3466 (compile nil `(lambda (x y)
3467 (declare (optimize speed safety))
3468 (setf (slot-value x 'bar) y))))
3469 (assert (= 1 notes))))
3470
3471 (with-test (:name :concatenate-string-opt)
3472 (flet ((test (type grep)
3473 (let* ((fun (compile nil `(lambda (a b c d e)
3474 (concatenate ',type a b c d e))))
3475 (args '("foo" #(#\.) "bar" (#\-) "quux"))
3476 (res (apply fun args)))
3477 (assert (search grep (with-output-to-string (out)
3478 (disassemble fun :stream out))))
3479 (assert (equal (apply #'concatenate type args)
3480 res))
3481 (assert (typep res type)))))
3482 (test 'string "%CONCATENATE-TO-STRING")
3483 (test 'simple-string "%CONCATENATE-TO-STRING")
3484 (test 'base-string "%CONCATENATE-TO-BASE-STRING")
3485 (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
3486
3487 (with-test (:name :satisfies-no-local-fun)
3488 (let ((fun (compile nil `(lambda (arg)
3489 (labels ((local-not-global-bug (x)
3490 t)
3491 (bar (x)
3492 (typep x '(satisfies local-not-global-bug))))
3493 (bar arg))))))
3494 (assert (eq 'local-not-global-bug
3495 (handler-case
3496 (funcall fun 42)
3497 (undefined-function (c)
3498 (cell-error-name c)))))))
3499
3500 ;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
3501 ;;; argument that is a complex structure (needing make-load-form
3502 ;;; processing) failed an AVER. The first attempt at a fix caused
3503 ;;; doing the same in-core to break.
3504 (with-test (:name :bug-310132)
3505 (compile nil '(lambda (&optional (foo #p"foo/bar")))))
3506
3507 (with-test (:name :bug-309129)
3508 (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
3509 (warningp nil)
3510 (fun (handler-bind ((warning (lambda (c)
3511 (setf warningp t) (muffle-warning c))))
3512 (compile nil src))))
3513 (assert warningp)
3514 (handler-case (funcall fun #(1))
3515 (type-error (c)
3516 ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
3517 ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
3518 (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
3519 (:no-error (&rest values)
3520 (declare (ignore values))
3521 (error "no error")))))
3522
3523 (with-test (:name :unary-round-type-derivation)
3524 (let* ((src '(lambda (zone)
3525 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
3526 (declare (ignore h))
3527 (round (* 60.0 m)))))
3528 (fun (compile nil src)))
3529 (assert (= (funcall fun 0.5) 30))))
3530
3531 (with-test (:name :bug-525949)
3532 (let* ((src '(lambda ()
3533 (labels ((always-one () 1)
3534 (f (z)
3535 (let ((n (funcall z)))
3536 (declare (fixnum n))
3537 (the double-float (expt n 1.0d0)))))
3538 (f #'always-one))))
3539 (warningp nil)
3540 (fun (handler-bind ((warning (lambda (c)
3541 (setf warningp t) (muffle-warning c))))
3542 (compile nil src))))
3543 (assert (not warningp))
3544 (assert (= 1.0d0 (funcall fun)))))
3545
3546 (with-test (:name :%array-data-vector-type-derivation)
3547 (let* ((f (compile nil
3548 `(lambda (ary)
3549 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3550 (setf (aref ary 0 0) 0))))
3551 (text (with-output-to-string (s)
3552 (disassemble f :stream s))))
3553 (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
3554
3555 (with-test (:name :array-storage-vector-type-derivation)
3556 (let ((f (compile nil
3557 `(lambda (ary)
3558 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3559 (ctu:compiler-derived-type (array-storage-vector ary))))))
3560 (assert (equal '(simple-array (unsigned-byte 32) (9))
3561 (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
3562
3563 (with-test (:name :bug-523612)
3564 (let ((fun
3565 (compile nil
3566 `(lambda (&key toff)
3567 (make-array 3 :element-type 'double-float
3568 :initial-contents
3569 (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
3570 (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
3571 (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
3572
3573 (with-test (:name :bug-309788)
3574 (let ((fun
3575 (compile nil
3576 `(lambda (x)
3577 (declare (optimize speed))
3578 (let ((env nil))
3579 (typep x 'fixnum env))))))
3580 (assert (not (ctu:find-named-callees fun)))))
3581
3582 (with-test (:name :bug-309124)
3583 (let ((fun
3584 (compile nil
3585 `(lambda (x)
3586 (declare (integer x))
3587 (declare (optimize speed))
3588 (cond ((typep x 'fixnum)
3589 "hala")
3590 ((typep x 'fixnum)
3591 "buba")
3592 ((typep x 'bignum)
3593 "hip")
3594 (t
3595 "zuz"))))))
3596 (assert (equal (list "hala" "hip")
3597 (sort (ctu:find-code-constants fun :type 'string)
3598 #'string<)))))
3599
3600 (with-test (:name :bug-316078)
3601 (let ((fun
3602 (compile nil
3603 `(lambda (x)
3604 (declare (type (and simple-bit-vector (satisfies bar)) x)
3605 (optimize speed))
3606 (elt x 5)))))
3607 (assert (not (ctu:find-named-callees fun)))
3608 (assert (= 1 (funcall fun #*000001)))
3609 (assert (= 0 (funcall fun #*000010)))))
3610
3611 (with-test (:name :mult-by-one-in-float-acc-zero)
3612 (assert (eql 1.0 (funcall (compile nil `(lambda (x)
3613 (declare (optimize (sb-c::float-accuracy 0)))
3614 (* x 1.0)))
3615 1)))
3616 (assert (eql -1.0 (funcall (compile nil `(lambda (x)
3617 (declare (optimize (sb-c::float-accuracy 0)))
3618 (* x -1.0)))
3619 1)))
3620 (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
3621 (declare (optimize (sb-c::float-accuracy 0)))
3622 (* x 1.0d0)))
3623 1)))
3624 (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
3625 (declare (optimize (sb-c::float-accuracy 0)))
3626 (* x -1.0d0)))
3627 1))))
3628
3629 (with-test (:name :dotimes-non-integer-counter-value)
3630 (assert-error (dotimes (i 8.6)) type-error))
3631
3632 (with-test (:name :bug-454681)
3633 ;; This used to break due to reference to a dead lambda-var during
3634 ;; inline expansion.
3635 (assert (compile nil
3636 `(lambda ()
3637 (multiple-value-bind (iterator+977 getter+978)
3638 (does-not-exist-but-does-not-matter)
3639 (flet ((iterator+976 ()
3640 (funcall iterator+977)))
3641 (declare (inline iterator+976))
3642 (let ((iterator+976 #'iterator+976))
3643 (funcall iterator+976))))))))
3644
3645 (with-test (:name :complex-float-local-fun-args)
3646 ;; As of 1.0.27.14, the lambda below failed to compile due to the
3647 ;; compiler attempting to pass unboxed complex floats to Z and the
3648 ;; MOVE-ARG method not expecting the register being used as a
3649 ;; temporary frame pointer. Reported by sykopomp in #lispgames,
3650 ;; reduced test case provided by _3b`.
3651 (compile nil '(lambda (a)
3652 (labels ((z (b c)
3653 (declare ((complex double-float) b c))
3654 (* b (z b c))))
3655 (loop for i below 10 do
3656 (setf a (z a a)))))))
3657
3658 (with-test (:name :bug-309130)
3659 (assert (eq :warning
3660 (handler-case
3661 (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
3662 ((and warning (not style-warning)) ()
3663 :warning))))
3664 (assert (eq :warning
3665 (handler-case
3666 (compile nil `(lambda (x)
3667 (declare (optimize (debug 0)))
3668 (declare (type vector x))
3669 (list (fill-pointer x) (svref x 1))))
3670 ((and warning (not style-warning)) ()
3671 :warning))))
3672 (assert (eq :warning
3673 (handler-case
3674 (compile nil `(lambda (x)
3675 (list (vector-push (svref x 0) x))))
3676 ((and warning (not style-warning)) ()
3677 :warning))))
3678 (assert (eq :warning
3679 (handler-case
3680 (compile nil `(lambda (x)
3681 (list (vector-push-extend (svref x 0) x))))
3682 ((and warning (not style-warning)) ()
3683 :warning)))))
3684
3685 (with-test (:name :bug-646796)
3686 (assert 42
3687 (funcall
3688 (compile nil
3689 `(lambda ()
3690 (load-time-value (the (values fixnum) 42)))))))
3691
3692 (with-test (:name :bug-654289)
3693 ;; Test that compile-times don't explode when quoted constants
3694 ;; get big.
3695 (labels ((time-n (n)
3696 (gc :full t) ; Let's not confuse the issue with GC
3697 (let* ((tree (make-tree (expt 10 n) nil))
3698 (t0 (get-internal-run-time))
3699 (f (compile nil `(lambda (x) (eq x (quote ,tree)))))
3700 (t1 (get-internal-run-time)))
3701 (assert (funcall f tree))
3702 (- t1 t0)))
3703 (make-tree (n acc)
3704 (cond ((zerop n) acc)
3705 (t (make-tree (1- n) (cons acc acc))))))
3706 (let* ((times (loop for i from 0 upto 4
3707 collect (time-n i)))
3708 (max-small (reduce #'max times :end 3))
3709 (max-big (reduce #'max times :start 3)))
3710 ;; This way is hopefully fairly CPU-performance insensitive.
3711 (unless (> (+ (truncate internal-time-units-per-second 10)
3712 (* 2 max-small))
3713 max-big)
3714 (error "Bad scaling or test? ~S" times)))))
3715
3716 (with-test (:name :bug-309063)
3717 (let ((fun (compile nil `(lambda (x)
3718 (declare (type (integer 0 0) x))
3719 (ash x 100)))))
3720 (assert (zerop (funcall fun 0)))))
3721
3722 (with-test (:name :bug-655872)
3723 (let ((f (compile nil `(lambda (x)
3724 (declare (optimize (safety 3)))
3725 (aref (locally (declare (optimize (safety 0)))
3726 (coerce x '(simple-vector 128)))
3727 60))))
3728 (long (make-array 100 :element-type 'fixnum)))
3729 (dotimes (i 100)
3730 (setf (aref long i) i))
3731 ;; 1. COERCE doesn't check the length in unsafe code.
3732 (assert (eql 60 (funcall f long)))
3733 ;; 2. The compiler doesn't trust the length from COERCE
3734 (assert (eq :caught
3735 (handler-case
3736 (funcall f (list 1 2 3))
3737 (sb-int:invalid-array-index-error (e)
3738 (assert (eql 60 (type-error-datum e)))
3739 (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
3740 :caught))))))
3741
3742 (with-test (:name :bug-655203-regression)
3743 (let ((fun (compile nil
3744 `(LAMBDA (VARIABLE)
3745 (LET ((CONTINUATION
3746 (LAMBDA
3747 (&OPTIONAL DUMMY &REST OTHER)
3748 (DECLARE (IGNORE OTHER))
3749 (PRIN1 DUMMY)
3750 (PRIN1 VARIABLE))))
3751 (FUNCALL CONTINUATION (LIST 1 2)))))))
3752 ;; This used to signal a bogus type-error.
3753 (assert (equal (with-output-to-string (*standard-output*)
3754 (funcall fun t))
3755 "(1 2)T"))))
3756
3757 (with-test (:name :constant-concatenate-compile-time)
3758 (flet ((make-lambda (n)
3759 `(lambda (x)
3760 (declare (optimize (speed 3) (space 0)))
3761 (concatenate 'string x ,(make-string n)))))
3762 (let* ((l0 (make-lambda 1))
3763 (l1 (make-lambda 10))
3764 (l2 (make-lambda 100))
3765 (l3 (make-lambda 1000))
3766 (t0 (get-internal-run-time))
3767 (f0 (compile nil l0))
3768 (t1 (get-internal-run-time))
3769 (f1 (compile nil l1))
3770 (t2 (get-internal-run-time))
3771 (f2 (compile nil l2))
3772 (t3 (get-internal-run-time))
3773 (f3 (compile nil l3))
3774 (t4 (get-internal-run-time))
3775 (d0 (- t1 t0))
3776 (d1 (- t2 t1))
3777 (d2 (- t3 t2))
3778 (d3 (- t4 t3))
3779 (short-avg (/ (+ d0 d1 d2) 3)))
3780 (assert (and f1 f2 f3))
3781 (assert (< d3 (* 10 short-avg))))))
3782
3783 (with-test (:name :bug-384892)
3784 (assert (equal
3785 ;; The assertion that BOOLEAN becomes (MEMBER T NIL)
3786 ;; is slightly brittle, but the rest of the
3787 ;; assertion is ok.
3788 '(function (fixnum fixnum &key (:k1 (member t nil)))
3789 (values (member t) &optional))
3790 (sb-kernel:%simple-fun-type
3791 (compile nil `(lambda (x y &key k1)
3792 (declare (fixnum x y))
3793 (declare (boolean k1))
3794 (declare (ignore x y k1))
3795 t))))))
3796
3797 (with-test (:name :bug-309448)
3798 ;; Like all tests trying to verify that something doesn't blow up
3799 ;; compile-times this is bound to be a bit brittle, but at least
3800 ;; here we try to establish a decent baseline.
3801 (labels ((time-it (lambda want &optional times)
3802 (gc :full t) ; let's keep GCs coming from other code out...
3803 (let* ((start (get-internal-run-time))
3804 (iterations 0)
3805 (fun (if times
3806 (loop repeat times
3807 for result = (compile nil lambda)
3808 finally (return result))
3809 (loop for result = (compile nil lambda)
3810 do (incf iterations)
3811 until (> (get-internal-run-time) (+ start 10))
3812 finally (return result))))
3813 (end (get-internal-run-time))
3814 (got (funcall fun)))
3815 (unless (eql want got)
3816 (error "wanted ~S, got ~S" want got))
3817 (values (- end start) iterations)))
3818 (test-it (simple result1 complex result2)
3819 (multiple-value-bind (time-simple iterations)
3820 (time-it simple result1)
3821 (assert (>= (* 10 (1+ time-simple))
3822 (time-it complex result2 iterations))))))
3823 ;; This is mostly identical as the next one, but doesn't create
3824 ;; hairy unions of numeric types.
3825 (test-it `(lambda ()
3826 (labels ((bar (baz bim)
3827 (let ((n (+ baz bim)))
3828 (* n (+ n 1) bim))))
3829 (let ((a (bar 1 1))
3830 (b (bar 1 1))
3831 (c (bar 1 1)))
3832 (- (+ a b) c))))
3833 6
3834 `(lambda ()
3835 (labels ((bar (baz bim)
3836 (let ((n (+ baz bim)))
3837 (* n (+ n 1) bim))))
3838 (let ((a (bar 1 1))
3839 (b (bar 1 5))
3840 (c (bar 1 15)))
3841 (- (+ a b) c))))
3842 -3864)
3843 (test-it `(lambda ()
3844 (labels ((sum-d (n)
3845 (let ((m (truncate 999 n)))
3846 (/ (* n m (1+ m)) 2))))
3847 (- (+ (sum-d 3)
3848 (sum-d 3))
3849 (sum-d 3))))
3850 166833
3851 `(lambda ()
3852 (labels ((sum-d (n)
3853 (let ((m (truncate 999 n)))
3854 (/ (* n m (1+ m)) 2))))
3855 (- (+ (sum-d 3)
3856 (sum-d 5))
3857 (sum-d 15))))
3858 233168)))
3859
3860 (with-test (:name :regression-1.0.44.34)
3861 (compile nil '(lambda (z &rest args)
3862 (declare (dynamic-extent args))
3863 (flet ((foo (w v) (list v w)))
3864 (setq z 0)
3865 (flet ((foo ()
3866 (foo z args)))
3867 (declare (sb-int:truly-dynamic-extent #'foo))
3868 (call #'foo nil))))))
3869
3870 (with-test (:name :bug-713626)
3871 (let ((f (eval '(constantly 42))))
3872 (handler-bind ((warning #'error))
3873 (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
3874
3875 (with-test (:name :known-fun-allows-other-keys)
3876 (handler-bind ((warning #'error))
3877 (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
3878 (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
3879
3880 (with-test (:name :bug-551227)
3881 ;; This function causes constraint analysis to perform a
3882 ;; ref-substitution that alters the A referred to in (G A) at in the
3883 ;; consequent of the IF to refer to be NUMBER, from the
3884 ;; LET-converted inline-expansion of MOD. This leads to attempting
3885 ;; to CLOSE-OVER a variable that simply isn't in scope when it is
3886 ;; referenced.
3887 (compile nil '(lambda (a)
3888 (if (let ((s a))
3889 (block :block
3890 (map nil
3891 (lambda (e)
3892 (return-from :block
3893 (f (mod a e))))
3894 s)))
3895 (g a)))))
3896
3897 (with-test (:name :funcall-lambda-inlined)
3898 (assert (not
3899 (ctu:find-code-constants
3900 (compile nil
3901 `(lambda (x y)
3902 (+ x (funcall (lambda (z) z) y))))
3903 :type 'function))))
3904
3905 (with-test (:name :bug-720382)
3906 (let ((w 0))
3907 (let ((f
3908 (handler-bind (((and warning (not style-warning))
3909 (lambda (c) (incf w))))
3910 (compile nil `(lambda (b) ((lambda () b) 1))))))
3911 (assert (= w 1))
3912 (assert (eq :error
3913 (handler-case (funcall f 0)
3914 (error () :error)))))))
3915
3916 (with-test (:name :multiple-args-to-function)
3917 (let ((form `(flet ((foo (&optional (x 13)) x))
3918 (funcall (function foo 42))))
3919 #+sb-eval (*evaluator-mode* :interpret))
3920 #+sb-eval
3921 (assert (eq :error
3922 (handler-case (eval form)
3923 (error () :error))))
3924 (multiple-value-bind (fun warn fail)
3925 (compile nil `(lambda () ,form))
3926 (assert (and warn fail))
3927 (assert (eq :error
3928 (handler-case (funcall fun)
3929 (error () :error)))))))
3930
3931 ;;; This doesn't test LVAR-FUN-IS directly, but captures it
3932 ;;; pretty accurately anyways.
3933 (with-test (:name :lvar-fun-is)
3934 (dolist (fun (list
3935 (lambda (x) (member x x :test #'eq))
3936 (lambda (x) (member x x :test 'eq))
3937 (lambda (x) (member x x :test #.#'eq))))
3938 (assert (equal (list #'sb-kernel:%member-eq)
3939 (ctu:find-named-callees fun))))
3940 (dolist (fun (list
3941 (lambda (x)
3942 (declare (notinline eq))
3943 (member x x :test #'eq))
3944 (lambda (x)
3945 (declare (notinline eq))
3946 (member x x :test 'eq))
3947 (lambda (x)
3948 (declare (notinline eq))
3949 (member x x :test #.#'eq))))
3950 (assert (member #'sb-kernel:%member-test
3951 (ctu:find-named-callees fun)))))
3952
3953 (with-test (:name :delete-to-delq-opt)
3954 (dolist (fun (list (lambda (x y)
3955 (declare (list y))
3956 (delete x y :test #'eq))
3957 (lambda (x y)
3958 (declare (fixnum x) (list y))
3959 (delete x y))
3960 (lambda (x y)
3961 (declare (symbol x) (list y))
3962 (delete x y :test #'eql))))
3963 (assert (equal (list #'sb-int:delq)
3964 (ctu:find-named-callees fun)))))
3965
3966 (with-test (:name :bug-767959)
3967 ;; This used to signal an error.
3968 (compile nil `(lambda ()
3969 (declare (optimize sb-c:store-coverage-data))
3970 (assoc
3971 nil
3972 '((:ordinary . ordinary-lambda-list))))))
3973
3974 ;; This test failed formerly because the source transform of TYPEP would be
3975 ;; disabled when storing coverage data, thus giving no semantics to
3976 ;; expressions such as (TYPEP x 'INTEGER). The compiler could therefore not
3977 ;; prove that the else clause of the IF is unreachable - which it must be
3978 ;; since X is asserted to be fixnum. The conflicting requirement on X
3979 ;; that it be acceptable to LENGTH signaled a full warning.
3980 ;; Nobody on sbcl-devel could remember why the source transform was disabled,
3981 ;; but nobody disagreed with undoing the disabling.
3982 (with-test (:name :sb-cover-and-typep)
3983 (multiple-value-bind (fun warnings-p failure-p)
3984 (compile nil '(lambda (x)
3985 (declare (fixnum x) (optimize sb-c:store-coverage-data))
3986 (if (typep x 'integer) x (length x))))
3987 (assert (and fun (not warnings-p) (not failure-p)))))
3988
3989 (with-test (:name :member-on-long-constant-list)
3990 ;; This used to blow stack with a sufficiently long list.
3991 (let ((cycle (list t)))
3992 (nconc cycle cycle)
3993 (compile nil `(lambda (x)
3994 (member x ',cycle)))))
3995
3996 (with-test (:name :bug-722734)
3997 (assert-error
3998 (funcall (compile
3999 nil
4000 '(lambda ()
4001 (eql (make-array 6)
4002 (list unbound-variable-1 unbound-variable-2)))))))
4003
4004 (with-test (:name :bug-771673)
4005 (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar))))
4006 ;; Make sure the compiler doesn't use THE, and check that setf-expansions
4007 ;; work.
4008 (let ((f (compile nil `(lambda (x y)
4009 (setf (truly-the fixnum (car x)) y)))))
4010 (let* ((cell (cons t t)))
4011 (funcall f cell :ok)
4012 (assert (equal '(:ok . t) cell)))))
4013
4014 (with-test (:name (:bug-793771 +))
4015 (let ((f (compile nil `(lambda (x y)
4016 (declare (type (single-float 2.0) x)
4017 (type (single-float (0.0)) y))
4018 (+ x y)))))
4019 (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
4020 (values (single-float 2.0) &optional))
4021 (sb-kernel:%simple-fun-type f)))))
4022
4023 (with-test (:name (:bug-793771 -))
4024 (let ((f (compile nil `(lambda (x y)
4025 (declare (type (single-float * 2.0) x)
4026 (type (single-float (0.0)) y))
4027 (- x y)))))
4028 (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
4029 (values (single-float * 2.0) &optional))
4030 (sb-kernel:%simple-fun-type f)))))
4031
4032 (with-test (:name (:bug-793771 *))
4033 (let ((f (compile nil `(lambda (x)
4034 (declare (type (single-float (0.0)) x))
4035 (* x 0.1)))))
4036 (assert (equal `(function ((single-float (0.0)))
4037 (values (or (member 0.0) (single-float (0.0))) &optional))
4038 (sb-kernel:%simple-fun-type f)))))
4039
4040 (with-test (:name (:bug-793771 /))
4041 (let ((f (compile nil `(lambda (x)
4042 (declare (type (single-float (0.0)) x))
4043 (/ x 3.0)))))
4044 (assert (equal `(function ((single-float (0.0)))
4045 (values (or (member 0.0) (single-float (0.0))) &optional))
4046 (sb-kernel:%simple-fun-type f)))))
4047
4048 (with-test (:name (:bug-486812 single-float))
4049 (compile nil `(lambda ()
4050 (sb-kernel:make-single-float -1))))
4051
4052 (with-test (:name (:bug-486812 double-float))
4053 (compile nil `(lambda ()
4054 (sb-kernel:make-double-float -1 0))))
4055
4056 (with-test (:name :bug-729765)
4057 (compile nil `(lambda (a b)
4058 (declare ((integer 1 1) a)
4059 ((integer 0 1) b)
4060 (optimize debug))
4061 (lambda () (< b a)))))
4062
4063 ;; Actually tests the assembly of RIP-relative operands to comparison
4064 ;; functions (one of the few x86 instructions that have extra bytes
4065 ;; *after* the mem operand's effective address, resulting in a wrong
4066 ;; offset).
4067 (with-test (:name :cmpps)
4068 (let ((foo (compile nil `(lambda (x)
4069 (= #C(2.0 3.0) (the (complex single-float) x))))))
4070 (assert (funcall foo #C(2.0 3.0)))
4071 (assert (not (funcall foo #C(1.0 2.0))))))
4072
4073 (with-test (:name :cmppd)
4074 (let ((foo (compile nil `(lambda (x)
4075 (= #C(2d0 3d0) (the (complex double-float) x))))))
4076 (assert (funcall foo #C(2d0 3d0)))
4077 (assert (not (funcall foo #C(1d0 2d0))))))
4078
4079 (with-test (:name :lvar-externally-checkable-type-nil)
4080 ;; Used to signal a BUG during compilation.
4081 (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
4082 (multiple-value-bind (i p) (funcall fun :start)
4083 (assert (= 2321321 i))
4084 (assert (= 8 p)))
4085 (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
4086 (assert (not i))
4087 (assert (typep e 'type-error)))))
4088
4089 (with-test (:name :simple-type-error-in-bound-propagation-a)
4090 (compile nil `(lambda (i)
4091 (declare (unsigned-byte i))
4092 (expt 10 (expt 7 (- 2 i))))))
4093
4094 (with-test (:name :simple-type-error-in-bound-propagation-b)
4095 (assert (equal `(FUNCTION (UNSIGNED-BYTE)
4096 (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
4097 (sb-kernel:%simple-fun-type
4098 (compile nil `(lambda (i)
4099 (declare (unsigned-byte i))
4100 (cos (expt 10 (+ 4096 i)))))))))
4101
4102 (with-test (:name :fixed-%more-arg-values)
4103 (let ((fun (compile nil `(lambda (&rest rest)
4104 (declare (optimize (safety 0)))
4105 (apply #'cons rest)))))
4106 (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
4107
4108 (with-test (:name :bug-826970)
4109 (let ((fun (compile nil `(lambda (a b c)
4110 (declare (type (member -2 1) b))
4111 (array-in-bounds-p a 4 b c)))))
4112 (assert (funcall fun (make-array '(5 2 2)) 1 1))))
4113
4114 (with-test (:name :bug-826971)
4115 (let* ((foo "foo")
4116 (fun (compile nil `(lambda (p1 p2)
4117 (schar (the (eql ,foo) p1) p2)))))
4118 (assert (eql #\f (funcall fun foo 0)))))
4119
4120 (with-test (:name :bug-738464)
4121 (multiple-value-bind (fun warn fail)
4122 (compile nil `(lambda ()
4123 (flet ((foo () 42))
4124 (declare (ftype non-function-type foo))
4125 (foo))))
4126 (assert (eql 42 (funcall fun)))
4127 (assert (and warn (not fail)))))
4128
4129 (with-test (:name :bug-832005)
4130 (let ((fun (compile nil `(lambda (x)
4131 (declare (type (complex single-float) x))
4132 (+ #C(0.0 1.0) x)))))
4133 (assert (= (funcall fun #C(1.0 2.0))
4134 #C(1.0 3.0)))))
4135
4136 ;; A refactoring 1.0.12.18 caused lossy computation of primitive
4137 ;; types for member types.
4138 (with-test (:name :member-type-primitive-type)
4139 (let ((fun (compile nil `(lambda (p1 p2 p3)
4140 (if p1
4141 (the (member #c(1.2d0 1d0)) p2)
4142 (the (eql #c(1.0 1.0)) p3))))))
4143 (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
4144 #c(1.2d0 1.0d0)))))
4145
4146 ;; Fall-through jump elimination made control flow fall through to trampolines.
4147 ;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
4148 ;; reproduced below (triggered a corruption warning and a memory fault).
4149 (with-test (:name :bug-883500)
4150 (funcall (compile nil `(lambda (a)
4151 (declare (type (integer -50 50) a))
4152 (declare (optimize (speed 0)))
4153 (mod (mod a (min -5 a)) 5)))
4154 1))
4155
4156 ;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
4157 #+sb-unicode
4158 (with-test (:name :bug-883519)
4159 (compile nil `(lambda (x)
4160 (declare (type character x))
4161 (eql x #\U0010FFFF))))
4162
4163 ;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
4164 (with-test (:name :bug-887220)
4165 (let ((incfer (compile
4166 nil
4167 `(lambda (vector index)
4168 (declare (type (simple-array sb-ext:word (4))
4169 vector)
4170 (type (mod 4) index))
4171 (sb-ext:atomic-incf (aref vector index) 1)
4172 vector))))
4173 (assert (equalp (funcall incfer
4174 (make-array 4 :element-type 'sb-ext:word
4175 :initial-element 0)
4176 1)
4177 #(0 1 0 0)))))
4178
4179 (with-test (:name :catch-interferes-with-debug-names)
4180 (let ((fun (funcall
4181 (compile nil
4182 `(lambda ()
4183 (catch 'out
4184 (flet ((foo ()
4185 (throw 'out (lambda () t))))
4186 (foo))))))))
4187 (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
4188
4189 (with-test (:name :interval-div-signed-zero)
4190 (let ((fun (compile nil
4191 `(Lambda (a)
4192 (declare (type (member 0 -272413371076) a))
4193 (ffloor (the number a) -63243.127451934015d0)))))
4194 (multiple-value-bind (q r) (funcall fun 0)
4195 (assert (eql -0d0 q))
4196 (assert (eql 0d0 r)))))
4197
4198 (with-test (:name :non-constant-keyword-typecheck)
4199 (let ((fun (compile nil
4200 `(lambda (p1 p3 p4)
4201 (declare (type keyword p3))
4202 (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
4203 (assert (funcall fun (cons 1.0 2.0) :test '=))))
4204
4205 (with-test (:name :truncate-wild-values)
4206 (multiple-value-bind (q r)
4207 (handler-bind ((warning #'error))
4208 (let ((sb-c::*check-consistency* t))
4209 (funcall (compile nil
4210 `(lambda (a)
4211 (declare (type (member 1d0 2d0) a))
4212 (block return-value-tag
4213 (funcall
4214 (the function
4215 (catch 'debug-catch-tag
4216 (return-from return-value-tag
4217 (progn (truncate a)))))))))
4218 2d0)))
4219 (assert (eql 2 q))
4220 (assert (eql 0d0 r))))
4221
4222 (with-test (:name :boxed-fp-constant-for-full-call)
4223 (let ((fun (compile nil
4224 `(lambda (x)
4225 (declare (double-float x))
4226 (unknown-fun 1.0d0 (+ 1.0d0 x))))))
4227 (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
4228
4229 (with-test (:name :only-one-boxed-constant-for-multiple-uses)
4230 (let* ((big (1+ most-positive-fixnum))
4231 (fun (compile nil
4232 `(lambda (x)
4233 (unknown-fun ,big (+ ,big x))))))
4234 (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
4235
4236 (with-test (:name :fixnum+float-coerces-fixnum
4237 :skipped-on :x86)
4238 (let ((fun (compile nil
4239 `(lambda (x y)
4240 (declare (fixnum x)
4241 (single-float y))
4242 (+ x y)))))
4243 (assert (not (ctu:find-named-callees fun)))
4244 (assert (not (search "GENERIC"
4245 (with-output-to-string (s)
4246 (disassemble fun :stream s)))))))
4247
4248 (with-test (:name :bug-803508)
4249 (compile nil `(lambda ()
4250 (print
4251 (lambda (bar)
4252 (declare (dynamic-extent bar))
4253 (foo bar))))))
4254
4255 (with-test (:name :bug-803508-b)
4256 (compile nil `(lambda ()
4257 (list
4258 (lambda (bar)
4259 (declare (dynamic-extent bar))
4260 (foo bar))))))
4261
4262 (with-test (:name :bug-803508-c)
4263 (compile nil `(lambda ()
4264 (list
4265 (lambda (bar &optional quux)
4266 (declare (dynamic-extent bar quux))
4267 (foo bar quux))))))
4268
4269 (with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
4270 (compile nil `(lambda (b c d)
4271 (declare (type (integer -20545789 207590862) c))
4272 (declare (type (integer -1 -1) d))
4273 (let ((i (unwind-protect 32 (shiftf d -1))))
4274 (or (if (= d c) 2 (= 3 b)) 4)))))
4275
4276 (with-test (:name :bug-913232)
4277 (compile nil `(lambda (x)
4278 (declare (optimize speed)
4279 (type (or (and (or (integer -100 -50)
4280 (integer 100 200)) (satisfies foo))
4281 (and (or (integer 0 10) (integer 20 30)) a)) x))
4282 x))
4283 (compile nil `(lambda (x)
4284 (declare (optimize speed)
4285 (type (and fixnum a) x))
4286 x)))
4287
4288 (with-test (:name :bug-959687)
4289 (multiple-value-bind (fun warn fail)
4290 (compile nil `(lambda (x)
4291 (case x
4292 (t
4293 :its-a-t)
4294 (otherwise
4295 :somethign-else))))
4296 (assert (and warn fail))
4297 (assert (not (ignore-errors (funcall fun t)))))
4298 (multiple-value-bind (fun warn fail)
4299 (compile nil `(lambda (x)
4300 (case x
4301 (otherwise
4302 :its-an-otherwise)
4303 (t
4304 :somethign-else))))
4305 (assert (and warn fail))
4306 (assert (not (ignore-errors (funcall fun t))))))
4307
4308 (with-test (:name :bug-924276)
4309 (assert (eq :style-warning
4310 (handler-case
4311 (compile nil `(lambda (a)
4312 (cons a (symbol-macrolet ((b 1))
4313 (declare (ignorable a))
4314 :c))))
4315 (style-warning ()
4316 :style-warning)))))
4317
4318 (with-test (:name :bug-974406)
4319 (let ((fun32 (compile nil `(lambda (x)
4320 (declare (optimize speed (safety 0)))
4321 (declare (type (integer 53 86) x))
4322 (logand (+ x 1032791128) 11007078467))))
4323 (fun64 (compile nil `(lambda (x)
4324 (declare (optimize speed (safety 0)))
4325 (declare (type (integer 53 86) x))
4326 (logand (+ x 1152921504606846975)
4327 38046409652025950207)))))
4328 (assert (= (funcall fun32 61) 268574721))
4329 (assert (= (funcall fun64 61) 60)))
4330 (let (result)
4331 (do ((width 5 (1+ width)))
4332 ((= width 130))
4333 (dotimes (extra 4)
4334 (let ((fun (compile nil `(lambda (x)
4335 (declare (optimize speed (safety 0)))
4336 (declare (type (integer 1 16) x))
4337 (logand
4338 (+ x ,(1- (ash 1 width)))
4339 ,(logior (ash 1 (+ width 1 extra))
4340 (1- (ash 1 width))))))))
4341 (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
4342 (push (cons width extra) result)))))
4343 (assert (null result))))
4344
4345 ;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
4346 ;; uses a MOV into memory or goes through a temporary register if the
4347 ;; value is larger than a certain number of bits. Check that it respects
4348 ;; the limits of immediate arguments to the MOV instruction (if not, the
4349 ;; assembler will fail an assertion) and doesn't have sign-extension
4350 ;; problems. (The test passes fixnum constants through the MOVE VOP
4351 ;; which calls MOVE-IMMEDIATE.)
4352 (with-test (:name :constant-fixnum-move)
4353 (let ((f (compile nil `(lambda (g)
4354 (funcall g
4355 ;; The first three args are
4356 ;; uninteresting as they are
4357 ;; passed in registers.
4358 1 2 3
4359 ,@(loop for i from 27 to 32
4360 collect (expt 2 i)))))))
4361 (assert (every #'plusp (funcall f #'list)))))
4362
4363 (with-test (:name (:malformed-ignore :lp-1000239))
4364 (assert-error
4365 (eval '(lambda () (declare (ignore (function . a)))))
4366 sb-int:simple-program-error)
4367 (assert-error
4368 (eval '(lambda () (declare (ignore (function a b)))))
4369 sb-int:simple-program-error)
4370 (assert-error
4371 (eval '(lambda () (declare (ignore (function)))))
4372 sb-int:simple-program-error)
4373 (assert-error
4374 (eval '(lambda () (declare (ignore (a)))))
4375 sb-int:simple-program-error)
4376 (assert-error
4377 (eval '(lambda () (declare (ignorable (a b)))))
4378 sb-int:simple-program-error))
4379
4380 (with-test (:name :malformed-type-declaraions)
4381 (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
4382
4383 (with-test (:name :compiled-program-error-escaped-source)
4384 (assert
4385 (handler-case
4386 (funcall (compile nil `(lambda () (lambda ("foo")))))
4387 (sb-int:compiled-program-error (e)
4388 (let ((source (read-from-string (sb-kernel::program-error-source e))))
4389 (equal source '#'(lambda ("foo"))))))))
4390
4391 (with-test (:name :escape-analysis-for-nlxs)
4392 (flet ((test (check lambda &rest args)
4393 (let* ((cell-note nil)
4394 (fun (handler-bind ((compiler-note
4395 (lambda (note)
4396 (when (search
4397 "Allocating a value-cell at runtime for"
4398 (princ-to-string note))
4399 (setf cell-note t)))))
4400 (compile nil lambda))))
4401 (assert (eql check cell-note))
4402 (if check
4403 (assert
4404 (eq :ok
4405 (handler-case
4406 (dolist (arg args nil)
4407 (setf fun (funcall fun arg)))
4408 (sb-int:simple-control-error (e)
4409 (when (equal
4410 (simple-condition-format-control e)
4411 "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
4412 :ok)))))
4413 (ctu:assert-no-consing (apply fun args))))))
4414 (test nil `(lambda (x)
4415 (declare (optimize speed))
4416 (block out
4417 (flet ((ex () (return-from out 'out!)))
4418 (typecase x
4419 (cons (or (car x) (ex)))
4420 (t (ex)))))) :foo)
4421 (test t `(lambda (x)
4422 (declare (optimize speed))
4423 (funcall
4424 (block nasty
4425 (flet ((oops () (return-from nasty t)))
4426 #'oops)))) t)
4427 (test t `(lambda (r)
4428 (declare (optimize speed))
4429 (block out
4430 (flet ((ex () (return-from out r)))
4431 (lambda (x)
4432 (typecase x
4433 (cons (or (car x) (ex)))
4434 (t (ex))))))) t t)
4435 (test t `(lambda (x)
4436 (declare (optimize speed))
4437 (flet ((eh (x)
4438 (flet ((meh () (return-from eh 'meh)))
4439 (lambda ()
4440 (typecase x
4441 (cons (or (car x) (meh)))
4442 (t (meh)))))))
4443 (funcall (eh x)))) t t)))
4444
4445 (with-test (:name (:bug-1050768 :symptom))
4446 ;; Used to signal an error.
4447 (compile nil
4448 `(lambda (string position)
4449 (char string position)
4450 (array-in-bounds-p string (1+ position)))))
4451
4452 (with-test (:name (:bug-1050768 :cause))
4453 (let ((types `((string string)
4454 ((or (simple-array character 24) (vector t 24))
4455 (or (simple-array character 24) (vector t))))))
4456 (dolist (pair types)
4457 (destructuring-bind (orig conservative) pair
4458 (assert sb-c::(type= (specifier-type cl-user::conservative)
4459 (conservative-type (specifier-type cl-user::orig))))))))
4460
4461 (with-test (:name (:smodular64 :wrong-width))
4462 (let ((fun (compile nil
4463 '(lambda (x)
4464 (declare (type (signed-byte 64) x))
4465 (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
4466 (assert (= (funcall fun 10038) -7033717698976955535))))
4467
4468 (with-test (:name (:smodular32 :wrong-width))
4469 (let ((fun (compile nil '(lambda (x)
4470 (declare (type (signed-byte 31) x))
4471 (sb-c::mask-signed-field 31 (- x 1055131947))))))
4472 (assert (= (funcall fun 10038) -1055121909))))
4473
4474 (with-test (:name :first-open-coded)
4475 (let ((fun (compile nil `(lambda (x) (first x)))))
4476 (assert (not (ctu:find-named-callees fun)))))
4477
4478 (with-test (:name :second-open-coded)
4479 (let ((fun (compile nil `(lambda (x) (second x)))))
4480 (assert (not (ctu:find-named-callees fun)))))
4481
4482 (with-test (:name :svref-of-symbol-macro)
4483 (compile nil `(lambda (x)
4484 (symbol-macrolet ((sv x))
4485 (values (svref sv 0) (setf (svref sv 0) 99))))))
4486
4487 ;; The compiler used to update the receiving LVAR's type too
4488 ;; aggressively when converting a large constant to a smaller
4489 ;; (potentially signed) one, causing other branches to be
4490 ;; inferred as dead.
4491 (with-test (:name :modular-cut-constant-to-width)
4492 (let ((test (compile nil
4493 `(lambda (x)
4494 (logand 254
4495 (case x
4496 ((3) x)
4497 ((2 2 0 -2 -1 2) 9223372036854775803)
4498 (t 358458651)))))))
4499 (assert (= (funcall test -10470605025) 26))))
4500
4501 (with-test (:name :append-type-derivation)
4502 (let ((test-cases
4503 '((lambda () (append 10)) (integer 10 10)
4504 (lambda () (append nil 10)) (integer 10 10)
4505 (lambda (x) (append x 10)) (or (integer 10 10) cons)
4506 (lambda (x) (append x (cons 1 2))) cons
4507 (lambda (x y) (append x (cons 1 2) y)) cons
4508 (lambda (x y) (nconc x (the list y) x)) t
4509 (lambda (x y) (nconc (the atom x) y)) t
4510 (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
4511 (lambda (x y) (nconc (the (or cons vector) x) y)) cons
4512 (lambda (x y) (nconc (the sequence x) y)) t
4513 (lambda (x y) (print (length y)) (append x y)) sequence
4514 (lambda (x y) (print (length y)) (append x y)) sequence
4515 (lambda (x y) (append (the (member (a) (b)) x) y)) cons
4516 (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
4517 (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
4518 (loop for (function result-type) on test-cases by #'cddr
4519 do (assert (sb-kernel:type= (sb-kernel:specifier-type
4520 (car (cdaddr (sb-kernel:%simple-fun-type
4521 (compile nil function)))))
4522 (sb-kernel:specifier-type result-type))))))
4523
4524 (with-test (:name :bug-504121)
4525 (compile nil `(lambda (s)
4526 (let ((p1 #'upper-case-p))
4527 (funcall
4528 (lambda (g)
4529 (funcall p1 g))))
4530 (let ((p2 #'(lambda (char) (upper-case-p char))))
4531 (funcall p2 s)))))
4532
4533 (with-test (:name (:bug-504121 :optional-missing))
4534 (compile nil `(lambda (s)
4535 (let ((p1 #'upper-case-p))
4536 (funcall
4537 (lambda (g &optional x)
4538 (funcall p1 g))))
4539 (let ((p2 #'(lambda (char) (upper-case-p char))))
4540 (funcall p2 s)))))
4541
4542 (with-test (:name (:bug-504121 :optional-superfluous))
4543 (compile nil `(lambda (s)
4544 (let ((p1 #'upper-case-p))
4545 (funcall
4546 (lambda (g &optional x)
4547 (funcall p1 g))
4548 #\1 2 3))
4549 (let ((p2 #'(lambda (char) (upper-case-p char))))
4550 (funcall p2 s)))))
4551
4552 (with-test (:name (:bug-504121 :key-odd))
4553 (compile nil `(lambda (s)
4554 (let ((p1 #'upper-case-p))
4555 (funcall
4556 (lambda (g &key x)
4557 (funcall p1 g))
4558 #\1 :x))
4559 (let ((p2 #'(lambda (char) (upper-case-p char))))
4560 (funcall p2 s)))))
4561
4562 (with-test (:name (:bug-504121 :key-unknown))
4563 (compile nil `(lambda (s)
4564 (let ((p1 #'upper-case-p))
4565 (funcall
4566 (lambda (g &key x)
4567 (funcall p1 g))
4568 #\1 :y 2))
4569 (let ((p2 #'(lambda (char) (upper-case-p char))))
4570 (funcall p2 s)))))
4571
4572 (with-test (:name :bug-1181684)
4573 (compile nil `(lambda ()
4574 (let ((hash #xD13CCD13))
4575 (setf hash (logand most-positive-word
4576 (ash hash 5)))))))
4577
4578 (with-test (:name (:local-&optional-recursive-inline :bug-1180992))
4579 (compile nil
4580 `(lambda ()
4581 (labels ((called (&optional a))
4582 (recursed (&optional b)
4583 (called)
4584 (recursed)))
4585 (declare (inline recursed called))
4586 (recursed)))))
4587
4588 (with-test (:name :constant-fold-logtest)
4589 (assert (equal (sb-kernel:%simple-fun-type
4590 (compile nil `(lambda (x)
4591 (declare (type (mod 1024) x)
4592 (optimize speed))
4593 (logtest x 2048))))
4594 '(function ((unsigned-byte 10)) (values null &optional)))))
4595
4596 ;; type mismatches on LVARs with multiple potential sources used to
4597 ;; be reported as mismatches with the value NIL. Make sure we get
4598 ;; a warning, but that it doesn't complain about a constant NIL ...
4599 ;; of type FIXNUM.
4600 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
4601 (block nil
4602 (handler-bind ((sb-int:type-warning
4603 (lambda (c)
4604 (assert
4605 (not (search "Constant "
4606 (simple-condition-format-control
4607 c))))
4608 (return))))
4609 (compile nil `(lambda (x y z)
4610 (declare (type fixnum y z))
4611 (aref (if x y z) 0))))
4612 (error "Where's my warning?")))
4613
4614 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
4615 (block nil
4616 (handler-bind ((style-warning
4617 (lambda (c)
4618 (assert
4619 (not (position
4620 nil
4621 (simple-condition-format-arguments c))))
4622 (return))))
4623 (compile nil `(lambda (x y z f)
4624 (declare (type fixnum y z))
4625 (catch (if x y z) (funcall f)))))
4626 (error "Where's my style-warning?")))
4627
4628 ;; Smoke test for rightward shifts
4629 (with-test (:name (:ash/right-signed))
4630 (let* ((f (compile nil `(lambda (x y)
4631 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4632 (type sb-vm:signed-word x)
4633 (optimize speed))
4634 (ash x (- y)))))
4635 (max (ash most-positive-word -1))
4636 (min (- -1 max)))
4637 (flet ((test (x y)
4638 (assert (= (ash x (- y))
4639 (funcall f x y)))))
4640 (dotimes (x 32)
4641 (dotimes (y (* 2 sb-vm:n-word-bits))
4642 (test x y)
4643 (test (- x) y)
4644 (test (- max x) y)
4645 (test (+ min x) y))))))
4646
4647 (with-test (:name (:ash/right-unsigned))
4648 (let ((f (compile nil `(lambda (x y)
4649 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4650 (type word x)
4651 (optimize speed))
4652 (ash x (- y)))))
4653 (max most-positive-word))
4654 (flet ((test (x y)
4655 (assert (= (ash x (- y))
4656 (funcall f x y)))))
4657 (dotimes (x 32)
4658 (dotimes (y (* 2 sb-vm:n-word-bits))
4659 (test x y)
4660 (test (- max x) y))))))
4661
4662 (with-test (:name (:ash/right-fixnum))
4663 (let ((f (compile nil `(lambda (x y)
4664 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4665 (type fixnum x)
4666 (optimize speed))
4667 (ash x (- y))))))
4668 (flet ((test (x y)
4669 (assert (= (ash x (- y))
4670 (funcall f x y)))))
4671 (dotimes (x 32)
4672 (dotimes (y (* 2 sb-vm:n-word-bits))
4673 (test x y)
4674 (test (- x) y)
4675 (test (- most-positive-fixnum x) y)
4676 (test (+ most-negative-fixnum x) y))))))
4677
4678 ;; expected failure
4679 (with-test (:name :fold-index-addressing-positive-offset)
4680 (let ((f (compile nil `(lambda (i)
4681 (if (typep i '(integer -31 31))
4682 (aref #. (make-array 63) (+ i 31))
4683 (error "foo"))))))
4684 (funcall f -31)))
4685
4686 ;; 5d3a728 broke something like this in CL-PPCRE
4687 (with-test (:name :fold-index-addressing-potentially-negative-index)
4688 (compile nil `(lambda (index vector)
4689 (declare (optimize speed (safety 0))
4690 ((simple-array character (*)) vector)
4691 ((unsigned-byte 24) index))
4692 (aref vector (1+ (mod index (1- (length vector))))))))
4693
4694 (with-test (:name :constant-fold-ash/right-fixnum)
4695 (compile nil `(lambda (a b)
4696 (declare (type fixnum a)
4697 (type (integer * -84) b))
4698 (ash a b))))
4699
4700 (with-test (:name :constant-fold-ash/right-word)
4701 (compile nil `(lambda (a b)
4702 (declare (type word a)
4703 (type (integer * -84) b))
4704 (ash a b))))
4705
4706 (with-test (:name :nconc-derive-type)
4707 (let ((function (compile nil `(lambda (x y)
4708 (declare (type (or cons fixnum) x))
4709 (nconc x y)))))
4710 (assert (equal (sb-kernel:%simple-fun-type function)
4711 '(function ((or cons fixnum) t) (values cons &optional))))))
4712
4713 ;; make sure that all data-vector-ref-with-offset VOPs are either
4714 ;; specialised on a 0 offset or accept signed indices
4715 (with-test (:name :data-vector-ref-with-offset-signed-index)
4716 (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
4717 (when dvr
4718 (assert
4719 (null
4720 (loop for info in (sb-c::fun-info-templates
4721 (sb-c::fun-info-or-lose dvr))
4722 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4723 unless (or (typep second-arg '(cons (eql :constant)))
4724 (find '(integer 0 0) third-arg :test 'equal)
4725 (equal second-arg
4726 `(:or ,(sb-c::primitive-type-or-lose
4727 'sb-vm::positive-fixnum)
4728 ,(sb-c::primitive-type-or-lose
4729 'fixnum))))
4730 collect info))))))
4731
4732 (with-test (:name :data-vector-set-with-offset-signed-index)
4733 (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
4734 (when dvr
4735 (assert
4736 (null
4737 (loop for info in (sb-c::fun-info-templates
4738 (sb-c::fun-info-or-lose dvr))
4739 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4740 unless (or (typep second-arg '(cons (eql :constant)))
4741 (find '(integer 0 0) third-arg :test 'equal)
4742 (equal second-arg
4743 `(:or ,(sb-c::primitive-type-or-lose
4744 'sb-vm::positive-fixnum)
4745 ,(sb-c::primitive-type-or-lose
4746 'fixnum))))
4747 collect info))))))
4748
4749 (with-test (:name :maybe-inline-ref-to-dead-lambda)
4750 (compile nil `(lambda (string)
4751 (declare (optimize speed (space 0)))
4752 (cond ((every #'digit-char-p string)
4753 nil)
4754 ((some (lambda (c)
4755 (digit-char-p c))
4756 string))))))
4757
4758 ;; the x87 backend used to sometimes signal FP errors during boxing,
4759 ;; because converting between double and single float values was a
4760 ;; noop (fixed), and no doubt many remaining issues. We now store
4761 ;; the value outside pseudo-atomic, so any SIGFPE should be handled
4762 ;; corrrectly.
4763 ;;
4764 ;; When it fails, this test lands into ldb.
4765 (with-test (:name :no-overflow-during-allocation)
4766 (handler-case (eval '(cosh 90))
4767 (floating-point-overflow ()
4768 t)))
4769
4770 ;; unbounded integer types could break integer arithmetic.
4771 (with-test (:name :bug-1199127)
4772 (compile nil `(lambda (b)
4773 (declare (type (integer -1225923945345 -832450738898) b))
4774 (declare (optimize (speed 3) (space 3) (safety 2)
4775 (debug 0) (compilation-speed 1)))
4776 (loop for lv1 below 3
4777 sum (logorc2
4778 (if (>= 0 lv1)
4779 (ash b (min 25 lv1))
4780 0)
4781 -2)))))
4782
4783 ;; non-trivial modular arithmetic operations would evaluate to wider results
4784 ;; than expected, and never be cut to the right final bitwidth.
4785 (with-test (:name :bug-1199428-1)
4786 (let ((f1 (compile nil `(lambda (a c)
4787 (declare (type (integer -2 1217810089) a))
4788 (declare (type (integer -6895591104928 -561736648588) c))
4789 (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
4790 (compilation-speed 3)))
4791 (logandc1 (gcd c)
4792 (+ (- a c)
4793 (loop for lv2 below 1 count t))))))
4794 (f2 (compile nil `(lambda (a c)
4795 (declare (notinline - + gcd logandc1))
4796 (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
4797 (compilation-speed 3)))
4798 (logandc1 (gcd c)
4799 (+ (- a c)
4800 (loop for lv2 below 1 count t)))))))
4801 (let ((a 530436387)
4802 (c -4890629672277))
4803 (assert (eql (funcall f1 a c)
4804 (funcall f2 a c))))))
4805
4806 (with-test (:name :bug-1199428-2)
4807 (let ((f1 (compile nil `(lambda (a b)
4808 (declare (type (integer -1869232508 -6939151) a))
4809 (declare (type (integer -11466348357 -2645644006) b))
4810 (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
4811 (compilation-speed 2)))
4812 (logand (lognand a -6) (* b -502823994)))))
4813 (f2 (compile nil `(lambda (a b)
4814 (logand (lognand a -6) (* b -502823994))))))
4815 (let ((a -1491588365)
4816 (b -3745511761))
4817 (assert (eql (funcall f1 a b)
4818 (funcall f2 a b))))))
4819
4820 ;; win32 is very specific about the order in which catch blocks
4821 ;; must be allocated on the stack
4822 (with-test (:name :bug-1072739)
4823 (let ((f (compile nil
4824 `(lambda ()
4825 (STRING=
4826 (LET ((% 23))
4827 (WITH-OUTPUT-TO-STRING (G13908)
4828 (PRINC
4829 (LET ()
4830 (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
4831 (HANDLER-CASE
4832 (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
4833 (UNBOUND-VARIABLE NIL
4834 (HANDLER-CASE
4835 (WITH-OUTPUT-TO-STRING (G13914)
4836 (PRINC %A%B% G13914)
4837 (PRINC "" G13914)
4838 G13914)
4839 (UNBOUND-VARIABLE NIL
4840 (HANDLER-CASE
4841 (WITH-OUTPUT-TO-STRING (G13913)
4842 (PRINC %A%B G13913)
4843 (PRINC "%" G13913)
4844 G13913)
4845 (UNBOUND-VARIABLE NIL
4846 (HANDLER-CASE
4847 (WITH-OUTPUT-TO-STRING (G13912)
4848 (PRINC %A% G13912)
4849 (PRINC "b%" G13912)
4850 G13912)
4851 (UNBOUND-VARIABLE NIL
4852 (HANDLER-CASE
4853 (WITH-OUTPUT-TO-STRING (G13911)
4854 (PRINC %A G13911)
4855 (PRINC "%b%" G13911)
4856 G13911)
4857 (UNBOUND-VARIABLE NIL
4858 (HANDLER-CASE
4859 (WITH-OUTPUT-TO-STRING (G13910)
4860 (PRINC % G13910)
4861 (PRINC "a%b%" G13910)
4862 G13910)
4863 (UNBOUND-VARIABLE NIL
4864 (ERROR "Interpolation error in \"%a%b%\"
4865 "))))))))))))))
4866 G13908)))
4867 "23a%b%")))))
4868 (assert (funcall f))))
4869
4870 (with-test (:name :equal-equalp-transforms)
4871 (let* ((s "foo")
4872 (bit-vector #*11001100)
4873 (values `(nil 1 2 "test"
4874 ;; Floats duplicated here to ensure we get newly created instances
4875 (read-from-string "1.1") (read-from-string "1.2d0")
4876 (read-from-string "1.1") (read-from-string "1.2d0")
4877 1.1 1.2d0 '("foo" "bar" "test")
4878 #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
4879 ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
4880 ,(make-hash-table) #\a #\b #\A #\C
4881 ,(make-random-state) 1/2 2/3)))
4882 ;; Test all permutations of different types
4883 (assert
4884 (loop
4885 for x in values
4886 always (loop
4887 for y in values
4888 always
4889 (and (eq (funcall (compile nil `(lambda (x y)
4890 (equal (the ,(type-of x) x)
4891 (the ,(type-of y) y))))
4892 x y)
4893 (equal x y))
4894 (eq (funcall (compile nil `(lambda (x y)
4895 (equalp (the ,(type-of x) x)
4896 (the ,(type-of y) y))))
4897 x y)
4898 (equalp x y))))))
4899 (assert
4900 (funcall (compile
4901 nil
4902 `(lambda (x y)
4903 (equal (the (cons (or simple-bit-vector simple-base-string))
4904 x)
4905 (the (cons (or (and bit-vector (not simple-array))
4906 (simple-array character (*))))
4907 y))))
4908 (list (string 'list))
4909 (list "LIST")))
4910 (assert
4911 (funcall (compile
4912 nil
4913 `(lambda (x y)
4914 (equalp (the (cons (or simple-bit-vector simple-base-string))
4915 x)
4916 (the (cons (or (and bit-vector (not simple-array))
4917 (simple-array character (*))))
4918 y))))
4919 (list (string 'list))
4920 (list "lisT")))))
4921
4922 (with-test (:name (restart-case optimize speed compiler-note)
4923 :skipped-on :sparc) ; crashes the test driver
4924 (handler-bind ((compiler-note #'error))
4925 (compile nil '(lambda ()
4926 (declare (optimize speed))
4927 (restart-case () (c ()))))
4928 (compile nil '(lambda ()
4929 (declare (optimize speed))
4930 (let (x)
4931 (restart-case (setf x (car (compute-restarts)))
4932 (c ()))
4933 x)))))
4934
4935 (with-test (:name :copy-more-arg
4936 :fails-on '(not (or :x86 :x86-64 :arm)))
4937 ;; copy-more-arg might not copy in the right direction
4938 ;; when there are more fixed args than stack frame slots,
4939 ;; and thus end up splatting a single argument everywhere.
4940 ;; Failing platforms still start their stack frames at 8 slots, so
4941 ;; this is less likely to happen.
4942 (let ((limit 33))
4943 (labels ((iota (n)
4944 (loop for i below n collect i))
4945 (test-function (function skip)
4946 ;; function should just be (subseq x skip)
4947 (loop for i from skip below (+ skip limit) do
4948 (let* ((values (iota i))
4949 (f (apply function values))
4950 (subseq (subseq values skip)))
4951 (assert (equal f subseq)))))
4952 (make-function (n)
4953 (let ((gensyms (loop for i below n collect (gensym))))
4954 (compile nil `(lambda (,@gensyms &rest rest)
4955 (declare (ignore ,@gensyms))
4956 rest)))))
4957 (dotimes (i limit)
4958 (test-function (make-function i) i)))))
4959
4960 (with-test (:name :apply-aref)
4961 (flet ((test (form)
4962 (let (warning)
4963 (handler-bind ((warning (lambda (c) (setf warning c))))
4964 (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
4965 (assert (not warning)))))
4966 (test `(lambda (x y) (setf (apply #'aref x y) 21)))
4967 (test `(lambda (x y) (setf (apply #'bit x y) 1)))
4968 (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
4969
4970 (with-test (:name :warn-on-the-values-constant)
4971 (multiple-value-bind (fun warnings-p failure-p)
4972 (compile nil
4973 ;; The compiler used to elide this test without
4974 ;; noting that the type demands multiple values.
4975 '(lambda () (the (values fixnum fixnum) 1)))
4976 (declare (ignore warnings-p))
4977 (assert (functionp fun))
4978 (assert failure-p)))
4979
4980 ;; quantifiers shouldn't cons themselves.
4981 (with-test (:name :quantifiers-no-consing)
4982 (let ((constantly-t (lambda (x) x t))
4983 (constantly-nil (lambda (x) x nil))
4984 (list (make-list 1000 :initial-element nil))
4985 (vector (make-array 1000 :initial-element nil)))
4986 (macrolet ((test (quantifier)
4987 (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
4988 `(flet ((,function (function sequence)
4989 (,quantifier function sequence)))
4990 (ctu:assert-no-consing (,function constantly-t list))
4991 (ctu:assert-no-consing (,function constantly-nil vector))))))
4992 (test some)
4993 (test every)
4994 (test notany)
4995 (test notevery))))
4996
4997 (with-test (:name :propagate-complex-type-tests)
4998 (flet ((test (type value)
4999 (let ((ftype (sb-kernel:%simple-fun-type
5000 (compile nil `(lambda (x)
5001 (if (typep x ',type)
5002 x
5003 ',value))))))
5004 (assert (typep ftype `(cons (eql function))))
5005 (assert (= 3 (length ftype)))
5006 (let* ((return (third ftype))
5007 (rtype (second return)))
5008 (assert (typep return `(cons (eql values)
5009 (cons t
5010 (cons (eql &optional)
5011 null)))))
5012 (assert (and (subtypep rtype type)
5013 (subtypep type rtype)))))))
5014 (mapc (lambda (params)
5015 (apply #'test params))
5016 `(((unsigned-byte 17) 0)
5017 ((member 1 3 5 7) 5)
5018 ((or symbol (eql 42)) t)))))
5019
5020 (with-test (:name :constant-fold-complex-type-tests)
5021 (assert (equal (sb-kernel:%simple-fun-type
5022 (compile nil `(lambda (x)
5023 (if (typep x '(member 1 3))
5024 (typep x '(member 1 3 15))
5025 t))))
5026 `(function (t) (values (member t) &optional))))
5027 (assert (equal (sb-kernel:%simple-fun-type
5028 (compile nil `(lambda (x)
5029 (declare (type (member 1 3) x))
5030 (typep x '(member 1 3 15)))))
5031 `(function ((or (integer 1 1) (integer 3 3)))
5032 (values (member t) &optional)))))
5033
5034 (with-test (:name :quietly-row-major-index-no-dimensions)
5035 (assert (handler-case
5036 (compile nil `(lambda (x) (array-row-major-index x)))
5037 (warning () nil))))
5038
5039 (with-test (:name :array-rank-transform)
5040 (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
5041
5042 (with-test (:name (:array-rank-fold :bug-1252108))
5043 (let (noted)
5044 (handler-bind ((sb-ext::code-deletion-note
5045 (lambda (x)
5046 (setf noted x))))
5047 (compile nil
5048 `(lambda (a)
5049 (typecase a
5050 ((array t 2)
5051 (when (= (array-rank a) 3)
5052 (array-dimension a 2)))))))
5053 (assert noted)))
5054
5055 (assert-error (upgraded-array-element-type 'an-undefined-type))
5056
5057 (with-test (:name :xchg-misencoding)
5058 (assert (eql (funcall (compile nil '(lambda (a b)
5059 (declare (optimize (speed 3) (safety 2))
5060 (type single-float a))
5061 (unless (eql b 1/2)
5062 (min a -1f0))))
5063 0f0 1)
5064 -1f0)))
5065
5066 (with-test (:name :malformed-declare)
5067 (multiple-value-bind (fun warnings-p failure-p)
5068 (compile nil '(lambda (x)
5069 (declare (unsigned-byte (x)))
5070 x))
5071 (assert (and fun warnings-p failure-p))))
5072
5073 (with-test (:name :no-dubious-asterisk-warning)
5074 (multiple-value-bind (fun warnings-p failure-p)
5075 (compile
5076 nil
5077 '(lambda (foo)
5078 (macrolet ((frob-some-stuff (&rest exprs)
5079 (let ((temps
5080 (mapcar
5081 (lambda (x)
5082 (if (symbolp x) (copy-symbol x) (gensym)))
5083 exprs)))
5084 `(let ,(mapcar #'list temps exprs)
5085 (if (and ,@temps)
5086 (format t "Got~@{ ~S~^ and~}~%" ,@temps))))))
5087 (frob-some-stuff *print-base* (car foo)))))
5088 (assert (and fun (not warnings-p) (not failure-p)))))
5089
5090 (with-test (:name :interr-type-specifier-hashing)
5091 (let ((specifiers
5092 (remove
5093 'simple-vector
5094 (map 'list
5095 (lambda (saetp)
5096 (sb-c::type-specifier
5097 (sb-c::specifier-type
5098 `(simple-array ,(sb-vm:saetp-specifier saetp) (*)))))
5099 sb-vm:*specialized-array-element-type-properties*))))
5100 (assert (sb-c::%interr-symbol-for-type-spec `(or ,@specifiers)))
5101 (assert (sb-c::%interr-symbol-for-type-spec
5102 `(or ,@specifiers system-area-pointer)))))
5103
5104 (with-test (:name :simple-rank-1-array-*-p-works)
5105 (assert (funcall (compile nil
5106 '(lambda () (typep #() '(simple-array * (*)))))))
5107 (loop for saetp across sb-vm:*specialized-array-element-type-properties*
5108 do
5109 (dotimes (n-dimensions 3) ; test ranks 0, 1, and 2.
5110 (let ((dims (make-list n-dimensions :initial-element 2)))
5111 (dolist (adjustable-p '(nil t))
5112 (let ((a (make-array dims :element-type (sb-vm:saetp-specifier saetp)
5113 :adjustable adjustable-p)))
5114 (assert (eq (and (= n-dimensions 1) (not adjustable-p))
5115 (typep a '(simple-array * (*)))))))))))
5116
5117 (with-test (:name :array-subtype-tests
5118 :skipped-on '(:not (:or :x86 :x86-64)))
5119 (assert (funcall (compile nil
5120 '(lambda ()
5121 (typep #() '(or simple-vector simple-string))))))
5122 (flet ((approx-lines-of-assembly-code (type-expr)
5123 (count #\Newline
5124 (with-output-to-string (s)
5125 (disassemble
5126 `(lambda (x)
5127 (declare (optimize (sb-c::verify-arg-count 0)))
5128 (typep x ',type-expr))
5129 :stream s)))))
5130 ;; These are fragile, but less bad than the possibility of messing up
5131 ;; any vops, especially since the generic code in 'vm-type' checks for
5132 ;; a vop by its name in a place that would otherwise be agnostic of the
5133 ;; backend were it not for my inability to test all platforms.
5134 (assert (< (approx-lines-of-assembly-code
5135 '(simple-array * (*))) 25))
5136 ;; this tested all possible widetags one at a time, e.g. in VECTOR-SAP
5137 (assert (< (approx-lines-of-assembly-code
5138 '(sb-kernel:simple-unboxed-array (*))) 25))
5139 ;; This is actually a strange type but it's what ANSI-STREAM-READ-N-BYTES
5140 ;; declares as its buffer, which would choke in %BYTE-BLT if you gave it
5141 ;; (simple-array t (*)). But that's a different problem.
5142 (assert (< (approx-lines-of-assembly-code
5143 '(or system-area-pointer (simple-array * (*)))) 29))
5144 ;; And this was used by %BYTE-BLT which tested widetags one-at-a-time.
5145 (assert (< (approx-lines-of-assembly-code
5146 '(or system-area-pointer (sb-kernel:simple-unboxed-array (*))))
5147 29))))
5148
5149 (with-test (:name :local-argument-mismatch-error-string)
5150 (let ((f (compile nil `(lambda (x)
5151 (flet ((foo ()))
5152 (foo x))))))
5153 (multiple-value-bind (ok err) (ignore-errors (funcall f 42))
5154 (assert (not ok))
5155 (assert (search "FLET FOO" (princ-to-string err))))))
5156
5157 (with-test (:name :bug-1310574-0)
5158 (multiple-value-bind (function warning failure)
5159 (compile nil `(lambda (a)
5160 (typecase a
5161 ((or (array * (* * 3)) (array * (* * 4)))
5162 (case (array-rank a)
5163 (2 (aref a 1 2)))))))
5164 (declare (ignore function))
5165 (assert (not warning))
5166 (assert (not failure))))
5167
5168 (with-test (:name :bug-1310574-1)
5169 (multiple-value-bind (function warning failure)
5170 (compile nil `(lambda (a)
5171 (typecase a
5172 ((or (array * ()) (array * (1)) (array * (1 2)))
5173 (case (array-rank a)
5174 (3 (aref a 1 2 3)))))))
5175 (declare (ignore function))
5176 (assert (not warning))
5177 (assert (not failure))))
5178
5179 (with-test (:name :bug-573747)
5180 (multiple-value-bind (function warnings-p failure-p)
5181 (compile nil '(lambda (x) (progn (declare (integer x)) (* x 6))))
5182 (assert warnings-p)
5183 (assert failure-p)))
5184
5185 ;; Something in this function used to confuse lifetime analysis into
5186 ;; recording multiple conflicts for a single TNs in the dolist block.
5187 (with-test (:name :bug-1327008)
5188 (handler-bind (((or style-warning compiler-note)
5189 (lambda (c)
5190 (muffle-warning c))))
5191 (compile nil
5192 `(lambda (scheduler-spec
5193 schedule-generation-method
5194 utc-earliest-time utc-latest-time
5195 utc-other-earliest-time utc-other-latest-time
5196 &rest keys
5197 &key queue
5198 maximum-mileage
5199 maximum-extra-legs
5200 maximum-connection-time
5201 slice-number
5202 scheduler-hints
5203 permitted-route-locations prohibited-route-locations
5204 preferred-connection-locations disfavored-connection-locations
5205 origins destinations
5206 permitted-carriers prohibited-carriers
5207 permitted-operating-carriers prohibited-operating-carriers
5208 start-airports end-airports
5209 circuity-limit
5210 specified-circuity-limit-extra-miles
5211 (preferred-carriers :unspecified)
5212 &allow-other-keys)
5213 (declare (optimize speed))
5214 (let ((table1 (list nil))
5215 (table2 (list nil))
5216 (skip-flifo-checks (getf scheduler-spec :skip-flifo-checks))
5217 (construct-gaps-p (getf scheduler-spec :construct-gaps-p))
5218 (gap-locations (getf scheduler-spec :gap-locations))
5219 (result-array (make-array 100))
5220 (number-dequeued 0)
5221 (n-new 0)
5222 (n-calcs 0)
5223 (exit-reason 0)
5224 (prev-start-airports origins)
5225 (prev-end-airports destinations)
5226 (prev-permitted-carriers permitted-carriers))
5227 (flet ((run-with-hint (hint random-magic other-randomness
5228 maximum-extra-legs
5229 preferred-origins
5230 preferred-destinations
5231 same-pass-p)
5232 (let* ((hint-permitted-carriers (first hint))
5233 (preferred-end-airports
5234 (ecase schedule-generation-method
5235 (:DEPARTURE preferred-destinations)
5236 (:ARRIVAL preferred-origins)))
5237 (revised-permitted-carriers
5238 (cond ((and hint-permitted-carriers
5239 (not (eq permitted-carriers :ANY)))
5240 (intersection permitted-carriers
5241 hint-permitted-carriers))
5242 (hint-permitted-carriers)
5243 (permitted-carriers)))
5244 (revised-maximum-mileage
5245 (min (let ((maximum-mileage 0))
5246 (dolist (o start-airports)
5247 (dolist (d end-airports)
5248 (setf maximum-mileage
5249 (max maximum-mileage (mileage o d)))))
5250 (round (+ (* circuity-limit maximum-mileage)
5251 (or specified-circuity-limit-extra-miles
5252 (hairy-calculation slice-number)))))
5253 maximum-mileage)))
5254 (when (or (not (equal start-airports prev-start-airports))
5255 (not (equal end-airports prev-end-airports))
5256 (and (not (equal revised-permitted-carriers
5257 prev-permitted-carriers))))
5258 (incf n-calcs)
5259 (calculate-vectors
5260 prohibited-carriers
5261 permitted-operating-carriers
5262 prohibited-operating-carriers
5263 permitted-route-locations
5264 prohibited-route-locations
5265 construct-gaps-p
5266 gap-locations
5267 preferred-carriers)
5268 (setf prev-permitted-carriers revised-permitted-carriers))
5269 (multiple-value-bind (this-number-dequeued
5270 this-exit-reason
5271 this-n-new)
5272 (apply #'schedule-loop
5273 utc-earliest-time utc-other-earliest-time
5274 utc-latest-time utc-other-latest-time
5275 scheduler-spec schedule-generation-method
5276 queue
5277 :maximum-mileage revised-maximum-mileage
5278 :maximum-extra-legs maximum-extra-legs
5279 :maximum-connection-time maximum-connection-time
5280 :same-pass-p same-pass-p
5281 :preferred-end-airports preferred-end-airports
5282 :maximum-blah random-magic
5283 :skip-flifo-checks skip-flifo-checks
5284 :magic1 table1
5285 :magic2 table2
5286 :preferred-connection-locations preferred-connection-locations
5287 :disfavored-connection-locations disfavored-connection-locations
5288 keys)
5289 (when other-randomness
5290 (loop for i fixnum from n-new to (+ n-new (1- this-n-new))
5291 do (hairy-calculation i result-array)))
5292 (incf number-dequeued this-number-dequeued)
5293 (incf n-new this-n-new)
5294 (setq exit-reason (logior exit-reason this-exit-reason))))))
5295 (let ((n-hints-processed 0))
5296 (dolist (hint scheduler-hints)
5297 (run-with-hint hint n-hints-processed t 0
5298 nil nil nil)
5299 (incf n-hints-processed)))
5300 (run-with-hint nil 42 nil maximum-extra-legs
5301 '(yyy) '(xxx) t))
5302 exit-reason)))))
5303
5304 (with-test (:name :dead-code-in-optional-dispatch)
5305 (multiple-value-bind (f warningp)
5306 ;; the translation of each optional entry is
5307 ;; (let ((#:g (error "nope"))) (funcall #<clambda> ...))
5308 ;; but the funcall is unreachable. Since this is an artifact of how the
5309 ;; lambda is converted, it should not generate a note as if in user code.
5310 (compile nil '(lambda (a &optional (b (error "nope")) (c (error "nope")))
5311 (values c b a)))
5312 (assert (and f (not warningp)))))
5313
5314 (with-test (:name :nth-value-of-non-constant-N)
5315 (labels ((foo (n f) (nth-value n (funcall f)))
5316 (bar () (values 0 1 2 3 4 5 6 7 8 9)))
5317 (assert (= (foo 5 #'bar) 5)) ; basic correctness
5318 (assert (eq (foo 12 #'bar) nil))
5319 (ctu:assert-no-consing (eql (foo 953 #'bar) 953))))
5320
5321 (with-test (:name :position-derive-type-optimizer)
5322 (assert-code-deletion-note
5323 '(lambda (x) ; the call to POSITION can't return 4
5324 (let ((i (position x #(a b c d) :test 'eq)))
5325 (case i (4 'nope) (t 'okeydokey))))))
5326
5327 ;; Assert that DO-PACKED-TNS has unsurprising behavior if the body RETURNs.
5328 ;; This isn't a test in the problem domain of CL - it's of an internal macro,
5329 ;; and x86-64-specific not because of broken-ness, but because it uses
5330 ;; known random TNs to play with. Printing "skipped on" for other backends
5331 ;; would be somewhat misleading in as much as it means nothing about
5332 ;; the correctness of the test on other architectures.
5333 #+x86-64
5334 (with-test (:name :do-packed-tn-iterator)
5335 (dotimes (i (ash 1 6))
5336 (labels ((make-tns (n)
5337 (mapcar 'copy-structure
5338 (subseq `sb-vm::(,rax-tn ,rbx-tn ,rcx-tn) 0 n)))
5339 (link (list)
5340 (when list
5341 (setf (sb-c::tn-next (car list)) (link (cdr list)))
5342 (car list))))
5343 (let* ((normal (make-tns (ldb (byte 2 0) i)))
5344 (restricted (make-tns (ldb (byte 2 2) i)))
5345 (wired (make-tns (ldb (byte 2 4) i)))
5346 (expect (append normal restricted wired))
5347 (comp (sb-c::make-empty-component))
5348 (ir2-comp (sb-c::make-ir2-component)))
5349 (setf (sb-c::component-info comp) ir2-comp
5350 (sb-c::ir2-component-normal-tns ir2-comp) (link normal)
5351 (sb-c::ir2-component-restricted-tns ir2-comp) (link restricted)
5352 (sb-c::ir2-component-wired-tns ir2-comp) (link wired))
5353 (let* ((list)
5354 (result (sb-c::do-packed-tns (tn comp 42) (push tn list))))
5355 (assert (eq result 42))
5356 (assert (equal expect (nreverse list))))
5357 (let* ((n 0) (list)
5358 (result (sb-c::do-packed-tns (tn comp 'bar)
5359 (push tn list)
5360 (if (= (incf n) 4) (return 'foo)))))
5361 (assert (eq result (if (>= (length expect) 4) 'foo 'bar)))
5362 (assert (equal (subseq expect 0 (min 4 (length expect)))
5363 (nreverse list))))))))
5364
5365 ;; lp# 310267
5366 (with-test (:name :optimize-quality-multiply-specified)
5367 (let ((*error-output* (make-broadcast-stream)))
5368 (let ((sb-c::*policy* sb-c::*policy*)) ; to keep this test pure
5369 (assert-signal (proclaim '(optimize space debug (space 0)))
5370 style-warning))
5371 (assert-signal
5372 (compile nil '(lambda () (declare (optimize speed (speed 0))) 5))
5373 style-warning)
5374 (assert-signal
5375 (compile nil '(lambda () (declare (optimize speed) (optimize (speed 0))) 5))
5376 style-warning)
5377 (assert-signal
5378 (compile nil '(lambda ()
5379 (declare (optimize speed)) (declare (optimize (speed 0)))
5380 5))
5381 style-warning))
5382
5383 ;; these are OK
5384 (assert-no-signal (proclaim '(optimize (space 3) space)))
5385 (assert-no-signal
5386 (compile nil '(lambda () (declare (optimize speed (speed 3))) 5)))
5387 (assert-no-signal
5388 (compile nil '(lambda () (declare (optimize speed) (optimize (speed 3))) 5)))
5389 (assert-no-signal
5390 (compile nil '(lambda ()
5391 (declare (optimize speed)) (declare (optimize (speed 3)))
5392 5))))
5393
5394 (with-test (:name :truncate-type-derivation)
5395 (assert (=
5396 4
5397 (funcall
5398 (compile nil
5399 '(lambda (a b)
5400 (truncate a
5401 (the (rational (1) (3)) b))))
5402 10 5/2))))
5403
5404 (with-test (:name :constantp-on-a-literal-function-works)
5405 (assert (constantp `(the (function (list) t) ,#'car))))
5406
5407 (with-test (:name :arg-count-error)
5408 (assert (eq :win (handler-case (funcall (intern "CONS") 1 2 3)
5409 (sb-int:simple-program-error () :win)
5410 (condition () :lose)))))
5411
5412 (with-test (:name :mv-conversion)
5413 (compile nil '(lambda (a)
5414 (tagbody (go 0)
5415 (list (unwind-protect a))
5416 (multiple-value-call #'list
5417 (values (catch 'ct5 (go 0))))
5418 0))))
5419
5420 (with-test (:name (:null-cleanups-1 :bug-1416704 :bug-404441))
5421 (let ((x (funcall
5422 (compile nil `(lambda ()
5423 (lambda (x)
5424 (declare (optimize speed))
5425 (if x
5426 (funcall (flet ((bar () 10)) #'bar))
5427 (funcall (flet ((fez ()
5428 (funcall (flet ((foo () 20)) #'foo))))
5429 #'fez)))))))))
5430 (assert (= (funcall x t) 10))
5431 (assert (= (funcall x nil) 20))))
5432
5433 (with-test (:name (:null-cleanups-2 :bug-1416704 :bug-404441))
5434 (let ((fun (funcall
5435 (compile nil `(lambda ()
5436 (lambda (x)
5437 (declare (optimize speed))
5438 (let* ((a2 (lambda () 20))
5439 (a4 (lambda ()))
5440 (a0 (flet ((f () (funcall a2)))
5441 #'f))
5442 (a3 (lambda ()
5443 (if x
5444 (if x
5445 (throw 'x 10)
5446 (let ((a5 (lambda () (funcall a4))))
5447 (funcall a5)))
5448 (funcall a0)))))
5449 (funcall a3))))))))
5450 (assert (= (catch 'x (funcall fun t)) 10))
5451 (assert (= (catch 'x (funcall fun nil)) 20))))
5452
5453
5454 (with-test (:name :locall-already-let-converted)
5455 (assert (eq (funcall
5456 (funcall
5457 (compile
5458 nil
5459 '(lambda ()
5460 (flet ((call (ff)
5461 (flet ((f () (return-from f ff)))
5462 (declare (inline f))
5463 (f)
5464 (f))))
5465 (declare (inline call))
5466 (call 1)
5467 (call (lambda () 'result)))))))
5468 'result)))
5469
5470 (with-test (:name :debug-dump-elsewhere)
5471 (assert
5472 (eql
5473 (catch 'x
5474 (funcall
5475 (compile nil
5476 '(lambda ()
5477 (declare (optimize debug))
5478 (throw 'x *)))))
5479 *)))
5480
5481 (with-test (:name :typep-quasiquoted-constant)
5482 (assert (null (ctu:find-named-callees
5483 (compile nil
5484 '(lambda (x)
5485 (typep x `(signed-byte ,sb-vm:n-word-bits))))))))
5486 (with-test (:name :logior-transform)
5487 (let ((function (compile nil '(lambda (c)
5488 (flet ((f (x)
5489 (the integer x)))
5490 (logior c (f nil)))))))
5491 (assert-error (funcall function 10)
5492 type-error)))
5493
5494 (with-test (:name :eql/integer-folding)
5495 (multiple-value-bind (f warning)
5496 (compile nil
5497 '(lambda (a)
5498 (fceiling (the (member 2.3 21672589639883401935) a))))
5499 (assert (and f (not warning)))))
5500
5501 (with-test (:name :position-derive-type)
5502 (let ((f (compile nil
5503 '(lambda (x)
5504 (declare (type (simple-string 90) x))
5505 (declare (muffle-conditions code-deletion-note))
5506 (let ((b (position #\i x)))
5507 (if (and (integerp b) (> b 100))
5508 'yikes 'okey-dokey))))))
5509 ;; The function can not return YIKES
5510 (assert (not (ctu:find-code-constants f :type '(eql yikes))))))
5511
5512 (with-test (:name :compile-file-error-position-reporting)
5513 (dolist (input '("data/wonky1.lisp" "data/wonky2.lisp" "data/wonky3.lisp"))
5514 (let ((expect (with-open-file (f input) (read f))))
5515 (assert (stringp expect))
5516 (let ((err-string (with-output-to-string (*error-output*)
5517 (compile-file input :print nil))))
5518 (assert (search expect err-string))))))
5519
5520 (with-test (:name :coerce-derive-type)
5521 (macrolet ((check (type ll form &rest values)
5522 `(assert (equal (funcall (compile nil `(lambda ,',ll
5523 (ctu:compiler-derived-type ,',form)))
5524 ,@values)
5525 ',type))))
5526 (check list
5527 (a)
5528 (coerce a 'list)
5529 nil)
5530 (check (unsigned-byte 32)
5531 (a)
5532 (coerce a '(unsigned-byte 32))
5533 10)
5534 (check character
5535 (a x)
5536 (coerce a (array-element-type (the (array character) x)))
5537 #\a
5538 "abc")
5539 (check (unsigned-byte 32)
5540 (a x)
5541 (coerce a (array-element-type (the (array (unsigned-byte 32)) x)))
5542 10
5543 (make-array 10 :element-type '(unsigned-byte 32)))))
5544
5545 (with-test (:name :associate-args)
5546 (assert-error
5547 (funcall (compile nil `(lambda (x) (+ 1 x nil)))
5548 2))
5549 (assert-error
5550 (funcall (compile nil `(lambda (x) (/ 1 x nil))) 4)))
Common Lisp compiler and runtime