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