tests/compiler.pure.lisp

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