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