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