1 ;;;; various compiler tests without side effects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (cl:in-package
:cl-user
)
16 (load "compiler-test-util.lisp")
18 ;; The tests in this file do not work under the legacy interpreter.
19 (when (and (eq sb-ext
:*evaluator-mode
* :interpret
)
20 (not (member :sb-fasteval
*features
*)))
21 (invoke-restart 'run-tests
::skip-file
))
23 ;;; Exercise a compiler bug (by crashing the compiler).
25 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
26 ;;; (2000-09-06 on cmucl-imp).
28 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
29 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
30 (with-test (:name
(:compiler-bug labels tagbody
))
31 (funcall (checked-compile
49 ;;; Exercise a compiler bug (by crashing the compiler).
51 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
52 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
53 (with-test (:name
(:compiler-bug flet inline
:undefined-function
))
54 (multiple-value-bind (fun failure-p warnings style-warnings
)
58 (block used-by-some-y?
62 (return-from used-by-some-y? t
)))))
63 (declare (inline frob
))
67 :allow-style-warnings t
)
68 (declare (ignore failure-p warnings
))
69 (assert (= 3 (length style-warnings
)))
72 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
73 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
74 ;;; Alexey Dejneka 2002-01-27
75 (assert (= 1 ; (used to give 0 under bug 112)
80 (declare (special x
)) y
)))))
81 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
86 (declare (special x
)) y
)))))
88 ;;; another LET-related bug fixed by Alexey Dejneka at the same
90 (with-test (:name
(let :repeated-name
:bug-112
))
91 ;; Should complain about duplicate variable names in LET binding
92 (multiple-value-bind (fun failure-p
)
93 (checked-compile `(lambda ()
98 (assert (functionp fun
))
101 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
102 ;;; Lichteblau 2002-05-21)
103 (with-test (:name
(let :earmuffs
))
104 ;; Compiling this code should cause a STYLE-WARNING about *X*
105 ;; looking like a special variable but not being one.
106 (multiple-value-bind (fun failure-p warnings style-warnings
)
110 (funcall (symbol-function 'x-getter
))
112 :allow-style-warnings
'sb-kernel
:asterisks-around-lexical-variable-name
)
113 (declare (ignore failure-p warnings
))
114 (assert (functionp fun
))
115 (assert (= 1 (length style-warnings
))))
116 ;; Compiling this code should not cause a warning (because the
117 ;; DECLARE turns *X* into a special variable as its name suggests it
119 (checked-compile `(lambda (n)
121 (declare (special *x
*))
122 (funcall (symbol-function 'x-getter
))
125 ;;; a bug in 0.7.4.11
126 (with-test (:name
(compile typep satisfies
))
127 (let ((*standard-output
* (make-broadcast-stream)))
128 (funcall (checked-compile
130 (dolist (i '(a b
1 2 "x" "y"))
131 ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
132 ;; TYPEP here but got confused and died, doing
133 ;; (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
134 ;; *BACKEND-TYPE-PREDICATES*
136 ;; and blowing up because TYPE= tried to call PLUSP on the
137 ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
138 (when (typep i
'(and integer
(satisfies oddp
)))
140 (funcall (checked-compile
143 (when (typep i
'(and integer
(satisfies oddp
)))
146 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
147 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
148 ;;; interactively-compiled functions was broken by sleaziness and
149 ;;; confusion in the assault on 0.7.0, so this expression used to
150 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
151 (eval '(function-lambda-expression #'(lambda (x) x
)))
153 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
154 ;;; variable is not optional.
155 (with-test (:name
(:lambda-list
&rest
:missing-name
))
156 (multiple-value-bind (fun failure-p
)
157 (checked-compile `(lambda (&rest
) 12) :allow-failure t
)
159 (assert-error (funcall fun
))))
161 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
162 ;;; a while; fixed by CSR 2002-07-18
163 (with-test (:name
:undefined-function-error
)
164 (multiple-value-bind (value error
)
165 (ignore-errors (funcall (checked-compile
166 `(lambda () (some-undefined-function))
167 :allow-style-warnings t
)))
168 (assert (null value
))
169 (assert (eq (cell-error-name error
) 'some-undefined-function
))))
171 (with-test (:name
:unbound-variable-error
)
172 (let ((foo (gensym)))
173 (assert (eq (handler-case (symbol-value foo
)
174 (unbound-variable (c) (cell-error-name c
)))
176 ;; on x86-64 the code for a literal symbol uses a slightly different path,
178 (assert (eq (handler-case xyzzy
*%state
179 (unbound-variable (c) (cell-error-name c
)))
181 ;; And finally, also on x86-64, there was massive confusion about
182 ;; variable names that looked like names of thread slots.
183 (assert (eq (handler-case *state
*
184 (unbound-variable (c) (cell-error-name c
)))
187 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
188 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
189 (with-test (:name
(:lambda-list
:non-symbols
))
191 (destructuring-bind (form wrongp
) case
192 (multiple-value-bind (fun failure-p
)
193 (checked-compile form
:allow-failure wrongp
)
194 (assert (functionp fun
))
197 (assert-error (funcall fun
))))))
198 '(((lambda ("foo") 12) t
)
199 ((lambda (foo) foo
) nil
)
201 ((lambda (&optional
12) "foo") t
)
202 ((lambda (&optional twelve
) twelve
) nil
)
204 ((lambda (&optional
(12 12)) "foo") t
)
205 ((lambda (&optional
(twelve 12)) twelve
) nil
)
207 ((lambda (&key
#\c
) "foo") t
)
208 ((lambda (&key c
) c
) nil
)
210 ((lambda (&key
(#\c
#\c
)) "foo") t
)
211 ((lambda (&key
(c #\c
)) c
) nil
)
213 ((lambda (&key
((#\c
#\c
) #\c
)) "foo") t
)
214 ((lambda (&key
((:c c-var
) #\c
)) c-var
) nil
))))
216 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
217 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
218 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
219 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y
3)) x
))) 14)
222 ;;; bug 181: bad type specifier dropped compiler into debugger
223 (with-test (:name
(compile declare
:bad-type-specifier
:bug-181
))
224 (multiple-value-bind (fun failure-p
)
225 (checked-compile `(lambda (x)
226 (declare (type (0) x
))
230 (assert-error (funcall fun
1) program-error
)))
232 (with-test (:name
(compile make-array
:bad-type-specifier
:bug-181
))
233 (multiple-value-bind (fun failure-p warnings
)
234 (checked-compile `(lambda (x)
236 (make-array 1 :element-type
'(0)))
238 (declare (ignore failure-p warnings
))
239 ;; FIXME (assert (= 1 (length warnings)))
240 (assert-error (funcall fun
1))))
242 ;;; the following functions must not be flushable
243 (dolist (form '((make-sequence 'fixnum
10)
244 (concatenate 'fixnum nil
)
245 (map 'fixnum
#'identity nil
)
246 (merge 'fixnum nil nil
#'<)))
247 (assert (not (eval `(locally (declare (optimize (safety 0)))
248 (ignore-errors (progn ,form t
)))))))
250 (dolist (form '((values-list (car (list '(1 .
2))))
252 (atan #c
(1 1) (car (list #c
(2 2))))
253 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
254 (nthcdr (car (list 5)) '(1 2 .
3))))
255 (assert (not (eval `(locally (declare (optimize (safety 3)))
256 (ignore-errors (progn ,form t
)))))))
258 ;;; feature: we shall complain if functions which are only useful for
259 ;;; their result are called and their result ignored.
260 (with-test (:name
:discarded-result
)
261 (loop for
(form expected-des
) in
262 '(((progn (nreverse (list 1 2)) t
)
263 "The return value of NREVERSE should not be discarded.")
264 ((progn (nreconc (list 1 2) (list 3 4)) t
)
265 "The return value of NRECONC should not be discarded.")
267 (declare (inline sort
))
268 (sort (list 1 2) #'<) t
)
269 ;; FIXME: it would be nice if this warned on non-inlined sort
270 ;; but the current simple boolean function attribute
271 ;; can't express the condition that would be required.
272 "The return value of STABLE-SORT-LIST should not be discarded.")
273 ((progn (sort (vector 1 2) #'<) t
)
274 ;; Apparently, SBCL (but not CL) guarantees in-place vector
275 ;; sort, so no warning.
277 ((progn (delete 2 (list 1 2)) t
)
278 "The return value of DELETE should not be discarded.")
279 ((progn (delete-if #'evenp
(list 1 2)) t
)
280 ("The return value of DELETE-IF should not be discarded."))
281 ((progn (delete-if #'evenp
(vector 1 2)) t
)
282 ("The return value of DELETE-IF should not be discarded."))
283 ((progn (delete-if-not #'evenp
(list 1 2)) t
)
284 "The return value of DELETE-IF-NOT should not be discarded.")
285 ((progn (delete-duplicates (list 1 2)) t
)
286 "The return value of DELETE-DUPLICATES should not be discarded.")
287 ((progn (merge 'list
(list 1 3) (list 2 4) #'<) t
)
288 "The return value of MERGE should not be discarded.")
289 ((progn (nreconc (list 1 3) (list 2 4)) t
)
290 "The return value of NRECONC should not be discarded.")
291 ((progn (nunion (list 1 3) (list 2 4)) t
)
292 "The return value of NUNION should not be discarded.")
293 ((progn (nintersection (list 1 3) (list 2 4)) t
)
294 "The return value of NINTERSECTION should not be discarded.")
295 ((progn (nset-difference (list 1 3) (list 2 4)) t
)
296 "The return value of NSET-DIFFERENCE should not be discarded.")
297 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t
)
298 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
299 for expected
= (sb-int:ensure-list expected-des
)
301 (multiple-value-bind (fun failure-p warnings style-warnings
)
302 (checked-compile `(lambda () ,form
) :allow-style-warnings
(when expected t
))
303 (declare (ignore failure-p warnings
))
305 (assert (= (length expected
) (length style-warnings
)))
306 (dolist (warning style-warnings
)
307 (let ((expect-one (pop expected
)))
308 (assert (search expect-one
309 (with-standard-io-syntax
310 (let ((*print-right-margin
* nil
))
311 (princ-to-string warning
))))
313 "~S should have warned ~S, but instead warned: ~A"
314 form expect-one warning
))))
315 (assert (functionp fun
)))))
317 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
318 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
319 (with-test (:name
(map :non-vector
))
320 (checked-compile `(lambda (x) (map 'simple-array
'identity x
))))
322 ;;; bug 129: insufficient syntax checking in MACROLET
323 (with-test (:name
(compile macrolet
:syntax
:bug-129
))
324 (multiple-value-bind (fun failure-p
)
325 (checked-compile '(lambda () (macrolet ((foo x
`',x
)) (foo 1 2 3)))
328 (assert-error (funcall fun
) program-error
)))
330 ;;; bug 124: environment of MACROLET-introduced macro expanders
331 (with-test (:name
(macrolet :bug-124
))
333 (macrolet ((mext (x) `(cons :mext
,x
)))
334 (macrolet ((mint (y) `'(:mint
,(mext y
))))
337 '((:MEXT
1 2) (:MINT
(:MEXT
1 2))))))
339 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
340 ;;; symbol is declared to be SPECIAL
341 (with-test (:name
(compile symbol-macrolet special program-error
:bug-48c
))
342 (multiple-value-bind (fun failure-p
)
343 (checked-compile '(lambda ()
344 (symbol-macrolet ((s '(1 2)))
345 (declare (special s
))
349 (assert-error (funcall fun
) program-error
)))
351 ;;; ECASE should treat a bare T as a literal key
352 (with-test (:name
(ecase t
1))
353 (assert-error (ecase 1 (t 0)) sb-kernel
:case-failure
))
355 (with-test (:name
(ecase t
2))
356 (assert (eql (ecase 1 (t 0) (1 2)) 2)))
358 ;;; FTYPE should accept any functional type specifier
359 (with-test (:name
(compile ftype function
))
360 (checked-compile '(lambda (x) (declare (ftype function f
)) (f x
))
361 :allow-style-warnings t
))
363 ;;; FUNCALL of special operators and macros should signal an
364 ;;; UNDEFINED-FUNCTION error
365 ;;; But note the subtle distinction between writing (FUNCALL 'QUOTE 1)
366 ;;; and (FUNCALL #'QUOTE 1). In the latter, the error must be signaled
367 ;;; by the FUNCTION special operator, but the error class is unspecified.
368 (with-test (:name
(funcall undefined-function cell-error-name quote
))
369 (multiple-value-bind (result error
)
370 (ignore-errors (funcall 'quote
1))
371 (assert (null result
))
372 (assert (typep error
'undefined-function
))
373 (assert (eq (cell-error-name error
) 'quote
))))
375 (with-test (:name
(funcall undefined-function cell-error-name and
))
376 (multiple-value-bind (result error
)
377 (ignore-errors (funcall 'and
1))
378 (assert (null result
))
379 (assert (typep error
'undefined-function
))
380 (assert (eq (cell-error-name error
) 'and
))))
382 ;;; PSETQ should behave when given complex symbol-macro arguments
383 (with-test (:name
(psetq symbol-macrolet
))
384 (multiple-value-bind (sequence index
)
385 (symbol-macrolet ((x (aref a
(incf i
)))
386 (y (aref a
(incf i
))))
387 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
389 (psetq x
(aref a
(incf i
))
392 (assert (equalp sequence
#(0 2 2 4 4 5 6 7 8 9)))
393 (assert (= index
4))))
395 (with-test (:name
(psetq :ill-formed-variable
))
396 (multiple-value-bind (fun failure-p
)
397 (checked-compile `(lambda ()
398 (let ((x (list 1 2)))
403 (assert-error (funcall fun
) program-error
)))
405 ;;; COPY-SEQ should work on known-complex vectors:
407 (let ((v (make-array 0 :fill-pointer
0)))
408 (vector-push-extend 1 v
)
411 ;;; to support INLINE functions inside MACROLET, it is necessary for
412 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
413 ;;; certain circumstances, one of which is when compile is called from
415 (with-test (:name
(compile function-lambda-expression
416 :toplevel
:must-return-lambda-expression
))
417 (let ((form '(lambda (x) (block nil
(print x
)))))
418 (assert (equal form
(function-lambda-expression
419 (checked-compile form
))))))
421 ;;; bug 62: too cautious type inference in a loop
422 (with-test (:name
(compile loop
:type-inference
))
423 (multiple-value-bind (fun failure-p warnings
)
424 (checked-compile `(lambda (a)
425 (declare (optimize speed
(safety 0)))
427 (array (loop (print (car a
))))))
430 (declare (ignore fun
))
432 (assert (= 1 (length warnings
)))))
434 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
436 (with-test (:name
(:compiler-bug declare type loop
))
438 `(lambda (key tree collect-path-p
)
439 (let ((lessp (key-lessp tree
))
440 (equalp (key-equalp tree
)))
441 (declare (type (function (t t
) boolean
) lessp equalp
))
443 (loop for node
= (root-node tree
)
444 then
(if (funcall lessp key
(node-key node
))
448 do
(return (values nil nil nil
))
449 do
(when collect-path-p
451 (when (funcall equalp key
(node-key node
))
452 (return (values node path t
)))))))
453 :allow-style-warnings t
))
455 ;;; CONSTANTLY should return a side-effect-free function (bug caught
456 ;;; by Paul Dietz' test suite)
458 (let ((fn (constantly (progn (incf i
) 1))))
460 (assert (= (funcall fn
) 1))
462 (assert (= (funcall fn
) 1))
465 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
466 (with-test (:name
(:lambda-list
&optional
:earmuffs
))
467 (loop for
(form warns-p
) in
468 '(((lambda (&optional
*x
*) *x
*) t
)
469 ((lambda (&optional
*x
* &rest y
) (values *x
* y
)) t
)
470 ((lambda (&optional
*print-length
*) (values *print-length
*)) nil
)
471 ((lambda (&optional
*print-length
* &rest y
) (values *print-length
* y
)) nil
)
472 ((lambda (&optional
*x
*) (declare (special *x
*)) (values *x
*)) nil
)
473 ((lambda (&optional
*x
* &rest y
) (declare (special *x
*)) (values *x
* y
)) nil
))
474 do
(let ((style-warnings (nth-value
476 form
:allow-style-warnings warns-p
))))
477 (assert (= (if warns-p
1 0) (length style-warnings
))))))
479 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
480 (assert (equal (funcall (eval '(lambda (x &optional
(y (pop x
))) (list x y
)))
484 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
485 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
486 (assert (eq (eval '((lambda (&key
) 'u
) :allow-other-keys nil
)) 'u
))
488 (assert-error (multiple-value-bind (a b c
)
489 (eval '(truncate 3 4))
490 (declare (integer c
))
494 (assert (equal (multiple-value-list (the (values &rest integer
)
498 ;;; Bug relating to confused representation for the wild function
500 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
502 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
504 (assert (eql (macrolet ((foo () 1))
505 (macrolet ((%f
(&optional
(x (macroexpand '(foo) env
)) &environment env
)
510 ;;; MACROLET should check for duplicated names
511 (with-test (:name
(macrolet :lambda-list
:repeated-names
))
512 (dolist (ll '((x (z x
))
513 (x y
&optional z x w
)
517 (x &optional
(y nil x
))
518 (x &optional
(y nil y
)) ; TODO this case prints "caught ERROR: ..." but doesn't set failure-p
521 (&key
(y nil z
) (z nil w
))
522 (&whole x
&optional x
)))
523 (let ((style-warnings (nth-value
526 (macrolet ((foo ,ll nil
)
527 (bar (&environment env
)
528 `',(macro-function 'foo env
)))
530 ;; FIXME :allow-failure is for the annotated case above
531 :allow-failure t
:allow-style-warnings t
))))
532 (assert style-warnings
))))
534 ;; Uh, this test is semi-bogus - it's trying to test that you can't
535 ;; repeat, but it's now actually testing that &WHOLE has to appear
536 ;; first, per the formal spec.
537 (with-test (:name
(macrolet :lambda-list
&whole
:must-be-first
))
538 (assert-error (checked-compile
540 (macrolet ((foo (&environment x
&whole x
) nil
)
541 (bar (&environment env
)
542 `',(macro-function 'foo env
)))
545 (assert (typep (eval `(the arithmetic-error
546 ',(make-condition 'arithmetic-error
)))
549 (with-test (:name
(compile make-array
:dimensions nil
))
550 (checked-compile `(lambda ()
551 (make-array nil
:initial-element
11))))
553 (assert-error (funcall (eval #'open
) "assertoid.lisp"
554 :external-format
'#:nonsense
))
555 (assert-error (funcall (eval #'load
) "assertoid.lisp"
556 :external-format
'#:nonsense
))
558 (assert (= (the (values integer symbol
) (values 1 'foo
13)) 1))
560 (with-test (:name
(compile eval the type-error
))
561 (let ((f (checked-compile
563 (declare (optimize (safety 3)))
564 (list (the fixnum
(the (real 0) (eval v
))))))))
565 (assert-error (funcall f
0.1) type-error
)
566 (assert-error (funcall f -
1) type-error
)))
568 ;;; the implicit block does not enclose lambda list
569 (with-test (:name
(compile :implicit block
:does-not-enclose
:lambda-list
))
570 (let ((forms '((defmacro #1=#:foo
(&optional
(x (return-from #1#)))
571 (declare (ignore x
)))
572 #+nil
(macrolet ((#2=#:foo
(&optional
(x (return-from #2#))))))
573 (define-compiler-macro #3=#:foo
(&optional
(x (return-from #3#)))
574 (declare (ignore x
)))
575 (deftype #4=#:foo
(&optional
(x (return-from #4#)))
576 (declare (ignore x
)))
577 (define-setf-expander #5=#:foo
(&optional
(x (return-from #5#)))
578 (declare (ignore x
)))
579 (defsetf #6=#:foo
(&optional
(x (return-from #6#))) ()
580 (declare (ignore x
))))))
583 1 (checked-compile `(lambda () ,form
) :allow-failure t
))))))
585 (with-test (:name
(compile make-array svref
:derive-type
))
586 (multiple-value-bind (fun failurep warnings
)
587 (checked-compile `(lambda ()
588 (svref (make-array '(8 9) :adjustable t
) 1))
590 (declare (ignore fun
))
592 (assert (= 1 (length warnings
)))))
594 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
595 (macrolet ((define-char=-test
(function form
)
596 `(with-test (:name
(compile ,function
:argument-type-check
))
597 (assert-error (funcall (checked-compile ,form
) #\a #\b nil
)
599 (define-char=-test char
= `(lambda (x y z
) (char= x y z
)))
600 (define-char=-test char
/= `(lambda (x y z
)
601 (declare (optimize (speed 3) (safety 3)))
604 ;;; Compiler lost return type of MAPCAR and friends
605 (with-test (:name
(compile mapcar mapc maplist mapl
606 :return-type
:type-derivation
))
607 (dolist (fun '(mapcar mapc maplist mapl
))
608 (assert (= 1 (length (nth-value
611 (1+ (,fun
#'print x
)))
612 :allow-warnings t
))))))
614 (assert (= 1 (length (nth-value
617 (declare (notinline mapcar
))
618 (1+ (mapcar #'print
'(1 2 3))))
619 :allow-warnings t
))))))
621 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
622 ;;; index was effectless
623 (with-test (:name
(compile setf aref bit-vector
))
624 (let ((f (checked-compile `(lambda (a v
)
625 (declare (type simple-bit-vector a
) (type bit v
))
626 (declare (optimize (speed 3) (safety 0)))
629 (let ((y (make-array 2 :element-type
'bit
:initial-element
0)))
630 (assert (equal y
#*00))
632 (assert (equal y
#*10)))))
634 ;;; use of declared array types
635 (with-test (:name
(compile declare array type
:no sb-ext
:compiler-note
))
636 (dolist (form `((lambda (x)
637 (declare (type (simple-array (simple-string 3) (5)) x
)
641 (declare (type (simple-array (simple-array bit
(10)) (10)) x
)
643 (1+ (aref (aref x
0) 0)))))
644 (checked-compile form
:allow-notes nil
)))
647 (with-test (:name
(compile typep not member
))
648 (let ((f (checked-compile `(lambda (x) (typep x
'(not (member 0d0
)))))))
649 (assert (funcall f
1d0
))))
651 (with-test (:name
(compile double-float atan
))
652 (checked-compile `(lambda (x)
653 (declare (double-float x
))
657 ;;; bogus optimization of BIT-NOT
658 (multiple-value-bind (result x
)
659 (eval '(let ((x (eval #*1001)))
660 (declare (optimize (speed 2) (space 3))
661 (type (bit-vector) x
))
662 (values (bit-not x nil
) x
)))
663 (assert (equal x
#*1001))
664 (assert (equal result
#*0110)))
666 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
667 (with-test (:name
(compile vector make-sequence sb-ext
:compiler-note
))
668 (let ((fun (checked-compile
670 (let ((x (make-sequence 'vector
10 :initial-element
'a
)))
674 (assert (equalp (funcall fun
) #(a a a a b a a a a a
)))))
676 ;;; this is not a check for a bug, but rather a test of compiler
678 (with-test (:name
(compile integer
:type-derivation
))
679 (dolist (type '((integer 0 *) ; upper bound
682 (real * (-10)) ; lower bound
684 (assert (= 1 (length (nth-value
687 (declare (optimize (speed 3) (compilation-speed 0)))
688 (loop for i from
1 to
(the (integer -
17 10) n
) by
2
689 collect
(when (> (random 10) 5)
690 (the ,type
(- i
11)))))
691 :allow-warnings t
)))))))
695 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
696 ;;; compiler has an optimized VOP for +; so this code should cause an
698 (with-test (:name
(compile integer
+ sb-ext
:compiler-note
:bug-278b
))
699 (assert (= 1 (length (nth-value
702 (declare (optimize speed
))
703 (declare (type integer i
))
706 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
708 (with-test (:name
(compile symbol-macrolet ignore ignorable
:bug-277
))
709 (checked-compile `(lambda (u v
)
710 (symbol-macrolet ((x u
)
716 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
717 (with-test (:name
(compile expt
:optimizer
))
718 (loop for
(x type
) in
721 (-14/3 (rational -
8 11))
730 (#c
(-3 4) (complex fixnum
))
731 (#c
(-3 4) (complex rational
))
732 (#c
(-3/7 4) (complex rational
))
733 (#c
(2s0 3s0
) (complex short-float
))
734 (#c
(2f0 3f0
) (complex single-float
))
735 (#c
(2d0 3d0
) (complex double-float
))
736 (#c
(2l0 3l0) (complex long-float
))
737 (#c
(2d0 3s0
) (complex float
))
738 (#c
(2 3f0
) (complex real
))
739 (#c
(2 3d0
) (complex real
))
740 (#c
(-3/7 4) (complex real
))
743 do
(dolist (zero '(0 0s0
0f0
0d0
0l0))
744 (dolist (real-zero (list zero
(- zero
)))
745 (let* ((src `(lambda (x) (expt (the ,type x
) ,real-zero
)))
746 (fun (checked-compile src
))
747 (result (1+ (funcall (eval #'*) x real-zero
))))
748 (assert (eql result
(funcall fun x
))))))))
750 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
751 ;;; wasn't recognized as a good type specifier.
752 (let ((fun (lambda (x y
)
753 (declare (type (integer -
1 0) x y
) (optimize speed
))
755 (assert (= (funcall fun
0 0) 0))
756 (assert (= (funcall fun
0 -
1) -
1))
757 (assert (= (funcall fun -
1 -
1) 0)))
759 ;;; from PFD's torture test, triggering a bug in our effective address
761 (with-test (:name
(compile declare type logandc1 logandc2
))
762 (checked-compile `(lambda (a b
)
763 (declare (type (integer 8 22337) b
))
766 (* (logandc1 (max -
29303 b
) 4) b
)
767 (abs (logorc1 (+ (logandc1 -
11 b
) 2607688420) -
31153924)))
768 (logeqv (max a
0) b
)))))
770 ;;; Alpha floating point modes weren't being reset after an exception,
771 ;;; leading to an exception on the second compile, below.
772 (with-test (:name
(compile :floating-point-mode
))
773 (let ((form `(lambda (x y
) (declare (type (double-float 0.0d0
) x y
)) (/ x y
))))
774 (checked-compile form
)
775 (handler-case (/ 1.0 0.0)
776 ;; provoke an exception
777 (arithmetic-error ()))
778 (checked-compile form
)))
780 ;;; bug reported by Paul Dietz: component last block does not have
782 (with-test (:name
(compile block return-from
))
783 (checked-compile `(lambda ()
784 (declare (notinline + logand
)
785 (optimize (speed 0)))
789 (return-from b5 -
220)))
791 (+ 359749 35728422))))
794 (with-test (:name
:ansi-misc
.293a
)
798 (declare (optimize (speed 2) (space 3) (safety 1)
799 (debug 2) (compilation-speed 2)))
801 (multiple-value-prog1
806 (complex (cl::handler-bind nil -
254932942) 0)))))))
807 :allow-style-warnings t
)
811 (with-test (:name
:ansi-misc
.293d
)
815 (declare (optimize (debug 3) (safety 0) (space 2)
816 (compilation-speed 2) (speed 2)))
818 (multiple-value-prog1
821 (return-from b4
(catch 'ct2
(progn (tagbody) 0)))))))))
824 (with-test (:name
:ansi-misc
.618)
828 (declare (optimize (space 0) (compilation-speed 2) (debug 0)
829 (speed 3) (safety 0)))
832 (multiple-value-prog1 0
833 (apply (constantly 0)
835 (catch 'ct2
(return-from b1
0))
840 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
841 (with-test (:name
(compile rem
:bug-294
))
842 (assert (= (funcall (checked-compile
844 (declare (optimize (speed 3))
845 (type (integer 2 152044363) b
))
846 (rem b
(min -
16 0))))
850 (with-test (:name
(compile mod
:bug-294
))
851 (assert (= (funcall (checked-compile
853 (declare (optimize (speed 3))
854 (type (integer 23062188 149459656) c
))
859 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
860 (with-test (:name
(compile logeqv rem
:dead-code
:block-splitting
))
861 (checked-compile `(lambda (a b c
)
863 (logeqv (rem c -
6758)
864 (rem b
(max 44 (return-from b6 a
))))))))
866 (with-test (:name
(compile block flet
:dead-code
:block-splitting
))
867 (checked-compile `(lambda ()
869 (flet ((foo (x y
) (if (> x y
) (print x
) (print y
))))
872 (foo (return 14) 2))))
873 :allow-style-warnings t
))
875 ;;; bug in Alpha backend: not enough sanity checking of arguments to
877 (with-test (:name
(compile ash
))
878 (assert (= (funcall (checked-compile
885 ;;; bug found by WHN and pfdietz: compiler failure while referencing
886 ;;; an entry point inside a deleted lambda
887 (with-test (:name
(compile :reference-entry-point-in-deleted lambda
))
894 (flet ((truly (fn bbd
)
898 (multiple-value-prog1
915 (wum #'bbfn
"hc3" (list)))
917 :allow-failure t
:allow-style-warnings t
))
919 (with-test (:name
(compile flet unwind-protect
:dead-code
))
920 (checked-compile `(lambda () (flet ((%f
() (unwind-protect nil
))) nil
))))
922 ;;; the strength reduction of constant multiplication used (before
923 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
924 ;;; certain circumstances, the compiler would derive that a perfectly
925 ;;; reasonable multiplication never returned, causing chaos. Fixed by
926 ;;; explicitly doing modular arithmetic, and relying on the backends
928 (with-test (:name
(compile * :constant
))
932 (declare (type (integer 178956970 178956970) x
)
938 ;;; bug in modular arithmetic and type specifiers
939 (with-test (:name
(compile logand
))
940 (assert (= (funcall (checked-compile '(lambda (x) (logand x x
0)))
944 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
945 ;;; produced wrong result for shift >=32 on X86
946 (with-test (:name
(compile mask-field
:fast-ash-mod32-c-vop
18))
947 (assert (= 0 (funcall
950 (declare (type (integer 4303063 101130078) a
))
951 (mask-field (byte 18 2) (ash a
77))))
954 ;;; rewrite the test case to get the unsigned-byte 32/64
955 ;;; implementation even after implementing some modular arithmetic
956 ;;; with signed-byte 30:
957 (with-test (:name
(compile mask-field
:fast-ash-mod32-c-vop
30))
958 (assert (= 0 (funcall
961 (declare (type (integer 4303063 101130078) a
))
962 (mask-field (byte 30 2) (ash a
77))))
964 (with-test (:name
(compile mask-field
:fast-ash-mod32-c-vop
64))
965 (assert (= 0 (funcall
968 (declare (type (integer 4303063 101130078) a
))
969 (mask-field (byte 64 2) (ash a
77))))
971 ;;; and a similar test case for the signed masking extension (not the
972 ;;; final interface, so change the call when necessary):
973 (with-test (:name
(compile sb-c
::mask-signed-field
:fast-ash-mod32-c-vop
30))
974 (assert (= 0 (funcall
977 (declare (type (integer 4303063 101130078) a
))
978 (sb-c::mask-signed-field
30 (ash a
77))))
980 (with-test (:name
(compile sb-c
::mask-signed-field
:fast-ash-mod32-c-vop
61))
981 (assert (= 0 (funcall
984 (declare (type (integer 4303063 101130078) a
))
985 (sb-c::mask-signed-field
61 (ash a
77))))
988 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
989 ;;; type check regeneration
990 (with-test (:name
(compile :flush-dest
:use
:regenerate-type-check
:misc
.101))
991 (assert (eql (funcall
994 (declare (type (integer 185501219873 303014665162) a
))
995 (declare (type (integer -
160758 255724) c
))
996 (declare (optimize (speed 3)))
998 (- -
554046873252388011622614991634432
1000 (unwind-protect 2791485))))
1001 (max (ignore-errors a
)
1002 (let ((v6 (- v8
(restart-case 980))))
1004 :allow-warnings
'sb-int
:type-warning
)
1005 259448422916 173715)
1007 (with-test (:name
(compile :flush-dest
:use
:regenerate-type-check
:misc
.103))
1008 (assert (eql (funcall
1018 (load-time-value -
6876935))))
1019 (if (logbitp 1 a
) b
(setq a -
1522022182249)))))))
1020 :allow-warnings
'sb-int
:type-warning
)
1021 -
1802767029877 -
12374959963)
1024 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
1025 (with-test (:name
(compile :node
/lvar
:derive-type
:misc
.1))
1026 (assert (eql (funcall (checked-compile
1028 (declare (type (integer -
3924 1001809828) c
))
1029 (declare (optimize (speed 3)))
1030 (min 47 (if (ldb-test (byte 2 14) c
)
1032 (ignore-errors -
732893970)))))
1035 (with-test (:name
(compile :node
/lvar
:derive-type
:misc
.2))
1036 (assert (eql (funcall
1039 (declare (type (integer -
1598566306 2941) b
))
1040 (declare (optimize (speed 3)))
1041 (max -
148949 (ignore-errors b
))))
1044 (with-test (:name
(compile :node
/lvar
:derive-type
:misc
.3))
1045 (assert (eql (funcall
1048 (declare (type (integer -
4 -
3) c
))
1050 (flet ((%f1
(f1-1 f1-2 f1-3
)
1051 (if (logbitp 0 (return-from b7
1052 (- -
815145138 f1-2
)))
1053 (return-from b7 -
2611670)
1055 (let ((v2 (%f1 -
2464 (%f1 -
1146 c c
) -
2)))
1057 :allow-style-warnings t
)
1060 (with-test (:name
(compile :node
/lvar
:derive-type
:misc
.4))
1061 (assert (eql (funcall
1064 (declare (type (integer -
29742055786 23602182204) b
))
1065 (declare (type (integer -
7409 -
2075) c
))
1066 (declare (optimize (speed 3)))
1070 (ignore-errors (return-from b6
1071 (if (= c
8) b
82674))))))
1073 :allow-style-warnings
'sb-int
:type-style-warning
)
1076 (with-test (:name
(compile :node
/lvar
:derive-type
:misc
.5))
1077 (assert (equal (multiple-value-list
1081 (declare (type (integer -
944 -
472) a
))
1082 (declare (optimize (speed 3)))
1086 (if (= 55957 a
) -
117 (ignore-errors
1087 (return-from b3 a
)))))))
1088 :allow-warnings
'sb-int
:type-warning
)
1093 (with-test (:name
(compile :misc
.158))
1094 (assert (zerop (funcall
1097 (declare (type (integer 79828 2625480458) a
))
1098 (declare (type (integer -
4363283 8171697) b
))
1099 (declare (type (integer -
301 0) c
))
1100 (if (equal 6392154 (logxor a b
))
1104 (logior (logandc2 c v5
)
1105 (common-lisp:handler-case
1106 (ash a
(min 36 22477)))))))))
1109 ;;; MISC.152, 153: deleted code and iteration var type inference
1110 (with-test (:name
(compile :deleted-code
:iteration-variable
:type-inference
:misc
.152))
1111 (assert (eql (funcall
1115 (let ((v1 (let ((v8 (unwind-protect 9365)))
1119 (labels ((%f11
(f11-1) f11-1
))
1123 (labels ((%f6
(f6-1 f6-2 f6-3
) v1
))
1124 (dpb (unwind-protect a
)
1126 (labels ((%f4
() 27322826))
1127 (%f6 -
2 -
108626545 (%f4
)))))))))))
1128 :allow-style-warnings t
)
1132 (with-test (:name
(compile :deleted-code
:iteration-variable
:type-inference
:misc
.153))
1133 (assert (eql (funcall
1138 ((-96879 -
1035 -
57680 -
106404 -
94516 -
125088)
1139 (unwind-protect 90309179))
1140 ((-20811 -
86901 -
9368 -
98520 -
71594)
1141 (let ((v9 (unwind-protect 136707)))
1144 (let ((v4 (return-from b3 v9
)))
1145 (- (ignore-errors (return-from b3 v4
))))))))
1153 (with-test (:name
(compile :misc
.165))
1154 (assert (eql (funcall
1164 &optional
(f17-4 185155520) (f17-5 c
)
1167 (%f17 -
1046 a
1115306 (%f17 b -
146330 422) -
337817)))
1168 (f15-5 a
) (f15-6 -
40))
1169 (return-from b3 -
16)))
1170 (multiple-value-call #'%f15
(values -
519354 a
121 c -
1905)))))
1171 :allow-style-warnings t
)
1176 (with-test (:name
(compile :misc
.172))
1177 (assert (eql (funcall
1180 (declare (notinline list apply
))
1181 (declare (optimize (safety 3)))
1182 (declare (optimize (speed 0)))
1183 (declare (optimize (debug 0)))
1184 (labels ((%f12
(f12-1 f12-2
)
1185 (labels ((%f2
(f2-1 f2-2
)
1192 (return-from %f12 b
)))
1195 (%f18
(%f18
150 -
64 f12-1
)
1202 &optional
(f7-3 (%f6
)))
1205 (%f2 b -
36582571))))
1206 (apply #'%f12
(list 774 -
4413))))
1207 :allow-style-warnings t
)
1212 (with-test (:name
(compile :misc
.173))
1213 (assert (eql (funcall
1216 (declare (notinline values
))
1217 (declare (optimize (safety 3)))
1218 (declare (optimize (speed 0)))
1219 (declare (optimize (debug 0)))
1222 &optional
(f11-3 c
) (f11-4 7947114)
1224 (flet ((%f3
(f3-1 &optional
(f3-2 b
) (f3-3 5529))
1226 (multiple-value-call #'%f3
1227 (values (%f3 -
30637724 b
) c
)))))
1229 (if (and nil
(%f11 a a
))
1230 (if (%f11 a
421778 4030 1)
1236 (%f11 c a c -
4 214720)
1245 :allow-style-warnings t
)
1249 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1250 ;;; local lambda argument
1251 (with-test (:name
(compile :ir2-copy-propagation
:misc
.177 :misc
.182))
1257 (declare (type (integer 804561 7640697) a
))
1258 (declare (type (integer -
1 10441401) b
))
1259 (declare (type (integer -
864634669 55189745) c
))
1260 (declare (ignorable a b c
))
1261 (declare (optimize (speed 3)))
1262 (declare (optimize (safety 1)))
1263 (declare (optimize (debug 1)))
1266 (labels ((%f4
() (round 200048 (max 99 c
))))
1269 (labels ((%f3
(f3-1) -
162967612))
1270 (%f3
(let* ((v8 (%f4
)))
1271 (setq f11-1
(%f4
)))))))))
1272 (%f11 -
120429363 (%f11
62362 b
))))
1273 :allow-style-warnings t
)
1274 6714367 9645616 -
637681868)
1277 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1279 (with-test (:name
(compile :value-transform
:derive-type
))
1280 (assert (equal (multiple-value-list
1284 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1287 (flet ((%f16
() 0)) (%f16
))))))))
1291 (with-test (:name
(compile :misc
.184))
1296 (declare (type (integer 867934833 3293695878) a
))
1297 (declare (type (integer -
82111 1776797) b
))
1298 (declare (type (integer -
1432413516 54121964) c
))
1299 (declare (optimize (speed 3)))
1300 (declare (optimize (safety 1)))
1301 (declare (optimize (debug 1)))
1303 (flet ((%f15
(f15-1 &optional
(f15-2 c
))
1304 (labels ((%f1
(f1-1 f1-2
) 0))
1307 (multiple-value-call #'%f15
1308 (values (%f15 c
0) (%f15
0)))))
1310 (flet ((%f8
(f8-1 &optional
(f8-2 (%f4
)) (f8-3 0))
1314 :allow-style-warnings t
)
1315 3040851270 1664281 -
1340106197))))
1318 (with-test (:name
(compile :misc
.249))
1323 (declare (notinline <=))
1324 (declare (optimize (speed 2) (space 3) (safety 0)
1325 (debug 1) (compilation-speed 3)))
1326 (if (if (<= 0) nil nil
)
1327 (labels ((%f9
(f9-1 f9-2 f9-3
)
1329 (dotimes (iv4 5 a
) (%f9
0 0 b
)))
1333 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1334 (with-test (:name
(compile :mod32
:misc
.259))
1339 (declare (type (integer 177547470 226026978) a
))
1340 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1341 (compilation-speed 1)))
1342 (logand a
(* a
438810))))
1347 ;;;; Bugs in stack analysis
1348 ;;; bug 299 (reported by PFD)
1349 (with-test (:name
(compile :stack-analysis
:bug-299
))
1354 (declare (optimize (debug 1)))
1355 (multiple-value-call #'list
1356 (if (eval t
) (eval '(values :a
:b
:c
)) nil
)
1357 (catch 'foo
(throw 'foo
(values :x
:y
)))))))
1358 '(:a
:b
:c
:x
:y
))))
1359 ;;; bug 298 (= MISC.183)
1360 (with-test (:name
(compile :bug-298
:misc
.183))
1361 (assert (zerop (funcall
1364 (declare (type (integer -
368154 377964) a
))
1365 (declare (type (integer 5044 14959) b
))
1366 (declare (type (integer -
184859815 -
8066427) c
))
1367 (declare (ignorable a b c
))
1368 (declare (optimize (speed 3)))
1369 (declare (optimize (safety 1)))
1370 (declare (optimize (debug 1)))
1372 (flet ((%f3
(f3-1 f3-2 f3-3
) 0))
1373 (apply #'%f3
0 (catch 'foo
(return-from b7
(%f3
0 b c
))) c nil
))))
1374 :allow-style-warnings t
)
1376 (assert (equal (eval '(let () (apply #'list
1 (list (catch 'a
(throw 'a
(block b
2)))))))
1378 (with-test (:name
(compile multiple-value-call block return-from
))
1379 (let ((f (checked-compile
1382 (multiple-value-call #'list
1386 (multiple-value-call #'list
1392 (return-from quux
1)
1393 (throw 'baz
2))))))))))))))
1394 (assert (equal (funcall f t
) '(:b
1)))
1395 (assert (equal (funcall f nil
) '(:a
2)))))
1398 (with-test (:name
(compile :misc
.185))
1403 (declare (type (integer 5 155656586618) a
))
1404 (declare (type (integer -
15492 196529) b
))
1405 (declare (type (integer 7 10) c
))
1406 (declare (optimize (speed 3)))
1407 (declare (optimize (safety 1)))
1408 (declare (optimize (debug 1)))
1411 &optional
(f3-4 a
) (f3-5 0)
1413 (labels ((%f10
(f10-1 f10-2 f10-3
)
1418 (- (if (equal a b
) b
(%f10 c a
0))
1419 (catch 'ct2
(throw 'ct2 c
)))
1422 (%f3
(%f3
(%f3 b
0 0 0) a
0) a b b b c
)))
1423 :allow-style-warnings t
)
1427 (with-test (:name
(eval compile
:misc
.186))
1430 '(let* ((form '(labels ((%f3
(f3-1 f3-2
) f3-1
))
1431 (apply #'%f3 b
(catch 'ct8
(throw 'ct8
(logeqv (%f3 c
0)))) nil
)))
1434 (declare (type (integer -
2 19) b
)
1435 (type (integer -
1520 218978) c
)
1436 (optimize (speed 3) (safety 1) (debug 1)))
1439 (declare (notinline logeqv apply
)
1440 (optimize (safety 3) (speed 0) (debug 0)))
1442 (cf1 (compile nil fn1
))
1443 (cf2 (compile nil fn2
))
1444 (result1 (multiple-value-list (funcall cf1
2 18886)))
1445 (result2 (multiple-value-list (funcall cf2
2 18886))))
1446 (if (equal result1 result2
)
1448 (values result1 result2
))))
1452 (with-test (:name
(compile :misc
.290))
1458 (optimize (speed 3) (space 3) (safety 1)
1459 (debug 2) (compilation-speed 0)))
1460 (apply (constantly 0) (catch 'ct2
0) 0 (catch 'ct2
0) nil
)))))))
1463 (with-test (:name
(compile :misc
.292))
1464 (assert (zerop (funcall
1467 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1468 (compilation-speed 2)))
1469 (apply (constantly 0)
1473 (apply (constantly 0)
1484 :allow-style-warnings t
)
1488 (with-test (:name
(compile :misc
.295))
1493 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1494 (multiple-value-prog1
1495 (the integer
(catch 'ct8
(catch 'ct7
15867134)))
1496 (catch 'ct1
(throw 'ct1
0))))))
1499 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1500 ;;; could transform known-values LVAR to UVL
1501 (with-test (:name
(compile :cast multiple-value-call
:misc
.361))
1502 (assert (zerop (funcall
1505 (declare (notinline boole values denominator list
))
1511 (compilation-speed 2)))
1516 (let ((v9 (ignore-errors (throw 'ct6
0))))
1518 (progv nil nil
(values (boole boole-and
0 v9
))))))))
1519 :allow-warnings
'sb-int
:type-warning
:allow-style-warnings t
)
1522 ;;; non-continuous dead UVL blocks
1523 (defun non-continuous-stack-test (x)
1524 (multiple-value-call #'list
1525 (eval '(values 11 12))
1526 (eval '(values 13 14))
1528 (return-from non-continuous-stack-test
1529 (multiple-value-call #'list
1530 (eval '(values :b1
:b2
))
1531 (eval '(values :b3
:b4
))
1534 (multiple-value-call (eval #'values
)
1535 (eval '(values 1 2))
1536 (eval '(values 3 4))
1539 (multiple-value-call (eval #'values
)
1540 (eval '(values :a1
:a2
))
1541 (eval '(values :a3
:a4
))
1544 (multiple-value-call (eval #'values
)
1545 (eval '(values 5 6))
1546 (eval '(values 7 8))
1549 (return-from int
:int
))))))))))))))))
1550 (assert (equal (non-continuous-stack-test t
) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext
)))
1551 (assert (equal (non-continuous-stack-test nil
) '(:b1
:b2
:b3
:b4
:a1
:a2
:a3
:a4
:int
)))
1553 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1555 (with-test (:name
(compile unwind-protect
:misc
.362))
1556 (assert (equal (multiple-value-list
1560 (declare (optimize (speed 3) (space 3) (safety 2)
1561 (debug 2) (compilation-speed 3)))
1564 (labels ((%f15
(f15-1 f15-2 f15-3
)
1565 (rational (throw 'ct5
0))))
1571 (progv '(*s2
* *s5
*) (list 0 (%f15
0 g
0)) b
)
1575 (common-lisp:handler-case
0))))
1576 :allow-style-warnings t
)
1582 (with-test (:name
(compile :misc
.275))
1588 (declare (notinline funcall min coerce
))
1594 (compilation-speed 1)))
1595 (flet ((%f12
(f12-1)
1598 (if f12-1
(multiple-value-prog1
1599 b
(return-from %f12
0))
1602 (funcall #'%f12
0))))
1605 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1606 ;;; potential problem: optimizers and type derivers for MAX and MIN
1607 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1608 (with-test (:name
(compile min max
:derive-type equalp
))
1609 (dolist (f '(min max
))
1610 (loop for complex-arg-args in
'((1d0 2d0
) (0d0 1d0
))
1611 for complex-arg
= `(if x
,@complex-arg-args
)
1613 (loop for args in
`((1 ,complex-arg
)
1615 for form
= `(,f
,@args
)
1616 for f1
= (checked-compile `(lambda (x) ,form
))
1617 and f2
= (checked-compile `(lambda (x)
1618 (declare (notinline min max
))
1621 (dolist (x '(nil t
))
1622 (assert (eql (funcall f1 x
) (funcall f2 x
))))))))
1625 ;; Ignore the note for the float -> pointer conversion of the
1627 (defun float->pointer-conversion-note-p
(condition)
1628 (string= (car (last (sb-c::simple-condition-format-arguments condition
)))
1630 (with-test (:name
(compile :trust-result-type-declaration
))
1633 (declare (optimize (speed 3) (safety 0)))
1634 (the double-float
(sqrt (the double-float x
))))
1635 :allow-notes
'(satisfies float-
>pointer-conversion-note-p
)))
1637 (with-test (:name
(compile block the return
))
1638 (let ((f (checked-compile
1640 (declare (optimize speed
(safety 0)))
1643 (multiple-value-prog1
1644 (sqrt (the double-float x
))
1646 (return :minus
)))))))))
1647 (assert (eql (funcall f -
1d0
) :minus
))
1648 (assert (eql (funcall f
4d0
) 2d0
))))
1650 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1651 (defun %ash
/right-note-p
(condition)
1652 (search "%ASH/RIGHT" (first (simple-condition-format-arguments condition
))))
1653 (with-test (:name
(compile deref
:bug-304
))
1657 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1658 (inhibit-warnings 0)))
1659 (declare (type (alien (* (unsigned 8))) a
)
1660 (type (unsigned-byte 32) i
))
1662 :allow-notes
'(satisfies %ash
/right-note-p
)))
1664 (with-test (:name
(compile identity
:derive-type
))
1667 (declare (type (integer -
100 100) x
))
1668 (declare (optimize speed
))
1669 (declare (notinline identity
))
1673 (with-test (:name
(compile funcall cddr
))
1674 (assert (null (funcall (checked-compile '(lambda (x) (funcall #'cddr x
))) nil
))))
1676 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1677 ;;; LVAR; here the first write may be cleared before the second is
1679 (with-test (:name
(compile :repeated-write-to-lvar
:misc
.293 :easy
))
1685 (declare (notinline complex
))
1686 (declare (optimize (speed 1) (space 0) (safety 1)
1687 (debug 3) (compilation-speed 3)))
1688 (flet ((%f
() (multiple-value-prog1 0 (return-from %f
0))))
1689 (complex (%f
) 0))))))))
1691 (with-test (:name
(compile :misc
.293 :harder
))
1692 ;; Similar to the above case, but can blow up in stack analysis if
1693 ;; the two blocks in the M-V-P1 are joined (due to both (FUNCALL Y)
1694 ;; forms producing multiple-value results into the same LVAR,
1695 ;; requiring a cleanup to be inserted between the two, yet not
1696 ;; possible due to the lack of a block boundary).
1699 (declare (notinline complex
))
1700 (declare (optimize (speed 1) (space 0) (safety 1)
1701 (debug 3) (compilation-speed 3)))
1702 (flet ((%f
(y) (multiple-value-prog1 (funcall y
)
1703 (return-from %f
(funcall y
)))))
1704 (complex (%f x
) 0)))))
1706 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1707 (with-test (:name
(compile :cast
:flush-lvar-derived-type
:misc
.110a
))
1708 (assert (zerop (funcall
1711 (declare (type (integer -
1294746569 1640996137) a
))
1712 (declare (type (integer -
807801310 3) c
))
1713 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1720 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7
0))) 0 0) 0))))
1722 :allow-warnings
'sb-int
:type-warning
)
1723 391833530 -
32785211))))
1725 ;;; efficiency notes for ordinary code
1726 (with-test (:name
(compile :no-notes
))
1727 (macrolet ((frob (arglist &body body
)
1729 (checked-compile '(lambda ,arglist
,@body
) :allow-notes nil
)
1732 '(lambda ,arglist
(declare (optimize speed
))
1734 (error "missing compiler note for ~S" ',body
)))))
1735 (frob (x) (funcall x
))
1736 (frob (x y
) (find x y
))
1737 (frob (x y
) (find-if x y
))
1738 (frob (x y
) (find-if-not x y
))
1739 (frob (x y
) (position x y
))
1740 (frob (x y
) (position-if x y
))
1741 (frob (x y
) (position-if-not x y
))
1742 (frob (x) (aref x
0))))
1744 (with-test (:name
(compile style-warning
:smoke
))
1745 (macrolet ((frob (style-warn-p form
)
1746 (unless (eq (car form
) 'lambda
)
1747 (setq form
`(lambda () ,form
)))
1750 3 (checked-compile ',form
:allow-style-warnings t
))
1751 (error "missing style-warning for ~S" ',form
))
1752 `(checked-compile ',form
))))
1753 (frob t
(lambda (x &optional y
&key z
) (list x y z
)))
1754 (frob nil
(lambda (x &optional y z
) (list x y z
)))
1755 (frob nil
(lambda (x &key y z
) (list x y z
)))
1756 (frob t
(defgeneric #:foo
(x &optional y
&key z
)))
1757 (frob nil
(defgeneric #:foo
(x &optional y z
)))
1758 (frob nil
(defgeneric #:foo
(x &key y z
)))
1759 (frob t
(defun #:foo
(x) (flet ((foo (x &optional y
&key z
) (list x y z
))) (foo x x
:z x
))))))
1761 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1762 ;;; note, because the system failed to derive the fact that the return
1763 ;;; from LOGXOR was small and negative, though the bottom one worked.
1764 (with-test (:name
(compile logxor
:derive-type
))
1767 (declare (optimize speed
(safety 0)))
1769 (declare (type (integer 3 6) x
)
1770 (type (integer -
6 -
3) y
))
1771 (+ (logxor x y
) most-positive-fixnum
)))
1775 (declare (optimize speed
(safety 0)))
1777 (declare (type (integer 3 6) y
)
1778 (type (integer -
6 -
3) x
))
1779 (+ (logxor x y
) most-positive-fixnum
)))
1782 ;;; check that modular ash gives the right answer, to protect against
1783 ;;; possible misunderstandings about the hardware shift instruction.
1784 (with-test (:name
(compile ash
:smoke
))
1785 (assert (zerop (funcall
1786 (checked-compile '(lambda (x y
)
1787 (declare (optimize speed
)
1788 (type (unsigned-byte 32) x y
))
1789 (logand #xffffffff
(ash x y
))))
1792 ;;; code instrumenting problems
1795 (declare (optimize (debug 3)))
1796 (list (the integer
(if nil
14 t
))))
1801 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD
))
1807 (COMPILATION-SPEED 0)))
1808 (MASK-FIELD (BYTE 7 26)
1810 (TAGBODY (THE INTEGER
(CATCH 'CT4
(LOGORC1 C -
15950))) 1)
1812 :allow-style-warnings t
)
1815 '(lambda (buffer i end
)
1816 (declare (optimize (debug 3)))
1817 (loop (when (not (eql 0 end
)) (return)))
1818 (let ((s (make-string end
)))
1819 (setf (schar s i
) (schar buffer i
))
1822 ;;; check that constant string prefix and suffix don't cause the
1823 ;;; compiler to emit code deletion notes.
1824 (with-test (:name
(compile pprint-logical-block
:prefix
:suffix
:no-notes
))
1827 (pprint-logical-block (s x
:prefix
"(")
1832 (pprint-logical-block (s x
:per-line-prefix
";")
1837 (pprint-logical-block (s x
:suffix
">")
1841 ;;; MISC.427: loop analysis requires complete DFO structure
1842 (with-test (:name
(compile :loop-analysis
:misc
.427))
1843 (assert (eql 17 (funcall
1846 (declare (notinline list reduce logior
))
1847 (declare (optimize (safety 2) (compilation-speed 1)
1848 (speed 3) (space 2) (debug 2)))
1850 (let* ((v5 (reduce #'+ (list 0 a
))))
1851 (declare (dynamic-extent v5
))
1856 (with-test (:name
(compile :misc
.434))
1857 (assert (zerop (funcall
1860 (declare (type (integer -
8431780939320 1571817471932) a
))
1861 (declare (type (integer -
4085 0) b
))
1862 (declare (ignorable a b
))
1865 (compilation-speed 0)
1866 #+sbcl
(sb-c:insert-step-conditions
0)
1873 (elt '(1954479092053)
1877 (lognand iv1
(ash iv1
(min 53 iv1
)))
1880 :allow-style-warnings t
)
1881 -
7639589303599 -
1368))))
1885 (declare (type (integer) a
))
1886 (declare (type (integer) b
))
1887 (declare (ignorable a b
))
1888 (declare (optimize (space 2) (compilation-speed 0)
1889 (debug 0) (safety 0) (speed 3)))
1891 (when (< iv1
2) (print 'x
)) ;; request for second constraint propagation pass
1892 (print (if (< iv1 iv1
)
1893 (logand (ash iv1 iv1
) 1)
1896 ;;; MISC.435: lambda var substitution in a deleted code.
1897 (with-test (:name
(compile :misc
.435))
1898 (assert (zerop (funcall
1901 (declare (notinline aref logandc2 gcd make-array
))
1903 (optimize (space 0) (safety 0) (compilation-speed 3)
1904 (speed 3) (debug 1)))
1907 (let* ((v2 (make-array nil
:initial-element
(catch 'ct1
(go tag2
)))))
1908 (declare (dynamic-extent v2
))
1909 (gcd (go tag2
) (logandc2 (catch 'ct2 c
) (aref v2
))))
1912 :allow-style-warnings t
)
1913 3021871717588 -
866608 -
2 -
17194))))
1915 ;;; MISC.436, 438: lost reoptimization
1916 (with-test (:name
(compile :lost-reoptimization
:misc
.436 :misc
.438))
1917 (assert (zerop (funcall
1920 (declare (type (integer -
2917822 2783884) a
))
1921 (declare (type (integer 0 160159) b
))
1922 (declare (ignorable a b
))
1924 (optimize (compilation-speed 1)
1928 ; #+sbcl (sb-c:insert-step-conditions 0)
1942 '(-10197561 486 430631291
1948 (assert (zerop (funcall
1951 (declare (type (integer 0 1696) a
))
1952 ; (declare (ignorable a))
1953 (declare (optimize (space 2) (debug 0) (safety 1)
1954 (compilation-speed 0) (speed 1)))
1955 (if (logbitp 0 (ash (1- a
) (min 11 a
))) 0 0)))
1959 (with-test (:name
(compile :bug-302
))
1960 (assert (checked-compile
1962 (declare (type (simple-array function
(2)) s
) (type ei ei
))
1963 (funcall (aref s ei
) x y
))
1964 :allow-style-warnings t
)))
1966 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1968 (with-test (:name
(compile :misc
.320))
1969 (assert (eql 102 (funcall
1972 (declare (optimize (speed 3) (space 0) (safety 2)
1973 (debug 2) (compilation-speed 0)))
1976 (flet ((%f12
() (rem 0 -
43)))
1977 (multiple-value-call #'%f12
(values)))))))))))
1979 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1980 (with-test (:name
(compile :misc
.437))
1981 (assert (zerop (funcall
1983 '(lambda (a b c d e
)
1984 (declare (notinline values complex eql
))
1986 (optimize (compilation-speed 3)
1993 &optional
(f10-4 (ignore-errors 0)) (f10-5 0)
1994 &key
&allow-other-keys
)
1995 (if (or (eql 0 0) t
) 0 (if f10-1
0 0))))
1996 (complex (multiple-value-call #'%f10
(values a c b
0 0)) 0)))
1997 :allow-style-warnings t
)
1998 80043 74953652306 33658947 -
63099937105 -
27842393))))
2000 ;;; bug #351 -- program-error for malformed LET and LET*, including those
2001 ;;; resulting from SETF of LET.
2002 (with-test (:name
(compile let let
* :malformed program-error
:bug-351
))
2003 (dolist (fun (list (checked-compile '(lambda (x) (let :bogus-let
:oops
))
2004 :allow-failure t
:allow-style-warnings t
)
2005 (checked-compile '(lambda (x) (let* :bogus-let
* :oops
))
2006 :allow-failure t
:allow-style-warnings t
)
2007 (checked-compile '(lambda (x) (push x
(let ((y 0)) y
)))
2008 :allow-failure t
:allow-warnings t
)))
2009 (assert (functionp fun
))
2010 (multiple-value-bind (res err
) (ignore-errors (funcall fun t
))
2012 (assert (typep err
'program-error
))
2013 (assert (not (sequence:emptyp
(princ-to-string err
)))))))
2015 (with-test (:name
(compile random
:distribution
))
2016 (let ((fun (checked-compile '(lambda (x) (random (if x
10 20))))))
2017 (dotimes (i 100 (error "bad RANDOM distribution"))
2018 (when (> (funcall fun nil
) 9)
2021 (when (> (funcall fun t
) 9)
2022 (error "bad RANDOM event")))))
2024 ;;; 0.8.17.28-sma.1 lost derived type information.
2025 (with-test (:name
(compile :0.8.17.28-sma
.1) :fails-on
:sparc
)
2028 (declare (optimize (speed 3) (safety 0)))
2029 (declare (type (integer 0 80) x
)
2030 (type (integer 0 11) y
)
2031 (type (simple-array (unsigned-byte 32) (*)) v
))
2032 (setf (aref v
0) (* (* x
#.
(floor (ash 1 32) (* 11 80))) y
))
2036 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
2037 ;;; prevented open coding of %LISTIFY-REST-ARGS.
2038 (with-test (:name
(compile :more-entry
:%listity-rest-args
))
2039 (let ((f (checked-compile '(lambda ()
2040 (declare (optimize (debug 3)))
2041 (with-simple-restart (blah "blah") (error "blah"))))))
2042 (handler-bind ((error (lambda (c) (declare (ignore c
)) (invoke-restart 'blah
))))
2043 (assert (equal (multiple-value-list (funcall f
)) '(nil t
))))))
2045 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
2046 ;;; constant index and value.
2047 (with-test (:name
(compile bit-vector setf aref
:overflow
))
2048 (loop for n-bits
= 1 then
(* n-bits
2)
2049 for type
= `(unsigned-byte ,n-bits
)
2050 and v-max
= (1- (ash 1 n-bits
))
2051 while
(<= n-bits sb-vm
:n-word-bits
)
2053 (let* ((n (* 2 (1+ (- sb-vm
::n-word-bits n-bits
))))
2054 (array1 (make-array n
:element-type type
))
2055 (array2 (make-array n
:element-type type
)))
2057 (dolist (v (list 0 v-max
))
2058 (let ((f (checked-compile
2060 (declare (type (simple-array ,type
(,n
)) a
))
2061 (setf (aref a
,i
) ,v
)))))
2062 (fill array1
(- v-max v
))
2063 (fill array2
(- v-max v
))
2065 (setf (aref array2 i
) v
)
2066 (assert (every #'= array1 array2
))))))))
2068 (with-test (:name
(compile array bit count
))
2069 (let ((fn (checked-compile '(lambda (x)
2070 (declare (type bit x
))
2071 (declare (optimize speed
))
2072 (let ((b (make-array 64 :element-type
'bit
2073 :initial-element
0)))
2075 (assert (= (funcall fn
0) 64))
2076 (assert (= (funcall fn
1) 0))))
2078 (with-test (:name
(compile simple-bit-vector equal
))
2079 (let ((fn (checked-compile '(lambda (x y
)
2080 (declare (type simple-bit-vector x y
))
2081 (declare (optimize speed
))
2085 (make-array 64 :element-type
'bit
:initial-element
0)
2086 (make-array 64 :element-type
'bit
:initial-element
0)))
2090 (make-array 64 :element-type
'bit
:initial-element
0)
2091 (let ((b (make-array 64 :element-type
'bit
:initial-element
0)))
2092 (setf (sbit b
63) 1)
2095 ;;; MISC.535: compiler failure
2096 (with-test (:name
(compile :misc
.535))
2097 (let ((c0 #c
(4196.088977268509d0 -
15943.3603515625d0
)))
2098 (assert (not (funcall
2101 (declare (optimize speed
(safety 1))
2104 (eql (the (complex double-float
) p1
) p2
)))
2105 c0
#c
(12 612/979))))))
2107 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
2108 ;;; simple-bit-vector functions.
2109 (with-test (:name
(compile simple-bit-vector count
:should-not-compiler-note
))
2110 (checked-compile '(lambda (x)
2111 (declare (type simple-bit-vector x
))
2114 (with-test (:name
(compile simple-bit-vector equal
:should-not-compiler-note
))
2115 (checked-compile '(lambda (x y
)
2116 (declare (type simple-bit-vector x y
))
2120 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
2121 ;;; code transformations.
2122 (with-test (:name
(compile :misc
.550))
2123 (assert (eql (funcall
2126 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
2129 (or p1
(the (eql t
) p2
))))
2133 ;;; MISC.548: type check weakening converts required type into
2135 (with-test (:name
(compile :misc
.548))
2140 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
2141 (atom (the (member f assoc-if write-line t w
) p1
))))
2144 ;;; Free special bindings only apply to the body of the binding form, not
2145 ;;; the initialization forms.
2146 (with-test (:name
(compile declare special
))
2148 (funcall (checked-compile
2151 (declare (special x
))
2153 ((lambda (&optional
(y x
))
2154 (declare (special x
)) y
))))))))))
2156 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
2157 ;;; a rational was zero, but didn't do the substitution, leading to a
2158 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
2159 ;;; machine's ASH instruction's immediate field) that the compiler
2160 ;;; thought was legitimate.
2161 (with-test (:name
:overlarge-immediate-in-ash-vop
)
2162 (checked-compile `(lambda (b)
2163 (declare (type (integer -
2 14) b
))
2164 (declare (ignorable b
))
2165 (ash (imagpart b
) 57))))
2167 ;;; bug reported by Eduardo Mu\~noz
2168 (with-test (:name
(compile vector loop
))
2170 `(lambda (struct first
)
2171 (declare (optimize speed
))
2172 (let* ((nodes (nodes struct
))
2173 (bars (bars struct
))
2174 (length (length nodes
))
2175 (new (make-array length
:fill-pointer
0)))
2176 (vector-push first new
)
2177 (loop with i fixnum
= 0
2178 for newl fixnum
= (length new
)
2179 while
(< newl length
) do
2180 (let ((oldl (length new
)))
2181 (loop for j fixnum from i below newl do
2182 (dolist (n (node-neighbours (aref new j
) bars
))
2183 (unless (find n new
)
2184 (vector-push n new
))))
2187 :allow-style-warnings t
))
2189 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
2191 (with-test (:name
(compile float
:bug-389
))
2192 (checked-compile `(lambda (x y a b c
)
2193 (- y
(* (signum x
) (sqrt (abs (- (* b x
) c
))))))
2194 :allow-style-warnings t
))
2196 ;;; Type inference from CHECK-TYPE
2197 (with-test (:name
(compile check-type
:type-inference
))
2198 (let ((notes (nth-value
2199 4 (checked-compile '(lambda (x)
2200 (declare (optimize (speed 3)))
2202 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
2203 (assert (> (length notes
) 1)))
2205 (let ((notes (nth-value
2206 4 (checked-compile '(lambda (x)
2207 (declare (optimize (speed 3)))
2208 (check-type x fixnum
)
2210 ;; Only the posssible word -> bignum conversion note
2211 (assert (= (length notes
) 1))))
2213 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
2214 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
2215 (with-test (:name
:sap-ref-float
)
2216 (checked-compile '(lambda (sap)
2217 (let ((x (setf (sb-vm::sap-ref-double sap
0) 1d0
)))
2219 (checked-compile '(lambda (sap)
2220 (let ((x (setf (sb-vm::sap-ref-single sap
0) 1f0
)))
2224 (with-test (:name
:string-union-types
)
2225 (checked-compile '(lambda (x)
2226 (declare (type (or (simple-array character
(6))
2227 (simple-array character
(5))) x
))
2230 ;;; MISC.623: missing functions for constant-folding
2231 (with-test (:name
(compile :constant-folding
:missing-functions
:misc
.623))
2236 (declare (optimize (space 2) (speed 0) (debug 2)
2237 (compilation-speed 3) (safety 0)))
2238 (loop for lv3 below
1
2240 (loop for lv2 below
2
2242 (bit #*1001101001001
2243 (min 12 (max 0 lv3
)))))))))))))
2245 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
2246 (with-test (:name
(compile :%logbitp-vops
:misc
.624))
2251 (declare (type (integer 21 28) a
))
2252 (declare (optimize (compilation-speed 1) (safety 2)
2253 (speed 0) (debug 0) (space 1)))
2254 (let* ((v7 (flet ((%f3
(f3-1 f3-2
)
2255 (loop for lv2 below
1
2259 (min 7 (max 0 (eval '0))))))))
2262 :allow-style-warnings t
)
2265 ;;; MISC.626: bandaged AVER was still wrong
2266 (with-test (:name
(compile logbitp
:misc
.626))
2267 (assert (eql -
829253
2271 (declare (type (integer -
902970 2) a
))
2272 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2273 (speed 0) (safety 3)))
2274 (prog2 (if (logbitp 30 a
) 0 (block b3
0)) a
)))
2277 ;; MISC.628: constant-folding %LOGBITP was buggy
2278 (with-test (:name
(compile logbitp
:constant-folding
:misc
.628))
2283 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2284 (speed 0) (debug 1)))
2285 (not (not (logbitp 0 (floor 2147483651 (min -
23 0)))))))))))
2287 ;; mistyping found by random-tester
2288 (with-test (:name
(compile :type-derivation
))
2293 (declare (optimize (speed 1) (debug 0)
2294 (space 2) (safety 0) (compilation-speed 0)))
2296 (* (/ (multiple-value-prog1 -
29457482 -
5602513511) 1)))))))))
2298 ;; aggressive constant folding (bug #400)
2299 (with-test (:name
(compile :aggressive-constant-folding
:bug-400
))
2301 (eq t
(funcall (checked-compile `(lambda () (or t
(the integer
(/ 1 0)))))))))
2303 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-1
))
2304 (checked-compile `(lambda (x y
)
2305 (when (eql x
(length y
))
2307 (declare (optimize (speed 3)))
2309 :allow-notes
'(not compiler-note
)))
2311 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-2
))
2312 (checked-compile `(lambda (x y
)
2313 (when (eql (length y
) x
)
2315 (declare (optimize (speed 3)))
2317 :allow-notes
'(not compiler-note
)))
2319 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-1
))
2320 (checked-compile `(lambda (x)
2321 (declare (type (single-float * (3.0
)) x
))
2325 :allow-notes
'(not compiler-note
)))
2327 (defun assert-code-deletion-note (lambda &optional
(howmany 1))
2328 (let ((notes (nth-value
2329 4 (checked-compile lambda
:allow-notes
'code-deletion-note
))))
2330 (assert (= howmany
(length notes
)))))
2332 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-2
))
2333 (assert-code-deletion-note
2335 (declare (type single-float x
))
2338 (error "This is unreachable."))))))
2340 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-3
2342 (assert-code-deletion-note
2344 (declare (type (single-float 0.0) x
))
2347 (error "This is unreachable."))))))
2349 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-4
2351 (assert-code-deletion-note
2353 (declare (type (single-float 0.0) x
)
2354 (type (single-float (0.0
)) y
))
2357 (error "This is unreachable."))))))
2359 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-1
))
2360 (assert-code-deletion-note
2362 (when (typep y
'fixnum
)
2364 (unless (typep x
'fixnum
)
2365 (error "This is unreachable"))
2368 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-2
))
2369 (assert-code-deletion-note
2371 (when (typep y
'fixnum
)
2373 (unless (typep x
'fixnum
)
2374 (error "This is unreachable"))
2377 ;; Reported by John Wiseman, sbcl-devel
2378 ;; Subject: [Sbcl-devel] float type derivation bug?
2379 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2380 (with-test (:name
(compile :type-derivation
:float-bounds
))
2383 (let* ((s (if (= (ash bits -
31) 0) 1 -
1))
2384 (e (logand (ash bits -
23) #xff
))
2386 (ash (logand bits
#x7fffff
) 1)
2387 (logior (logand bits
#x7fffff
) #x800000
))))
2388 (float (* s m
(expt 2 (- e
150))))))))
2390 ;; Reported by James Knight
2391 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2392 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2393 (with-test (:name
(compile logbitp
:vop
))
2395 `(lambda (days shift
)
2396 (declare (type fixnum shift days
))
2398 (canonicalized-shift (+ shift
1))
2399 (first-wrapping-day (- 1 canonicalized-shift
)))
2400 (declare (type fixnum result
))
2401 (dotimes (source-day 7)
2402 (declare (type (integer 0 6) source-day
))
2403 (when (logbitp source-day days
)
2407 (if (< source-day first-wrapping-day
)
2408 (+ source-day canonicalized-shift
)
2410 canonicalized-shift
)
2414 ;;; MISC.637: incorrect delaying of conversion of optional entries
2415 ;;; with hairy constant defaults
2416 (with-test (:name
(compile :optional-entry
:hairy-defaults
:misc
.637))
2417 (let ((fun (checked-compile
2419 (labels ((%f11
(f11-2 &key key1
)
2420 (labels ((%f8
(f8-2 &optional
(f8-5 (if nil
(return-from %f11
0) 0)))
2425 (assert (eq (funcall fun
) :good
))))
2427 ;;; MISC.555: new reference to an already-optimized local function
2428 (with-test (:name
(compile :already-optimized
:local-function
:misc
.555))
2429 (let ((fun (checked-compile
2431 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0))
2434 (assert (funcall fun
:good
))
2435 (assert-error (funcall fun
42) type-error
)))
2437 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2438 (with-test (:name
(compile *random-state
*))
2439 (let* ((state (make-random-state))
2440 (*random-state
* (make-random-state state
))
2441 (a (random most-positive-fixnum
)))
2442 (setf *random-state
* state
)
2443 (checked-compile `(lambda (x a
)
2444 (declare (single-float x
)
2445 (type (simple-array double-float
) a
))
2446 (+ (loop for i across a
2449 (assert (= a
(random most-positive-fixnum
)))))
2451 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2452 (with-test (:name
(compile let
:conversion
:lost
:nlx-infos
:misc
.641))
2453 (let ((fun (checked-compile
2455 (declare (optimize (speed 1) (space 0) (debug 2)
2456 (compilation-speed 0) (safety 1)))
2457 (flet ((%f3
(f3-1 &key
(key1 (count (floor 0 (min -
74 0)) #())))
2459 (apply #'%f3
0 nil
)))
2460 :allow-style-warnings t
)))
2461 (assert (zerop (funcall fun
)))))
2463 ;;; 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
2464 (with-test (:name
(compile make-array aref
:size-mismatch
))
2465 (checked-compile `(lambda ()
2466 (let ((x (make-array '(1) :element-type
'(signed-byte 32))))
2467 (setf (aref x
0) 1)))))
2469 ;;; step instrumentation confusing the compiler, reported by Faré
2470 (with-test (:name
(compile step
))
2471 (checked-compile `(lambda ()
2472 (declare (optimize (debug 2))) ; not debug 3!
2473 (let ((val "foobar"))
2474 (map-into (make-array (list (length val
))
2475 :element-type
'(unsigned-byte 8))
2476 #'char-code val
)))))
2478 ;;; overconfident primitive type computation leading to bogus type
2480 (with-test (:name
(compile :primitive-type standard-object condition function
))
2481 (flet ((test-case/incompatible
(type1 type2 object1 object2
)
2482 (multiple-value-bind (fun failure-p warnings
)
2485 (declare (type (and ,type1
,type2
) x
))
2487 :allow-failure t
:allow-warnings t
)
2489 (assert (= (length warnings
) 1))
2490 ;; FIXME (declare (type <equivalent-to-empty-type> x)) is
2491 ;; currently dropped instead of compiled into a type
2493 ;; (assert-error (funcall fun object1) type-error)
2494 ;; (assert-error (funcall fun object2) type-error)
2496 (test-case/compatible
(type1 type2 object1 object2
)
2497 (let ((fun (checked-compile
2499 (declare (type (and ,type1
,type2
) x
))
2501 (when (typep object1 type2
)
2502 (assert (typep (funcall fun object1
) type1
)))
2503 (when (typep object2 type1
)
2504 (assert (typep (funcall fun object2
) type2
))))))
2505 ;; TODO Add structure classes, SEQUENCE and EXTENDED-SEQUENCE
2506 (let ((types `((condition .
,(make-condition 'error
))
2507 (sb-kernel:funcallable-instance .
,#'print-object
)
2508 (function .
,#'identity
)
2509 (sb-kernel:instance .
,(find-class 'class
))
2510 (standard-object .
,(find-class 'class
))))
2511 (compatible '((sb-kernel:instance . condition
)
2512 (sb-kernel:instance . standard-object
)
2513 (sb-kernel:funcallable-instance . function
)
2514 (sb-kernel:funcallable-instance . standard-object
)
2515 (function . standard-object
))))
2516 (loop :for
(type1 . object1
) :in types
:do
2517 (loop :for
(type2 . object2
) :in types
:do
2519 (if (or (eq type1 type2
)
2520 (find-if (lambda (cell)
2521 (or (and (eq type1
(car cell
))
2522 (eq type2
(cdr cell
)))
2523 (and (eq type2
(car cell
))
2524 (eq type1
(cdr cell
)))))
2526 #'test-case
/compatible
2527 #'test-case
/incompatible
)
2528 type1 type2 object1 object2
))))))
2530 ;;; VALUES declaration: while the declaration is a non-standard and
2531 ;;; possibly a non-conforming extension, as long as we do support it,
2532 ;;; we might as well get it right.
2534 ;;; The first of the following two tests originally asserted that the
2535 ;;; declaration _was_ allowed in a LET* form (The test was originally
2536 ;;; added in reaction to a bug reported by Kaersten Poeck on
2537 ;;; sbcl-devel 20061023). After commit
2538 ;;; 498e00334f2b1ba87c3edd557bbce4247977a11d, the declaration is
2539 ;;; accepted in LAMBDA but not LET*. The current form of the tests
2541 (with-test (:name
(compile let
* declare values
))
2542 (multiple-value-bind (fun failure-p warnings
)
2543 (checked-compile '(lambda () (let* () (declare (values list
))))
2545 (declare (ignore fun failure-p
))
2546 (assert (= (length warnings
) 1))))
2548 (with-test (:name
(compile lambda declare values
))
2549 (let ((fun (checked-compile '(lambda (x) (declare (values list
)) x
))))
2550 (assert (equal (sb-impl::%fun-type fun
)
2551 '(function (t) (values list
&optional
))))))
2553 ;;; test for some problems with too large immediates in x86-64 modular
2555 (with-test (:name
(compile :modular-arithmetic-vops
))
2557 '(lambda (x) (declare (fixnum x
))
2558 (logand most-positive-fixnum
(logxor x most-positive-fixnum
))))
2561 '(lambda (x) (declare (fixnum x
))
2562 (logand most-positive-fixnum
(+ x most-positive-fixnum
))))
2565 '(lambda (x) (declare (fixnum x
))
2566 (logand most-positive-fixnum
(* x most-positive-fixnum
)))))
2569 (with-test (:name
:propagate-type-through-error-and-binding
)
2571 2 (checked-compile '(lambda (x)
2572 (list (let ((y (the real x
)))
2573 (unless (floatp y
) (error ""))
2575 (integer-length x
)))
2576 :allow-warnings
'sb-int
:type-warning
))))
2578 ;; Dead / in safe code
2579 (with-test (:name
(compile / :dead
:safe
))
2580 (assert-error (funcall (checked-compile
2582 (declare (optimize (safety 3)))
2589 ;;; Dead unbound variable (bug 412)
2590 (with-test (:name
(compile :dead-unbound
:bug-412
))
2592 (funcall (checked-compile '(lambda ()
2598 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2599 (with-test (:name
(compile subseq simple-vector
:no-notes
))
2602 (funcall (checked-compile
2604 (declare (optimize speed
)
2612 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2613 (with-test (:name
(compile copy-seq simple-bit-vector
:if-input-does-not-exist
))
2616 (funcall (checked-compile
2618 (declare (optimize speed
)
2622 (vector 1 2 3 4)))))
2624 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2625 (with-test (:name
(mismatch :data-vector-ref-with-offset
))
2626 (assert (not (mismatch #(1.0f0
2.0f0
)
2627 (make-array 2 :element-type
'single-float
2628 :initial-contents
(list 1.0f0
2.0f0
))))))
2630 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2631 ;;; large bignums to floats
2632 (with-test (:name
(compile * / + -
:interval-arithmetic
))
2633 (dolist (op '(* / + -
))
2634 (let ((fun (checked-compile
2636 (declare (type (integer 0 #.
(* 2 (truncate most-positive-double-float
))) x
))
2639 do
(let ((arg (random (truncate most-positive-double-float
))))
2640 (assert (eql (funcall fun arg
)
2641 (funcall op
0.0d0 arg
))))))))
2643 (with-test (:name
(compile :high-debug-known-function-inlining
))
2644 (funcall (checked-compile
2646 (declare (optimize (debug 3)) (inline append
))
2647 (let ((fun (lambda (body)
2651 (funcall fun
'((foo (bar)))))))))
2653 (with-test (:name
(compile :high-debug-known-function-transform-with-optional-arguments
))
2654 (checked-compile '(lambda (x y
)
2655 (declare (optimize sb-c
::preserve-single-use-debug-variables
))
2657 (some-unknown-function
2659 (return (member x y
))))
2663 :allow-style-warnings t
))
2665 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2667 (with-test (:name
(compile sb-sys
:with-pinned-objects
:known-type fixnum character
))
2668 (checked-compile '(lambda (x y
)
2669 (declare (fixnum y
) (character x
))
2670 (sb-sys:with-pinned-objects
(x y
)
2671 (some-random-function)))
2672 :allow-style-warnings t
))
2674 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2676 (with-test (:name
(compile :bug-423
))
2677 (let ((sb-c::*check-consistency
* t
))
2678 (flet ((make-lambda (type)
2682 (let ((q (truly-the list z
)))
2685 (let ((q (truly-the vector z
)))
2689 (checked-compile (make-lambda 'list
))
2690 (checked-compile (make-lambda 'vector
)))))
2692 ;;; this caused a momentary regression when an ill-adviced fix to
2693 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2695 ;;; 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)
2696 ;;; [Condition of type SIMPLE-ERROR]
2697 (with-test (:name
(compile :bug-427
))
2704 (setf (sb-alien:deref
(sb-alien:cast
(sb-alien:sap-alien
(unknown1) (* unsigned-char
))
2705 (* double-float
))) frob
))
2707 (%zig
(the (values (single-float (0.0
) 1.0) &optional
) (unknown2)))
2710 :allow-style-warnings t
2711 :allow-warnings
'sb-int
:local-argument-mismatch
))
2713 ;;; non-required arguments in HANDLER-BIND
2714 (with-test (:name
(compile handler-bind
:lambda-list
))
2715 (let ((fun (checked-compile
2718 (handler-bind ((error (lambda (&rest args
) (return (cons :oops args
)))))
2720 (assert (eq :oops
(car (funcall fun
0))))))
2722 ;;; NIL is a legal function name
2723 (assert (eq 'a
(flet ((nil () 'a
)) (nil))))
2726 (with-test (:name
(compile :misc
.528))
2727 (assert (null (let* ((x 296.3066f0
)
2729 (form `(lambda (r p2
)
2730 (declare (optimize speed
(safety 1))
2731 (type (simple-array single-float nil
) r
)
2732 (type (integer -
9369756340 22717335) p2
))
2733 (setf (aref r
) (* ,x
(the (eql 22717067) p2
)))
2735 (r (make-array nil
:element-type
'single-float
))
2737 (funcall (checked-compile form
) r y
)
2738 (let ((actual (aref r
)))
2739 (unless (eql expected actual
)
2740 (list expected actual
)))))))
2742 (with-test (:name
(compile :misc
.529))
2743 (assert (null (let* ((x -
2367.3296f0
)
2745 (form `(lambda (r p2
)
2746 (declare (optimize speed
(safety 1))
2747 (type (simple-array single-float nil
) r
)
2748 (type (eql 46790178) p2
))
2749 (setf (aref r
) (+ ,x
(the (integer 45893897) p2
)))
2751 (r (make-array nil
:element-type
'single-float
))
2753 (funcall (checked-compile form
) r y
)
2754 (let ((actual (aref r
)))
2755 (unless (eql expected actual
)
2756 (list expected actual
)))))))
2759 (with-test (:name
(compile :misc
.556))
2765 (optimize (speed 1) (safety 0)
2766 (debug 0) (space 0))
2767 (type (member 8174.8604) p1
)
2768 (type (member -
95195347) p2
))
2770 8174.8604 -
95195347))))
2773 (with-test (:name
(compile :misc
.557))
2778 (declare (optimize (speed 3) (safety 0) (debug 3) (space 1))
2779 (type (member -
94430.086f0
) p1
))
2780 (floor (the single-float p1
) 19311235)))
2784 (with-test (:name
(compile :misc
.558))
2789 (declare (optimize (speed 1) (safety 2)
2790 (debug 2) (space 3))
2791 (type (eql -
39466.56f0
) p1
))
2792 (ffloor p1
305598613)))
2796 (with-test (:name
(compile :misc
.559))
2801 (declare (optimize (speed 1) (safety 1) (debug 1) (space 2))
2802 (type (eql -
83232.09f0
) p1
))
2803 (ceiling p1 -
83381228)))
2807 (with-test (:name
(compile :misc
.560))
2812 (declare (optimize (speed 1) (safety 1)
2813 (debug 1) (space 0))
2814 (type (member -
66414.414f0
) p1
))
2815 (ceiling p1 -
63019173f0
)))
2819 (with-test (:name
(compile :misc
.561))
2824 (declare (optimize (speed 0) (safety 1)
2825 (debug 0) (space 1))
2826 (type (eql 20851.398f0
) p1
))
2827 (fceiling p1
80839863)))
2831 (with-test (:name
(compile :misc
.581))
2834 (checked-compile '(lambda (x)
2835 (declare (type (eql -
5067.2056) x
))
2840 (with-test (:name
(compile :misc
.581a
))
2843 (checked-compile '(lambda (x) (declare (type (eql -
1.0) x
))
2849 (with-test (:name
(compile :misc
.582))
2850 (assert (plusp (funcall
2853 (declare (optimize (speed 0) (safety 1) (debug 1) (space 1))
2854 (type (eql -
39887.645) p1
))
2855 (mod p1
382352925)))
2859 (with-test (:name
(compile :misc
.587))
2860 (assert (let ((result (funcall
2863 (declare (optimize (speed 0) (safety 3) (debug 1) (space 0))
2864 (type (eql 33558541) p2
))
2867 (typep result
'single-float
))))
2870 (with-test (:name
(compile :misc
.635))
2872 (let* ((form '(lambda (p2)
2873 (declare (optimize (speed 0) (safety 1)
2874 (debug 2) (space 2))
2875 (type (member -
19261719) p2
))
2876 (ceiling -
46022.094 p2
))))
2877 (values (funcall (checked-compile form
) -
19261719))))))
2880 (with-test (:name
(compile :misc
.636))
2881 (assert (let* ((x 26899.875)
2883 (declare (optimize (speed 3) (safety 1) (debug 3) (space 1))
2884 (type (member ,x
#:g5437 char-code
#:g5438
) p2
))
2886 (floatp (funcall (checked-compile form
) x
)))))
2889 (with-test (:name
(compile :misc
.622))
2894 (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
2896 (+ 81535869 (the (member 17549.955 #:g35917
) p2
))))
2898 (+ 81535869 17549.955))))
2901 (with-test (:name
(compile :misc
.654))
2903 (let ((form '(lambda (p2)
2904 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2905 (type (member integer eql
) p2
))
2907 (funcall (checked-compile form
) 'integer
)))))
2910 (with-test (:name
(compile :misc
.656))
2912 (let ((form '(lambda (p2)
2913 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2914 (type (member integer mod
) p2
))
2916 (funcall (checked-compile form
) 'integer
)))))
2919 (with-test (:name
(compile :misc
.657))
2921 (let ((form '(lambda (p2)
2922 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2923 (type (member integer values
) p2
))
2925 (funcall (checked-compile form
) 'integer
)))))
2927 (with-test (:name
(compile aref string
:derive-type
))
2928 (assert (eq 'character
2929 (funcall (checked-compile
2931 (ctu:compiler-derived-type
(aref (the string s
) 0))))
2934 (with-test (:name
(compile aref base-string
:derive-type
))
2935 (assert (eq #+sb-unicode
'base-char
2936 #-sb-unicode
'character
2937 (funcall (checked-compile
2939 (ctu:compiler-derived-type
(aref (the base-string s
) 0))))
2940 (coerce "foo" 'base-string
)))))
2942 (with-test (:name
(compile dolist
:constant
:derive-type
))
2943 (assert (equal '(integer 1 3)
2944 (funcall (checked-compile
2946 (dolist (y '(1 2 3))
2948 (return (ctu:compiler-derived-type y
))))))
2951 (with-test (:name
(compile dolist
:simple list
:derive-type
))
2952 (assert (equal '(integer 1 3)
2953 (funcall (checked-compile
2955 (dolist (y (list 1 2 3))
2957 (return (ctu:compiler-derived-type y
))))))
2960 (with-test (:name
(compile dolist
:dotted-constant-list
:derive-type
))
2961 (multiple-value-bind (fun failure-p warnings style-warnings
)
2964 (dolist (y '(1 2 3 .
4) :foo
)
2966 (return (ctu:compiler-derived-type y
)))))
2967 :allow-style-warnings t
)
2968 (declare (ignore failure-p warnings
))
2969 (assert (= 1 (length style-warnings
)))
2970 (assert (equal '(integer 1 3) (funcall fun t
)))
2971 (assert-error (funcall fun nil
) type-error
)))
2973 (with-test (:name
(compile destructuring-bind
:constant list
))
2978 (destructuring-bind (a (b c
) d
) '(1 (2 3) 4)
2980 :allow-notes nil
))))
2986 (destructuring-bind (a (b c
) d
) '(1 "foo" 4)
2991 ;;; Functions with non-required arguments used to end up with
2992 ;;; (&OPTIONAL-DISPATCH ...) as their names.
2993 (with-test (:name
:hairy-function-name
)
2994 (assert (eq 'read-line
(nth-value 2 (function-lambda-expression #'read-line
))))
2995 (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line
))))
2997 ;;; PROGV + RESTRICT-COMPILER-POLICY
2998 ;; META: there's a test in compiler.impure.lisp that also tests
2999 ;; interaction of PROGV with (debug 3). These tests should be together.
3000 (with-test (:name
(compile progv sb-ext
:restrict-compiler-policy
))
3001 (let ((sb-c::*policy-min
* sb-c
::*policy-min
*)
3002 (sb-c::*policy-max
* sb-c
::*policy-max
*))
3003 (restrict-compiler-policy 'debug
3)
3004 (let ((fun (checked-compile
3007 (declare (special i
))
3009 (progv '(i) (list (+ i
1))
3012 (assert (equal '(1 2 1) (funcall fun
1))))))
3014 ;;; It used to be possible to confuse the compiler into
3015 ;;; IR2-converting such a call to CONS
3016 (with-test (:name
(compile :late-bound-primitive
))
3017 (checked-compile `(lambda ()
3021 (with-test (:name
(compile :hairy-array-element-type-derivation
))
3024 (declare (type (and simple-string
(satisfies array-has-fill-pointer-p
)) x
))
3025 (array-element-type x
))))
3027 (with-test (:name
(compile &rest
:derive-type
1))
3028 (multiple-value-bind (type derivedp
)
3029 (funcall (checked-compile `(lambda (&rest args
)
3030 (ctu:compiler-derived-type args
)))
3032 (assert (eq 'list type
))
3035 (with-test (:name
(compile &rest
:derive-type
2))
3036 (multiple-value-bind (type derivedp
)
3037 (funcall (funcall (checked-compile `
3039 (lambda (&rest args
)
3040 (ctu:compiler-derived-type args
))))))
3041 (assert (eq 'list type
))
3044 (with-test (:name
(compile &rest
:derive-type
3))
3045 (multiple-value-bind (type derivedp
)
3046 (funcall (funcall (checked-compile
3048 (lambda (&optional x
&rest args
)
3049 (unless x
(error "oops"))
3050 (ctu:compiler-derived-type args
)))))
3052 (assert (eq 'list type
))
3055 (with-test (:name
(compile &rest
:derive-type
4))
3056 (multiple-value-bind (type derivedp
)
3057 (funcall (funcall (checked-compile
3059 (lambda (&optional x
&rest args
)
3060 (declare (type (or null integer
) x
))
3061 (when x
(setf args x
))
3062 (ctu:compiler-derived-type args
)))))
3064 (assert (equal '(or cons null integer
) type
))
3067 (with-test (:name
(compile base-char typep
:elimination
))
3068 (assert (eq (funcall (checked-compile
3070 (declare (type base-char ch
) (optimize (speed 3) (safety 0)))
3071 (typep ch
'base-char
)))
3075 (with-test (:name
:regression-1.0
.24.37)
3076 (checked-compile `(lambda (&key
(test (constantly t
)))
3077 (when (funcall test
)
3080 ;;; Attempt to test a decent cross section of conditions
3081 ;;; and values types to move conditionally.
3083 ((test-comparison (comparator type x y
)
3085 ,@(loop for
(result-type a b
)
3091 (nil #c
(1.0
1.0) #c
(2.0
2.0))
3095 ((unsigned-byte #.sb-vm
:n-word-bits
)
3096 (1+ most-positive-fixnum
)
3097 (+ 2 most-positive-fixnum
))
3098 ((signed-byte #.sb-vm
:n-word-bits
)
3099 -
1 (* 2 most-negative-fixnum
))
3100 (single-float 0.0 1.0)
3101 (double-float 0d0
1d0
))
3102 for lambda
= (if result-type
3104 (declare (,type x y
)
3106 (if (,comparator x y
)
3109 (declare (,type x y
))
3110 (if (,comparator x y
)
3112 for args
= `(,x
,y
,@(and result-type
3116 (eql (funcall (checked-compile ',lambda
)
3118 (eval '(,lambda
,@args
))))))))
3119 (sb-vm::with-float-traps-masked
3120 (:divide-by-zero
:overflow
:inexact
:invalid
)
3121 (let (#+sb-eval
(sb-ext:*evaluator-mode
* :interpret
))
3122 (declare (sb-ext:muffle-conditions style-warning
))
3123 (test-comparison eql t t nil
)
3124 (test-comparison eql t t t
)
3126 (test-comparison = t
1 0)
3127 (test-comparison = t
1 1)
3128 (test-comparison = t
(1+ most-positive-fixnum
) (+ 2 most-positive-fixnum
))
3129 (test-comparison = fixnum
1 0)
3130 (test-comparison = fixnum
0 0)
3131 (test-comparison = (unsigned-byte #.sb-vm
:n-word-bits
) 1 0)
3132 (test-comparison = (unsigned-byte #.sb-vm
:n-word-bits
) 0 0)
3133 (test-comparison = (signed-byte #.sb-vm
:n-word-bits
) 1 0)
3134 (test-comparison = (signed-byte #.sb-vm
:n-word-bits
) 1 1)
3136 (test-comparison = single-float
0.0 1.0)
3137 (test-comparison = single-float
1.0 1.0)
3138 (test-comparison = single-float
(/ 1.0 0.0) (/ 1.0 0.0))
3139 (test-comparison = single-float
(/ 1.0 0.0) 1.0)
3140 (test-comparison = single-float
(/ 0.0 0.0) (/ 0.0 0.0))
3141 (test-comparison = single-float
(/ 0.0 0.0) 0.0)
3143 (test-comparison = double-float
0d0
1d0
)
3144 (test-comparison = double-float
1d0
1d0
)
3145 (test-comparison = double-float
(/ 1d0
0d0
) (/ 1d0
0d0
))
3146 (test-comparison = double-float
(/ 1d0
0d0
) 1d0
)
3147 (test-comparison = double-float
(/ 0d0
0d0
) (/ 0d0
0d0
))
3148 (test-comparison = double-float
(/ 0d0
0d0
) 0d0
)
3150 (test-comparison < t
1 0)
3151 (test-comparison < t
0 1)
3152 (test-comparison < t
1 1)
3153 (test-comparison < t
(1+ most-positive-fixnum
) (+ 2 most-positive-fixnum
))
3154 (test-comparison < t
(+ 2 most-positive-fixnum
) (1+ most-positive-fixnum
))
3155 (test-comparison < fixnum
1 0)
3156 (test-comparison < fixnum
0 1)
3157 (test-comparison < fixnum
0 0)
3158 (test-comparison < (unsigned-byte #.sb-vm
:n-word-bits
) 1 0)
3159 (test-comparison < (unsigned-byte #.sb-vm
:n-word-bits
) 0 1)
3160 (test-comparison < (unsigned-byte #.sb-vm
:n-word-bits
) 0 0)
3161 (test-comparison < (signed-byte #.sb-vm
:n-word-bits
) 1 0)
3162 (test-comparison < (signed-byte #.sb-vm
:n-word-bits
) 0 1)
3163 (test-comparison < (signed-byte #.sb-vm
:n-word-bits
) 1 1)
3165 (test-comparison < single-float
0.0 1.0)
3166 (test-comparison < single-float
1.0 0.0)
3167 (test-comparison < single-float
1.0 1.0)
3168 (test-comparison < single-float
(/ 1.0 0.0) (/ 1.0 0.0))
3169 (test-comparison < single-float
(/ 1.0 0.0) 1.0)
3170 (test-comparison < single-float
1.0 (/ 1.0 0.0))
3171 (test-comparison < single-float
(/ 0.0 0.0) (/ 0.0 0.0))
3172 (test-comparison < single-float
(/ 0.0 0.0) 0.0)
3174 (test-comparison < double-float
0d0
1d0
)
3175 (test-comparison < double-float
1d0
0d0
)
3176 (test-comparison < double-float
1d0
1d0
)
3177 (test-comparison < double-float
(/ 1d0
0d0
) (/ 1d0
0d0
))
3178 (test-comparison < double-float
(/ 1d0
0d0
) 1d0
)
3179 (test-comparison < double-float
1d0
(/ 1d0
0d0
))
3180 (test-comparison < double-float
(/ 0d0
0d0
) (/ 0d0
0d0
))
3181 (test-comparison < double-float
(/ 0d0
0d0
) 0d0
)
3182 (test-comparison < double-float
0d0
(/ 0d0
0d0
))
3184 (test-comparison > t
1 0)
3185 (test-comparison > t
0 1)
3186 (test-comparison > t
1 1)
3187 (test-comparison > t
(1+ most-positive-fixnum
) (+ 2 most-positive-fixnum
))
3188 (test-comparison > t
(+ 2 most-positive-fixnum
) (1+ most-positive-fixnum
))
3189 (test-comparison > fixnum
1 0)
3190 (test-comparison > fixnum
0 1)
3191 (test-comparison > fixnum
0 0)
3192 (test-comparison > (unsigned-byte #.sb-vm
:n-word-bits
) 1 0)
3193 (test-comparison > (unsigned-byte #.sb-vm
:n-word-bits
) 0 1)
3194 (test-comparison > (unsigned-byte #.sb-vm
:n-word-bits
) 0 0)
3195 (test-comparison > (signed-byte #.sb-vm
:n-word-bits
) 1 0)
3196 (test-comparison > (signed-byte #.sb-vm
:n-word-bits
) 0 1)
3197 (test-comparison > (signed-byte #.sb-vm
:n-word-bits
) 1 1)
3199 (test-comparison > single-float
0.0 1.0)
3200 (test-comparison > single-float
1.0 0.0)
3201 (test-comparison > single-float
1.0 1.0)
3202 (test-comparison > single-float
(/ 1.0 0.0) (/ 1.0 0.0))
3203 (test-comparison > single-float
(/ 1.0 0.0) 1.0)
3204 (test-comparison > single-float
1.0 (/ 1.0 0.0))
3205 (test-comparison > single-float
(/ 0.0 0.0) (/ 0.0 0.0))
3206 (test-comparison > single-float
(/ 0.0 0.0) 0.0)
3208 (test-comparison > double-float
0d0
1d0
)
3209 (test-comparison > double-float
1d0
0d0
)
3210 (test-comparison > double-float
1d0
1d0
)
3211 (test-comparison > double-float
(/ 1d0
0d0
) (/ 1d0
0d0
))
3212 (test-comparison > double-float
(/ 1d0
0d0
) 1d0
)
3213 (test-comparison > double-float
1d0
(/ 1d0
0d0
))
3214 (test-comparison > double-float
(/ 0d0
0d0
) (/ 0d0
0d0
))
3215 (test-comparison > double-float
(/ 0d0
0d0
) 0d0
)
3216 (test-comparison > double-float
0d0
(/ 0d0
0d0
)))))
3218 (with-test (:name
:car-and-cdr-type-derivation-conservative
)
3219 (let ((f1 (checked-compile
3221 (declare (optimize speed
))
3222 (let ((x (the (cons fixnum fixnum
) (cons 1 2))))
3223 (declare (type (cons t fixnum
) x
))
3225 (+ (car x
) (cdr x
))))))
3226 (f2 (checked-compile
3228 (declare (optimize speed
))
3229 (let ((x (the (cons fixnum fixnum
) (cons 1 2))))
3231 (+ (car x
) (cdr x
)))))))
3232 (flet ((test-error (e value
)
3233 (assert (typep e
'type-error
))
3234 (assert (eq 'number
(type-error-expected-type e
)))
3235 (assert (eq value
(type-error-datum e
)))))
3238 (multiple-value-bind (res err
) (ignore-errors (funcall f1 v1
))
3240 (test-error err v1
))
3241 (multiple-value-bind (res err
) (ignore-errors (funcall f2 v2
))
3243 (test-error err v2
))))))
3245 (with-test (:name
:array-dimension-derivation-conservative
)
3246 (let ((f (checked-compile `(lambda (x)
3247 (declare (optimize speed
))
3248 (declare (type (array * (4 4)) x
))
3250 (setq x
(make-array '(4 4)))
3251 (adjust-array y
'(3 5))
3252 (array-dimension y
0))))))
3253 (assert (= 3 (funcall f
(make-array '(4 4) :adjustable t
))))))
3255 (with-test (:name
:with-timeout-code-deletion-note
)
3256 (checked-compile `(lambda ()
3257 (sb-ext:with-timeout
0
3261 (with-test (:name
:full-warning-for-undefined-type-in-cl
)
3262 (multiple-value-bind (fun failure-p warnings
)
3263 (checked-compile `(lambda (x) (the replace x
)) :allow-warnings t
)
3264 (declare (ignore fun failure-p
))
3265 (assert (= 1 (length warnings
)))))
3267 (with-test (:name
:single-warning-for-single-undefined-type
)
3268 ;; STYLE-WARNING for symbol not in cl package.
3269 (multiple-value-bind (fun failure-p warnings style-warnings
)
3270 (checked-compile `(lambda (x) (the #:no-type x
))
3271 :allow-style-warnings t
)
3272 (declare (ignore fun failure-p warnings
))
3273 (assert (= 1 (length style-warnings
))))
3275 ;; Full WARNING for invalid type specifier starting with QUOTE.
3276 (multiple-value-bind (fun failure-p warnings
)
3277 (checked-compile `(lambda (x) (the 'fixnum x
)) :allow-warnings t
)
3278 (declare (ignore fun failure-p
))
3279 (assert (= 1 (length warnings
)))))
3281 (with-test (:name
:complex-subtype-dumping-in-xc
)
3283 (= sb-vm
:complex-single-float-widetag
3284 (sb-kernel:widetag-of
3285 (sb-vm:saetp-initial-element-default
(sb-c::find-saetp
'(complex single-float
))))))
3287 (= sb-vm
:complex-double-float-widetag
3288 (sb-kernel:widetag-of
3289 (sb-vm:saetp-initial-element-default
(sb-c::find-saetp
'(complex double-float
)))))))
3291 (with-test (:name
(compile complex single-float make-array
:fill
))
3292 (assert (every (lambda (x) (= #c
(1.0
2.0) x
))
3296 (make-array (list n
)
3297 :element-type
'(complex single-float
)
3298 :initial-element x
)))
3302 (with-test (:name
:regression-1.0
.28.21)
3303 (let ((fun (checked-compile `(lambda (x) (typep x
'(simple-array * 1))))))
3304 (assert (funcall fun
(vector 1 2 3)))
3305 (assert (funcall fun
"abc"))
3306 (assert (not (funcall fun
(make-array '(2 2)))))))
3308 (with-test (:name
:no-silly-compiler-notes-from-character-function
)
3309 (dolist (name '(char-code char-int character char-name standard-char-p
3310 graphic-char-p alpha-char-p upper-case-p lower-case-p
3311 both-case-p digit-char-p alphanumericp digit-char-p
))
3312 (checked-compile `(lambda (x)
3313 (declare (character x
) (optimize (speed 3)))
3316 (dolist (name '(char= char
/= char
< char
> char
<= char
>=
3317 char-lessp char-greaterp char-not-greaterp
3319 (checked-compile `(lambda (x y
)
3320 (declare (character x y
) (optimize speed
))
3324 ;;; optimizing make-array
3325 (with-test (:name
(make-array :open-code-initial-contents
))
3327 (assert (not (ctu:find-named-callees
3328 (checked-compile form
))))))
3329 (test `(lambda (x y z
)
3330 (make-array '(3) :initial-contents
(list x y z
))))
3331 (test `(lambda (x y z
)
3332 (make-array '3 :initial-contents
(vector x y z
))))
3333 (test `(lambda (x y z
)
3334 (make-array '3 :initial-contents
`(,x
,y
,z
))))
3335 (test `(lambda (x y z
)
3336 ;; Single-use FLET is eliminated,
3337 ;; so MAKE-ARRAY's result is obviously a vector.
3338 (flet ((size () '(3)))
3339 (make-array (size) :initial-contents
`(,x
,y
,z
)))))
3340 (test `(lambda (x y z
)
3341 (flet ((size () (list 3))) ; here too
3342 (make-array (size) :initial-contents
`(,x
,y
,z
)))))))
3344 ;;; optimizing array-in-bounds-p
3345 (with-test (:name
:optimize-array-in-bounds-p
)
3347 (macrolet ((find-callees (&body body
)
3348 `(ctu:find-named-callees
3349 (checked-compile '(lambda () ,@body
))
3350 :name
'array-in-bounds-p
))
3351 (must-optimize (&body exprs
)
3353 ,@(loop for expr in exprs
3354 collect
`(assert (not (find-callees
3356 (must-not-optimize (&body exprs
)
3358 ,@(loop for expr in exprs
3359 collect
`(assert (find-callees
3363 (let ((a (make-array '(1))))
3364 (array-in-bounds-p a
0))
3365 ;; exceeds upper bound (constant)
3366 (let ((a (make-array '(1))))
3367 (array-in-bounds-p a
1))
3368 ;; exceeds upper bound (interval)
3369 (let ((a (make-array '(1))))
3370 (array-in-bounds-p a
(+ 1 (random 2))))
3371 ;; negative lower bound (constant)
3372 (let ((a (make-array '(1))))
3373 (array-in-bounds-p a -
1))
3374 ;; negative lower bound (interval)
3375 (let ((a (make-array 3))
3376 (i (- (random 1) 20)))
3377 (array-in-bounds-p a i
))
3378 ;; multiple known dimensions
3379 (let ((a (make-array '(1 1))))
3380 (array-in-bounds-p a
0 0))
3382 (let ((s (the (simple-string 10) (eval "0123456789"))))
3383 (array-in-bounds-p s
9)))
3385 ;; don't trust non-simple array length in safety=1
3386 (let ((a (the (array * (10 20)) (make-array '(10 20) :adjustable t
))))
3387 (eval `(adjust-array ,a
'(0 0)))
3388 (array-in-bounds-p a
9 0))
3389 ;; multiple unknown dimensions
3390 (let ((a (make-array (list (random 20) (random 5)))))
3391 (array-in-bounds-p a
5 2))
3392 ;; some other known dimensions
3393 (let ((a (make-array (list 1 (random 5)))))
3394 (array-in-bounds-p a
0 2))
3395 ;; subscript might be negative
3396 (let ((a (make-array '(5 10))))
3397 (array-in-bounds-p a
1 (- (random 3) 2)))
3398 ;; subscript might be too large
3399 (let ((a (make-array '(5 10))))
3400 (array-in-bounds-p a
(random 6) 1))
3401 ;; unknown upper bound
3402 (let ((a (make-array '(5 10))))
3403 (array-in-bounds-p a
(get-universal-time) 1))
3404 ;; unknown lower bound
3405 (let ((a (make-array '(5 30))))
3406 (array-in-bounds-p a
0 (- (get-universal-time))))
3407 ;; in theory we should be able to optimize
3408 ;; the following but the current implementation
3409 ;; doesn't cut it because the array type's
3410 ;; dimensions get reported as (* *).
3411 (let ((a (make-array (list (random 20) 1))))
3412 (array-in-bounds-p a
5 2))))))
3414 ;;; optimizing (EXPT -1 INTEGER)
3415 (with-test (:name
(expt -
1 integer
))
3416 (dolist (x '(-1 -
1.0 -
1.0d0
))
3417 (let ((fun (checked-compile `(lambda (x) (expt ,x
(the fixnum x
))))))
3418 (assert (not (ctu:find-named-callees fun
)))
3421 (assert (eql x
(funcall fun i
)))
3422 (assert (eql (- x
) (funcall fun i
))))))))
3424 (with-test (:name
:float-division-using-exact-reciprocal
)
3425 (flet ((test (lambda-form arg res
&key
(check-insts t
))
3426 (let* ((fun (checked-compile lambda-form
))
3427 (disassembly (with-output-to-string (s)
3428 (disassemble fun
:stream s
))))
3429 ;; Let's make sure there is no division at runtime: for x86 and
3430 ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
3431 ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
3435 (assert (not (search "DIV" disassembly
))))
3436 ;; No generic arithmetic!
3437 (assert (not (search "GENERIC" disassembly
)))
3438 (assert (eql res
(funcall fun arg
))))))
3439 (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
3440 (dolist (type '(single-float double-float
))
3441 (let* ((cf (coerce c type
))
3442 (arg (- (random (* 2 cf
)) cf
))
3443 (r1 (eval `(/ ,arg
,cf
)))
3444 (r2 (eval `(/ ,arg
,(- cf
)))))
3445 (test `(lambda (x) (declare (,type x
)) (/ x
,cf
)) arg r1
)
3446 (test `(lambda (x) (declare (,type x
)) (/ x
,(- cf
))) arg r2
)
3447 ;; rational args should get optimized as well
3448 (test `(lambda (x) (declare (,type x
)) (/ x
,c
)) arg r1
)
3449 (test `(lambda (x) (declare (,type x
)) (/ x
,(- c
))) arg r2
))))
3450 ;; Also check that inexact reciprocals (1) are not used by default (2) are
3451 ;; used with FLOAT-ACCURACY=0.
3452 (dolist (type '(single-float double-float
))
3453 (let ((trey (coerce 3 type
))
3454 (one (coerce 1 type
)))
3455 (test `(lambda (x) (declare (,type x
)) (/ x
3)) trey one
3459 (optimize (sb-c::float-accuracy
0)))
3461 trey
(eval `(* ,trey
(/ ,trey
))))))))
3463 (with-test (:name
:float-multiplication-by-one
)
3464 (flet ((test (lambda-form arg
&optional
(result arg
))
3465 (let* ((fun1 (checked-compile lambda-form
))
3466 (fun2 (funcall (checked-compile
3468 (declare (optimize (sb-c::float-accuracy
0)))
3470 (disassembly1 (with-output-to-string (s)
3471 (disassemble fun1
:stream s
)))
3472 (disassembly2 (with-output-to-string (s)
3473 (disassemble fun2
:stream s
))))
3474 ;; Multiplication at runtime should be eliminated only with
3475 ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
3477 (assert (and (search "MUL" disassembly1
)
3478 (not (search "MUL" disassembly2
))))
3479 ;; Not generic arithmetic, please!
3480 (assert (and (not (search "GENERIC" disassembly1
))
3481 (not (search "GENERIC" disassembly2
))))
3482 (assert (eql result
(funcall fun1 arg
)))
3483 (assert (eql result
(funcall fun2 arg
))))))
3484 (dolist (type '(single-float double-float
))
3485 (let* ((one (coerce 1 type
))
3486 (arg (random (* 2 one
)))
3488 (test `(lambda (x) (declare (,type x
)) (* x
1)) arg
)
3489 (test `(lambda (x) (declare (,type x
)) (* x -
1)) arg -r
)
3490 (test `(lambda (x) (declare (,type x
)) (* x
,one
)) arg
)
3491 (test `(lambda (x) (declare (,type x
)) (* x
,(- one
))) arg -r
)))))
3493 (with-test (:name
:float-addition-of-zero
)
3494 (flet ((test (lambda-form arg
&optional
(result arg
))
3495 (let* ((fun1 (checked-compile lambda-form
))
3496 (fun2 (funcall (checked-compile
3498 (declare (optimize (sb-c::float-accuracy
0)))
3500 (disassembly1 (with-output-to-string (s)
3501 (disassemble fun1
:stream s
)))
3502 (disassembly2 (with-output-to-string (s)
3503 (disassemble fun2
:stream s
))))
3504 ;; Let's make sure there is no addition at runtime: for x86 and
3505 ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
3506 ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
3507 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3508 ;; addition in to catch SNaNs.
3510 (assert (and (search "FADD" disassembly1
)
3511 (not (search "FADD" disassembly2
))))
3513 (let ((inst (if (typep result
'double-float
)
3515 (assert (and (search inst disassembly1
)
3516 (not (search inst disassembly2
)))))
3517 (assert (eql result
(funcall fun1 arg
)))
3518 (assert (eql result
(funcall fun2 arg
))))))
3519 (test `(lambda (x) (declare (single-float x
)) (+ x
0)) 123.45)
3520 (test `(lambda (x) (declare (single-float x
)) (+ x
0.0)) 543.21)
3521 (test `(lambda (x) (declare (single-float x
)) (+ x
0.0d0
)) 42.00 42.d0
)
3522 (test `(lambda (x) (declare (double-float x
)) (+ x
0)) 123.45d0
)
3523 (test `(lambda (x) (declare (double-float x
)) (+ x
0.0)) 543.21d0
)
3524 (test `(lambda (x) (declare (double-float x
)) (+ x
0.0d0
)) 42.d0
)))
3526 (with-test (:name
:float-substraction-of-zero
)
3527 (flet ((test (lambda-form arg
&optional
(result arg
))
3528 (let* ((fun1 (checked-compile lambda-form
))
3529 (fun2 (funcall (checked-compile
3531 (declare (optimize (sb-c::float-accuracy
0)))
3533 (disassembly1 (with-output-to-string (s)
3534 (disassemble fun1
:stream s
)))
3535 (disassembly2 (with-output-to-string (s)
3536 (disassemble fun2
:stream s
))))
3537 ;; Let's make sure there is no substraction at runtime: for x86
3538 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
3539 ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
3540 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3541 ;; substraction in in to catch SNaNs.
3543 (assert (and (search "FSUB" disassembly1
)
3544 (not (search "FSUB" disassembly2
))))
3546 (let ((inst (if (typep result
'double-float
)
3548 (assert (and (search inst disassembly1
)
3549 (not (search inst disassembly2
)))))
3550 (assert (eql result
(funcall fun1 arg
)))
3551 (assert (eql result
(funcall fun2 arg
))))))
3552 (test `(lambda (x) (declare (single-float x
)) (- x
0)) 123.45)
3553 (test `(lambda (x) (declare (single-float x
)) (- x
0.0)) 543.21)
3554 (test `(lambda (x) (declare (single-float x
)) (- x
0.0d0
)) 42.00 42.d0
)
3555 (test `(lambda (x) (declare (double-float x
)) (- x
0)) 123.45d0
)
3556 (test `(lambda (x) (declare (double-float x
)) (- x
0.0)) 543.21d0
)
3557 (test `(lambda (x) (declare (double-float x
)) (- x
0.0d0
)) 42.d0
)))
3559 (with-test (:name
:float-multiplication-by-two
)
3560 (flet ((test (lambda-form arg
&optional
(result arg
))
3561 (let* ((fun1 (checked-compile lambda-form
))
3562 (fun2 (funcall (checked-compile
3564 (declare (optimize (sb-c::float-accuracy
0)))
3566 (disassembly1 (with-output-to-string (s)
3567 (disassemble fun1
:stream s
)))
3568 (disassembly2 (with-output-to-string (s)
3569 (disassemble fun2
:stream s
))))
3570 ;; Let's make sure there is no multiplication at runtime: for x86
3571 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
3572 ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
3575 (assert (and (not (search "MUL" disassembly1
))
3576 (not (search "MUL" disassembly2
))))
3577 (assert (eql result
(funcall fun1 arg
)))
3578 (assert (eql result
(funcall fun2 arg
))))))
3579 (test `(lambda (x) (declare (single-float x
)) (* x
2)) 123.45 246.9)
3580 (test `(lambda (x) (declare (single-float x
)) (* x
2.0)) 543.21 1086.42)
3581 (test `(lambda (x) (declare (single-float x
)) (* x
2.0d0
)) 42.00 84.d0
)
3582 (test `(lambda (x) (declare (double-float x
)) (* x
2)) 123.45d0
246.9d0
)
3583 (test `(lambda (x) (declare (double-float x
)) (* x
2.0)) 543.21d0
1086.42d0
)
3584 (test `(lambda (x) (declare (double-float x
)) (* x
2.0d0
)) 42.0d0
84.0d0
)))
3586 (with-test (:name
:bug-392203
)
3587 ;; Used to hit an AVER in COMVERT-MV-CALL.
3588 (assert (zerop (funcall
3591 (flet ((k (&rest x
) (declare (ignore x
)) 0))
3592 (multiple-value-call #'k
#'k
))))))))
3594 (with-test (:name
:allocate-closures-failing-aver
)
3595 (let ((f (checked-compile `(lambda ()
3596 (labels ((k (&optional x
) #'k
))))
3597 :allow-style-warnings t
)))
3598 (assert (null (funcall f
)))))
3600 (with-test (:name
:flush-vector-creation
:skipped-on
:interpreter
)
3601 (let ((f (checked-compile `(lambda ()
3605 (ctu:assert-no-consing
(funcall f
))))
3607 (with-test (:name
:array-type-predicates
)
3608 (dolist (et (list* '(integer -
1 200) '(integer -
256 1)
3611 '(double-float 0d0
(1d0))
3612 '(single-float (0s0) (1s0))
3613 '(or (eql 1d0
) (eql 10d0
))
3615 '(complex (member 10 20))
3616 '(complex (member 10d0
20d0
))
3617 '(complex (member 10s0
20s0
))
3618 '(or integer double-float
)
3622 #+sb-unicode
'extended-char
3623 #+sb-unicode
'(eql #\cyrillic_small_letter_yu
)
3624 sb-kernel
::*specialized-array-element-types
*))
3626 (let* ((v (make-array 3 :element-type et
))
3627 (fun (checked-compile
3629 (list (if (typep ,v
'(simple-array ,et
(*)))
3632 (if (typep (elt ,v
0) '(simple-array ,et
(*)))
3635 (assert (equal '(:good
:good
) (funcall fun
)))))))
3637 (with-test (:name
:truncate-float
)
3638 (let ((s (checked-compile `(lambda (x)
3639 (declare (single-float x
))
3641 (d (checked-compile `(lambda (x)
3642 (declare (double-float x
))
3644 (s-inlined (checked-compile
3646 (declare (type (single-float 0.0s0
1.0s0
) x
))
3648 (d-inlined (checked-compile
3650 (declare (type (double-float 0.0d0
1.0d0
) x
))
3652 ;; Check that there is no generic arithmetic
3653 (assert (not (search "GENERIC"
3654 (with-output-to-string (out)
3655 (disassemble s
:stream out
)))))
3656 (assert (not (search "GENERIC"
3657 (with-output-to-string (out)
3658 (disassemble d
:stream out
)))))
3659 ;; Check that we actually inlined the call when we were supposed to.
3660 (assert (not (search "UNARY-TRUNCATE"
3661 (with-output-to-string (out)
3662 (disassemble s-inlined
:stream out
)))))
3663 (assert (not (search "UNARY-TRUNCATE"
3664 (with-output-to-string (out)
3665 (disassemble d-inlined
:stream out
)))))))
3667 (with-test (:name
(make-array :unnamed-dimension-leaf
))
3668 (let ((fun (checked-compile `(lambda (stuff)
3669 (make-array (map 'list
'length stuff
))))))
3670 (assert (equalp #2A
((0 0 0) (0 0 0))
3671 (funcall fun
'((1 2) (1 2 3)))))))
3673 (with-test (:name
:fp-decoding-funs-not-flushable-in-safe-code
)
3674 (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3675 integer-decode-float
))
3676 (let ((fun (checked-compile `(lambda (x)
3677 (declare (optimize safety
))
3685 (error "(~S ~S) did not error"
3691 (when (member name
'(decode-float integer-decode-float
))
3692 (test sb-ext
:single-float-positive-infinity
))))))
3694 (with-test (:name
:sap-ref-16
)
3695 (let* ((fun (checked-compile
3697 (declare (type sb-sys
:system-area-pointer x
)
3698 (type (integer 0 100) y
))
3699 (sb-sys:sap-ref-16 x
(+ 4 y
)))))
3700 (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3701 '(simple-array (unsigned-byte 8) (*))))
3702 (sap (sb-sys:vector-sap vector
))
3703 (ret (funcall fun sap
0)))
3704 ;; test for either endianness
3705 (assert (or (= ret
(+ (* 5 256) 4)) (= ret
(+ (* 4 256) 5))))))
3707 (with-test (:name
(compile coerce
:type-warning
))
3708 (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3709 (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3710 (let ((fun (checked-compile `(lambda (x)
3711 (declare (type simple-vector x
))
3712 (coerce x
'(vector ,type
))))))
3713 (assert (typep (funcall fun
#(1)) `(simple-array ,type
(*)))))))
3715 (with-test (:name
(compile truncate double-float
))
3716 (let ((fun (checked-compile `(lambda (x)
3717 (multiple-value-bind (q r
)
3718 (truncate (coerce x
'double-float
))
3719 (declare (type unsigned-byte q
)
3720 (type double-float r
))
3722 (assert (equal (funcall fun
1.0d0
) '(1 0.0d0
)))))
3724 (with-test (:name
:set-slot-value-no-warning
)
3725 (let ((notes (nth-value
3726 4 (checked-compile `(lambda (x y
)
3727 (declare (optimize speed safety
))
3728 (setf (slot-value x
'bar
) y
))))))
3729 (assert (= 1 (length notes
)))))
3731 (with-test (:name
(concatenate :string-opt
))
3732 (flet ((test (type grep
)
3733 (let* ((fun (checked-compile `(lambda (a b c d e
)
3734 (concatenate ',type a b c d e
))))
3735 (args '("foo" #(#\.
) "bar" (#\-
) "quux"))
3736 (res (apply fun args
)))
3737 (assert (search grep
(with-output-to-string (out)
3738 (disassemble fun
:stream out
))))
3739 (assert (equal (apply #'concatenate type args
)
3741 (assert (typep res type
)))))
3743 (test 'string
"%CONCATENATE-TO-STRING")
3745 (test 'simple-string
"%CONCATENATE-TO-STRING")
3746 (test 'base-string
"%CONCATENATE-TO-BASE-STRING")
3747 (test 'simple-base-string
"%CONCATENATE-TO-BASE-STRING")))
3749 (with-test (:name
(satisfies :no-local-fun
))
3750 (let ((fun (checked-compile
3752 (labels ((local-not-global-bug (x)
3755 (typep x
'(satisfies local-not-global-bug
))))
3757 (assert (eq 'local-not-global-bug
3760 (undefined-function (c)
3761 (cell-error-name c
)))))))
3763 ;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
3764 ;;; argument that is a complex structure (needing make-load-form
3765 ;;; processing) failed an AVER. The first attempt at a fix caused
3766 ;;; doing the same in-core to break.
3767 (with-test (:name
:bug-310132
)
3768 (checked-compile `(lambda (&optional
(foo #p
"foo/bar")))
3769 :allow-style-warnings t
))
3771 (with-test (:name
:bug-309129
)
3772 (multiple-value-bind (fun failurep warnings
)
3773 (checked-compile `(lambda (v) (values (svref v
0) (vector-pop v
)))
3774 :allow-failure t
:allow-warnings t
)
3776 (assert (= 1 (length warnings
)))
3777 (handler-case (funcall fun
#(1))
3779 ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
3780 ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
3781 (assert (not (typep (type-error-datum c
) (type-error-expected-type c
)))))
3782 (:no-error
(&rest values
)
3783 (declare (ignore values
))
3784 (error "no error")))))
3786 (with-test (:name
(round :unary
:type-derivation
))
3787 (let ((fun (checked-compile
3789 (multiple-value-bind (h m
) (truncate (abs zone
) 1.0)
3790 (declare (ignore h
))
3791 (round (* 60.0 m
)))))))
3792 (assert (= (funcall fun
0.5) 30))))
3794 (with-test (:name
:bug-525949
)
3795 (let ((fun (checked-compile
3797 (labels ((always-one () 1)
3799 (let ((n (funcall z
)))
3800 (declare (fixnum n
))
3801 (the double-float
(expt n
1.0d0
)))))
3802 (f #'always-one
))))))
3803 (assert (= 1.0d0
(funcall fun
)))))
3805 (with-test (:name
:%array-data-type-derivation
)
3806 (let* ((f (checked-compile
3808 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary
))
3809 (setf (aref ary
0 0) 0))))
3810 (text (with-output-to-string (s)
3811 (disassemble f
:stream s
))))
3812 (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text
)))))
3814 (with-test (:name
:array-storage-vector-type-derivation
)
3815 (let ((f (checked-compile
3817 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary
))
3818 (ctu:compiler-derived-type
(array-storage-vector ary
))))))
3819 (assert (equal '(simple-array (unsigned-byte 32) (9))
3820 (funcall f
(make-array '(3 3) :element-type
'(unsigned-byte 32)))))))
3822 (with-test (:name
:bug-523612
)
3823 (let ((fun (checked-compile
3824 `(lambda (&key toff
)
3825 (make-array 3 :element-type
'double-float
3827 (if toff
(list toff
0d0
0d0
) (list 0d0
0d0
0d0
)))))))
3828 (assert (equalp (vector 0.0d0
0.0d0
0.0d0
) (funcall fun
:toff nil
)))
3829 (assert (equalp (vector 2.3d0
0.0d0
0.0d0
) (funcall fun
:toff
2.3d0
)))))
3831 (with-test (:name
:bug-309788
)
3832 (let ((fun (checked-compile `(lambda (x)
3833 (declare (optimize speed
))
3835 (typep x
'fixnum env
))))))
3836 (assert (not (ctu:find-named-callees fun
)))))
3838 (with-test (:name
:bug-309124
)
3839 (let ((fun (checked-compile `(lambda (x)
3840 (declare (integer x
))
3841 (declare (optimize speed
))
3842 (cond ((typep x
'fixnum
)
3850 (assert (equal (list "hala" "hip")
3851 (sort (ctu:find-code-constants fun
:type
'string
)
3854 (with-test (:name
:bug-316078
)
3855 (let ((fun (checked-compile
3857 (declare (type (and simple-bit-vector
(satisfies bar
)) x
)
3860 (assert (not (ctu:find-named-callees fun
)))
3861 (assert (= 1 (funcall fun
#*000001)))
3862 (assert (= 0 (funcall fun
#*000010)))))
3864 (with-test (:name
:mult-by-one-in-float-acc-zero
)
3865 (assert (eql 1.0 (funcall (checked-compile
3867 (declare (optimize (sb-c::float-accuracy
0)))
3870 (assert (eql -
1.0 (funcall (checked-compile
3872 (declare (optimize (sb-c::float-accuracy
0)))
3875 (assert (eql 1.0d0
(funcall (checked-compile
3877 (declare (optimize (sb-c::float-accuracy
0)))
3880 (assert (eql -
1.0d0
(funcall (checked-compile
3882 (declare (optimize (sb-c::float-accuracy
0)))
3886 (with-test (:name
:dotimes-non-integer-counter-value
)
3887 (multiple-value-bind (fun failure-p warnings
)
3888 (checked-compile `(lambda () (dotimes (i 8.6)))
3889 :allow-warnings
'sb-int
:type-warning
)
3890 (declare (ignore failure-p
))
3892 (assert-error (funcall fun
) type-error
)))
3894 (with-test (:name
:bug-454681
)
3895 ;; This used to break due to reference to a dead lambda-var during
3896 ;; inline expansion.
3897 (assert (checked-compile
3899 (multiple-value-bind (iterator+977 getter
+978)
3900 (does-not-exist-but-does-not-matter)
3901 (flet ((iterator+976 ()
3902 (funcall iterator
+977)))
3903 (declare (inline iterator
+976))
3904 (let ((iterator+976 #'iterator
+976))
3905 (funcall iterator
+976)))))
3906 :allow-style-warnings t
)))
3908 (with-test (:name
:complex-float-local-fun-args
)
3909 ;; As of 1.0.27.14, the lambda below failed to compile due to the
3910 ;; compiler attempting to pass unboxed complex floats to Z and the
3911 ;; MOVE-ARG method not expecting the register being used as a
3912 ;; temporary frame pointer. Reported by sykopomp in #lispgames,
3913 ;; reduced test case provided by _3b`.
3914 (checked-compile `(lambda (a)
3916 (declare ((complex double-float
) b c
))
3918 (loop for i below
10 do
3919 (setf a
(z a a
)))))))
3921 (with-test (:name
(compile :bug-309130
))
3923 (let ((warnings (nth-value
3924 2 (checked-compile form
:allow-warnings t
))))
3925 (assert (= 1 (length warnings
))))))
3926 (test `(lambda () (svref (make-array 8 :adjustable t
) 1)))
3928 (declare (optimize (debug 0)))
3929 (declare (type vector x
))
3930 (list (fill-pointer x
) (svref x
1))))
3932 (list (vector-push (svref x
0) x
))))
3934 (list (vector-push-extend (svref x
0) x
))))))
3936 (with-test (:name
(compile :bug-646796
))
3937 (assert (= 42 (funcall (checked-compile
3939 (load-time-value (the (values fixnum
) 42))))))))
3941 (with-test (:name
(compile :bug-654289
))
3942 ;; Test that compile-times don't explode when quoted constants
3944 (labels ((time-n (n)
3945 (gc :full t
) ; Let's not confuse the issue with GC
3946 (let* ((tree (make-tree (expt 10 n
) nil
))
3947 (t0 (get-internal-run-time))
3948 (f (checked-compile `(lambda (x) (eq x
(quote ,tree
)))))
3949 (t1 (get-internal-run-time)))
3950 (assert (funcall f tree
))
3953 (cond ((zerop n
) acc
)
3954 (t (make-tree (1- n
) (cons acc acc
))))))
3955 (let* ((times (loop for i from
0 upto
4
3956 collect
(time-n i
)))
3957 (max-small (reduce #'max times
:end
3))
3958 (max-big (reduce #'max times
:start
3)))
3959 ;; This way is hopefully fairly CPU-performance insensitive.
3960 (unless (> (+ (truncate internal-time-units-per-second
10)
3963 (error "Bad scaling or test? ~S" times
)))))
3965 (with-test (:name
(compile :bug-309063
))
3966 (let ((fun (checked-compile `(lambda (x)
3967 (declare (type (integer 0 0) x
))
3969 (assert (zerop (funcall fun
0)))))
3971 (with-test (:name
(compile :bug-655872
))
3972 (let ((f (checked-compile
3974 (declare (optimize (safety 3)))
3975 (aref (locally (declare (optimize (safety 0)))
3976 (coerce x
'(simple-vector 128)))
3978 (long (make-array 100 :element-type
'fixnum
)))
3980 (setf (aref long i
) i
))
3981 ;; 1. COERCE doesn't check the length in unsafe code.
3982 (assert (eql 60 (funcall f long
)))
3983 ;; 2. The compiler doesn't trust the length from COERCE
3986 (funcall f
(list 1 2 3))
3987 (sb-int:invalid-array-index-error
(e)
3988 (assert (eql 60 (type-error-datum e
)))
3989 (assert (equal '(integer 0 (3)) (type-error-expected-type e
)))
3992 (with-test (:name
(compile :bug-655203-regression
))
3993 (let ((fun (checked-compile
3997 (&OPTIONAL DUMMY
&REST OTHER
)
3998 (DECLARE (IGNORE OTHER
))
4001 (FUNCALL CONTINUATION
(LIST 1 2)))))))
4002 ;; This used to signal a bogus type-error.
4003 (assert (equal (with-output-to-string (*standard-output
*)
4007 (with-test (:name
:constant-concatenate-compile-time
)
4008 (flet ((make-lambda (n)
4010 (declare (optimize (speed 3) (space 0)))
4011 (concatenate 'string x
,(make-string n
)))))
4012 (let* ((l0 (make-lambda 1))
4013 (l1 (make-lambda 10))
4014 (l2 (make-lambda 100))
4015 (l3 (make-lambda 1000))
4016 (t0 (get-internal-run-time))
4017 (f0 (checked-compile l0
))
4018 (t1 (get-internal-run-time))
4019 (f1 (checked-compile l1
))
4020 (t2 (get-internal-run-time))
4021 (f2 (checked-compile l2
))
4022 (t3 (get-internal-run-time))
4023 (f3 (checked-compile l3
))
4024 (t4 (get-internal-run-time))
4029 (short-avg (/ (+ d0 d1 d2
) 3)))
4030 (assert (and f0 f1 f2 f3
))
4031 (assert (< d3
(* 10 short-avg
))))))
4033 (with-test (:name
:bug-384892
)
4035 '(function (fixnum fixnum
&key
(:k1 boolean
))
4036 (values (member t
) &optional
))
4037 (sb-kernel:%simple-fun-type
4038 (checked-compile `(lambda (x y
&key k1
)
4039 (declare (fixnum x y
))
4040 (declare (boolean k1
))
4041 (declare (ignore x y k1
))
4044 (with-test (:name
:bug-309448
)
4045 ;; Like all tests trying to verify that something doesn't blow up
4046 ;; compile-times this is bound to be a bit brittle, but at least
4047 ;; here we try to establish a decent baseline.
4048 (labels ((time-it (lambda want
&optional times
)
4049 (gc :full t
) ; let's keep GCs coming from other code out...
4050 (let* ((start (get-internal-run-time))
4054 for result
= (checked-compile lambda
)
4055 finally
(return result
))
4056 (loop for result
= (checked-compile lambda
)
4057 do
(incf iterations
)
4058 until
(> (get-internal-run-time) (+ start
10))
4059 finally
(return result
))))
4060 (end (get-internal-run-time))
4061 (got (funcall fun
)))
4062 (unless (eql want got
)
4063 (error "wanted ~S, got ~S" want got
))
4064 (values (- end start
) iterations
)))
4065 (test-it (simple result1 complex result2
)
4066 (multiple-value-bind (time-simple iterations
)
4067 (time-it simple result1
)
4068 (assert (>= (* 10 (1+ time-simple
))
4069 (time-it complex result2 iterations
))))))
4070 ;; This is mostly identical as the next one, but doesn't create
4071 ;; hairy unions of numeric types.
4072 (test-it `(lambda ()
4073 (labels ((bar (baz bim
)
4074 (let ((n (+ baz bim
)))
4075 (* n
(+ n
1) bim
))))
4082 (labels ((bar (baz bim
)
4083 (let ((n (+ baz bim
)))
4084 (* n
(+ n
1) bim
))))
4090 (test-it `(lambda ()
4092 (let ((m (truncate 999 n
)))
4093 (/ (* n m
(1+ m
)) 2))))
4100 (let ((m (truncate 999 n
)))
4101 (/ (* n m
(1+ m
)) 2))))
4107 (with-test (:name
:regression-1.0
.44.34)
4109 `(lambda (z &rest args
)
4110 (declare (dynamic-extent args
))
4111 (flet ((foo (w v
) (list v w
)))
4115 (declare (sb-int:truly-dynamic-extent
#'foo
))
4117 :allow-style-warnings t
))
4119 (with-test (:name
:bug-713626
)
4120 (let ((f (eval '(constantly 42))))
4121 (assert (= 42 (funcall (checked-compile
4122 `(lambda () (funcall ,f
1 2 3))))))))
4124 (with-test (:name
:known-fun-allows-other-keys
)
4125 (funcall (checked-compile
4126 `(lambda () (directory "." :allow-other-keys t
))))
4127 (funcall (checked-compile
4128 `(lambda () (directory "." :bar t
:allow-other-keys t
)))))
4130 (with-test (:name
:bug-551227
)
4131 ;; This function causes constraint analysis to perform a
4132 ;; ref-substitution that alters the A referred to in (G A) at in the
4133 ;; consequent of the IF to refer to be NUMBER, from the
4134 ;; LET-converted inline-expansion of MOD. This leads to attempting
4135 ;; to CLOSE-OVER a variable that simply isn't in scope when it is
4147 :allow-style-warnings t
))
4149 (with-test (:name
:funcall-lambda-inlined
)
4151 (ctu:find-code-constants
4152 (checked-compile `(lambda (x y
)
4153 (+ x
(funcall (lambda (z) z
) y
))))
4156 (with-test (:name
:bug-720382
)
4157 (multiple-value-bind (fun failurep warnings
)
4158 (checked-compile `(lambda (b) ((lambda () b
) 1)) :allow-warnings t
)
4160 (assert (= 1 (length warnings
)))
4161 (assert-error (funcall fun
0))))
4163 (with-test (:name
:multiple-args-to-function
)
4164 (let ((form `(flet ((foo (&optional
(x 13)) x
))
4165 (funcall (function foo
42))))
4166 #+sb-eval
(*evaluator-mode
* :interpret
))
4169 (handler-case (eval form
)
4170 (error () :error
))))
4171 (multiple-value-bind (fun failure-p
)
4172 (checked-compile `(lambda () ,form
) :allow-failure t
)
4174 (assert-error (funcall fun
)))))
4176 ;;; This doesn't test LVAR-FUN-IS directly, but captures it
4177 ;;; pretty accurately anyways.
4178 (with-test (:name
:lvar-fun-is
:skipped-on
:interpreter
)
4180 (lambda (x) (member x x
:test
#'eq
))
4181 (lambda (x) (member x x
:test
'eq
))
4182 (lambda (x) (member x x
:test
#.
#'eq
))))
4183 (assert (equal (list #'sb-kernel
:%member-eq
)
4184 (ctu:find-named-callees fun
))))
4187 (declare (notinline eq
))
4188 (member x x
:test
#'eq
))
4190 (declare (notinline eq
))
4191 (member x x
:test
'eq
))
4193 (declare (notinline eq
))
4194 (member x x
:test
#.
#'eq
))))
4195 (assert (member #'sb-kernel
:%member-test
4196 (ctu:find-named-callees fun
)))))
4198 (with-test (:name
:delete-to-delq-opt
:skipped-on
:interpreter
)
4199 (dolist (fun (list (lambda (x y
)
4201 (delete x y
:test
#'eq
))
4203 (declare (fixnum x
) (list y
))
4206 (declare (symbol x
) (list y
))
4207 (delete x y
:test
#'eql
))))
4208 (assert (equal (list #'sb-int
:delq
)
4209 (ctu:find-named-callees fun
)))))
4211 (with-test (:name
(compile :bug-767959
))
4212 ;; This used to signal an error.
4213 (checked-compile `(lambda ()
4214 (declare (optimize sb-c
:store-coverage-data
))
4217 '((:ordinary . ordinary-lambda-list
))))))
4219 ;; This test failed formerly because the source transform of TYPEP would be
4220 ;; disabled when storing coverage data, thus giving no semantics to
4221 ;; expressions such as (TYPEP x 'INTEGER). The compiler could therefore not
4222 ;; prove that the else clause of the IF is unreachable - which it must be
4223 ;; since X is asserted to be fixnum. The conflicting requirement on X
4224 ;; that it be acceptable to LENGTH signaled a full warning.
4225 ;; Nobody on sbcl-devel could remember why the source transform was disabled,
4226 ;; but nobody disagreed with undoing the disabling.
4227 (with-test (:name
(compile :sb-cover-and-typep
))
4228 (multiple-value-bind (fun failure-p warnings
)
4231 (declare (fixnum x
) (optimize sb-c
:store-coverage-data
))
4232 (if (typep x
'integer
) x
(length x
)))
4234 (declare (ignore fun failure-p
))
4235 (assert (not warnings
))))
4237 (with-test (:name
(compile :member
:on-long-constant-list
))
4238 ;; This used to blow stack with a sufficiently long list.
4239 (let ((cycle (list t
)))
4241 (checked-compile `(lambda (x)
4242 (member x
',cycle
)))))
4244 (with-test (:name
(compile :bug-722734
))
4246 (funcall (checked-compile
4249 (list unbound-variable-1 unbound-variable-2
)))
4250 :allow-warnings t
))))
4252 (with-test (:name
(compile :bug-771673
))
4253 (assert (equal `(the foo bar
) (macroexpand `(truly-the foo bar
))))
4254 ;; Make sure the compiler doesn't use THE, and check that setf-expansions
4256 (let ((f (checked-compile `(lambda (x y
)
4257 (setf (truly-the fixnum
(car x
)) y
)))))
4258 (let* ((cell (cons t t
)))
4259 (funcall f cell
:ok
)
4260 (assert (equal '(:ok . t
) cell
)))))
4262 (with-test (:name
(compile :bug-793771
+))
4263 (let ((f (checked-compile `(lambda (x y
)
4264 (declare (type (single-float 2.0) x
)
4265 (type (single-float (0.0
)) y
))
4267 (assert (equal `(function ((single-float 2.0) (single-float (0.0
)))
4268 (values (single-float 2.0) &optional
))
4269 (sb-kernel:%simple-fun-type f
)))))
4271 (with-test (:name
(compile :bug-793771 -
))
4272 (let ((f (checked-compile `(lambda (x y
)
4273 (declare (type (single-float * 2.0) x
)
4274 (type (single-float (0.0
)) y
))
4276 (assert (equal `(function ((single-float * 2.0) (single-float (0.0
)))
4277 (values (single-float * 2.0) &optional
))
4278 (sb-kernel:%simple-fun-type f
)))))
4280 (with-test (:name
(:bug-793771
*))
4281 (let ((f (checked-compile
4283 (declare (type (single-float (0.0
)) x
))
4285 (assert (equal `(function ((single-float (0.0
)))
4286 (values (single-float 0.0) &optional
))
4287 (sb-kernel:%simple-fun-type f
)))))
4289 (with-test (:name
(:bug-793771
/))
4290 (let ((f (checked-compile
4292 (declare (type (single-float (0.0
)) x
))
4294 (assert (equal `(function ((single-float (0.0
)))
4295 (values (single-float 0.0) &optional
))
4296 (sb-kernel:%simple-fun-type f
)))))
4298 (with-test (:name
(compile :bug-486812 single-float
))
4299 (checked-compile `(lambda ()
4300 (sb-kernel:make-single-float -
1))))
4302 (with-test (:name
(compile :bug-486812 double-float
))
4303 (checked-compile `(lambda ()
4304 (sb-kernel:make-double-float -
1 0))))
4306 (with-test (:name
(compile :bug-729765
))
4307 (checked-compile `(lambda (a b
)
4308 (declare ((integer 1 1) a
)
4311 (lambda () (< b a
)))))
4313 ;; Actually tests the assembly of RIP-relative operands to comparison
4314 ;; functions (one of the few x86 instructions that have extra bytes
4315 ;; *after* the mem operand's effective address, resulting in a wrong
4317 (with-test (:name
(compile :cmpps
))
4318 (let ((foo (checked-compile
4320 (= #C
(2.0
3.0) (the (complex single-float
) x
))))))
4321 (assert (funcall foo
#C
(2.0
3.0)))
4322 (assert (not (funcall foo
#C
(1.0
2.0))))))
4324 (with-test (:name
(compile :cmppd
))
4325 (let ((foo (checked-compile
4327 (= #C
(2d0 3d0
) (the (complex double-float
) x
))))))
4328 (assert (funcall foo
#C
(2d0 3d0
)))
4329 (assert (not (funcall foo
#C
(1d0 2d0
))))))
4331 (with-test (:name
(compile :lvar-externally-checkable-type-nil
))
4332 ;; Used to signal a BUG during compilation.
4333 (let ((fun (checked-compile `(lambda (a) (parse-integer "12321321" (the (member :start
) a
) 1)))))
4334 (multiple-value-bind (i p
) (funcall fun
:start
)
4335 (assert (= 2321321 i
))
4337 (assert-error (funcall fun
:end
) type-error
)))
4339 (with-test (:name
(compile simple-type-error
:in-bound-propagation-a
))
4340 (checked-compile `(lambda (i)
4341 (declare (unsigned-byte i
))
4342 (expt 10 (expt 7 (- 2 i
))))))
4344 (with-test (:name
(compile simple-type-error
:in-bound-propagation-b
))
4345 (assert (equal `(FUNCTION (UNSIGNED-BYTE)
4346 (VALUES (SINGLE-FLOAT -
1F0
1F0
) &OPTIONAL
))
4347 (sb-kernel:%simple-fun-type
4348 (checked-compile `(lambda (i)
4349 (declare (unsigned-byte i
))
4350 (cos (expt 10 (+ 4096 i
)))))))))
4352 (with-test (:name
(compile :fixed-%more-arg-values
))
4353 (let ((fun (checked-compile `(lambda (&rest rest
)
4354 (declare (optimize (safety 0)))
4355 (apply #'cons rest
)))))
4356 (assert (equal '(car . cdr
) (funcall fun
'car
'cdr
)))))
4358 (with-test (:name
(compile :bug-826970
))
4359 (let ((fun (checked-compile `(lambda (a b c
)
4360 (declare (type (member -
2 1) b
))
4361 (array-in-bounds-p a
4 b c
)))))
4362 (assert (funcall fun
(make-array '(5 2 2)) 1 1))))
4364 (with-test (:name
(compile :bug-826971
))
4366 (fun (checked-compile `(lambda (p1 p2
)
4367 (schar (the (eql ,foo
) p1
) p2
)))))
4368 (assert (eql #\f (funcall fun foo
0)))))
4370 (with-test (:name
(compile :bug-738464
))
4371 (multiple-value-bind (fun failure-p warnings style-warnings
)
4372 (checked-compile `(lambda ()
4374 (declare (ftype non-function-type foo
))
4376 :allow-style-warnings t
)
4377 (declare (ignore failure-p warnings
))
4378 (assert style-warnings
)
4379 (assert (eql 42 (funcall fun
)))))
4381 (with-test (:name
(compile :bug-832005
))
4382 (let ((fun (checked-compile
4384 (declare (type (complex single-float
) x
))
4385 (+ #C
(0.0
1.0) x
)))))
4386 (assert (= (funcall fun
#C
(1.0
2.0))
4389 ;; A refactoring 1.0.12.18 caused lossy computation of primitive
4390 ;; types for member types.
4391 (with-test (:name
(compile member type
:primitive-type
))
4392 (let ((fun (checked-compile `(lambda (p1 p2 p3
)
4394 (the (member #c
(1.2d0
1d0
)) p2
)
4395 (the (eql #c
(1.0
1.0)) p3
))))))
4396 (assert (eql (funcall fun
1 #c
(1.2d0
1d0
) #c
(1.0
1.0))
4399 ;; Fall-through jump elimination made control flow fall through to trampolines.
4400 ;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
4401 ;; reproduced below (triggered a corruption warning and a memory fault).
4402 (with-test (:name
(compile :bug-883500
))
4403 (funcall (checked-compile `(lambda (a)
4404 (declare (type (integer -
50 50) a
))
4405 (declare (optimize (speed 0)))
4406 (mod (mod a
(min -
5 a
)) 5)))
4409 ;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
4411 (with-test (:name
(compile :bug-883519
))
4412 (checked-compile `(lambda (x)
4413 (declare (type character x
))
4414 (eql x
#\U0010FFFF
))))
4416 ;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
4417 (with-test (:name
(compile :bug-887220
))
4418 (let ((incfer (checked-compile
4419 `(lambda (vector index
)
4420 (declare (type (simple-array sb-ext
:word
(4))
4422 (type (mod 4) index
))
4423 (sb-ext:atomic-incf
(aref vector index
) 1)
4425 (assert (equalp (funcall incfer
4426 (make-array 4 :element-type
'sb-ext
:word
4431 (with-test (:name
(compile catch
:interferes-with-debug-names
))
4437 (throw 'out
(lambda () t
))))
4439 (assert (equal '(lambda () :in foo
) (sb-kernel:%fun-name fun
)))))
4441 (with-test (:name
(compile :interval-div-signed-zero
))
4442 (let ((fun (checked-compile
4444 (declare (type (member 0 -
272413371076) a
))
4445 (ffloor (the number a
) -
63243.127451934015d0
)))))
4446 (multiple-value-bind (q r
) (funcall fun
0)
4447 (assert (eql -
0d0 q
))
4448 (assert (eql 0d0 r
)))))
4450 (with-test (:name
(compile :non-constant-keyword-typecheck
))
4451 (let ((fun (checked-compile
4453 (declare (type keyword p3
))
4454 (tree-equal p1
(cons 1 2) (the (member :test
) p3
) p4
)))))
4455 (assert (funcall fun
(cons 1.0 2.0) :test
'=))))
4457 (with-test (:name
(compile truncate
:wild-values
))
4458 (multiple-value-bind (q r
)
4460 (let ((sb-c::*check-consistency
* t
))
4463 (declare (type (member 1d0
2d0
) a
))
4464 (block return-value-tag
4467 (catch 'debug-catch-tag
4468 (return-from return-value-tag
4469 (progn (truncate a
))))))))))
4472 (assert (eql 0d0 r
))))
4474 (with-test (:name
(compile :boxed-fp-constant-for-full-call
))
4475 (let ((fun (checked-compile
4477 (declare (double-float x
))
4478 (unknown-fun 1.0d0
(+ 1.0d0 x
)))
4479 :allow-style-warnings t
)))
4480 (assert (equal '(1.0d0
) (ctu:find-code-constants fun
:type
'double-float
)))))
4482 (with-test (:name
(compile :only-one-boxed-constant-for-multiple-uses
))
4483 (let* ((big (1+ most-positive-fixnum
))
4484 (fun (checked-compile
4486 (unknown-fun ,big
(+ ,big x
)))
4487 :allow-style-warnings t
)))
4488 (assert (= 1 (length (ctu:find-code-constants fun
:type
`(eql ,big
)))))))
4490 (with-test (:name
(compile fixnum
+ float
:coerces fixnum
)
4492 (let ((fun (checked-compile
4497 (assert (not (ctu:find-named-callees fun
)))
4498 (assert (not (search "GENERIC"
4499 (with-output-to-string (s)
4500 (disassemble fun
:stream s
)))))))
4502 (with-test (:name
(compile :bug-803508
))
4503 (checked-compile `(lambda ()
4506 (declare (dynamic-extent bar
))
4508 :allow-style-warnings t
))
4510 (with-test (:name
(compile :bug-803508-b
))
4511 (checked-compile `(lambda ()
4514 (declare (dynamic-extent bar
))
4516 :allow-style-warnings t
))
4518 (with-test (:name
(compile :bug-803508-c
))
4519 (checked-compile `(lambda ()
4521 (lambda (bar &optional quux
)
4522 (declare (dynamic-extent bar quux
))
4524 :allow-style-warnings t
))
4526 (with-test (:name
(compile :cprop-with-constant-but-assigned-to-closure-variable
))
4527 (checked-compile `(lambda (b c d
)
4528 (declare (type (integer -
20545789 207590862) c
))
4529 (declare (type (integer -
1 -
1) d
))
4530 (let ((i (unwind-protect 32 (shiftf d -
1))))
4531 (or (if (= d c
) 2 (= 3 b
)) 4)))
4532 :allow-style-warnings t
))
4534 (with-test (:name
(compile :bug-913232
)
4535 :fails-on
:interpreter
) ; no idea why it fails randomly
4536 (checked-compile `(lambda (x)
4537 (declare (optimize speed
)
4538 (type (or (and (or (integer -
100 -
50)
4541 (and (or (integer 0 10) (integer 20 30)) a
))
4544 :allow-style-warnings t
)
4545 (checked-compile `(lambda (x)
4546 (declare (optimize speed
)
4547 (type (and fixnum a
) x
))
4549 :allow-style-warnings t
))
4551 (with-test (:name
(compile :bug-959687
))
4553 (multiple-value-bind (fun failure-p warnings style-warnings
)
4554 (checked-compile form
:allow-failure t
:allow-style-warnings t
)
4555 (declare (ignore warnings
))
4556 (assert (and failure-p style-warnings
))
4557 (assert-error(funcall fun t
)))))
4569 :somethign-else
))))))
4571 (with-test (:name
(compile :bug-924276
))
4573 3 (checked-compile `(lambda (a)
4574 (cons a
(symbol-macrolet ((b 1))
4575 (declare (ignorable a
))
4577 :allow-style-warnings t
))))
4579 (with-test (:name
(compile :bug-974406
))
4580 (let ((fun32 (checked-compile
4582 (declare (optimize speed
(safety 0)))
4583 (declare (type (integer 53 86) x
))
4584 (logand (+ x
1032791128) 11007078467))))
4585 (fun64 (checked-compile
4587 (declare (optimize speed
(safety 0)))
4588 (declare (type (integer 53 86) x
))
4589 (logand (+ x
1152921504606846975)
4590 38046409652025950207)))))
4591 (assert (= (funcall fun32
61) 268574721))
4592 (assert (= (funcall fun64
61) 60)))
4594 (do ((width 5 (1+ width
)))
4597 (let ((fun (checked-compile
4599 (declare (optimize speed
(safety 0)))
4600 (declare (type (integer 1 16) x
))
4602 (+ x
,(1- (ash 1 width
)))
4603 ,(logior (ash 1 (+ width
1 extra
))
4604 (1- (ash 1 width
))))))))
4605 (unless (= (funcall fun
16) (logand 15 (1- (ash 1 width
))))
4606 (push (cons width extra
) result
)))))
4607 (assert (null result
))))
4609 ;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
4610 ;; uses a MOV into memory or goes through a temporary register if the
4611 ;; value is larger than a certain number of bits. Check that it respects
4612 ;; the limits of immediate arguments to the MOV instruction (if not, the
4613 ;; assembler will fail an assertion) and doesn't have sign-extension
4614 ;; problems. (The test passes fixnum constants through the MOVE VOP
4615 ;; which calls MOVE-IMMEDIATE.)
4616 (with-test (:name
(compile :constant-fixnum-move
))
4617 (let ((f (checked-compile `(lambda (g)
4619 ;; The first three args are
4620 ;; uninteresting as they are
4621 ;; passed in registers.
4623 ,@(loop for i from
27 to
32
4624 collect
(expt 2 i
)))))))
4625 (assert (every #'plusp
(funcall f
#'list
)))))
4627 (with-test (:name
(eval :malformed-ignore
:lp-1000239
)
4628 :skipped-on
:interpreter
)
4630 (eval '(lambda () (declare (ignore (function . a
)))))
4631 sb-int
:simple-program-error
)
4633 (eval '(lambda () (declare (ignore (function a b
)))))
4634 sb-int
:simple-program-error
)
4636 (eval '(lambda () (declare (ignore (function)))))
4637 sb-int
:simple-program-error
)
4639 (eval '(lambda () (declare (ignore (a)))))
4640 sb-int
:simple-program-error
)
4642 (eval '(lambda () (declare (ignorable (a b
)))))
4643 sb-int
:simple-program-error
))
4645 (with-test (:name
(compile :malformed-type-declaraions
))
4646 (checked-compile '(lambda (a) (declare (type (integer 1 2 .
3) a
)))
4649 (with-test (:name
:compiled-program-error-escaped-source
)
4652 (funcall (checked-compile `(lambda () (lambda ("foo")))
4654 (sb-int:compiled-program-error
(e)
4655 (let ((source (read-from-string (sb-kernel::program-error-source e
))))
4656 (equal source
'#'(lambda ("foo"))))))))
4658 (defun cell-note-p (condition)
4659 (search "Allocating a value-cell at runtime for"
4660 (princ-to-string condition
)))
4661 (with-test (:name
(compile :escape-analysis-for-nlxs
)
4662 :skipped-on
:interpreter
)
4663 (flet ((test (check lambda
&rest args
)
4664 (multiple-value-bind (fun failure-p warnings style-warnings notes
)
4665 (checked-compile lambda
:allow-style-warnings t
)
4666 (declare (ignore failure-p warnings style-warnings
))
4667 (assert (eql check
(when (some #'cell-note-p notes
) t
)))
4672 (dolist (arg args nil
)
4673 (setf fun
(funcall fun arg
)))
4674 (sb-int:simple-control-error
(e)
4676 (simple-condition-format-control e
)
4677 "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
4679 (ctu:assert-no-consing
(apply fun args
))))))
4680 (test nil
`(lambda (x)
4681 (declare (optimize speed
))
4683 (flet ((ex () (return-from out
'out
!)))
4685 (cons (or (car x
) (ex)))
4687 (test t
`(lambda (x)
4688 (declare (optimize speed
))
4691 (flet ((oops () (return-from nasty t
)))
4693 (test t
`(lambda (r)
4694 (declare (optimize speed
))
4696 (flet ((ex () (return-from out r
)))
4699 (cons (or (car x
) (ex)))
4701 (test t
`(lambda (x)
4702 (declare (optimize speed
))
4704 (flet ((meh () (return-from eh
'meh
)))
4707 (cons (or (car x
) (meh)))
4709 (funcall (eh x
)))) t t
)))
4711 (with-test (:name
(compile :bug-1050768
:symptom
))
4712 ;; Used to signal an error.
4714 `(lambda (string position
)
4715 (char string position
)
4716 (array-in-bounds-p string
(1+ position
)))))
4718 (with-test (:name
(:bug-1050768
:cause
))
4719 (let ((types `((string string
)
4720 ((or (simple-array character
24) (vector t
24))
4721 (or (simple-array character
24) (vector t
))))))
4722 (dolist (pair types
)
4723 (destructuring-bind (orig conservative
) pair
4724 (assert sb-c
::(type= (specifier-type cl-user
::conservative
)
4725 (conservative-type (specifier-type cl-user
::orig
))))))))
4727 (with-test (:name
(compile :smodular64
:wrong-width
))
4728 (let ((fun (checked-compile
4730 (declare (type (signed-byte 64) x
))
4731 (sb-c::mask-signed-field
64 (- x
7033717698976965573))))))
4732 (assert (= (funcall fun
10038) -
7033717698976955535))))
4734 (with-test (:name
(compile :smodular32
:wrong-width
))
4735 (let ((fun (checked-compile
4737 (declare (type (signed-byte 31) x
))
4738 (sb-c::mask-signed-field
31 (- x
1055131947))))))
4739 (assert (= (funcall fun
10038) -
1055121909))))
4741 (with-test (:name
(compile :first-open-coded
))
4742 (let ((fun (checked-compile `(lambda (x) (first x
)))))
4743 (assert (not (ctu:find-named-callees fun
)))))
4745 (with-test (:name
(compile :second-open-coded
))
4746 (let ((fun (checked-compile `(lambda (x) (second x
)))))
4747 (assert (not (ctu:find-named-callees fun
)))))
4749 (with-test (:name
(compile svref
:symbol-macro
))
4750 (checked-compile `(lambda (x)
4751 (symbol-macrolet ((sv x
))
4752 (values (svref sv
0) (setf (svref sv
0) 99))))))
4754 ;; The compiler used to update the receiving LVAR's type too
4755 ;; aggressively when converting a large constant to a smaller
4756 ;; (potentially signed) one, causing other branches to be
4757 ;; inferred as dead.
4758 (with-test (:name
(compile :modular-cut-constant-to-width
))
4759 (let ((test (checked-compile
4764 ((2 2 0 -
2 -
1 2) 9223372036854775803)
4766 (assert (= (funcall test -
10470605025) 26))))
4768 (with-test (:name
(compile append
:derive-type
))
4770 '((lambda () (append 10)) (integer 10 10)
4771 (lambda () (append nil
10)) (integer 10 10)
4772 (lambda (x) (append x
10)) (or (integer 10 10) cons
)
4773 (lambda (x) (append x
(cons 1 2))) cons
4774 (lambda (x y
) (append x
(cons 1 2) y
)) cons
4775 (lambda (x y
) (nconc x
(the list y
) x
)) t
4776 (lambda (x y
) (nconc (the atom x
) y
)) t
4777 (lambda (x y
) (nconc (the (or null
(eql 10)) x
) y
)) t
4778 (lambda (x y
) (nconc (the (or cons vector
) x
) y
)) cons
4779 (lambda (x y
) (nconc (the sequence x
) y
)) t
4780 (lambda (x y
) (print (length y
)) (append x y
)) sequence
4781 (lambda (x y
) (print (length y
)) (append x y
)) sequence
4782 (lambda (x y
) (append (the (member (a) (b)) x
) y
)) cons
4783 (lambda (x y
) (append (the (member (a) (b) c
) x
) y
)) cons
4784 (lambda (x y
) (append (the (member (a) (b) nil
) x
) y
)) t
)))
4785 (loop for
(function result-type
) on test-cases by
#'cddr
4786 do
(assert (sb-kernel:type
= (sb-kernel:specifier-type
4787 (car (cdaddr (sb-kernel:%simple-fun-type
4788 (checked-compile function
)))))
4789 (sb-kernel:specifier-type result-type
))))))
4791 (with-test (:name
(compile :bug-504121
))
4792 (checked-compile `(lambda (s)
4793 (let ((p1 #'upper-case-p
))
4797 (let ((p2 #'(lambda (char) (upper-case-p char
))))
4799 :allow-warnings
'sb-int
:local-argument-mismatch
))
4801 (with-test (:name
(compile :bug-504121
:optional-missing
))
4802 (checked-compile `(lambda (s)
4803 (let ((p1 #'upper-case-p
))
4805 (lambda (g &optional x
)
4807 (let ((p2 #'(lambda (char) (upper-case-p char
))))
4809 :allow-warnings
'sb-int
:local-argument-mismatch
))
4811 (with-test (:name
(compile :bug-504121
:optional-superfluous
))
4812 (checked-compile `(lambda (s)
4813 (let ((p1 #'upper-case-p
))
4815 (lambda (g &optional x
)
4818 (let ((p2 #'(lambda (char) (upper-case-p char
))))
4820 :allow-warnings
'sb-int
:local-argument-mismatch
))
4822 (with-test (:name
(compile :bug-504121
:key-odd
))
4823 (checked-compile `(lambda (s)
4824 (let ((p1 #'upper-case-p
))
4829 (let ((p2 #'(lambda (char) (upper-case-p char
))))
4833 (with-test (:name
(compile :bug-504121
:key-unknown
))
4834 (checked-compile `(lambda (s)
4835 (let ((p1 #'upper-case-p
))
4840 (let ((p2 #'(lambda (char) (upper-case-p char
))))
4844 (with-test (:name
(compile :bug-1181684
))
4845 (checked-compile `(lambda ()
4846 (let ((hash #xD13CCD13
))
4847 (setf hash
(logand most-positive-word
4850 (with-test (:name
(compile :local-
&optional-recursive-inline
:bug-1180992
))
4851 (checked-compile `(lambda ()
4852 (labels ((called (&optional a
))
4853 (recursed (&optional b
)
4856 (declare (inline recursed called
))
4858 :allow-style-warnings t
))
4860 (with-test (:name
(compile :constant-fold-logtest
))
4861 (assert (equal (sb-kernel:%simple-fun-type
4862 (checked-compile `(lambda (x)
4863 (declare (type (mod 1024) x
)
4866 '(function ((unsigned-byte 10)) (values null
&optional
)))))
4868 ;; type mismatches on LVARs with multiple potential sources used to
4869 ;; be reported as mismatches with the value NIL. Make sure we get
4870 ;; a warning, but that it doesn't complain about a constant NIL ...
4872 (with-test (:name
(compile :multiple-use-lvar-interpreted-as-NIL
:cast
))
4873 (let ((warnings (nth-value
4874 2 (checked-compile `(lambda (x y z
)
4875 (declare (type fixnum y z
))
4876 (aref (if x y z
) 0))
4877 :allow-warnings
'sb-int
:type-warning
))))
4879 (assert (notany (lambda (condition)
4881 (simple-condition-format-control
4885 (with-test (:name
(compile :multiple-use-lvar-interpreted-as-NIL catch
))
4886 (let ((warnings (nth-value
4887 3 (checked-compile `(lambda (x y z f
)
4888 (declare (type fixnum y z
))
4889 (catch (if x y z
) (funcall f
)))
4890 :allow-style-warnings t
))))
4892 (assert (notany (lambda (condition)
4894 (simple-condition-format-arguments
4898 ;; Smoke test for rightward shifts
4899 (with-test (:name
(compile :ash
/right-signed
))
4900 (let* ((f (checked-compile `(lambda (x y
)
4901 (declare (type (mod ,(* 2 sb-vm
:n-word-bits
)) y
)
4902 (type sb-vm
:signed-word x
)
4905 (max (ash most-positive-word -
1))
4908 (assert (= (ash x
(- y
))
4911 (dotimes (y (* 2 sb-vm
:n-word-bits
))
4915 (test (+ min x
) y
))))))
4917 (with-test (:name
(compile :ash
/right-unsigned
))
4918 (let ((f (checked-compile `(lambda (x y
)
4919 (declare (type (mod ,(* 2 sb-vm
:n-word-bits
)) y
)
4923 (max most-positive-word
))
4925 (assert (= (ash x
(- y
))
4928 (dotimes (y (* 2 sb-vm
:n-word-bits
))
4930 (test (- max x
) y
))))))
4932 (with-test (:name
(compile :ash
/right-fixnum
))
4933 (let ((f (checked-compile `(lambda (x y
)
4934 (declare (type (mod ,(* 2 sb-vm
:n-word-bits
)) y
)
4939 (assert (= (ash x
(- y
))
4942 (dotimes (y (* 2 sb-vm
:n-word-bits
))
4945 (test (- most-positive-fixnum x
) y
)
4946 (test (+ most-negative-fixnum x
) y
))))))
4949 (with-test (:name
(compile :fold-index-addressing-positive-offset
))
4950 (let ((f (checked-compile `(lambda (i)
4951 (if (typep i
'(integer -
31 31))
4952 (aref #.
(make-array 63) (+ i
31))
4956 ;; 5d3a728 broke something like this in CL-PPCRE
4957 (with-test (:name
(compile :fold-index-addressing-potentially-negative-index
))
4958 (checked-compile `(lambda (index vector
)
4959 (declare (optimize speed
(safety 0))
4960 ((simple-array character
(*)) vector
)
4961 ((unsigned-byte 24) index
))
4962 (aref vector
(1+ (mod index
(1- (length vector
))))))))
4964 (with-test (:name
(compile :constant-fold-ash
/right-fixnum
))
4965 (checked-compile `(lambda (a b
)
4966 (declare (type fixnum a
)
4967 (type (integer * -
84) b
))
4970 (with-test (:name
(compile :constant-fold-ash
/right-word
))
4971 (checked-compile `(lambda (a b
)
4972 (declare (type word a
)
4973 (type (integer * -
84) b
))
4976 (with-test (:name
(compile :nconc-derive-type
))
4977 (let ((function (checked-compile `(lambda (x y
)
4978 (declare (type (or cons fixnum
) x
))
4980 (assert (equal (sb-kernel:%simple-fun-type function
)
4981 '(function ((or cons fixnum
) t
) (values cons
&optional
))))))
4983 ;; make sure that all data-vector-ref-with-offset VOPs are either
4984 ;; specialised on a 0 offset or accept signed indices
4985 (with-test (:name
:data-vector-ref-with-offset-signed-index
)
4986 (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
4990 (loop for info in
(sb-c::fun-info-templates
4991 (sb-c::fun-info-or-lose dvr
))
4992 for
(nil second-arg third-arg
) = (sb-c::vop-info-arg-types info
)
4993 unless
(or (typep second-arg
'(cons (eql :constant
)))
4994 (equal third-arg
'(:constant .
(integer 0 0)))
4996 `(:or
,(sb-c::primitive-type-or-lose
4997 'sb-vm
::positive-fixnum
)
4998 ,(sb-c::primitive-type-or-lose
5002 (with-test (:name
:data-vector-set-with-offset-signed-index
)
5003 (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
5007 (loop for info in
(sb-c::fun-info-templates
5008 (sb-c::fun-info-or-lose dvr
))
5009 for
(nil second-arg third-arg
) = (sb-c::vop-info-arg-types info
)
5010 unless
(or (typep second-arg
'(cons (eql :constant
)))
5011 (equal third-arg
'(:constant .
(integer 0 0)))
5013 `(:or
,(sb-c::primitive-type-or-lose
5014 'sb-vm
::positive-fixnum
)
5015 ,(sb-c::primitive-type-or-lose
5019 (with-test (:name
(compile :maybe-inline-ref-to-dead-lambda
))
5020 (checked-compile `(lambda (string)
5021 (declare (optimize speed
(space 0)))
5022 (cond ((every #'digit-char-p string
)
5028 ;; the x87 backend used to sometimes signal FP errors during boxing,
5029 ;; because converting between double and single float values was a
5030 ;; noop (fixed), and no doubt many remaining issues. We now store
5031 ;; the value outside pseudo-atomic, so any SIGFPE should be handled
5034 ;; When it fails, this test lands into ldb.
5035 (with-test (:name
:no-overflow-during-allocation
)
5036 (handler-case (eval '(cosh 90))
5037 (floating-point-overflow ()
5040 ;; unbounded integer types could break integer arithmetic.
5041 (with-test (:name
(compile :bug-1199127
))
5044 (declare (type (integer -
1225923945345 -
832450738898) b
))
5045 (declare (optimize (speed 3) (space 3) (safety 2)
5046 (debug 0) (compilation-speed 1)))
5047 (loop for lv1 below
3
5050 (ash b
(min 25 lv1
))
5054 ;; non-trivial modular arithmetic operations would evaluate to wider results
5055 ;; than expected, and never be cut to the right final bitwidth.
5056 (with-test (:name
(compile :bug-1199428-1
))
5057 (let ((f1 (checked-compile
5059 (declare (type (integer -
2 1217810089) a
))
5060 (declare (type (integer -
6895591104928 -
561736648588) c
))
5061 (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
5062 (compilation-speed 3)))
5065 (loop for lv2 below
1 count t
))))))
5066 (f2 (checked-compile
5068 (declare (notinline -
+ gcd logandc1
))
5069 (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
5070 (compilation-speed 3)))
5073 (loop for lv2 below
1 count t
)))))))
5076 (assert (eql (funcall f1 a c
)
5077 (funcall f2 a c
))))))
5079 (with-test (:name
(compile :bug-1199428-2
))
5080 (let ((f1 (checked-compile
5082 (declare (type (integer -
1869232508 -
6939151) a
))
5083 (declare (type (integer -
11466348357 -
2645644006) b
))
5084 (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
5085 (compilation-speed 2)))
5086 (logand (lognand a -
6) (* b -
502823994)))))
5087 (f2 (checked-compile
5089 (logand (lognand a -
6) (* b -
502823994))))))
5090 (let ((a -
1491588365)
5092 (assert (eql (funcall f1 a b
)
5093 (funcall f2 a b
))))))
5095 ;; win32 is very specific about the order in which catch blocks
5096 ;; must be allocated on the stack
5097 (with-test (:name
(compile :bug-1072739
))
5098 (let ((f (checked-compile
5102 (WITH-OUTPUT-TO-STRING (G13908)
5105 (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS
3)))
5107 (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909
) G13909
)
5108 (UNBOUND-VARIABLE NIL
5110 (WITH-OUTPUT-TO-STRING (G13914)
5111 (PRINC %A%B% G13914
)
5114 (UNBOUND-VARIABLE NIL
5116 (WITH-OUTPUT-TO-STRING (G13913)
5120 (UNBOUND-VARIABLE NIL
5122 (WITH-OUTPUT-TO-STRING (G13912)
5126 (UNBOUND-VARIABLE NIL
5128 (WITH-OUTPUT-TO-STRING (G13911)
5130 (PRINC "%b%" G13911
)
5132 (UNBOUND-VARIABLE NIL
5134 (WITH-OUTPUT-TO-STRING (G13910)
5136 (PRINC "a%b%" G13910
)
5138 (UNBOUND-VARIABLE NIL
5139 (ERROR "Interpolation error in \"%a%b%\"
5143 (assert (funcall f
))))
5145 (with-test (:name
(compile :equal-equalp-transforms
))
5147 (bit-vector #*11001100)
5148 (values `(nil 1 2 "test"
5149 ;; Floats duplicated here to ensure we get newly created instances
5150 (read-from-string "1.1") (read-from-string "1.2d0")
5151 (read-from-string "1.1") (read-from-string "1.2d0")
5152 1.1 1.2d0
'("foo" "bar" "test")
5153 #(1 2 3 4) #*101010 (make-broadcast-stream) #p
"/tmp/file"
5154 ,s
(copy-seq ,s
) ,bit-vector
(copy-seq ,bit-vector
)
5155 ,(make-hash-table) #\a #\b #\A
#\C
5156 ,(make-random-state) 1/2 2/3)))
5157 ;; Test all permutations of different types
5164 (and (eq (funcall (checked-compile
5166 (equal (the ,(type-of x
) x
)
5167 (the ,(type-of y
) y
))))
5170 (eq (funcall (checked-compile
5172 (equalp (the ,(type-of x
) x
)
5173 (the ,(type-of y
) y
))))
5177 (funcall (checked-compile
5179 (equal (the (cons (or simple-bit-vector simple-base-string
))
5181 (the (cons (or (and bit-vector
(not simple-array
))
5182 (simple-array character
(*))))
5184 (list (string 'list
))
5187 (funcall (checked-compile
5189 (equalp (the (cons (or simple-bit-vector simple-base-string
))
5191 (the (cons (or (and bit-vector
(not simple-array
))
5192 (simple-array character
(*))))
5194 (list (string 'list
))
5197 (with-test (:name
(compile restart-case optimize speed compiler-note
)
5198 ;; Cannot-DX note crashes test driver unless we have this:
5199 :skipped-on
'(not :stack-allocatable-fixed-objects
))
5200 (checked-compile '(lambda ()
5201 (declare (optimize speed
))
5202 (restart-case () (c ()))))
5203 (checked-compile '(lambda ()
5204 (declare (optimize speed
))
5206 (restart-case (setf x
(car (compute-restarts)))
5210 (with-test (:name
(compile :copy-more-arg
)
5211 :fails-on
'(not (or :x86
:x86-64
:arm
:arm64
)))
5212 ;; copy-more-arg might not copy in the right direction
5213 ;; when there are more fixed args than stack frame slots,
5214 ;; and thus end up splatting a single argument everywhere.
5215 ;; Failing platforms still start their stack frames at 8 slots, so
5216 ;; this is less likely to happen.
5219 (loop for i below n collect i
))
5220 (test-function (function skip
)
5221 ;; function should just be (subseq x skip)
5222 (loop for i from skip below
(+ skip limit
) do
5223 (let* ((values (iota i
))
5224 (f (apply function values
))
5225 (subseq (subseq values skip
)))
5226 (assert (equal f subseq
)))))
5228 (let ((gensyms (loop for i below n collect
(gensym))))
5229 (checked-compile `(lambda (,@gensyms
&rest rest
)
5230 (declare (ignore ,@gensyms
))
5233 (test-function (make-function i
) i
)))))
5235 (with-test (:name
(compile :apply-aref
))
5236 (checked-compile `(lambda (x y
) (setf (apply #'aref x y
) 21)))
5237 (checked-compile `(lambda (x y
) (setf (apply #'bit x y
) 1)))
5238 (checked-compile `(lambda (x y
) (setf (apply #'sbit x y
) 0))))
5240 (with-test (:name
(compile :warn-on-the-values-constant
))
5241 (multiple-value-bind (fun failure-p
)
5243 ;; The compiler used to elide this test without
5244 ;; noting that the type demands multiple values.
5245 '(lambda () (the (values fixnum fixnum
) 1))
5246 :allow-failure t
:allow-warnings t
)
5247 (assert (functionp fun
))
5248 (assert failure-p
)))
5250 ;; quantifiers shouldn't cons themselves.
5251 (with-test (:name
:quantifiers-no-consing
5252 :skipped-on
'(or :interpreter
5253 (not :stack-allocatable-closures
)))
5254 (let ((constantly-t (lambda (x) x t
))
5255 (constantly-nil (lambda (x) x nil
))
5256 (list (make-list 1000 :initial-element nil
))
5257 (vector (make-array 1000 :initial-element nil
)))
5258 (macrolet ((test (quantifier)
5259 (let ((function (make-symbol (format nil
"TEST-~A" quantifier
))))
5260 `(flet ((,function
(function sequence
)
5261 (,quantifier function sequence
)))
5262 (ctu:assert-no-consing
(,function constantly-t list
))
5263 (ctu:assert-no-consing
(,function constantly-nil vector
))))))
5269 (with-test (:name
:propagate-complex-type-tests
)
5270 (flet ((test (type value
)
5271 (let ((ftype (sb-kernel:%simple-fun-type
5272 (checked-compile `(lambda (x)
5273 (if (typep x
',type
)
5276 (assert (typep ftype
`(cons (eql function
))))
5277 (assert (= 3 (length ftype
)))
5278 (let* ((return (third ftype
))
5279 (rtype (second return
)))
5280 (assert (typep return
`(cons (eql values
)
5282 (cons (eql &optional
)
5284 (assert (and (subtypep rtype type
)
5285 (subtypep type rtype
)))))))
5286 (mapc (lambda (params)
5287 (apply #'test params
))
5288 `(((unsigned-byte 17) 0)
5289 ((member 1 3 5 7) 5)
5290 ((or symbol
(eql 42)) t
)))))
5292 (with-test (:name
:constant-fold-complex-type-tests
)
5293 (assert (equal (sb-kernel:%simple-fun-type
5294 (checked-compile `(lambda (x)
5295 (if (typep x
'(member 1 3))
5296 (typep x
'(member 1 3 15))
5298 `(function (t) (values (member t
) &optional
))))
5299 (assert (equal (sb-kernel:%simple-fun-type
5300 (checked-compile `(lambda (x)
5301 (declare (type (member 1 3) x
))
5302 (typep x
'(member 1 3 15)))))
5303 `(function ((or (integer 1 1) (integer 3 3)))
5304 (values (member t
) &optional
)))))
5306 (with-test (:name
:quietly-row-major-index-no-dimensions
)
5307 (checked-compile `(lambda (x) (array-row-major-index x
))))
5309 (with-test (:name
:array-rank-transform
)
5310 (checked-compile `(lambda (a) (array-rank (the an-imaginary-type a
)))
5311 :allow-style-warnings t
))
5313 (with-test (:name
(:array-rank-fold
:bug-1252108
))
5314 (let ((notes (nth-value
5319 (when (= (array-rank a
) 3)
5320 (array-dimension a
2)))))))))
5321 (assert (= 1 (length notes
)))))
5323 (assert-error (upgraded-array-element-type 'an-undefined-type
))
5325 (with-test (:name
:xchg-misencoding
)
5326 (assert (eql (funcall (checked-compile
5328 (declare (optimize (speed 3) (safety 2))
5329 (type single-float a
))
5335 (with-test (:name
:malformed-declare
)
5337 1 (checked-compile `(lambda (x)
5338 (declare (unsigned-byte (x)))
5340 :allow-failure t
))))
5342 (with-test (:name
:no-dubious-asterisk-warning
)
5345 (macrolet ((frob-some-stuff (&rest exprs
)
5349 (if (symbolp x
) (copy-symbol x
) (gensym)))
5351 `(let ,(mapcar #'list temps exprs
)
5353 (format t
"Got~@{ ~S~^ and~}~%" ,@temps
))))))
5354 (frob-some-stuff *print-base
* (car foo
))))))
5356 (with-test (:name
:interr-type-specifier-hashing
)
5362 (sb-c::type-specifier
5363 (sb-c::specifier-type
5364 `(simple-array ,(sb-vm:saetp-specifier saetp
) (*)))))
5365 sb-vm
:*specialized-array-element-type-properties
*))))
5366 (assert (sb-c::%interr-symbol-for-type-spec
`(or ,@specifiers
)))
5367 (assert (sb-c::%interr-symbol-for-type-spec
5368 `(or ,@specifiers system-area-pointer
)))))
5370 (with-test (:name
:simple-rank-1-array-
*-p-works
)
5371 (assert (funcall (checked-compile
5372 `(lambda () (typep #() '(simple-array * (*)))))))
5373 (loop for saetp across sb-vm
:*specialized-array-element-type-properties
*
5375 (dotimes (n-dimensions 3) ; test ranks 0, 1, and 2.
5376 (let ((dims (make-list n-dimensions
:initial-element
2)))
5377 (dolist (adjustable-p '(nil t
))
5378 (let ((a (make-array dims
:element-type
(sb-vm:saetp-specifier saetp
)
5379 :adjustable adjustable-p
)))
5380 (assert (eq (and (= n-dimensions
1) (not adjustable-p
))
5381 (typep a
'(simple-array * (*)))))))))))
5383 (with-test (:name
:array-subtype-tests
5384 :skipped-on
'(:not
(:or
:x86
:x86-64
)))
5385 (assert (funcall (checked-compile
5387 (typep #() '(or simple-vector simple-string
))))))
5388 (flet ((approx-lines-of-assembly-code (type-expr)
5390 (with-output-to-string (s)
5393 (declare (optimize (sb-c::verify-arg-count
0)))
5394 (typep x
',type-expr
))
5396 ;; These are fragile, but less bad than the possibility of messing up
5397 ;; any vops, especially since the generic code in 'vm-type' checks for
5398 ;; a vop by its name in a place that would otherwise be agnostic of the
5399 ;; backend were it not for my inability to test all platforms.
5400 (assert (< (approx-lines-of-assembly-code
5401 '(simple-array * (*))) 25))
5402 ;; this tested all possible widetags one at a time, e.g. in VECTOR-SAP
5403 (assert (< (approx-lines-of-assembly-code
5404 '(sb-kernel:simple-unboxed-array
(*))) 25))
5405 ;; This is actually a strange type but it's what ANSI-STREAM-READ-N-BYTES
5406 ;; declares as its buffer, which would choke in %BYTE-BLT if you gave it
5407 ;; (simple-array t (*)). But that's a different problem.
5408 (assert (< (approx-lines-of-assembly-code
5409 '(or system-area-pointer
(simple-array * (*)))) 29))
5410 ;; And this was used by %BYTE-BLT which tested widetags one-at-a-time.
5411 (assert (< (approx-lines-of-assembly-code
5412 '(or system-area-pointer
(sb-kernel:simple-unboxed-array
(*))))
5415 (with-test (:name
:local-argument-mismatch-error-string
)
5416 (multiple-value-bind (fun failurep warnings
)
5417 (checked-compile `(lambda (x)
5421 (declare (ignore failurep
))
5422 (assert (= 1 (length warnings
)))
5423 (multiple-value-bind (ok err
) (ignore-errors (funcall fun
42))
5425 (assert (search "FLET FOO" (princ-to-string err
))))))
5427 (with-test (:name
:bug-1310574-0
)
5428 (checked-compile `(lambda (a)
5430 ((or (array * (* * 3)) (array * (* * 4)))
5431 (case (array-rank a
)
5432 (2 (aref a
1 2))))))))
5434 (with-test (:name
:bug-1310574-1
)
5435 (checked-compile `(lambda (a)
5437 ((or (array * ()) (array * (1)) (array * (1 2)))
5438 (case (array-rank a
)
5439 (3 (aref a
1 2 3))))))))
5441 (with-test (:name
:bug-573747
)
5443 1 (checked-compile `(lambda (x) (progn (declare (integer x
)) (* x
6)))
5444 :allow-failure t
))))
5446 ;; Something in this function used to confuse lifetime analysis into
5447 ;; recording multiple conflicts for a single TNs in the dolist block.
5448 (with-test (:name
:bug-1327008
)
5450 `(lambda (scheduler-spec
5451 schedule-generation-method
5452 utc-earliest-time utc-latest-time
5453 utc-other-earliest-time utc-other-latest-time
5458 maximum-connection-time
5461 permitted-route-locations prohibited-route-locations
5462 preferred-connection-locations disfavored-connection-locations
5463 origins destinations
5464 permitted-carriers prohibited-carriers
5465 permitted-operating-carriers prohibited-operating-carriers
5466 start-airports end-airports
5468 specified-circuity-limit-extra-miles
5469 (preferred-carriers :unspecified
)
5471 (declare (optimize speed
))
5472 (let ((table1 (list nil
))
5474 (skip-flifo-checks (getf scheduler-spec
:skip-flifo-checks
))
5475 (construct-gaps-p (getf scheduler-spec
:construct-gaps-p
))
5476 (gap-locations (getf scheduler-spec
:gap-locations
))
5477 (result-array (make-array 100))
5482 (prev-start-airports origins
)
5483 (prev-end-airports destinations
)
5484 (prev-permitted-carriers permitted-carriers
))
5485 (flet ((run-with-hint (hint random-magic other-randomness
5488 preferred-destinations
5490 (let* ((hint-permitted-carriers (first hint
))
5491 (preferred-end-airports
5492 (ecase schedule-generation-method
5493 (:DEPARTURE preferred-destinations
)
5494 (:ARRIVAL preferred-origins
)))
5495 (revised-permitted-carriers
5496 (cond ((and hint-permitted-carriers
5497 (not (eq permitted-carriers
:ANY
)))
5498 (intersection permitted-carriers
5499 hint-permitted-carriers
))
5500 (hint-permitted-carriers)
5501 (permitted-carriers)))
5502 (revised-maximum-mileage
5503 (min (let ((maximum-mileage 0))
5504 (dolist (o start-airports
)
5505 (dolist (d end-airports
)
5506 (setf maximum-mileage
5507 (max maximum-mileage
(mileage o d
)))))
5508 (round (+ (* circuity-limit maximum-mileage
)
5509 (or specified-circuity-limit-extra-miles
5510 (hairy-calculation slice-number
)))))
5512 (when (or (not (equal start-airports prev-start-airports
))
5513 (not (equal end-airports prev-end-airports
))
5514 (and (not (equal revised-permitted-carriers
5515 prev-permitted-carriers
))))
5519 permitted-operating-carriers
5520 prohibited-operating-carriers
5521 permitted-route-locations
5522 prohibited-route-locations
5526 (setf prev-permitted-carriers revised-permitted-carriers
))
5527 (multiple-value-bind (this-number-dequeued
5530 (apply #'schedule-loop
5531 utc-earliest-time utc-other-earliest-time
5532 utc-latest-time utc-other-latest-time
5533 scheduler-spec schedule-generation-method
5535 :maximum-mileage revised-maximum-mileage
5536 :maximum-extra-legs maximum-extra-legs
5537 :maximum-connection-time maximum-connection-time
5538 :same-pass-p same-pass-p
5539 :preferred-end-airports preferred-end-airports
5540 :maximum-blah random-magic
5541 :skip-flifo-checks skip-flifo-checks
5544 :preferred-connection-locations preferred-connection-locations
5545 :disfavored-connection-locations disfavored-connection-locations
5547 (when other-randomness
5548 (loop for i fixnum from n-new to
(+ n-new
(1- this-n-new
))
5549 do
(hairy-calculation i result-array
)))
5550 (incf number-dequeued this-number-dequeued
)
5551 (incf n-new this-n-new
)
5552 (setq exit-reason
(logior exit-reason this-exit-reason
))))))
5553 (let ((n-hints-processed 0))
5554 (dolist (hint scheduler-hints
)
5555 (run-with-hint hint n-hints-processed t
0
5557 (incf n-hints-processed
)))
5558 (run-with-hint nil
42 nil maximum-extra-legs
5561 :allow-style-warnings t
))
5563 (with-test (:name
:dead-code-in-optional-dispatch
)
5564 ;; the translation of each optional entry is
5565 ;; (let ((#:g (error "nope"))) (funcall #<clambda> ...))
5566 ;; but the funcall is unreachable. Since this is an artifact of how the
5567 ;; lambda is converted, it should not generate a note as if in user code.
5569 `(lambda (a &optional
(b (error "nope")) (c (error "nope")))
5572 (with-test (:name
:nth-value-of-non-constant-N
:skipped-on
:interpreter
)
5573 (labels ((foo (n f
) (nth-value n
(funcall f
)))
5574 (bar () (values 0 1 2 3 4 5 6 7 8 9)))
5575 (assert (= (foo 5 #'bar
) 5)) ; basic correctness
5576 (assert (eq (foo 12 #'bar
) nil
))
5577 (ctu:assert-no-consing
(eql (foo 953 #'bar
) 953))))
5579 (with-test (:name
:position-derive-type-optimizer
)
5580 (assert-code-deletion-note
5581 '(lambda (x) ; the call to POSITION can't return 4
5582 (let ((i (position x
#(a b c d
) :test
'eq
)))
5583 (case i
(4 'nope
) (t 'okeydokey
))))))
5585 ;; Assert that DO-PACKED-TNS has unsurprising behavior if the body RETURNs.
5586 ;; This isn't a test in the problem domain of CL - it's of an internal macro,
5587 ;; and x86-64-specific not because of broken-ness, but because it uses
5588 ;; known random TNs to play with. Printing "skipped on" for other backends
5589 ;; would be somewhat misleading in as much as it means nothing about
5590 ;; the correctness of the test on other architectures.
5592 (with-test (:name
:do-packed-tn-iterator
)
5593 (dotimes (i (ash 1 6))
5594 (labels ((make-tns (n)
5595 (mapcar 'copy-structure
5596 (subseq `sb-vm
::(,rax-tn
,rbx-tn
,rcx-tn
) 0 n
)))
5599 (setf (sb-c::tn-next
(car list
)) (link (cdr list
)))
5601 (let* ((normal (make-tns (ldb (byte 2 0) i
)))
5602 (restricted (make-tns (ldb (byte 2 2) i
)))
5603 (wired (make-tns (ldb (byte 2 4) i
)))
5604 (expect (append normal restricted wired
))
5605 (comp (sb-c::make-empty-component
))
5606 (ir2-comp (sb-c::make-ir2-component
)))
5607 (setf (sb-c::component-info comp
) ir2-comp
5608 (sb-c::ir2-component-normal-tns ir2-comp
) (link normal
)
5609 (sb-c::ir2-component-restricted-tns ir2-comp
) (link restricted
)
5610 (sb-c::ir2-component-wired-tns ir2-comp
) (link wired
))
5612 (result (sb-c::do-packed-tns
(tn comp
42) (push tn list
))))
5613 (assert (eq result
42))
5614 (assert (equal expect
(nreverse list
))))
5616 (result (sb-c::do-packed-tns
(tn comp
'bar
)
5618 (if (= (incf n
) 4) (return 'foo
)))))
5619 (assert (eq result
(if (>= (length expect
) 4) 'foo
'bar
)))
5620 (assert (equal (subseq expect
0 (min 4 (length expect
)))
5621 (nreverse list
))))))))
5624 (with-test (:name
(optimize :quality-multiply-specified
:bug-310267
))
5625 (let ((sb-c::*policy
* sb-c
::*policy
*)) ; to keep this test pure
5626 (assert-signal (proclaim '(optimize space debug
(space 0)))
5629 (assert (= 1 (length (nth-value
5631 form
:allow-style-warnings t
)))))))
5632 (test `(lambda () (declare (optimize speed
(speed 0))) 5))
5633 (test `(lambda () (declare (optimize speed
) (optimize (speed 0))) 5))
5635 (declare (optimize speed
)) (declare (optimize (speed 0)))
5639 (assert-no-signal (proclaim '(optimize (space 3) space
)))
5640 (checked-compile `(lambda () (declare (optimize speed
(speed 3))) 5))
5641 (checked-compile `(lambda () (declare (optimize speed
) (optimize (speed 3))) 5))
5642 (checked-compile `(lambda ()
5643 (declare (optimize speed
)) (declare (optimize (speed 3)))
5646 (with-test (:name
(truncate :type-derivation
))
5647 (assert (= 4 (funcall (checked-compile
5649 (truncate a
(the (rational (1) (3)) b
))))
5652 (with-test (:name
:constantp-on-a-literal-function-works
)
5653 (assert (constantp `(the (function (list) t
) ,#'car
))))
5655 (with-test (:name
:arg-count-error
)
5656 (assert (eq :win
(handler-case (funcall (intern "CONS") 1 2 3)
5657 (sb-int:simple-program-error
() :win
)
5658 (condition () :lose
)))))
5660 (with-test (:name
:mv-conversion
)
5661 (checked-compile `(lambda (a)
5663 (list (unwind-protect a
))
5664 (multiple-value-call #'list
5665 (values (catch 'ct5
(go 0))))
5668 (with-test (:name
(:null-cleanups-1
:bug-1416704
:bug-404441
))
5673 (declare (optimize speed
))
5675 (funcall (flet ((bar () 10)) #'bar
))
5676 (funcall (flet ((fez ()
5677 (funcall (flet ((foo () 20)) #'foo
))))
5679 (assert (= (funcall x t
) 10))
5680 (assert (= (funcall x nil
) 20))))
5682 (with-test (:name
(:null-cleanups-2
:bug-1416704
:bug-404441
))
5687 (declare (optimize speed
))
5688 (let* ((a2 (lambda () 20))
5690 (a0 (flet ((f () (funcall a2
)))
5696 (let ((a5 (lambda () (funcall a4
))))
5700 (assert (= (catch 'x
(funcall fun t
)) 10))
5701 (assert (= (catch 'x
(funcall fun nil
)) 20))))
5704 (with-test (:name
:locall-already-let-converted
)
5705 (assert (eq (funcall
5710 (flet ((f () (return-from f ff
)))
5711 (declare (inline f
))
5714 (declare (inline call
))
5716 (call (lambda () 'result
)))))))
5719 (with-test (:name
:debug-dump-elsewhere
)
5720 (assert (eql (catch 'x
5724 (declare (optimize debug
))
5728 (with-test (:name
(typep :quasiquoted-constant
))
5729 (assert (null (ctu:find-named-callees
5732 (typep x
`(signed-byte ,sb-vm
:n-word-bits
))))))))
5734 (with-test (:name
(logior :transform
))
5735 (multiple-value-bind (fun failurep warnings
)
5736 (checked-compile `(lambda (c)
5739 (logior c
(f nil
))))
5742 (assert (= 1 (length warnings
)))
5743 (assert-error (funcall fun
10) type-error
)))
5745 (with-test (:name
:eql
/integer-folding
)
5748 (fceiling (the (member 2.3 21672589639883401935) a
)))))
5750 (with-test (:name
(position :derive-type
))
5751 (let ((f (checked-compile
5753 (declare (type (simple-string 90) x
))
5754 (declare (muffle-conditions code-deletion-note
))
5755 (let ((b (position #\i x
)))
5756 (if (and (integerp b
) (> b
100))
5757 'yikes
'okey-dokey
))))))
5758 ;; The function can not return YIKES
5759 (assert (not (ctu:find-code-constants f
:type
'(eql yikes
))))))
5761 (with-test (:name
:compile-file-error-position-reporting
)
5762 (dolist (input '("data/wonky1.lisp" "data/wonky2.lisp" "data/wonky3.lisp"))
5763 (let ((expect (with-open-file (f input
) (read f
))))
5764 (assert (stringp expect
))
5765 (let ((err-string (with-output-to-string (*error-output
*)
5766 (compile-file input
:print nil
))))
5767 (assert (search expect err-string
))))))
5769 (with-test (:name
(coerce :derive-type
))
5770 (macrolet ((check (type ll form
&rest values
)
5771 `(assert (equal (funcall (checked-compile
5773 (ctu:compiler-derived-type
,',form
)))
5780 (check (unsigned-byte 32)
5782 (coerce a
'(unsigned-byte 32))
5786 (coerce a
(array-element-type (the (array character
) x
)))
5789 (check (unsigned-byte 32)
5791 (coerce a
(array-element-type (the (array (unsigned-byte 32)) x
)))
5793 (make-array 10 :element-type
'(unsigned-byte 32)))))
5795 (with-test (:name
:associate-args
)
5796 (flet ((test (form argument
)
5797 (multiple-value-bind (fun failurep warnings
)
5798 (checked-compile form
:allow-warnings t
)
5800 (assert (= 1 (length warnings
)))
5801 (assert-error (funcall fun argument
)))))
5802 (test `(lambda (x) (+ 1 x nil
)) 2)
5803 (test `(lambda (x) (/ 1 x nil
)) 4)))
5805 (with-test (:name
:eager-substitute-single-use-lvar
)
5809 (declare (optimize (debug 0) (safety 0)))
5810 (let ((a (the fixnum a
))
5814 (flet ((jump () (go loop
)))
5817 (setf z
(the fixnum
(if (= x
1) #xFFF a
)))
5824 (with-test (:name
:vop-on-eql-type
)
5826 (funcall (checked-compile
5828 (declare ((eql -
7) b
)
5836 (with-test (:name
:vop-on-eql-type
.2)
5839 (funcall (checked-compile
5841 (declare ((eql -
7) b
)
5844 (+ (random 10) b
))))
5847 (with-test (:name
:vop-on-eql-type
.3)
5850 (funcall (checked-compile
5852 (declare ((eql -
7) b
)
5853 (optimize (compilation-speed 0) debug
))
5855 (+ (random 10) b
))))
5859 (multiple-value-bind (fun failurep
)
5860 (checked-compile `(lambda () ,form
)
5863 (assert-error (funcall fun
) sb-int
:compiled-program-error
))))
5865 (with-test (:name
(compile macrolet
:malformed
))
5866 (test '(macrolet (foo () 'bar
)))
5867 (test '(macrolet x
))
5868 (test '(symbol-macrolet x
))
5869 (test '(symbol-macrolet (x))))
5871 (with-test (:name
(compile flet
:malformed
))
5872 (test '(flet (foo () 'bar
)))
5874 (test '(labels (foo () 'bar
)))
5875 (test '(labels x
))))
5877 (with-test (:name
:compile-load-time-value-interpreted-mode
)
5878 ;; This test exercises the same pattern as HANDLER-BIND (to a
5879 ;; degree). In particular a HANDLER-BIND that was compiled when the
5880 ;; *EVALUATOR-MODE* was :INTERPRET would not compile its class
5881 ;; predicates, because LOAD-TIME-VALUE just called EVAL, and you
5882 ;; would get back a list with an interpreted function in it.
5884 ;; In the code below, this function when called would generate a new
5885 ;; symbol each time. But if the compiler processes the guts as it
5886 ;; should, you get back a compiled lambda which returns a constant
5888 (let ((f (let ((sb-ext:*evaluator-mode
* :interpret
))
5894 (sb-int:keywordicate
(gensym))))
5896 (eq (funcall (car (funcall f
)))
5897 (funcall (car (funcall f
))))))
5899 (with-test (:name
:constant-fold-%eql
/integer
)
5901 (funcall (checked-compile
5903 (declare (type (complex single-float
) x
)
5904 (optimize (debug 2)))
5905 (member (the (eql #c
(0.0
0.0)) x
)
5906 '(1 2 3 9912477572127105188))))
5909 (with-test (:name
(compile svref
:constant
))
5911 (= (funcall (checked-compile
5912 `(lambda () (svref #(1 2 3) 1))))
5915 (with-test (:name
(compile char-equal
:type-intersection
))
5917 (eq (funcall (checked-compile
5919 (char-equal (the (member #\a #\B
) x
)
5920 (the (eql #\A
) y
))))
5924 (with-test (:name
(oddp fixnum
:no-consing
))
5925 (let ((f (checked-compile '(lambda (x) (oddp x
)))))
5926 (ctu:assert-no-consing
(funcall f most-positive-fixnum
))))
5927 (with-test (:name
(oddp bignum
:no-consing
))
5928 (let ((f (checked-compile '(lambda (x) (oddp x
))))
5929 (x (* most-positive-fixnum most-positive-fixnum
3)))
5930 (ctu:assert-no-consing
(funcall f x
))))
5931 (with-test (:name
(logtest fixnum
:no-consing
:bug-1277690
))
5932 (let ((f (checked-compile '(lambda (x) (logtest x most-positive-fixnum
)))))
5933 (ctu:assert-no-consing
(funcall f
1))))
5934 (with-test (:name
(logtest bignum
:no-consing
))
5935 (let ((f (checked-compile '(lambda (x) (logtest x
1))))
5936 (x (* most-positive-fixnum most-positive-fixnum
3)))
5937 (ctu:assert-no-consing
(funcall f x
))))
5939 (with-test (:name
(sb-c::mask-signed-field
:randomized
))
5942 (let* ((ool (checked-compile '(lambda (s i
)
5943 (sb-c::mask-signed-field s i
))))
5944 (size (random (* sb-vm
:n-word-bits
2)))
5945 (constant (checked-compile `(lambda (i)
5946 (sb-c::mask-signed-field
,size i
))))
5947 (arg (- (random (* most-positive-fixnum
8)) (* most-positive-fixnum
4)))
5948 (declared (checked-compile `(lambda (i)
5949 (declare (type (integer ,(- (abs arg
)) ,(abs arg
)) i
))
5950 (sb-c::mask-signed-field
,size i
))))
5951 (ool-answer (funcall ool size arg
))
5952 (constant-answer (funcall constant arg
))
5953 (declared-answer (funcall declared arg
)))
5954 (unless (= ool-answer constant-answer declared-answer
)
5955 (push (list size arg ool-answer constant-answer declared-answer
) result
))))
5956 (assert (null result
))))
5958 (with-test (:name
:array-dimensions-
*)
5959 (= (funcall (checked-compile
5961 (declare ((or (vector t
) (array character
)) array
))
5962 (array-dimension array
0)))
5966 (with-test (:name
:generate-type-checks-on-dead-blocks
)
5967 (assert (equalp (funcall (checked-compile
5969 (declare (optimize (safety 3))
5970 (type (member vector
42) a
))
5971 (map a
'list
(the vector b
) #*)))
5975 (with-test (:name
(make-list :large
1))
5976 (checked-compile `(lambda ()
5977 (make-list (expt 2 28) :initial-element
0))))
5979 (with-test (:name
(make-list :large
2)
5980 :skipped-on
'(not :64-bit
))
5981 (checked-compile `(lambda ()
5982 (make-list (expt 2 30) :initial-element
0))))
5984 (with-test (:name
:bad-cond
)
5987 '(lambda () (cond (t 10) 20)))))
5989 (with-test (:name
:removed-dx-cast
)
5991 (checked-compile `(lambda ()
5993 (let ((x (the integer
(return 0))))
5994 (declare (dynamic-extent x
))
5995 (unwind-protect x
1))))))
5998 (with-test (:name
:isqrt-derivation
)
5999 (assert (eql (funcall (checked-compile
6001 (isqrt (count (the bit i
) #*11101))))
6005 (with-test (:name
:vector-zero-initialization
)
6006 (assert (equalp (funcall (funcall (checked-compile
6008 (declare ((eql 0) x
)
6009 (optimize (debug 2)))
6011 (vector x
(isqrt b
)))))
6015 (with-test (:name
:cons-zero-initialization
)
6016 (assert (equalp (funcall (funcall (checked-compile
6018 (declare ((eql 0) x
)
6019 (optimize (debug 2)))
6021 (cons x
(isqrt b
)))))
6025 (with-test (:name
:check-important-result-warning
)
6026 (multiple-value-bind (fun failure warnings style-warnings
)
6027 (checked-compile '(lambda (x z
)
6028 (declare (notinline nintersection
))
6029 (nintersection x z
) x
)
6030 :allow-style-warnings t
)
6031 (declare (ignore fun failure warnings
))
6032 (loop for c in style-warnings
6034 (assert (search "NINTERSECTION"
6035 (princ-to-string c
))))))
6037 (with-test (:name
:destroyed-constant-warning
)
6038 (multiple-value-bind (fun failure warnings
)
6039 (checked-compile '(lambda ()
6040 (declare (notinline nunion
))
6041 (nunion '(1 2 3) '(1 2 4)))
6043 (declare (ignore fun failure
))
6044 (loop for c in warnings
6046 (assert (search "NUNION"
6047 (princ-to-string c
))))))
6049 (with-test (:name
:%array-data-complex-type-derivation
)
6050 (let ((type (funcall (checked-compile
6052 (ctu:compiler-derived-type
(sb-kernel:%array-data
(the array x
)))))
6054 (assert (eq type
'array
))))
6056 (with-test (:name
:equalp-transofrm
)
6058 (funcall (checked-compile
6060 (equalp (the (simple-array single-float
(*)) x
)
6061 (the (simple-array double-float
(*)) y
))))
6062 (coerce '(1f0) '(simple-array single-float
(*)))
6063 (coerce '(1d0) '(simple-array double-float
(*))))))
6065 (with-test (:name
:array-hairy-type-derivation
)
6067 (equal (funcall (checked-compile
6069 (subseq (the (and (satisfies sb-impl
::vector-with-fill-pointer-p
)
6072 (make-array 3 :element-type
'character
6074 :initial-contents
"abc"))
6077 (with-test (:name
:nreverse-derive-type
)
6079 (not (funcall (checked-compile
6081 (eql (car (nreverse (the (cons (eql 10)) x
))) 10)))
6084 (with-test (:name
:subseq-derive-type
)
6086 (equalp (funcall (checked-compile
6088 (subseq (the (simple-vector 3) x
) 1)))
6092 (with-test (:name
:sequence-derive-type
)
6094 (equalp (funcall (checked-compile
6096 (copy-seq (the (and string
(not (simple-array nil
))) x
))))
6097 (make-array 3 :element-type
'character
6099 :initial-contents
"123"))
6102 (with-test (:name
:sequence-derive-type
.2)
6104 (funcall (checked-compile
6106 (equal (the (and string
(not (simple-array nil
))) x
) y
)))
6107 (make-array 3 :element-type
'character
6109 :initial-contents
"123")
6112 (with-test (:name
:sequence-derive-type
.3)
6114 (equalp (funcall (checked-compile
6116 (subseq (the (or (simple-array * (*)) string
) x
) 0 2)))
6120 (with-test (:name
:not-enough-values-cast
)
6122 (not (funcall (checked-compile
6124 (car (describe 1 (make-broadcast-stream)))))))))
6126 ;; To check the :EXIT-DELETION tests below, enable the following form,
6127 ;; which allows the compiler to delete all vestigial exits, even if it
6128 ;; "shouldn't", which should case the :EXIT-DELETION tests to fail in
6131 (without-package-locks
6132 (defun sb-c::may-delete-vestigial-exit
(cast)
6133 (declare (ignore cast
))
6136 ;; Vestigial exit deletion was a bit too aggressive, causing stack
6137 ;; analysis to decide that the value of (BAR 10) in both cases below
6138 ;; needed to be nipped out from under the dynamic-extent allocation of
6139 ;; Y (or #'Y), which %NIP-VALUES refused to do (DX values must not be
6140 ;; moved once allocated).
6141 (with-test (:name
(compile :exit-deletion
:bug-1563127
:variable
))
6142 (checked-compile '(lambda (x)
6144 (multiple-value-prog1 (bar 10)
6146 (declare (dynamic-extent y
))
6149 (return-from test
))))))
6150 :allow-style-warnings t
))
6152 (with-test (:name
(compile :exit-deletion
:bug-1563127
:function
))
6153 (checked-compile '(lambda (x)
6155 (multiple-value-prog1 (bar 10)
6156 (flet ((y () (list x
)))
6157 (declare (dynamic-extent #'y
))
6160 (return-from test
))))))
6161 :allow-style-warnings t
))
6163 (with-test (:name
(compile :exit-deletion
:bug-533930
))
6164 (checked-compile '(lambda ()
6166 (multiple-value-prog1 42
6168 (let ((x (cons t t
)))
6169 (declare (dynamic-extent x
))
6170 (return-from a
(catch 'ct
(foo x
))))))))
6171 :allow-style-warnings t
))
6173 (with-test (:name
(compile :exit-deletion
:bug-518099
))
6174 (checked-compile '(lambda (a)
6176 (multiple-value-prog1 42
6182 (with-test (:name
(compile :exit-deletion
:bug-1655011
))
6183 (checked-compile '(lambda (x)
6185 (multiple-value-prog1 (catch 'ct
)
6186 (let ((* (list 10)))
6187 (declare (dynamic-extent *))
6191 (with-test (:name
(compile :exit-deletion
:2017-
01-
30))
6192 (checked-compile '(lambda (b c
)
6194 (multiple-value-prog1 42
6196 (if b
(return-from b5
6197 (catch 'foo c
)))))))))
6199 (with-test (:name
(compile :exit-deletion
:2017-
01-
30 :even-more-subtle
))
6200 (checked-compile '(lambda (b c
)
6202 (multiple-value-prog1 42
6204 (if b
(return-from b5
6206 (error "even more subtle"))))))))
6207 :allow-style-warnings t
))
6209 (with-test (:name
(compile :exit-deletion
:2017-
01-
31 :tagbody
))
6211 (checked-compile '(lambda (b c
)
6212 (declare (notinline funcall
))
6214 (multiple-value-prog1 42
6217 (funcall c
(lambda () (go away
))))
6219 ;; Be careful here: The return value can be garbage. Our saving
6220 ;; grace is that it's stack garbage, thus by definition GC-safe to
6221 ;; hold in a register long enough to take its address, but we
6222 ;; really don't want to try and externalize it in any way.
6223 (assert (= (sb-kernel:get-lisp-obj-address
6224 (funcall test-closure t
#'funcall
))
6225 (sb-kernel:get-lisp-obj-address
6228 (with-test (:name
:mv-call-no-let-conversion
)
6233 (locally (declare (optimize (sb-c::let-conversion
0)))
6234 (multiple-value-call #'lisp-implementation-version
(values))))))
6235 (lisp-implementation-version)))
6240 (locally (declare (optimize (sb-c::let-conversion
0)))
6241 (multiple-value-call #'lisp-implementation-type
(values))))))
6242 (lisp-implementation-type)))
6247 (locally (declare (optimize (sb-c::let-conversion
0)))
6248 (multiple-value-call #'princ-to-string
1)))))
6251 (with-test (:name
:mv-call-argument-mismatch
)
6255 '(lambda () (multiple-value-call #'cons
1 2 3))
6256 :allow-warnings t
))))
6258 (with-test (:name
:valid-callable-argument-cast
)
6259 (assert (equal (funcall (checked-compile '(lambda (x)
6260 (find-if (the function
#'oddp
)
6265 (with-test (:name
:usigned-word-float-conversion
)
6266 (assert (= (rational (funcall (checked-compile `(lambda (x)
6267 (float (the sb-ext
:word x
) 1d0
)))
6268 sb-ext
:most-positive-word
))
6270 #+64-bit
18446744073709551616)))
6272 (with-test (:name
:callable-argument-mismatch-on-xep
)
6273 (assert (= (funcall (checked-compile
6275 (locally (declare (notinline reduce
))
6276 (reduce (lambda (a b
)
6281 (assert (= (funcall (checked-compile
6283 (locally (declare (notinline reduce
))
6284 (reduce (lambda (&optional a b z
)
6285 (declare (ignore z
))
6291 (with-test (:name
:mv-call-type-derivation
6293 (assert (equal (funcall (checked-compile
6295 (multiple-value-call
6296 (lambda (&optional a
&rest r
)
6300 (values-list list
)))
6305 (with-test (:name
:delete-optional-dispatch-xep
)
6306 (let ((name (gensym)))
6307 (assert (= (funcall (checked-compile `(sb-int:named-lambda
,name
6311 (multiple-value-call #',name
(1- x
)))))
6315 (with-test (:name
:yes-or-no-p-type
)
6316 (checked-compile `(lambda ()
6318 (checked-compile `(lambda ()
6320 (checked-compile `(lambda ()
6321 (yes-or-no-p #'list
)))
6322 (checked-compile `(lambda ()
6323 (y-or-n-p #'list
))))
6325 (with-test (:name
:callable-delayed-mismatch
)
6326 (multiple-value-bind (fun failure-p warnings
)
6327 (checked-compile '(lambda () (let ((f 'cons
)) (find-if f
'(10))))
6328 :allow-warnings
'simple-warning
)
6329 (declare (ignore fun
))
6331 (assert (= (length warnings
) 1))
6332 (search "The function CONS is called by"
6333 (princ-to-string (first warnings
)))))
6335 (with-test (:name
:set-type-conflict
)
6336 (assert (nth-value 1
6338 '(lambda () (set '// 10))
6339 :allow-warnings t
))))
6341 (with-test (:name
:two-arg-funs-check
)
6342 (loop for
(nil x
) in sb-c
::*two-arg-functions
*
6344 (assert (fboundp x
))
6345 (assert (sb-int:info
:function
:info x
))))
6347 (with-test (:name
:two-arg-with-two-arguments-only
)
6348 (assert (funcall (checked-compile `(lambda (x y
) (string-lessp x y
:start1
0)))
6352 (with-test (:name
:optimize-functional-arguments-casts
)
6353 (let ((fun (checked-compile
6355 (declare (type atom key
))
6356 (find 1 list
:key
(the (member car
) key
))))))
6357 (assert (equal (funcall fun
'((a b
) (1 a
)) 'car
)
6359 (assert-error (equal (funcall fun
'((a b
) (1 a
)) 'cdr
)
6362 (with-test (:name
:two-arg-rewriting-find-if
)
6363 (assert (= (funcall (checked-compile
6365 (declare (type vector x
))
6366 (find-if #'oddp x
:key
'-
)))
6370 (with-test (:name
:transforms-check-policy-first
)
6371 (assert (eql (funcall (checked-compile
6373 (declare (optimize speed space
))
6374 (find x
"a b c" :test
#'char-equal
))
6379 (with-test (:name
(:valid-callable-argument
:toplevel-xep
))
6380 (assert (nth-value 2 (checked-compile `(lambda (l) (find-if (lambda ()) l
))
6381 :allow-warnings t
))))
6383 (with-test (:name
(:valid-callable-argument
:handler-bind
))
6384 (assert (nth-value 2 (checked-compile
6385 `(lambda (l) (handler-bind ((error (lambda ()))) (funcall l
)))
6386 :allow-warnings t
))))
6388 (with-test (:name
(:ignore
:macrolet
))
6390 (funcall (checked-compile `(lambda ()
6391 (macrolet ((f () 10))
6392 (declare (ignorable #'f
))
6396 (eql (assert-no-signal
6397 (eval `(macrolet ((f () 10))
6398 (declare (ignorable #'f
))
6402 (with-test (:name
(:cast
:values-
&rest
))
6403 (assert (not (funcall (checked-compile
6405 (values (the (values &rest integer
)
6406 (eval '(values))))))))))
6409 (with-test (:name
(:cast
:values-
&optional
))
6410 (assert (not (funcall (checked-compile
6412 (declare (optimize debug
))
6413 (let ((x (the (values &optional integer
) (eval '(values)))))
6418 (with-test (:name
(:setf-schar
:type-mismatch
))
6419 (let ((fun (checked-compile
6420 `(lambda (a) (setf (schar a
0) #\HIRAGANA_LETTER_SMALL_TU
)))))
6421 (let ((string (string #\a))
6422 (base-string (coerce "a" 'simple-base-string
)))
6423 (assert (eq (funcall fun string
) #\HIRAGANA_LETTER_SMALL_TU
))
6424 (assert (equal string
(string #\HIRAGANA_LETTER_SMALL_TU
)))
6425 (assert-error (funcall fun base-string
) type-error
)
6426 (assert (equal base-string
"a")))))
6428 (with-test (:name
:can-escape-functionals-escape
)
6431 (declare (optimize (speed 3)))
6432 (lambda () (unwind-protect :x
:z
)))
6436 (declare (optimize (speed 3)))
6437 (lambda () (catch :x
)))
6440 (with-test (:name
(:combination-implementation-style
:constants
))
6441 (assert (funcall (checked-compile
6443 (declare (optimize (speed 2) (safety 0)))
6444 (logbitp (the (eql 1) p1
)
6445 (the fixnum p2
)))) 1 2)))
6447 (with-test (:name
:reducing-constants
6448 ;; x86 delays FPE signalling
6450 (assert (eql (funcall (checked-compile
6456 (assert (eql (funcall (checked-compile
6458 (* #C
(4.457268f31
0.0) 4 x
6461 #C
(-4.123312f37 -
0.0))))
6463 (with-test (:name
:logbitp-past-fixnum
)
6464 (let ((fun (checked-compile `(lambda (x)
6465 (logbitp sb-vm
:n-fixnum-bits
6467 (assert (not (funcall fun
1)))
6468 (assert (funcall fun -
1))))
6470 (with-test (:name
:dpb-implementation-style
)
6471 (assert (= (funcall (checked-compile
6474 (declare (type sb-vm
:signed-word res
))
6475 (setf res
(dpb res
(byte 1 2) res
))
6479 (with-test (:name
:dpb-implementation-style
.2)
6480 (let ((fun (checked-compile
6482 (declare (fixnum x i
))
6483 (dpb x
(byte 0 0) i
)))))
6484 (assert (= (funcall fun
0 1) 1))
6485 (assert (= (funcall fun -
1 1) 1))))
6487 (with-test (:name
:fixnum-mod-p-immediate
)
6488 (let ((fun (checked-compile `(lambda (x)
6489 (declare (type fixnum x
))
6490 (typep x
'(integer 0 2049))))))
6491 (assert (not (funcall fun
2050)))
6492 (assert (not (funcall fun -
1)))
6493 (assert (funcall fun
1))
6494 (assert (funcall fun
0))))
6496 (with-test (:name
:initial-contents-element-type-mismatch
)
6500 (checked-compile `(lambda (x)
6501 (make-array '(1 2) :element-type
'list
6502 :initial-contents x
)))
6504 #2A
(((1 2) (3 4))))))
6506 (with-test (:name
:unknown-values-receiver-register-clobber
)
6507 (assert (= (funcall (checked-compile `(lambda ()
6509 (declare (sb-int:truly-dynamic-extent x
))
6511 (catch 'ct
(the integer
6512 (eval (dotimes (i 1 42) 42)))))))))
6516 (with-test (:name
:single-float-bits-to-signed-stack
)
6517 (assert (= (funcall (checked-compile `(lambda (p1)
6518 (declare (optimize (speed 0) (space 0))
6519 (type single-float p1
))
6520 (scale-float p1
27)))
6524 (with-test (:name
(compile :call
:dotted-list
))
6526 (multiple-value-bind (fun failure-p warnings style-warnings notes
6528 (checked-compile `(lambda () ,form
)
6529 :allow-failure t
:allow-warnings t
)
6530 (declare (ignore fun warnings style-warnings notes
))
6532 (assert (= 1 (length compiler-errors
)))
6533 (assert (search "is not a proper list."
6534 (princ-to-string (first compiler-errors
)))))))
6535 (test '(cons 1 .
2))
6536 (test '((lambda (x) x
) .
1))
6537 (test '(let () .
1))))
6539 (with-test (:name
:ldb-rlwinm
)
6540 (assert (= (funcall (checked-compile `(lambda (x)
6541 (declare (fixnum x
))
6542 (ldb (byte 13 19) x
)))
6546 (with-test (:name
:logand-transform
)
6551 (flet ((%f
(&key
(y (throw 'ct1
1)))
6552 (return-from %f y
)))
6557 (with-test (:name
:left-ash-cut-amount
)
6559 (zerop (funcall (checked-compile `(lambda (b z
)
6560 (declare (type fixnum b
)
6561 (type (and fixnum unsigned-byte
) z
))
6562 (ldb (byte 64 0) (ash b z
))))
6565 (with-test (:name
:stp-load-fp-tn
)
6568 `(sb-int:named-lambda
,(gensym) (a)
6569 (declare (optimize (debug 2)))
6572 (locally (declare (notinline values
))
6573 (values a a a a a a a a a a a
)))