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 ;;;; This file of tests was added because the tests in 'compiler.pure.lisp'
15 ;;;; are a total hodgepodge- there is often no hugely compelling reason for
16 ;;;; their being tests of the compiler per se, such as whether
17 ;;;; INPUT-ERROR-IN-COMPILED-FILE is a subclass of SERIOUS-CONDITION;
18 ;;;; in addition to which it is near impossible to wade through the
19 ;;;; ton of nameless, slow, and noisy tests.
21 ;;;; This file strives to do better on all fronts:
22 ;;;; the tests should be fast, named, and not noisy.
24 (cl:in-package
:cl-user
)
26 (load "compiler-test-util.lisp")
28 (defun compiles-with-warning (lambda)
29 (assert (nth-value 2 (checked-compile lambda
:allow-warnings t
))))
31 (with-test (:name
(ldb :recognize-local-macros
))
32 ;; Should not call %LDB
33 (assert (not (ctu:find-named-callees
36 (declare (optimize speed
))
37 (macrolet ((b () '(byte 2 2)))
38 (ldb (b) (the fixnum x
)))))))))
40 (with-test (:name
(dpb :eval-order
:lp-1458190
))
41 (sb-int:collect
((calls))
43 (dpb (progn (calls 'eval-new
) new
)
44 (progn (calls 'eval-byte
) (byte 10 10))
45 (progn (calls 'eval-old
) old
))))
47 (assert (equal (calls)
48 '(eval-new eval-byte eval-old
))))))
50 ;; Best practice treats TRULY-THE as a special operator, not a macro,
51 ;; in a context such as (DPB X (TRULY-THE SB-KERNEL:BYTE-SPECIFIER ...) Y).
52 ;; DPB used to expand its second argument using MACROEXPAND and lose
53 ;; the nuance of TRULY-THE. Strictly speaking, byte-specifier is not a
54 ;; type specifier that users are supposed to know about, so portable code
55 ;; should not care, but this might affect internal code.
56 (with-test (:name
(dpb :inner-macro
))
57 (flet ((source-xform (sexpr)
58 (funcall (sb-int:info
:function
:source-transform
(car sexpr
))
59 sexpr
(sb-kernel:make-null-lexenv
))))
60 (assert (equal-mod-gensyms
62 '(dpb (new) (truly-the sb-kernel
:byte-specifier bspec
) (old)))
64 (byte (truly-the sb-kernel
:byte-specifier bspec
)))
65 (sb-kernel:%dpb new
(byte-size byte
) (byte-position byte
)
68 (with-test (:name
:inline-satisfies-predicate
)
69 ;; If we remove the indirections in these functions,
70 ;; this test should visibly break so that we can write a new test
71 ;; that asserts that inlining F works in (THE (SATISFIES F) obj).
72 (assert (equal (sb-ext:typexpand
'sb-impl
::function-name
)
73 '(satisfies sb-int
:legal-fun-name-p
)))
74 (let ((f (checked-compile '(lambda (x) (the sb-impl
::function-name x
)))))
75 (assert (equal (list (symbol-function 'sb-int
:valid-function-name-p
))
76 (ctu:find-named-callees f
))))
77 (let ((f (checked-compile '(lambda (x)
78 (declare (notinline sb-int
:legal-fun-name-p
))
79 (the sb-impl
::function-name x
)))))
80 (assert (equal (list (symbol-function 'sb-int
:legal-fun-name-p
))
81 (ctu:find-named-callees f
)))))
83 (with-test (:name
(make-array :untestable-type
:no-warning
))
84 (checked-compile `(lambda () (make-array '(2 2)
85 :element-type
`(satisfies foofa
)))))
87 (with-test (:name
(make-array nil
:no-warning
))
88 (checked-compile '(lambda () (make-array '(2 2) :element-type nil
))))
90 (with-test (:name
(nth-value :huge-n
:works
))
91 (flet ((return-a-ton-of-values ()
92 (values-list (loop for i below
5000 collect i
))))
93 (assert (= (nth-value 1 (return-a-ton-of-values)) 1))
94 (assert (= (nth-value 4000 (return-a-ton-of-values)) 4000))))
96 (defstruct (a-test-structure-foo
97 (:constructor make-a-foo-1
)
98 (:constructor make-a-foo-2
(b &optional a
)))
100 (b nil
:type integer
))
102 (with-test (:name
:improperly-initialized-slot-warns
)
103 ;; should warn because B's default is NIL, not an integer.
104 (compiles-with-warning '(lambda () (make-a-foo-1 :a
'what
)))
105 ;; should warn because A's default is 0
106 (compiles-with-warning '(lambda () (make-a-foo-2 3))))
108 (with-test (:name
(inline structure
:ctor
:no declaim
))
109 (let ((f (checked-compile '(lambda ()
110 (make-a-foo-1 :a
'wat
:b
3)))))
111 (assert (ctu:find-named-callees f
)))
112 (let ((f (checked-compile '(lambda ()
113 (declare (inline make-a-foo-1
))
114 (make-a-foo-1 :a
'wat
:b
3)))))
115 (assert (not (ctu:find-named-callees f
)))))
117 (with-test (:name
:internal-name-p
:skipped-on
:sb-xref-for-internals
)
118 (assert (sb-c::internal-name-p
'sb-int
:neq
)))
120 (with-test (:name
(:coerce-callable-to-fun
:note
))
121 (flet ((try (form what
)
122 (multiple-value-bind (fun failure-p warnings style-warnings notes
)
123 (checked-compile `(lambda (x)
124 (declare (optimize speed
))
126 (declare (ignore fun failure-p warnings style-warnings
))
127 (assert (search (format nil
"~A is not known to be" what
)
128 (princ-to-string (first notes
)))))))
130 (try '(eval `(work-with ,x
)) "callable expression")
132 ;; For this I'd accept either Z or X in the message.
133 (try '(progn (let ((z x
)) (identity z
))) "X")))
135 (with-test (:name
(princ-to-string :unflushable
))
136 ;; Ordinary we'll flush it
137 (let ((f (checked-compile '(lambda (x) (princ-to-string x
) x
))))
138 (assert (not (ctu:find-named-callees f
:name
'princ-to-string
))))
139 ;; But in high safety it should be called for effect
140 (let ((f (checked-compile '(lambda (x)
141 (declare (optimize safety
)) (princ-to-string x
) x
))))
142 (assert (ctu:find-named-callees f
:name
'princ-to-string
))))
144 (with-test (:name
:space-bounds-no-consing
145 :skipped-on
:interpreter
)
146 ;; Asking for the size of a heap space should not cost anything!
147 (ctu:assert-no-consing
(sb-vm::%space-bounds
:static
))
148 (ctu:assert-no-consing
(sb-vm::space-bytes
:static
)))
150 (with-test (:name
(sb-vm::map-allocated-objects
:no-consing
)
152 :skipped-on
:interpreter
)
154 (sb-int:dx-flet
((f (obj type size
)
155 (declare (ignore obj type size
))
157 (ctu:assert-no-consing
158 (sb-vm::map-allocated-objects
#'f
:dynamic
)
161 (with-test (:name
:pack-varints-as-bignum
)
162 (dotimes (i 500) ; do some random testing this many times
163 (let* ((random-numbers (loop repeat
(+ (random 20) 3)
164 collect
(1+ (random 4000))))
165 (test-list (sort (delete-duplicates random-numbers
) #'<))
166 (packed-int (sb-c::pack-code-fixup-locs test-list
))
167 (result (make-array 1 :element-type
'sb-ext
:word
)))
168 ;; The packer intrinsically self-checks the packing
169 ;; so we don't need to assert anything about that.
170 (sb-sys:with-pinned-objects
(packed-int result
)
171 ;; Now exercise the C unpacker.
172 ;; This hack of allocating 4 longs is terrible, but whatever.
173 (let ((unpacker (make-alien long
4))
175 (alien-funcall (extern-alien "varint_unpacker_init"
176 (function void
(* long
) unsigned
))
178 (sb-kernel:get-lisp-obj-address packed-int
))
179 (sb-int:collect
((unpacked))
183 (extern-alien "varint_unpack"
184 (function int
(* long
) system-area-pointer
))
185 unpacker
(sb-sys:vector-sap result
))))
186 (let ((val (aref result
0)))
187 ;; status of 0 is EOF, val = 0 means a decoded value was 0,
188 ;; which can't happen, so it's effectively EOF.
189 (when (or (eql status
0) (eql val
0)) (return))
190 (let ((loc (+ prev-loc val
)))
192 (setq prev-loc loc
)))))
193 (assert (equal (unpacked) test-list
))))))))
195 (with-test (:name
(symbol-value symbol-global-value
:quoted-constant
))
196 (let ((f (checked-compile '(lambda () (symbol-value 'char-code-limit
)))))
197 (assert (not (ctu:find-code-constants f
:type
'symbol
))))
198 (let ((f (checked-compile '(lambda () (symbol-global-value 'char-code-limit
)))))
199 (assert (not (ctu:find-code-constants f
:type
'symbol
)))))
201 (with-test (:name
(:set symbol-value
:of defglobal
))
202 (let ((s 'sb-c
::*recognized-declarations
*))
203 (assert (eq (sb-int:info
:variable
:kind s
) :global
)) ; verify precondition
204 (let ((f (checked-compile `(lambda () (setf (symbol-value ',s
) nil
)))))
205 ;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE>
206 (assert (not (ctu:find-code-constants f
:type
'sb-kernel
:fdefn
))))))
208 (with-test (:name
:layout-constants
209 :skipped-on
(not (and :x86-64
:immobile-space
)))
210 (let ((addr-of-pathname-layout
212 (sb-kernel:get-lisp-obj-address
(sb-kernel:find-layout
'pathname
))
215 ;; The constant should appear in two CMP instructions
216 (dolist (line (split-string
217 (with-output-to-string (s)
218 (let ((sb-disassem:*disassem-location-column-width
* 0))
219 (disassemble 'pathnamep
:stream s
)))
221 (when (and (search "CMP" line
) (search addr-of-pathname-layout line
))
223 (assert (= count
2))))
225 (with-test (:name
:set-symbol-value-imm
:skipped-on
(not :x86-64
))
227 (dolist (line (split-string
228 (with-output-to-string (s)
229 (let ((sb-disassem:*disassem-location-column-width
* 0))
230 (disassemble '(lambda () (setq *print-base
* 8)) :stream s
)))
232 (when (and #+sb-thread
(search "MOV QWORD PTR [R" line
)
233 #-sb-thread
(search "MOV QWORD PTR [" line
)
234 (search (format nil
", ~D" (ash 8 sb-vm
:n-fixnum-tag-bits
)) line
))
238 (with-test (:name
:linkage-table-bogosity
:skipped-on
(not :sb-dynamic-core
))
239 (let ((strings (map 'list
(lambda (x) (if (consp x
) (car x
) x
))
240 #+sb-dynamic-core sb-vm
::+required-foreign-symbols
+
241 #-sb-dynamic-core
'())))
242 (assert (= (length (remove-duplicates strings
:test
'string
=))
245 (with-test (:name
(:no style-warning
:for inline
:cl-fun
))
246 (checked-compile '(lambda (x)
247 (declare (optimize (speed 3)) (inline length
)
248 (muffle-conditions compiler-note
))
251 (with-test (:name
:deleted-return-use
)
252 (checked-compile-and-assert ()
256 (let ((a (catch 'x
)))
257 (flet ((%f
(a &optional b
)
262 (with-test (:name
:shift-right-transform-nil-type
)
263 (checked-compile-and-assert (:optimize nil
)
265 (declare (type (integer -
10 -
6) c
)
266 (optimize (debug 2)))
268 (flet ((f1 (a &optional
(b (shiftf b
0)) c d
)
269 (declare (ignore a b c d
))
281 (with-test (:name
:move-lvar-result-through-unused-cast
)
282 (checked-compile-and-assert (:optimize nil
)
284 (declare (optimize (debug 0)))
288 (apply #'f
(list 2 3))))
289 (declare (notinline f
))
294 (with-test (:name
(:type-conflict funcall
:external-lambda
))
295 (compiles-with-warning `(lambda ()
296 (let ((x (lambda (x) (declare (fixnum x
)) x
)))
299 (with-test (:name
(:type-conflict
:callable
:external-lambda
))
300 (compiles-with-warning `(lambda ()
301 (let ((x (lambda (x) (declare (fixnum x
)) x
)))
302 (find-if x
"abca")))))
304 (with-test (:name
(:type-conflict map
:result-type
))
305 (compiles-with-warning `(lambda (str)
306 (map 'string
(lambda (x) (declare (ignore x
)) nil
)
309 (with-test (:name
(:type-conflict
:by-name
))
310 (compiles-with-warning `(lambda (str)
311 (map 'string
'evenp str
))))
313 (with-test (:name
(:type-conflict
:callable
:reporting
))
314 (multiple-value-bind (fun failure-p warnings
)
315 (checked-compile '(lambda (x) (map-into (make-string 10) #'evenp x
))
316 :allow-warnings
'warning
)
317 (declare (ignore fun
))
319 (assert (= (length warnings
) 1))
320 (search "Derived type of EVENP is"
321 (princ-to-string (first warnings
)))))
323 (with-test (:name
(:type-conflict string
:union-type
))
324 (compiles-with-warning `(lambda (x)
325 (find-if #'evenp
(the string x
)))))
327 (with-test (:name
(:type-conflict map-into
:let
))
328 (compiles-with-warning `(lambda (z)
330 (map-into z
#'evenp x
)))))
332 (with-test (:name
(:type-conflict map-into
:result
))
333 (compiles-with-warning `(lambda (z)
334 (map-into (make-string 10) #'evenp z
))))
336 (with-test (:name
(:type-conflict complement
))
340 (find z
"l" :test
(complement #'=)))
341 :allow-style-warnings t
))))
343 (with-test (:name
:type-across-hairy-lambda-transforms
)
344 (assert (subtypep (sb-kernel:%simple-fun-type
345 (checked-compile `(lambda (x) (find 1 (the vector x
)))))
346 '(function * (values (or (integer 1 1) null
) &optional
)))))
348 (with-test (:name
:lea-type-derivation
)
349 (checked-compile-and-assert ()
351 (declare ((integer -
3755795408964870057 -
3391381516052960895)
353 (ldb (byte 22 10) (* b
9)))
354 ((-3391381516052980893) 2826685)))
356 (with-test (:name
(:unused
&optional
:and
&key
))
357 (checked-compile-and-assert (:allow-style-warnings t
)
358 `(lambda (&optional x
&key
)
363 (with-test (:name
(:unknown values
:coercion
))
364 (checked-compile-and-assert ()
366 (declare (notinline values typep
))
367 (the integer
(values a
2305843009213693946 a -
207)))
368 ((123) (values 123 2305843009213693946 123 -
207))))
370 (with-test (:name
:deleted-block-during-generate-type-checks
)
371 (checked-compile-and-assert (:allow-warnings t
)
373 (declare (notinline min ash conjugate oddp
>=))
374 (if (and (or t
(>= a
)) (oddp 0))
377 (labels ((f (a b c
&key
)
378 (declare (ignore a b c
))
387 (ignore-errors (throw 'c
1))))
391 (with-test (:name
:block-delete-twice
)
392 (checked-compile-and-assert ()
394 (declare (notinline >=))
396 (lambda (x &key
(key (if (>= 0 1)
397 (return (catch 'ct5
0)))))
398 (declare (ignore key
))
400 (() 123 :test
(lambda (values expected
)
401 (equal (multiple-value-list
402 (funcall (first values
) (first expected
)))
405 (with-test (:name
:dead-lvars-and-stack-analysis
)
406 (checked-compile-and-assert ()
411 (multiple-value-prog1 19
413 (return-from b5
333)))))))
416 (with-test (:name
:mv-call-more-values
)
417 (checked-compile-and-assert ()
419 (multiple-value-call (lambda (&optional x y
&rest args
)
420 (declare (ignore args
))
425 (with-test (:name
:unused-casts-at-ir2-convert
)
426 (checked-compile-and-assert ()
430 (labels ((%f
(x &key
)
433 (unwind-protect (%f
(%f
0)))))))
436 (with-test (:name
:cmov-constants-different-primitive-type
)
437 (checked-compile-and-assert ()
440 ((2030) 4611686018427387908)
445 ((2030) 4611686018427387908)))
447 (with-test (:name
:mv-bind-skipping-vars-on-reoptimize
)
448 (checked-compile-and-assert ()
451 (apply (lambda (&rest args
)
452 (declare (ignore args
)))
458 (with-test (:name
:transform-on-a-nil-arg
)
459 (checked-compile-and-assert ()
463 (multiple-value-prog1
464 (unwind-protect (return 32))
465 (catch 'tag
(return 33)))
470 (with-test (:name
:nesteted-dx-deleted-uses
)
471 (checked-compile-and-assert ()
474 (let* ((v1 (make-array nil
:initial-element
476 (return-from b2 a
)))))
477 (declare (dynamic-extent v1
))
481 (with-test (:name
:deleted-during-locall-analyze-fun-1
)
482 (checked-compile-and-assert (:allow-warnings t
)
487 (() (condition 'program-error
))))
489 (with-test (:name
:delete-return-without-flush-dest
)
492 (funcall (checked-compile
495 (multiple-value-prog1 *
501 (with-test (:name
:let-conversion-inside-deleted-lambda
.1)
502 (checked-compile-and-assert ()
514 (with-test (:name
:let-conversion-inside-deleted-lambda
.2)
515 (checked-compile-and-assert ()
519 (lambda () (return)))
528 (with-test (:name
:unconvert-tail-calls
)
529 (checked-compile-and-assert ()
532 (labels ((f (&optional
(a (return))
536 (declare (ignore a b c args
))
545 (with-test (:name
:deleting-exits-with-multiple-users
)
546 (checked-compile-and-assert ()
549 (multiple-value-prog1 b
550 (tagbody (return (multiple-value-prog1 3
551 (if a
(go z
)))) z
))))
555 (with-test (:name
:merge-tail-sets-deleted-functional
)
556 (checked-compile-and-assert ()
564 (let ((x (progn (lambda (&optional
(x a
)) x
)
566 (return-from b3 a
))))
567 (unwind-protect x
)))))))
570 (with-test (:name
:interval-div-zero
)
571 (checked-compile-and-assert (:optimize
:safe
)
573 (truncate (the (integer 0 0) x
)
574 (the (rational (1) (2)) y
)))
575 ((0 3/2) (values 0 0))))
577 (with-test (:name
:float-remainders-rounding-errors
)
578 (loop for fun in
'(ceiling truncate floor
579 fceiling ftruncate ffloor
582 (assert (member (second
583 (third (sb-kernel:%simple-fun-type
586 (nth-value 1 (,fun
(the double-float x
) 1/2)))))))
587 '(double-float real
)))))
589 (with-test (:name
:float-quotient-rounding-errors
)
590 (checked-compile-and-assert (:optimize
:safe
)
592 (floor -
114658225103614 84619.58))
593 (() (values -
1354984705 8473228.0)))
594 (checked-compile-and-assert (:optimize
:safe
)
596 (ceiling 114658225103614 84619.58))
597 (() (values 1354984705 -
8473228.0))))
599 (with-test (:name
:complex-float-contagion
)
600 (checked-compile-and-assert ()
602 (declare (type (or double-float integer
) p1
))
604 ((1d0) #c
(1d0 2d0
))))
606 (with-test (:name
:equal-transform-member-types
)
609 (checked-compile-and-assert ()
611 (declare (type (member ,s1
) p1
)
612 (type (member ,s2
#*10) p2
))
616 (with-test (:name
:equalp-transform-numeric-types
)
617 (checked-compile-and-assert ()
619 (declare (type (or fixnum list
) p1
)
620 (type double-float p2
))
624 (with-test (:name
:equalp-transform-zero-array
)
625 (checked-compile-and-assert ()
627 (declare (simple-string a
)
628 (simple-bit-vector b
))
632 (with-test (:name
:fill-transform-returning-array-data
)
633 (let ((vector (make-array 10 :fill-pointer
2)))
634 (checked-compile-and-assert ()
636 (declare (type (vector t
) v
))
640 (with-test (:name
:missing-error-context
)
643 (with-output-to-string (*error-output
*)
644 (compile nil
'(sb-int:named-lambda bob
() (otherfun) 3)))))
645 (assert (search "in: SB-INT:NAMED-LAMBDA BOB" string
)))))
647 ;; Unrepeatability is confusing:
648 ;; The first compiler invocation used to leave *last-format-string*
649 ;; with a toplevel value, so the second would not print enough context
650 ;; because the format control and args were the same.
653 (with-test (:name
:cast-deletion-notes
)
654 (checked-compile-and-assert
657 (setf m
(list 1 2 3))
660 ((nil) #(1 2 3) :test
#'equalp
)))
662 (with-test (:name
:cast-deletion-notes
.2)
663 (multiple-value-bind (fun fail warn style notes
)
666 (setf m
(list 1 2 3))
671 (declare (ignore fail warn style
))
672 (assert (equalp (funcall fun nil
)
674 (assert (= (length notes
) 1))
675 (assert (typep (car notes
) 'code-deletion-note
))))
677 (with-test (:name
:array-call-type-deriver
)
678 (checked-compile-and-assert
681 (funcall (the (function (t t
)) #'aref
)
684 (((vector 333)) 333)))
686 (with-test (:name
:function-designator-cast-removal
)
687 (let ((fun (checked-compile
689 (declare (list vectors x
))
690 (map 'list
#'svref vectors x
)))))
691 (assert (notany (lambda (c)
694 (eq (sb-c::fdefn-name c
) 'svref
))
697 (ctu:find-code-constants fun
)))
698 (assert (equal (funcall fun
'(#(44)) '(0)) '(44)))))
700 (with-test (:name
:zombie-casts
)
701 (checked-compile-and-assert
707 (multiple-value-call #'f
708 (values (the integer
(unwind-protect (f 10 20)))
712 (with-test (:name
:zombie-casts
.2)
713 (let ((sb-c::*max-optimize-iterations
* 1))
714 (checked-compile-and-assert
717 (declare (type fixnum a b
))
718 (elt '(167992664 119771479)
721 (if (typep b
'(integer -
52))
727 (with-test (:name
:find-dfo-on-deleted-lambda
)
729 (funcall (checked-compile
731 (declare (notinline <))
737 (return (catch 'c
))))))
741 (with-test (:name
:ir1-ir2-dead-code-consistency
)
742 (checked-compile-and-assert
746 count
(zerop (min x x x x x x x x x x
))))
749 (with-test (:name
:ir1-ir2-dead-code-consistency
)
750 (checked-compile-and-assert
754 count
(zerop (min x x x x x x x x x x
))))
757 (with-test (:name
(setf svref
:constant-modification
))
759 (= (length (nth-value 2
762 (setf (svref #(a b c
) 1) x
))
763 :allow-warnings
'sb-int
:constant-modified
)))
766 (with-test (:name
(debug :constant-modification
))
768 (= (length (nth-value 2
771 (declare (optimize (debug 2)))
774 :allow-warnings
'sb-int
:constant-modified
)))
777 (with-test (:name
(debug :unused-tn-long-arglist
))
778 (checked-compile-and-assert
781 (declare (sb-vm:word n
))
783 (nth-value 33 (funcall x .
#.
(loop for i to
35 collect i
))))
784 ((10 (lambda (&rest args
) (values-list args
))) 33)))
786 (with-test (:name
(debug :unused-tn-very-long-arglist
))
787 (checked-compile-and-assert
790 (declare (sb-vm:word n
))
792 (nth-value 33 (funcall x .
#.
(loop for i to
350 collect i
))))
793 ((10 (lambda (&rest args
) (values-list args
))) 33)))
795 (with-test (:name
(dynamic-extent :recursive-local-functions
))
798 (let ((s (labels ((%f
() (%f
)))
800 (declare (dynamic-extent s
))
803 (with-test (:name
(:ctypep
:hairy-types
))
806 (the (cons (satisfies error
)) '("a"))))
810 `(lambda () (the (array abc
) #()))
811 :allow-style-warnings t
))))
813 (with-test (:name
(catch :evaluate-tag-before-%catch
))
814 (checked-compile-and-assert
815 (:allow-style-warnings t
)
817 (catch (multiple-value-call #'+
818 (if z
1 (values 1 2)))
823 (with-test (:name
:fewer-cast-conversions
)
824 (multiple-value-bind (fun failed
)
827 (let* ((v (cons 0 (catch 'ct
(the integer nil
)))))
828 (declare (dynamic-extent v
))
833 (handler-bind ((error (lambda (c) c
(throw 'ct
33))))
834 (assert (= (funcall fun
) 33)))))
836 (with-test (:name
:constant-folding-with-callable-args
)
837 (checked-compile '(lambda () (count #'%f
'(a)))
838 :allow-style-warnings t
))
840 (with-test (:name
:flushable-with-callable-args
)
841 (let ((fun (checked-compile '(lambda (y) (let ((x (count y
'(1 2 3))))
842 (declare (ignore x
)))))))
843 (assert (not (ctu:find-named-callees fun
)))))
845 (with-test (:name
(remove :count
))
846 (checked-compile-and-assert
849 (remove x
"aaa" :count
2))
851 (checked-compile-and-assert
854 (remove-if (lambda (y) (eql y x
)) "aaa" :count
2))
857 (with-test (:name
(:constant-fold
:allow-other-keys
))
858 (checked-compile-and-assert
861 (reduce #'+ '(1 2 3) :allow-other-keys t
:bad x
))
864 (with-test (:name
(:constant-fold
:allow-other-keys
.2))
865 (checked-compile-and-assert
868 (reduce #'+ '(1 2 3) :allow-other-keys x
))
871 (with-test (:name
(:constant-fold
:repeat-keys
))
872 (checked-compile-and-assert
875 (member nil
'(1 2 3) :key
#'evenp
:key x
))
876 ((1) '(1 2 3) :test
#'equal
)))
880 (with-test (:name
:function-and-instance-primitive-type
)
881 (checked-compile-and-assert
884 (declare (function f
))
885 (the standard-object f
)
886 (funcall f
#'list t
))
887 ((#'documentation
) (documentation #'list t
))))
889 (with-test (:name
:mv-call-safety-0
)
890 (checked-compile-and-assert
893 (flet ((%f1
(x y
) (+ x y
)))
894 (apply #'%f1 a
(list 0))))
897 (with-test (:name
:cast-type-check-external
)
898 (checked-compile-and-assert
901 (declare (notinline +))
903 (loop for lv2 below
1
911 (with-test (:name
:flush-combination-non-fun-type
)
912 (checked-compile-and-assert
915 (rassoc-if-not #'values
'((1 . a
)) :allow-other-keys t
)
919 (with-test (:name
:symeval-nil
)
920 (checked-compile-and-assert
923 (sb-kernel:symeval nil
))
926 (with-test (:name
(:physenv-analyze
:deleted-lambda
))
927 (checked-compile-and-assert
933 (ignore-errors (format log
""))))
936 (with-test (:name
(:ensure-lvar-fun-form
:lvar-uses
))
937 (checked-compile-and-assert
939 `(lambda (op) (funcall (case op
(equal '=) (t '=)) 1 2))
943 (with-test (:name
:substitute-let-funargs-during-find-initial-dfo
)
951 (with-test (:name
:split-ir2-blocks-cmov
)
952 (checked-compile-and-assert
962 (with-test (:name
:=-rational-complex-rational-fold
)
963 (let ((fun (checked-compile '(lambda (x)
964 (declare ((complex integer
) x
))
966 (fun2 (checked-compile '(lambda (x)
967 (declare ((complex rational
) x
))
969 (assert (equal (sb-kernel:%simple-fun-type fun
)
970 '(function ((complex integer
)) (values null
&optional
))))
971 (assert (not (funcall fun
#C
(10 10))))
972 (assert (equal (sb-kernel:%simple-fun-type fun2
)
973 '(function ((complex rational
)) (values null
&optional
))))
974 (assert (not (funcall fun2
#C
(10 10))))))
976 (with-test (:name
:find-type-deriver
)
977 (checked-compile-and-assert
980 (find 1 x
:key
#'values
))
983 (with-test (:name
:tail-call-ltn-annotation
)
984 (checked-compile-and-assert
988 (multiple-value-call #'print
995 (with-test (:name
(:substitute-lvar-uses
:deleted-code-and-dx-lvars
))
1003 (unwind-protect 1))))
1004 (declare (dynamic-extent v
))
1006 :allow-warnings t
))))
1008 (with-test (:name
(restart-case :declaration-processing
))
1009 (checked-compile-and-assert
1012 (restart-case (list)
1013 (my-restart (x) "foo" "bar" x
)))
1015 (checked-compile-and-assert
1018 (restart-case (list)
1019 (my-restart () (declare))))
1022 (with-test (:name
(handler-case :declaration-processing
))
1023 (checked-compile-and-assert
1026 (handler-case (list 1 2) (error (e) "foo" "bar" e
)))
1028 (assert (nth-value 1
1031 (handler-case (declare)))
1032 :allow-failure t
))))
1034 (with-test (:name
(:unconvert-tail-calls
:deleted-call
))
1035 (assert (nth-value 1
1038 (labels ((%f
(&optional
(x (* 2 nil
(%f
)))) x
))
1041 :allow-warnings t
))))
1043 (with-test (:name
(:equal-transform
:nil-types
))
1044 (assert (nth-value 1
1049 (not (or (>= y y
) (equal y -
787357528)))
1050 (the integer
(or (>= y y
) (equal y -
787357528))))))
1051 :allow-warnings t
))))
1055 (with-test (:name
(:delete-recursive-optional
))
1056 (checked-compile '(lambda (x)
1058 (labels ((f (&optional a
) (values x a
#'f
))))))))
1060 (with-test (:name
(:combination-args-flow-cleanly-p
:unused-result
))
1061 (checked-compile-and-assert
1064 (let ((v (flet ((%f
(x)
1068 (declare (dynamic-extent v
))
1072 (with-test (:name
(:delete-ref
:maintain-lambda-calls-or-closes
))
1073 (checked-compile `(lambda (c y
)
1089 (with-test (:name
(the :nil-type
))
1092 (flet ((f () (the nil
0)))
1095 (with-test (:name
:concatenate-transform-hairy-type
)
1098 (concatenate '(and string
(satisfies eval
)) x
))))