tests/compiler.pure.lisp

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