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 (list* '(integer -1 200) '(integer -256 1)
3285                      '(integer 0 128)
3286                      sb-kernel::*specialized-array-element-types*))
3287     (when et
3288       (let* ((v (make-array 3 :element-type et))
3289              (fun (compile nil `(lambda ()
3290                                   (list
3291                                    (if (typep ,v '(simple-array ,et (*)))
3292                                        :good
3293                                        :bad)
3294                                    (if (typep (elt ,v 0) '(simple-array ,et (*)))
3295                                        :bad
3296                                        :good))))))
3297         (assert (equal '(:good :good) (funcall fun)))))))
3298
3299 (with-test (:name :truncate-float)
3300   (let ((s (compile nil `(lambda (x)
3301                            (declare (single-float x))
3302                            (truncate x))))
3303         (d (compile nil `(lambda (x)
3304                            (declare (double-float x))
3305                            (truncate x))))
3306         (s-inlined (compile nil '(lambda (x)
3307                                   (declare (type (single-float 0.0s0 1.0s0) x))
3308                                   (truncate x))))
3309         (d-inlined (compile nil '(lambda (x)
3310                                   (declare (type (double-float 0.0d0 1.0d0) x))
3311                                   (truncate x)))))
3312     ;; Check that there is no generic arithmetic
3313     (assert (not (search "GENERIC"
3314                          (with-output-to-string (out)
3315                            (disassemble s :stream out)))))
3316     (assert (not (search "GENERIC"
3317                          (with-output-to-string (out)
3318                            (disassemble d :stream out)))))
3319     ;; Check that we actually inlined the call when we were supposed to.
3320     (assert (not (search "UNARY-TRUNCATE"
3321                          (with-output-to-string (out)
3322                            (disassemble s-inlined :stream out)))))
3323     (assert (not (search "UNARY-TRUNCATE"
3324                          (with-output-to-string (out)
3325                            (disassemble d-inlined :stream out)))))))
3326
3327 (with-test (:name :make-array-unnamed-dimension-leaf)
3328   (let ((fun (compile nil `(lambda (stuff)
3329                              (make-array (map 'list 'length stuff))))))
3330     (assert (equalp #2A((0 0 0) (0 0 0))
3331                     (funcall fun '((1 2) (1 2 3)))))))
3332
3333 (with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
3334   (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3335                   integer-decode-float))
3336     (let ((fun (compile nil `(lambda (x)
3337                                (declare (optimize safety))
3338                                (,name x)
3339                                nil))))
3340       (flet ((test (arg)
3341                (unless (eq :error
3342                            (handler-case
3343                                (funcall fun arg)
3344                              (error () :error)))
3345                  (error "(~S ~S) did not error"
3346                         name arg))))
3347         ;; No error
3348         (funcall fun 1.0)
3349         ;; Error
3350         (test 'not-a-float)
3351         (when (member name '(decode-float integer-decode-float))
3352           (test sb-ext:single-float-positive-infinity))))))
3353
3354 (with-test (:name :sap-ref-16)
3355   (let* ((fun (compile nil `(lambda (x y)
3356                               (declare (type sb-sys:system-area-pointer x)
3357                                        (type (integer 0 100) y))
3358                               (sb-sys:sap-ref-16 x (+ 4 y)))))
3359          (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3360                          '(simple-array (unsigned-byte 8) (*))))
3361          (sap (sb-sys:vector-sap vector))
3362          (ret (funcall fun sap 0)))
3363     ;; test for either endianness
3364     (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
3365
3366 (with-test (:name :coerce-type-warning)
3367   (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3368                   (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3369     (multiple-value-bind (fun warningsp failurep)
3370         (compile nil `(lambda (x)
3371                         (declare (type simple-vector x))
3372                         (coerce x '(vector ,type))))
3373       (assert (null warningsp))
3374       (assert (null failurep))
3375       (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
3376
3377 (with-test (:name :truncate-double-float)
3378   (let ((fun (compile nil `(lambda (x)
3379                              (multiple-value-bind (q r)
3380                                  (truncate (coerce x 'double-float))
3381                                (declare (type unsigned-byte q)
3382                                         (type double-float r))
3383                                (list q r))))))
3384     (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
3385
3386 (with-test (:name :set-slot-value-no-warning)
3387   (let ((notes 0))
3388     (handler-bind ((warning #'error)
3389                    (sb-ext:compiler-note (lambda (c)
3390                                            (declare (ignore c))
3391                                            (incf notes))))
3392       (compile nil `(lambda (x y)
3393                       (declare (optimize speed safety))
3394                       (setf (slot-value x 'bar) y))))
3395     (assert (= 1 notes))))
3396
3397 (with-test (:name :concatenate-string-opt)
3398   (flet ((test (type grep)
3399            (let* ((fun (compile nil `(lambda (a b c d e)
3400                                       (concatenate ',type a b c d e))))
3401                   (args '("foo" #(#\.) "bar" (#\-) "quux"))
3402                   (res (apply fun args)))
3403              (assert (search grep (with-output-to-string (out)
3404                                     (disassemble fun :stream out))))
3405              (assert (equal (apply #'concatenate type args)
3406                             res))
3407              (assert (typep res type)))))
3408     (test 'string "%CONCATENATE-TO-STRING")
3409     (test 'simple-string "%CONCATENATE-TO-STRING")
3410     (test 'base-string "%CONCATENATE-TO-BASE-STRING")
3411     (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
3412
3413 (with-test (:name :satisfies-no-local-fun)
3414   (let ((fun (compile nil `(lambda (arg)
3415                              (labels ((local-not-global-bug (x)
3416                                         t)
3417                                       (bar (x)
3418                                         (typep x '(satisfies local-not-global-bug))))
3419                                (bar arg))))))
3420     (assert (eq 'local-not-global-bug
3421                 (handler-case
3422                     (funcall fun 42)
3423                   (undefined-function (c)
3424                     (cell-error-name c)))))))
3425
3426 ;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
3427 ;;; argument that is a complex structure (needing make-load-form
3428 ;;; processing) failed an AVER.  The first attempt at a fix caused
3429 ;;; doing the same in-core to break.
3430 (with-test (:name :bug-310132)
3431   (compile nil '(lambda (&optional (foo #p"foo/bar")))))
3432
3433 (with-test (:name :bug-309129)
3434   (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
3435          (warningp nil)
3436          (fun (handler-bind ((warning (lambda (c)
3437                                         (setf warningp t) (muffle-warning c))))
3438                 (compile nil src))))
3439     (assert warningp)
3440     (handler-case (funcall fun #(1))
3441       (type-error (c)
3442         ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
3443         ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
3444         (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
3445       (:no-error (&rest values)
3446         (declare (ignore values))
3447         (error "no error")))))
3448
3449 (with-test (:name :unary-round-type-derivation)
3450   (let* ((src '(lambda (zone)
3451                 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
3452                   (declare (ignore h))
3453                   (round (* 60.0 m)))))
3454          (fun (compile nil src)))
3455     (assert (= (funcall fun 0.5) 30))))
3456
3457 (with-test (:name :bug-525949)
3458   (let* ((src '(lambda ()
3459                 (labels ((always-one () 1)
3460                          (f (z)
3461                            (let ((n (funcall z)))
3462                              (declare (fixnum n))
3463                              (the double-float (expt n 1.0d0)))))
3464                   (f #'always-one))))
3465          (warningp nil)
3466          (fun (handler-bind ((warning (lambda (c)
3467                                         (setf warningp t) (muffle-warning c))))
3468                 (compile nil src))))
3469     (assert (not warningp))
3470     (assert (= 1.0d0 (funcall fun)))))
3471
3472 (with-test (:name :%array-data-vector-type-derivation)
3473   (let* ((f (compile nil
3474                      `(lambda (ary)
3475                         (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3476                         (setf (aref ary 0 0) 0))))
3477          (text (with-output-to-string (s)
3478                  (disassemble f :stream s))))
3479     (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
3480
3481 (with-test (:name :array-storage-vector-type-derivation)
3482   (let ((f (compile nil
3483                     `(lambda (ary)
3484                        (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3485                        (ctu:compiler-derived-type (array-storage-vector ary))))))
3486     (assert (equal '(simple-array (unsigned-byte 32) (9))
3487                    (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
3488
3489 (with-test (:name :bug-523612)
3490   (let ((fun
3491          (compile nil
3492                   `(lambda (&key toff)
3493                      (make-array 3 :element-type 'double-float
3494                                  :initial-contents
3495                                  (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
3496     (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
3497     (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
3498
3499 (with-test (:name :bug-309788)
3500   (let ((fun
3501          (compile nil
3502                   `(lambda (x)
3503                      (declare (optimize speed))
3504                      (let ((env nil))
3505                        (typep x 'fixnum env))))))
3506     (assert (not (ctu:find-named-callees fun)))))
3507
3508 (with-test (:name :bug-309124)
3509   (let ((fun
3510          (compile nil
3511                   `(lambda (x)
3512                      (declare (integer x))
3513                      (declare (optimize speed))
3514                      (cond ((typep x 'fixnum)
3515                             "hala")
3516                            ((typep x 'fixnum)
3517                             "buba")
3518                            ((typep x 'bignum)
3519                             "hip")
3520                            (t
3521                             "zuz"))))))
3522     (assert (equal (list "hala" "hip")
3523                    (sort (ctu:find-code-constants fun :type 'string)
3524                          #'string<)))))
3525
3526 (with-test (:name :bug-316078)
3527   (let ((fun
3528          (compile nil
3529                   `(lambda (x)
3530                      (declare (type (and simple-bit-vector (satisfies bar)) x)
3531                               (optimize speed))
3532                      (elt x 5)))))
3533     (assert (not (ctu:find-named-callees fun)))
3534     (assert (= 1 (funcall fun #*000001)))
3535     (assert (= 0 (funcall fun #*000010)))))
3536
3537 (with-test (:name :mult-by-one-in-float-acc-zero)
3538   (assert (eql 1.0 (funcall (compile nil `(lambda (x)
3539                                             (declare (optimize (sb-c::float-accuracy 0)))
3540                                             (* x 1.0)))
3541                             1)))
3542   (assert (eql -1.0 (funcall (compile nil `(lambda (x)
3543                                              (declare (optimize (sb-c::float-accuracy 0)))
3544                                              (* x -1.0)))
3545                              1)))
3546   (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
3547                                               (declare (optimize (sb-c::float-accuracy 0)))
3548                                               (* x 1.0d0)))
3549                               1)))
3550   (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
3551                                                (declare (optimize (sb-c::float-accuracy 0)))
3552                                                (* x -1.0d0)))
3553                                1))))
3554
3555 (with-test (:name :dotimes-non-integer-counter-value)
3556   (assert (raises-error? (dotimes (i 8.6)) type-error)))
3557
3558 (with-test (:name :bug-454681)
3559   ;; This used to break due to reference to a dead lambda-var during
3560   ;; inline expansion.
3561   (assert (compile nil
3562                    `(lambda ()
3563                       (multiple-value-bind (iterator+977 getter+978)
3564                           (does-not-exist-but-does-not-matter)
3565                         (flet ((iterator+976 ()
3566                                  (funcall iterator+977)))
3567                           (declare (inline iterator+976))
3568                           (let ((iterator+976 #'iterator+976))
3569                             (funcall iterator+976))))))))
3570
3571 (with-test (:name :complex-float-local-fun-args)
3572   ;; As of 1.0.27.14, the lambda below failed to compile due to the
3573   ;; compiler attempting to pass unboxed complex floats to Z and the
3574   ;; MOVE-ARG method not expecting the register being used as a
3575   ;; temporary frame pointer.  Reported by sykopomp in #lispgames,
3576   ;; reduced test case provided by _3b`.
3577   (compile nil '(lambda (a)
3578                   (labels ((z (b c)
3579                               (declare ((complex double-float) b c))
3580                               (* b (z b c))))
3581                           (loop for i below 10 do
3582                                 (setf a (z a a)))))))
3583
3584 (with-test (:name :bug-309130)
3585   (assert (eq :warning
3586               (handler-case
3587                   (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
3588                 ((and warning (not style-warning)) ()
3589                   :warning))))
3590   (assert (eq :warning
3591               (handler-case
3592                   (compile nil `(lambda (x)
3593                                   (declare (optimize (debug 0)))
3594                                   (declare (type vector x))
3595                                   (list (fill-pointer x) (svref x 1))))
3596                 ((and warning (not style-warning)) ()
3597                   :warning))))
3598   (assert (eq :warning
3599               (handler-case
3600                   (compile nil `(lambda (x)
3601                                   (list (vector-push (svref x 0) x))))
3602                 ((and warning (not style-warning)) ()
3603                   :warning))))
3604   (assert (eq :warning
3605               (handler-case
3606                   (compile nil `(lambda (x)
3607                                   (list (vector-push-extend (svref x 0) x))))
3608                 ((and warning (not style-warning)) ()
3609                   :warning)))))
3610
3611 (with-test (:name :bug-646796)
3612   (assert 42
3613           (funcall
3614            (compile nil
3615                     `(lambda ()
3616                        (load-time-value (the (values fixnum) 42)))))))
3617
3618 (with-test (:name :bug-654289)
3619   ;; Test that compile-times don't explode when quoted constants
3620   ;; get big.
3621   (labels ((time-n (n)
3622              (gc :full t) ; Let's not confuse the issue with GC
3623              (let* ((tree (make-tree (expt 10 n) nil))
3624                     (t0 (get-internal-run-time))
3625                     (f (compile nil `(lambda (x) (eq x (quote ,tree)))))
3626                     (t1 (get-internal-run-time)))
3627                (assert (funcall f tree))
3628                (- t1 t0)))
3629            (make-tree (n acc)
3630              (cond ((zerop n) acc)
3631                    (t (make-tree (1- n) (cons acc acc))))))
3632     (let* ((times (loop for i from 0 upto 4
3633                         collect (time-n i)))
3634            (max-small (reduce #'max times :end 3))
3635            (max-big (reduce #'max times :start 3)))
3636       ;; This way is hopefully fairly CPU-performance insensitive.
3637       (unless (> (+ (truncate internal-time-units-per-second 10)
3638                     (* 2 max-small))
3639                  max-big)
3640         (error "Bad scaling or test? ~S" times)))))
3641
3642 (with-test (:name :bug-309063)
3643   (let ((fun (compile nil `(lambda (x)
3644                              (declare (type (integer 0 0) x))
3645                              (ash x 100)))))
3646     (assert (zerop (funcall fun 0)))))
3647
3648 (with-test (:name :bug-655872)
3649   (let ((f (compile nil `(lambda (x)
3650                            (declare (optimize (safety 3)))
3651                            (aref (locally (declare (optimize (safety 0)))
3652                                    (coerce x '(simple-vector 128)))
3653                                  60))))
3654         (long (make-array 100 :element-type 'fixnum)))
3655     (dotimes (i 100)
3656       (setf (aref long i) i))
3657     ;; 1. COERCE doesn't check the length in unsafe code.
3658     (assert (eql 60 (funcall f long)))
3659     ;; 2. The compiler doesn't trust the length from COERCE
3660     (assert (eq :caught
3661                 (handler-case
3662                     (funcall f (list 1 2 3))
3663                   (sb-int:invalid-array-index-error (e)
3664                     (assert (eql 60 (type-error-datum e)))
3665                     (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
3666                     :caught))))))
3667
3668 (with-test (:name :bug-655203-regression)
3669   (let ((fun (compile nil
3670                       `(LAMBDA (VARIABLE)
3671                          (LET ((CONTINUATION
3672                                 (LAMBDA
3673                                     (&OPTIONAL DUMMY &REST OTHER)
3674                                   (DECLARE (IGNORE OTHER))
3675                                   (PRIN1 DUMMY)
3676                                   (PRIN1 VARIABLE))))
3677                            (FUNCALL CONTINUATION (LIST 1 2)))))))
3678     ;; This used to signal a bogus type-error.
3679     (assert (equal (with-output-to-string (*standard-output*)
3680                      (funcall fun t))
3681                    "(1 2)T"))))
3682
3683 (with-test (:name :constant-concatenate-compile-time)
3684   (flet ((make-lambda (n)
3685            `(lambda (x)
3686               (declare (optimize (speed 3) (space 0)))
3687               (concatenate 'string x ,(make-string n)))))
3688     (let* ((l0 (make-lambda 1))
3689            (l1 (make-lambda 10))
3690            (l2 (make-lambda 100))
3691            (l3 (make-lambda 1000))
3692            (t0 (get-internal-run-time))
3693            (f0 (compile nil l0))
3694            (t1 (get-internal-run-time))
3695            (f1 (compile nil l1))
3696            (t2 (get-internal-run-time))
3697            (f2 (compile nil l2))
3698            (t3 (get-internal-run-time))
3699            (f3 (compile nil l3))
3700            (t4 (get-internal-run-time))
3701            (d0 (- t1 t0))
3702            (d1 (- t2 t1))
3703            (d2 (- t3 t2))
3704            (d3 (- t4 t3))
3705            (short-avg (/ (+ d0 d1 d2) 3)))
3706       (assert (and f1 f2 f3))
3707       (assert (< d3 (* 10 short-avg))))))
3708
3709 (with-test (:name :bug-384892)
3710   (assert (equal
3711            '(function (fixnum fixnum &key (:k1 (member nil t)))
3712              (values (member t) &optional))
3713            (sb-kernel:%simple-fun-type
3714             (compile nil `(lambda (x y &key k1)
3715                             (declare (fixnum x y))
3716                             (declare (boolean k1))
3717                             (declare (ignore x y k1))
3718                             t))))))
3719
3720 (with-test (:name :bug-309448)
3721   ;; Like all tests trying to verify that something doesn't blow up
3722   ;; compile-times this is bound to be a bit brittle, but at least
3723   ;; here we try to establish a decent baseline.
3724   (labels ((time-it (lambda want &optional times)
3725              (gc :full t) ; let's keep GCs coming from other code out...
3726              (let* ((start (get-internal-run-time))
3727                     (iterations 0)
3728                     (fun (if times
3729                              (loop repeat times
3730                                    for result = (compile nil lambda)
3731                                    finally (return result))
3732                              (loop for result = (compile nil lambda)
3733                                    do (incf iterations)
3734                                    until (> (get-internal-run-time) (+ start 10))
3735                                    finally (return result))))
3736                     (end (get-internal-run-time))
3737                     (got (funcall fun)))
3738                (unless (eql want got)
3739                  (error "wanted ~S, got ~S" want got))
3740                (values (- end start) iterations)))
3741            (test-it (simple result1 complex result2)
3742              (multiple-value-bind (time-simple iterations)
3743                  (time-it simple result1)
3744                (assert (>= (* 10 (1+ time-simple))
3745                            (time-it complex result2 iterations))))))
3746     ;; This is mostly identical as the next one, but doesn't create
3747     ;; hairy unions of numeric types.
3748     (test-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 1))
3754                         (c (bar 1 1)))
3755                     (- (+ a b) c))))
3756              6
3757              `(lambda ()
3758                 (labels ((bar (baz bim)
3759                            (let ((n (+ baz bim)))
3760                              (* n (+ n 1) bim))))
3761                   (let ((a (bar 1 1))
3762                         (b (bar 1 5))
3763                         (c (bar 1 15)))
3764                     (- (+ a b) c))))
3765              -3864)
3766     (test-it `(lambda ()
3767                 (labels ((sum-d (n)
3768                            (let ((m (truncate 999 n)))
3769                              (/ (* n m (1+ m)) 2))))
3770                   (- (+ (sum-d 3)
3771                         (sum-d 3))
3772                      (sum-d 3))))
3773              166833
3774              `(lambda ()
3775                 (labels ((sum-d (n)
3776                            (let ((m (truncate 999 n)))
3777                              (/ (* n m (1+ m)) 2))))
3778                   (- (+ (sum-d 3)
3779                         (sum-d 5))
3780                      (sum-d 15))))
3781              233168)))
3782
3783 (with-test (:name :regression-1.0.44.34)
3784   (compile nil '(lambda (z &rest args)
3785                  (declare (dynamic-extent args))
3786                  (flet ((foo (w v) (list v w)))
3787                    (setq z 0)
3788                    (flet ((foo ()
3789                             (foo z args)))
3790                      (declare (sb-int:truly-dynamic-extent #'foo))
3791                      (call #'foo nil))))))
3792
3793 (with-test (:name :bug-713626)
3794   (let ((f (eval '(constantly 42))))
3795     (handler-bind ((warning #'error))
3796       (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
3797
3798 (with-test (:name :known-fun-allows-other-keys)
3799   (handler-bind ((warning #'error))
3800     (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
3801     (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
3802
3803 (with-test (:name :bug-551227)
3804   ;; This function causes constraint analysis to perform a
3805   ;; ref-substitution that alters the A referred to in (G A) at in the
3806   ;; consequent of the IF to refer to be NUMBER, from the
3807   ;; LET-converted inline-expansion of MOD.  This leads to attempting
3808   ;; to CLOSE-OVER a variable that simply isn't in scope when it is
3809   ;; referenced.
3810   (compile nil '(lambda (a)
3811                   (if (let ((s a))
3812                         (block :block
3813                           (map nil
3814                                (lambda (e)
3815                                  (return-from :block
3816                                    (f (mod a e))))
3817                                s)))
3818                       (g a)))))
3819
3820 (with-test (:name :funcall-lambda-inlined)
3821   (assert (not
3822            (ctu:find-code-constants
3823             (compile nil
3824                      `(lambda (x y)
3825                         (+ x (funcall (lambda (z) z) y))))
3826             :type 'function))))
3827
3828 (with-test (:name :bug-720382)
3829   (let ((w 0))
3830     (let ((f
3831            (handler-bind (((and warning (not style-warning))
3832                            (lambda (c) (incf w))))
3833              (compile nil `(lambda (b) ((lambda () b) 1))))))
3834       (assert (= w 1))
3835       (assert (eq :error
3836                   (handler-case (funcall f 0)
3837                     (error () :error)))))))
3838
3839 (with-test (:name :multiple-args-to-function)
3840   (let ((form `(flet ((foo (&optional (x 13)) x))
3841                  (funcall (function foo 42))))
3842         #+sb-eval (*evaluator-mode* :interpret))
3843     #+sb-eval
3844     (assert (eq :error
3845                 (handler-case (eval form)
3846                   (error () :error))))
3847     (multiple-value-bind (fun warn fail)
3848         (compile nil `(lambda () ,form))
3849       (assert (and warn fail))
3850           (assert (eq :error
3851                       (handler-case (funcall fun)
3852                         (error () :error)))))))
3853
3854 ;;; This doesn't test LVAR-FUN-IS directly, but captures it
3855 ;;; pretty accurately anyways.
3856 (with-test (:name :lvar-fun-is)
3857   (dolist (fun (list
3858                 (lambda (x) (member x x :test #'eq))
3859                 (lambda (x) (member x x :test 'eq))
3860                 (lambda (x) (member x x :test #.#'eq))))
3861     (assert (equal (list #'sb-kernel:%member-eq)
3862                    (ctu:find-named-callees fun))))
3863   (dolist (fun (list
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                 (lambda (x)
3871                   (declare (notinline eq))
3872                   (member x x :test #.#'eq))))
3873     (assert (member #'sb-kernel:%member-test
3874                     (ctu:find-named-callees fun)))))
3875
3876 (with-test (:name :delete-to-delq-opt)
3877   (dolist (fun (list (lambda (x y)
3878                        (declare (list y))
3879                        (delete x y :test #'eq))
3880                      (lambda (x y)
3881                        (declare (fixnum x) (list y))
3882                        (delete x y))
3883                      (lambda (x y)
3884                        (declare (symbol x) (list y))
3885                        (delete x y :test #'eql))))
3886     (assert (equal (list #'sb-int:delq)
3887                    (ctu:find-named-callees fun)))))
3888
3889 (with-test (:name :bug-767959)
3890   ;; This used to signal an error.
3891   (compile nil `(lambda ()
3892                   (declare (optimize sb-c:store-coverage-data))
3893                   (assoc
3894                    nil
3895                    '((:ordinary . ordinary-lambda-list))))))
3896
3897 (with-test (:name :member-on-long-constant-list)
3898   ;; This used to blow stack with a sufficiently long list.
3899   (let ((cycle (list t)))
3900     (nconc cycle cycle)
3901     (compile nil `(lambda (x)
3902                     (member x ',cycle)))))
3903
3904 (with-test (:name :bug-722734)
3905   (assert (raises-error?
3906             (funcall (compile
3907                       nil
3908                       '(lambda ()
3909                         (eql (make-array 6)
3910                          (list unbound-variable-1 unbound-variable-2))))))))
3911
3912 (with-test (:name :bug-771673)
3913   (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar))))
3914   ;; Make sure the compiler doesn't use THE, and check that setf-expansions
3915   ;; work.
3916   (let ((f (compile nil `(lambda (x y)
3917                            (setf (truly-the fixnum (car x)) y)))))
3918     (let* ((cell (cons t t)))
3919       (funcall f cell :ok)
3920       (assert (equal '(:ok . t) cell)))))
3921
3922 (with-test (:name (:bug-793771 +))
3923   (let ((f (compile nil `(lambda (x y)
3924                             (declare (type (single-float 2.0) x)
3925                                      (type (single-float (0.0)) y))
3926                            (+ x y)))))
3927     (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
3928                               (values (single-float 2.0) &optional))
3929                    (sb-kernel:%simple-fun-type f)))))
3930
3931 (with-test (:name (:bug-793771 -))
3932   (let ((f (compile nil `(lambda (x y)
3933                             (declare (type (single-float * 2.0) x)
3934                                      (type (single-float (0.0)) y))
3935                            (- x y)))))
3936     (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
3937                               (values (single-float * 2.0) &optional))
3938                    (sb-kernel:%simple-fun-type f)))))
3939
3940 (with-test (:name (:bug-793771 *))
3941   (let ((f (compile nil `(lambda (x)
3942                             (declare (type (single-float (0.0)) x))
3943                            (* x 0.1)))))
3944     (assert (equal `(function ((single-float (0.0)))
3945                               (values (or (member 0.0) (single-float (0.0))) &optional))
3946                    (sb-kernel:%simple-fun-type f)))))
3947
3948 (with-test (:name (:bug-793771 /))
3949   (let ((f (compile nil `(lambda (x)
3950                             (declare (type (single-float (0.0)) x))
3951                            (/ x 3.0)))))
3952     (assert (equal `(function ((single-float (0.0)))
3953                               (values (or (member 0.0) (single-float (0.0))) &optional))
3954                    (sb-kernel:%simple-fun-type f)))))
3955
3956 (with-test (:name (:bug-486812 single-float))
3957   (compile nil `(lambda ()
3958                   (sb-kernel:make-single-float -1))))
3959
3960 (with-test (:name (:bug-486812 double-float))
3961   (compile nil `(lambda ()
3962                   (sb-kernel:make-double-float -1 0))))
3963
3964 (with-test (:name :bug-729765)
3965   (compile nil `(lambda (a b)
3966                   (declare ((integer 1 1) a)
3967                            ((integer 0 1) b)
3968                            (optimize debug))
3969                   (lambda () (< b a)))))
3970
3971 ;; Actually tests the assembly of RIP-relative operands to comparison
3972 ;; functions (one of the few x86 instructions that have extra bytes
3973 ;; *after* the mem operand's effective address, resulting in a wrong
3974 ;; offset).
3975 (with-test (:name :cmpps)
3976   (let ((foo (compile nil `(lambda (x)
3977                              (= #C(2.0 3.0) (the (complex single-float) x))))))
3978     (assert (funcall foo #C(2.0 3.0)))
3979     (assert (not (funcall foo #C(1.0 2.0))))))
3980
3981 (with-test (:name :cmppd)
3982   (let ((foo (compile nil `(lambda (x)
3983                              (= #C(2d0 3d0) (the (complex double-float) x))))))
3984     (assert (funcall foo #C(2d0 3d0)))
3985     (assert (not (funcall foo #C(1d0 2d0))))))
3986
3987 (with-test (:name :lvar-externally-checkable-type-nil)
3988   ;; Used to signal a BUG during compilation.
3989   (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
3990     (multiple-value-bind (i p) (funcall fun :start)
3991       (assert (= 2321321 i))
3992       (assert (= 8 p)))
3993     (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
3994       (assert (not i))
3995       (assert (typep e 'type-error)))))
3996
3997 (with-test (:name :simple-type-error-in-bound-propagation-a)
3998   (compile nil `(lambda (i)
3999                   (declare (unsigned-byte i))
4000                   (expt 10 (expt 7 (- 2 i))))))
4001
4002 (with-test (:name :simple-type-error-in-bound-propagation-b)
4003   (assert (equal `(FUNCTION (UNSIGNED-BYTE)
4004                             (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
4005                  (sb-kernel:%simple-fun-type
4006                   (compile nil `(lambda (i)
4007                                   (declare (unsigned-byte i))
4008                                   (cos (expt 10 (+ 4096 i)))))))))
4009
4010 (with-test (:name :fixed-%more-arg-values)
4011   (let ((fun (compile nil `(lambda (&rest rest)
4012                              (declare (optimize (safety 0)))
4013                              (apply #'cons rest)))))
4014     (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
4015
4016 (with-test (:name :bug-826970)
4017   (let ((fun (compile nil `(lambda (a b c)
4018                              (declare (type (member -2 1) b))
4019                              (array-in-bounds-p a 4 b c)))))
4020     (assert (funcall fun (make-array '(5 2 2)) 1 1))))
4021
4022 (with-test (:name :bug-826971)
4023   (let* ((foo "foo")
4024          (fun (compile nil `(lambda (p1 p2)
4025                               (schar (the (eql ,foo) p1) p2)))))
4026     (assert (eql #\f (funcall fun foo 0)))))
4027
4028 (with-test (:name :bug-738464)
4029   (multiple-value-bind (fun warn fail)
4030       (compile nil `(lambda ()
4031                       (flet ((foo () 42))
4032                         (declare (ftype non-function-type foo))
4033                         (foo))))
4034     (assert (eql 42 (funcall fun)))
4035     (assert (and warn (not fail)))))
4036
4037 (with-test (:name :bug-832005)
4038   (let ((fun (compile nil `(lambda (x)
4039                              (declare (type (complex single-float) x))
4040                              (+ #C(0.0 1.0) x)))))
4041     (assert (= (funcall fun #C(1.0 2.0))
4042                #C(1.0 3.0)))))
4043
4044 ;; A refactoring  1.0.12.18 caused lossy computation of primitive
4045 ;; types for member types.
4046 (with-test (:name :member-type-primitive-type)
4047   (let ((fun (compile nil `(lambda (p1 p2 p3)
4048                              (if p1
4049                                  (the (member #c(1.2d0 1d0)) p2)
4050                                  (the (eql #c(1.0 1.0)) p3))))))
4051     (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
4052                  #c(1.2d0 1.0d0)))))
4053
4054 ;; Fall-through jump elimination made control flow fall through to trampolines.
4055 ;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
4056 ;; reproduced below (triggered a corruption warning and a memory fault).
4057 (with-test (:name :bug-883500)
4058   (funcall (compile nil `(lambda (a)
4059                            (declare (type (integer -50 50) a))
4060                            (declare (optimize (speed 0)))
4061                            (mod (mod a (min -5 a)) 5)))
4062            1))
4063
4064 ;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
4065 #+sb-unicode
4066 (with-test (:name :bug-883519)
4067   (compile nil `(lambda (x)
4068                   (declare (type character x))
4069                   (eql x #\U0010FFFF))))
4070
4071 ;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
4072 (with-test (:name :bug-887220)
4073   (let ((incfer (compile
4074                  nil
4075                  `(lambda (vector index)
4076                     (declare (type (simple-array sb-ext:word (4))
4077                                    vector)
4078                              (type (mod 4) index))
4079                     (sb-ext:atomic-incf (aref vector index) 1)
4080                     vector))))
4081     (assert (equalp (funcall incfer
4082                              (make-array 4 :element-type 'sb-ext:word
4083                                            :initial-element 0)
4084                              1)
4085                     #(0 1 0 0)))))
4086
4087 (with-test (:name :catch-interferes-with-debug-names)
4088   (let ((fun (funcall
4089               (compile nil
4090                        `(lambda ()
4091                           (catch 'out
4092                               (flet ((foo ()
4093                                        (throw 'out (lambda () t))))
4094                                 (foo))))))))
4095     (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
4096
4097 (with-test (:name :interval-div-signed-zero)
4098   (let ((fun (compile nil
4099                       `(Lambda (a)
4100                          (declare (type (member 0 -272413371076) a))
4101                          (ffloor (the number a) -63243.127451934015d0)))))
4102     (multiple-value-bind (q r) (funcall fun 0)
4103       (assert (eql -0d0 q))
4104       (assert (eql 0d0 r)))))
4105
4106 (with-test (:name :non-constant-keyword-typecheck)
4107   (let ((fun (compile nil
4108                       `(lambda (p1 p3 p4)
4109                          (declare (type keyword p3))
4110                          (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
4111     (assert (funcall fun (cons 1.0 2.0) :test '=))))
4112
4113 (with-test (:name :truncate-wild-values)
4114   (multiple-value-bind (q r)
4115       (handler-bind ((warning #'error))
4116         (let ((sb-c::*check-consistency* t))
4117           (funcall (compile nil
4118                             `(lambda (a)
4119                                (declare (type (member 1d0 2d0) a))
4120                                (block return-value-tag
4121                                  (funcall
4122                                   (the function
4123                                        (catch 'debug-catch-tag
4124                                          (return-from return-value-tag
4125                                            (progn (truncate a)))))))))
4126                    2d0)))
4127     (assert (eql 2 q))
4128     (assert (eql 0d0 r))))
4129
4130 (with-test (:name :boxed-fp-constant-for-full-call)
4131   (let ((fun (compile nil
4132                       `(lambda (x)
4133                          (declare (double-float x))
4134                          (unknown-fun 1.0d0 (+ 1.0d0 x))))))
4135     (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
4136
4137 (with-test (:name :only-one-boxed-constant-for-multiple-uses)
4138   (let* ((big (1+ most-positive-fixnum))
4139          (fun (compile nil
4140                        `(lambda (x)
4141                           (unknown-fun ,big (+ ,big x))))))
4142     (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
4143
4144 (with-test (:name :fixnum+float-coerces-fixnum
4145             :skipped-on :x86)
4146   (let ((fun (compile nil
4147                       `(lambda (x y)
4148                          (declare (fixnum x)
4149                                   (single-float y))
4150                          (+ x y)))))
4151     (assert (not (ctu:find-named-callees fun)))
4152     (assert (not (search "GENERIC"
4153                          (with-output-to-string (s)
4154                            (disassemble fun :stream s)))))))
4155
4156 (with-test (:name :bug-803508)
4157   (compile nil `(lambda ()
4158                   (print
4159                    (lambda (bar)
4160                      (declare (dynamic-extent bar))
4161                      (foo bar))))))
4162
4163 (with-test (:name :bug-803508-b)
4164   (compile nil `(lambda ()
4165                   (list
4166                    (lambda (bar)
4167                      (declare (dynamic-extent bar))
4168                      (foo bar))))))
4169
4170 (with-test (:name :bug-803508-c)
4171   (compile nil `(lambda ()
4172                   (list
4173                    (lambda (bar &optional quux)
4174                      (declare (dynamic-extent bar quux))
4175                      (foo bar quux))))))
4176
4177 (with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
4178   (compile nil `(lambda (b c d)
4179                   (declare (type (integer -20545789 207590862) c))
4180                   (declare (type (integer -1 -1) d))
4181                   (let ((i (unwind-protect 32 (shiftf d -1))))
4182                     (or (if (= d c)  2 (= 3 b)) 4)))))
4183
4184 (with-test (:name :bug-913232)
4185   (compile nil `(lambda (x)
4186                   (declare (optimize speed)
4187                            (type (or (and (or (integer -100 -50)
4188                                               (integer 100 200)) (satisfies foo))
4189                                      (and (or (integer 0 10) (integer 20 30)) a)) x))
4190                   x))
4191   (compile nil `(lambda (x)
4192                   (declare (optimize speed)
4193                            (type (and fixnum a) x))
4194                   x)))
4195
4196 (with-test (:name :bug-959687)
4197   (multiple-value-bind (fun warn fail)
4198       (compile nil `(lambda (x)
4199                       (case x
4200                         (t
4201                          :its-a-t)
4202                         (otherwise
4203                          :somethign-else))))
4204     (assert (and warn fail))
4205     (assert (not (ignore-errors (funcall fun t)))))
4206   (multiple-value-bind (fun warn fail)
4207       (compile nil `(lambda (x)
4208                       (case x
4209                         (otherwise
4210                          :its-an-otherwise)
4211                         (t
4212                          :somethign-else))))
4213     (assert (and warn fail))
4214     (assert (not (ignore-errors (funcall fun t))))))
4215
4216 (with-test (:name :bug-924276)
4217   (assert (eq :style-warning
4218               (handler-case
4219                   (compile nil `(lambda (a)
4220                                   (cons a (symbol-macrolet ((b 1))
4221                                             (declare (ignorable a))
4222                                             :c))))
4223                 (style-warning ()
4224                   :style-warning)))))
4225
4226 (with-test (:name :bug-974406)
4227   (let ((fun32 (compile nil `(lambda (x)
4228                                (declare (optimize speed (safety 0)))
4229                                (declare (type (integer 53 86) x))
4230                                (logand (+ x 1032791128) 11007078467))))
4231         (fun64 (compile nil `(lambda (x)
4232                                (declare (optimize speed (safety 0)))
4233                                (declare (type (integer 53 86) x))
4234                                (logand (+ x 1152921504606846975)
4235                                        38046409652025950207)))))
4236     (assert (= (funcall fun32 61) 268574721))
4237     (assert (= (funcall fun64 61) 60)))
4238   (let (result)
4239     (do ((width 5 (1+ width)))
4240         ((= width 130))
4241       (dotimes (extra 4)
4242         (let ((fun (compile nil `(lambda (x)
4243                                    (declare (optimize speed (safety 0)))
4244                                    (declare (type (integer 1 16) x))
4245                                    (logand
4246                                     (+ x ,(1- (ash 1 width)))
4247                                     ,(logior (ash 1 (+ width 1 extra))
4248                                              (1- (ash 1 width))))))))
4249           (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
4250             (push (cons width extra) result)))))
4251     (assert (null result))))
4252
4253 ;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
4254 ;; uses a MOV into memory or goes through a temporary register if the
4255 ;; value is larger than a certain number of bits. Check that it respects
4256 ;; the limits of immediate arguments to the MOV instruction (if not, the
4257 ;; assembler will fail an assertion) and doesn't have sign-extension
4258 ;; problems. (The test passes fixnum constants through the MOVE VOP
4259 ;; which calls MOVE-IMMEDIATE.)
4260 (with-test (:name :constant-fixnum-move)
4261   (let ((f (compile nil `(lambda (g)
4262                            (funcall g
4263                                     ;; The first three args are
4264                                     ;; uninteresting as they are
4265                                     ;; passed in registers.
4266                                     1 2 3
4267                                     ,@(loop for i from 27 to 32
4268                                             collect (expt 2 i)))))))
4269     (assert (every #'plusp (funcall f #'list)))))
4270
4271 (with-test (:name (:malformed-ignore :lp-1000239))
4272   (raises-error?
4273    (eval '(lambda () (declare (ignore (function . a)))))
4274    sb-int:compiled-program-error)
4275   (raises-error?
4276    (eval '(lambda () (declare (ignore (function a b)))))
4277    sb-int:compiled-program-error)
4278   (raises-error?
4279    (eval '(lambda () (declare (ignore (function)))))
4280    sb-int:compiled-program-error)
4281   (raises-error?
4282    (eval '(lambda () (declare (ignore (a)))))
4283    sb-int:compiled-program-error)
4284   (raises-error?
4285    (eval '(lambda () (declare (ignorable (a b)))))
4286    sb-int:compiled-program-error))
4287
4288 (with-test (:name :malformed-type-declaraions)
4289   (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
4290
4291 (with-test (:name :compiled-program-error-escaped-source)
4292   (assert
4293    (handler-case
4294        (funcall (compile nil `(lambda () (lambda ("foo")))))
4295      (sb-int:compiled-program-error (e)
4296        (let ((source (read-from-string (sb-kernel::program-error-source e))))
4297          (equal source '#'(lambda ("foo"))))))))
4298
4299 (with-test (:name :escape-analysis-for-nlxs)
4300   (flet ((test (check lambda &rest args)
4301            (let* ((cell-note nil)
4302                   (fun (handler-bind ((compiler-note
4303                                         (lambda (note)
4304                                           (when (search
4305                                                  "Allocating a value-cell at runtime for"
4306                                                  (princ-to-string note))
4307                                             (setf cell-note t)))))
4308                           (compile nil lambda))))
4309              (assert (eql check cell-note))
4310              (if check
4311                  (assert
4312                   (eq :ok
4313                       (handler-case
4314                           (dolist (arg args nil)
4315                             (setf fun (funcall fun arg)))
4316                         (sb-int:simple-control-error (e)
4317                           (when (equal
4318                                  (simple-condition-format-control e)
4319                                  "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
4320                             :ok)))))
4321                  (ctu:assert-no-consing (apply fun args))))))
4322     (test nil `(lambda (x)
4323                  (declare (optimize speed))
4324                  (block out
4325                    (flet ((ex () (return-from out 'out!)))
4326                      (typecase x
4327                        (cons (or (car x) (ex)))
4328                        (t (ex)))))) :foo)
4329     (test t   `(lambda (x)
4330                  (declare (optimize speed))
4331                  (funcall
4332                   (block nasty
4333                     (flet ((oops () (return-from nasty t)))
4334                       #'oops)))) t)
4335     (test t   `(lambda (r)
4336                  (declare (optimize speed))
4337                  (block out
4338                    (flet ((ex () (return-from out r)))
4339                      (lambda (x)
4340                        (typecase x
4341                          (cons (or (car x) (ex)))
4342                          (t (ex))))))) t t)
4343     (test t   `(lambda (x)
4344                  (declare (optimize speed))
4345                  (flet ((eh (x)
4346                           (flet ((meh () (return-from eh 'meh)))
4347                             (lambda ()
4348                               (typecase x
4349                                 (cons (or (car x) (meh)))
4350                                 (t (meh)))))))
4351                    (funcall (eh x)))) t t)))
4352
4353 (with-test (:name (:bug-1050768 :symptom))
4354   ;; Used to signal an error.
4355   (compile nil
4356            `(lambda (string position)
4357               (char string position)
4358               (array-in-bounds-p string (1+ position)))))
4359
4360 (with-test (:name (:bug-1050768 :cause))
4361   (let ((types `((string string)
4362                  ((or (simple-array character 24) (vector t 24))
4363                   (or (simple-array character 24) (vector t))))))
4364     (dolist (pair types)
4365       (destructuring-bind (orig conservative) pair
4366         (assert sb-c::(type= (specifier-type cl-user::conservative)
4367                              (conservative-type (specifier-type cl-user::orig))))))))
4368
4369 (with-test (:name (:smodular64 :wrong-width))
4370   (let ((fun (compile nil
4371                       '(lambda (x)
4372                          (declare (type (signed-byte 64) x))
4373                          (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
4374     (assert (= (funcall fun 10038) -7033717698976955535))))
4375
4376 (with-test (:name (:smodular32 :wrong-width))
4377   (let ((fun (compile nil '(lambda (x)
4378                              (declare (type (signed-byte 31) x))
4379                              (sb-c::mask-signed-field 31 (- x 1055131947))))))
4380     (assert (= (funcall fun 10038) -1055121909))))
4381
4382 (with-test (:name :first-open-coded)
4383   (let ((fun (compile nil `(lambda (x) (first x)))))
4384     (assert (not (ctu:find-named-callees fun)))))
4385
4386 (with-test (:name :second-open-coded)
4387   (let ((fun (compile nil `(lambda (x) (second x)))))
4388     (assert (not (ctu:find-named-callees fun)))))
4389
4390 (with-test (:name :svref-of-symbol-macro)
4391   (compile nil `(lambda (x)
4392                   (symbol-macrolet ((sv x))
4393                     (values (svref sv 0) (setf (svref sv 0) 99))))))
4394
4395 ;; The compiler used to update the receiving LVAR's type too
4396 ;; aggressively when converting a large constant to a smaller
4397 ;; (potentially signed) one, causing other branches to be
4398 ;; inferred as dead.
4399 (with-test (:name :modular-cut-constant-to-width)
4400   (let ((test (compile nil
4401                        `(lambda (x)
4402                           (logand 254
4403                                   (case x
4404                                     ((3) x)
4405                                     ((2 2 0 -2 -1 2) 9223372036854775803)
4406                                     (t 358458651)))))))
4407     (assert (= (funcall test -10470605025) 26))))
4408
4409 (with-test (:name :append-type-derivation)
4410   (let ((test-cases
4411           '((lambda () (append 10)) (integer 10 10)
4412             (lambda () (append nil 10)) (integer 10 10)
4413             (lambda (x) (append x 10)) (or (integer 10 10) cons)
4414             (lambda (x) (append x (cons 1 2))) cons
4415             (lambda (x y) (append x (cons 1 2) y)) cons
4416             (lambda (x y) (nconc x (the list y) x)) t
4417             (lambda (x y) (nconc (the atom x) y)) t
4418             (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
4419             (lambda (x y) (nconc (the (or cons vector) x) y)) cons
4420             (lambda (x y) (nconc (the sequence x) y)) t
4421             (lambda (x y) (print (length y)) (append x y)) sequence
4422             (lambda (x y) (print (length y)) (append x y)) sequence
4423             (lambda (x y) (append (the (member (a) (b)) x) y)) cons
4424             (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
4425             (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
4426     (loop for (function result-type) on test-cases by #'cddr
4427           do (assert (sb-kernel:type= (sb-kernel:specifier-type
4428                                        (car (cdaddr (sb-kernel:%simple-fun-type
4429                                                      (compile nil function)))))
4430                                       (sb-kernel:specifier-type result-type))))))
4431
4432 (with-test (:name :bug-504121)
4433   (compile nil `(lambda (s)
4434                   (let ((p1 #'upper-case-p))
4435                     (funcall
4436                      (lambda (g)
4437                        (funcall p1 g))))
4438                   (let ((p2 #'(lambda (char) (upper-case-p char))))
4439                     (funcall p2 s)))))
4440
4441 (with-test (:name (:bug-504121 :optional-missing))
4442   (compile nil `(lambda (s)
4443                   (let ((p1 #'upper-case-p))
4444                     (funcall
4445                      (lambda (g &optional x)
4446                        (funcall p1 g))))
4447                   (let ((p2 #'(lambda (char) (upper-case-p char))))
4448                     (funcall p2 s)))))
4449
4450 (with-test (:name (:bug-504121 :optional-superfluous))
4451   (compile nil `(lambda (s)
4452                   (let ((p1 #'upper-case-p))
4453                     (funcall
4454                      (lambda (g &optional x)
4455                        (funcall p1 g))
4456                      #\1 2 3))
4457                   (let ((p2 #'(lambda (char) (upper-case-p char))))
4458                     (funcall p2 s)))))
4459
4460 (with-test (:name (:bug-504121 :key-odd))
4461   (compile nil `(lambda (s)
4462                   (let ((p1 #'upper-case-p))
4463                     (funcall
4464                      (lambda (g &key x)
4465                        (funcall p1 g))
4466                      #\1 :x))
4467                   (let ((p2 #'(lambda (char) (upper-case-p char))))
4468                     (funcall p2 s)))))
4469
4470 (with-test (:name (:bug-504121 :key-unknown))
4471   (compile nil `(lambda (s)
4472                   (let ((p1 #'upper-case-p))
4473                     (funcall
4474                      (lambda (g &key x)
4475                        (funcall p1 g))
4476                      #\1 :y 2))
4477                   (let ((p2 #'(lambda (char) (upper-case-p char))))
4478                     (funcall p2 s)))))
4479
4480 (with-test (:name :bug-1181684)
4481   (compile nil `(lambda ()
4482                   (let ((hash #xD13CCD13))
4483                     (setf hash (logand most-positive-word
4484                                        (ash hash 5)))))))
4485
4486 (with-test (:name (:local-&optional-recursive-inline :bug-1180992))
4487   (compile nil
4488            `(lambda ()
4489               (labels ((called (&optional a))
4490                        (recursed (&optional b)
4491                          (called)
4492                          (recursed)))
4493                 (declare (inline recursed called))
4494                 (recursed)))))
4495
4496 (with-test (:name :constant-fold-logtest)
4497   (assert (equal (sb-kernel:%simple-fun-type
4498                   (compile nil `(lambda (x)
4499                                   (declare (type (mod 1024) x)
4500                                            (optimize speed))
4501                                   (logtest x 2048))))
4502                  '(function ((unsigned-byte 10)) (values null &optional)))))
4503
4504 ;; type mismatches on LVARs with multiple potential sources used to
4505 ;; be reported as mismatches with the value NIL.  Make sure we get
4506 ;; a warning, but that it doesn't complain about a constant NIL ...
4507 ;; of type FIXNUM.
4508 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
4509   (block nil
4510     (handler-bind ((sb-int:type-warning
4511                      (lambda (c)
4512                        (assert
4513                         (not (search "Constant "
4514                                      (simple-condition-format-control
4515                                       c))))
4516                        (return))))
4517       (compile nil `(lambda (x y z)
4518                       (declare (type fixnum y z))
4519                       (aref (if x y z) 0))))
4520     (error "Where's my warning?")))
4521
4522 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
4523   (block nil
4524     (handler-bind ((style-warning
4525                      (lambda (c)
4526                        (assert
4527                         (not (position
4528                               nil
4529                               (simple-condition-format-arguments c))))
4530                        (return))))
4531       (compile nil `(lambda (x y z f)
4532                       (declare (type fixnum y z))
4533                       (catch (if x y z) (funcall f)))))
4534     (error "Where's my style-warning?")))
4535
4536 ;; Smoke test for rightward shifts
4537 (with-test (:name (:ash/right-signed))
4538   (let* ((f (compile nil `(lambda (x y)
4539                             (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4540                                      (type sb-vm:signed-word x)
4541                                      (optimize speed))
4542                             (ash x (- y)))))
4543          (max (ash most-positive-word -1))
4544          (min (- -1 max)))
4545     (flet ((test (x y)
4546              (assert (= (ash x (- y))
4547                         (funcall f x y)))))
4548       (dotimes (x 32)
4549         (dotimes (y (* 2 sb-vm:n-word-bits))
4550           (test x y)
4551           (test (- x) y)
4552           (test (- max x) y)
4553           (test (+ min x) y))))))
4554
4555 (with-test (:name (:ash/right-unsigned))
4556   (let ((f (compile nil `(lambda (x y)
4557                            (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4558                                     (type word x)
4559                                     (optimize speed))
4560                            (ash x (- y)))))
4561         (max most-positive-word))
4562     (flet ((test (x y)
4563              (assert (= (ash x (- y))
4564                         (funcall f x y)))))
4565       (dotimes (x 32)
4566         (dotimes (y (* 2 sb-vm:n-word-bits))
4567           (test x y)
4568           (test (- max x) y))))))
4569
4570 (with-test (:name (:ash/right-fixnum))
4571   (let ((f (compile nil `(lambda (x y)
4572                            (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4573                                     (type fixnum x)
4574                                     (optimize speed))
4575                            (ash x (- y))))))
4576     (flet ((test (x y)
4577              (assert (= (ash x (- y))
4578                         (funcall f x y)))))
4579       (dotimes (x 32)
4580         (dotimes (y (* 2 sb-vm:n-word-bits))
4581           (test x y)
4582           (test (- x) y)
4583           (test (- most-positive-fixnum x) y)
4584           (test (+ most-negative-fixnum x) y))))))
4585
4586 ;; expected failure
4587 (with-test (:name :fold-index-addressing-positive-offset)
4588   (let ((f (compile nil `(lambda (i)
4589                            (if (typep i '(integer -31 31))
4590                                (aref #. (make-array 63) (+ i 31))
4591                                (error "foo"))))))
4592     (funcall f -31)))
4593
4594 ;; 5d3a728 broke something like this in CL-PPCRE
4595 (with-test (:name :fold-index-addressing-potentially-negative-index)
4596   (compile nil `(lambda (index vector)
4597                   (declare (optimize speed (safety 0))
4598                            ((simple-array character (*)) vector)
4599                            ((unsigned-byte 24) index))
4600                   (aref vector (1+ (mod index (1- (length vector))))))))
4601
4602 (with-test (:name :constant-fold-ash/right-fixnum)
4603   (compile nil `(lambda (a b)
4604                   (declare (type fixnum a)
4605                            (type (integer * -84) b))
4606                   (ash a b))))
4607
4608 (with-test (:name :constant-fold-ash/right-word)
4609   (compile nil `(lambda (a b)
4610                   (declare (type word a)
4611                            (type (integer * -84) b))
4612                   (ash a b))))
4613
4614 (with-test (:name :nconc-derive-type)
4615   (let ((function (compile nil `(lambda (x y)
4616                                   (declare (type (or cons fixnum) x))
4617                                   (nconc x y)))))
4618     (assert (equal (sb-kernel:%simple-fun-type function)
4619                    '(function ((or cons fixnum) t) (values cons &optional))))))
4620
4621 ;; make sure that all data-vector-ref-with-offset VOPs are either
4622 ;; specialised on a 0 offset or accept signed indices
4623 (with-test (:name :data-vector-ref-with-offset-signed-index)
4624   (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
4625     (when dvr
4626       (assert
4627        (null
4628         (loop for info in (sb-c::fun-info-templates
4629                            (sb-c::fun-info-or-lose dvr))
4630               for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4631               unless (or (typep second-arg '(cons (eql :constant)))
4632                          (find '(integer 0 0) third-arg :test 'equal)
4633                          (equal second-arg
4634                                 `(:or ,(sb-c::primitive-type-or-lose
4635                                         'sb-vm::positive-fixnum)
4636                                       ,(sb-c::primitive-type-or-lose
4637                                         'fixnum))))
4638                 collect info))))))
4639
4640 (with-test (:name :data-vector-set-with-offset-signed-index)
4641   (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
4642     (when dvr
4643       (assert
4644        (null
4645         (loop for info in (sb-c::fun-info-templates
4646                            (sb-c::fun-info-or-lose dvr))
4647               for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4648               unless (or (typep second-arg '(cons (eql :constant)))
4649                          (find '(integer 0 0) third-arg :test 'equal)
4650                          (equal second-arg
4651                                 `(:or ,(sb-c::primitive-type-or-lose
4652                                         'sb-vm::positive-fixnum)
4653                                       ,(sb-c::primitive-type-or-lose
4654                                         'fixnum))))
4655                 collect info))))))
4656
4657 (with-test (:name :maybe-inline-ref-to-dead-lambda)
4658   (compile nil `(lambda (string)
4659                   (declare (optimize speed (space 0)))
4660                   (cond ((every #'digit-char-p string)
4661                          nil)
4662                         ((some (lambda (c)
4663                                  (digit-char-p c))
4664                                string))))))
4665
4666 ;; the x87 backend used to sometimes signal FP errors during boxing,
4667 ;; because converting between double and single float values was a
4668 ;; noop (fixed), and no doubt many remaining issues.  We now store
4669 ;; the value outside pseudo-atomic, so any SIGFPE should be handled
4670 ;; corrrectly.
4671 ;;
4672 ;; When it fails, this test lands into ldb.
4673 (with-test (:name :no-overflow-during-allocation)
4674   (handler-case (eval '(cosh 90))
4675     (floating-point-overflow ()
4676       t)))
4677
4678 ;; unbounded integer types could break integer arithmetic.
4679 (with-test (:name :bug-1199127)
4680   (compile nil `(lambda (b)
4681                   (declare (type (integer -1225923945345 -832450738898) b))
4682                   (declare (optimize (speed 3) (space 3) (safety 2)
4683                                      (debug 0) (compilation-speed 1)))
4684                   (loop for lv1 below 3
4685                         sum (logorc2
4686                              (if (>= 0 lv1)
4687                                  (ash b (min 25 lv1))
4688                                  0)
4689                              -2)))))
4690
4691 ;; non-trivial modular arithmetic operations would evaluate to wider results
4692 ;; than expected, and never be cut to the right final bitwidth.
4693 (with-test (:name :bug-1199428-1)
4694   (let ((f1 (compile nil `(lambda (a c)
4695                             (declare (type (integer -2 1217810089) a))
4696                             (declare (type (integer -6895591104928 -561736648588) c))
4697                             (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
4698                                                (compilation-speed 3)))
4699                             (logandc1 (gcd c)
4700                                       (+ (- a c)
4701                                          (loop for lv2 below 1 count t))))))
4702         (f2 (compile nil `(lambda (a c)
4703                             (declare (notinline - + gcd logandc1))
4704                             (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
4705                                                (compilation-speed 3)))
4706                             (logandc1 (gcd c)
4707                                       (+ (- a c)
4708                                          (loop for lv2 below 1 count t)))))))
4709     (let ((a 530436387)
4710           (c -4890629672277))
4711       (assert (eql (funcall f1 a c)
4712                    (funcall f2 a c))))))
4713
4714 (with-test (:name :bug-1199428-2)
4715   (let ((f1 (compile nil `(lambda (a b)
4716                             (declare (type (integer -1869232508 -6939151) a))
4717                             (declare (type (integer -11466348357 -2645644006) b))
4718                             (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
4719                                                (compilation-speed 2)))
4720                             (logand (lognand a -6) (* b -502823994)))))
4721         (f2 (compile nil `(lambda (a b)
4722                             (logand (lognand a -6) (* b -502823994))))))
4723     (let ((a -1491588365)
4724           (b -3745511761))
4725       (assert (eql (funcall f1 a b)
4726                    (funcall f2 a b))))))
4727
4728 ;; win32 is very specific about the order in which catch blocks
4729 ;; must be allocated on the stack
4730 (with-test (:name :bug-1072739)
4731   (let ((f (compile nil
4732                     `(lambda ()
4733                        (STRING=
4734                         (LET ((% 23))
4735                           (WITH-OUTPUT-TO-STRING (G13908)
4736                             (PRINC
4737                              (LET ()
4738                                (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
4739                                (HANDLER-CASE
4740                                    (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
4741                                  (UNBOUND-VARIABLE NIL
4742                                    (HANDLER-CASE
4743                                        (WITH-OUTPUT-TO-STRING (G13914)
4744                                          (PRINC %A%B% G13914)
4745                                          (PRINC "" G13914)
4746                                          G13914)
4747                                      (UNBOUND-VARIABLE NIL
4748                                        (HANDLER-CASE
4749                                            (WITH-OUTPUT-TO-STRING (G13913)
4750                                              (PRINC %A%B G13913)
4751                                              (PRINC "%" G13913)
4752                                              G13913)
4753                                          (UNBOUND-VARIABLE NIL
4754                                            (HANDLER-CASE
4755                                                (WITH-OUTPUT-TO-STRING (G13912)
4756                                                  (PRINC %A% G13912)
4757                                                  (PRINC "b%" G13912)
4758                                                  G13912)
4759                                              (UNBOUND-VARIABLE NIL
4760                                                (HANDLER-CASE
4761                                                    (WITH-OUTPUT-TO-STRING (G13911)
4762                                                      (PRINC %A G13911)
4763                                                      (PRINC "%b%" G13911)
4764                                                      G13911)
4765                                                  (UNBOUND-VARIABLE NIL
4766                                                    (HANDLER-CASE
4767                                                        (WITH-OUTPUT-TO-STRING (G13910)
4768                                                          (PRINC % G13910)
4769                                                          (PRINC "a%b%" G13910)
4770                                                          G13910)
4771                                                      (UNBOUND-VARIABLE NIL
4772                                                        (ERROR "Interpolation error in \"%a%b%\"
4773 "))))))))))))))
4774                              G13908)))
4775                         "23a%b%")))))
4776     (assert (funcall f))))
4777
4778 (with-test (:name :equal-equalp-transforms)
4779   (let* ((s "foo")
4780          (bit-vector #*11001100)
4781          (values `(nil 1 2 "test"
4782                        ;; Floats duplicated here to ensure we get newly created instances
4783                        (read-from-string "1.1") (read-from-string "1.2d0")
4784                        (read-from-string "1.1") (read-from-string "1.2d0")
4785                        1.1 1.2d0 '("foo" "bar" "test")
4786                        #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
4787                        ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
4788                        ,(make-hash-table) #\a #\b #\A #\C
4789                        ,(make-random-state) 1/2 2/3)))
4790     ;; Test all permutations of different types
4791     (assert
4792      (loop
4793        for x in values
4794        always (loop
4795                 for y in values
4796                 always
4797                 (and (eq (funcall (compile nil `(lambda (x y)
4798                                                   (equal (the ,(type-of x) x)
4799                                                          (the ,(type-of y) y))))
4800                                   x y)
4801                          (equal x y))
4802                      (eq (funcall (compile nil `(lambda (x y)
4803                                                   (equalp (the ,(type-of x) x)
4804                                                           (the ,(type-of y) y))))
4805                                   x y)
4806                          (equalp x y))))))
4807     (assert
4808      (funcall (compile
4809                nil
4810                `(lambda (x y)
4811                   (equal (the (cons (or simple-bit-vector simple-base-string))
4812                               x)
4813                          (the (cons (or (and bit-vector (not simple-array))
4814                                         (simple-array character (*))))
4815                               y))))
4816               (list (string 'list))
4817               (list "LIST")))
4818     (assert
4819      (funcall (compile
4820                nil
4821                `(lambda (x y)
4822                   (equalp (the (cons (or simple-bit-vector simple-base-string))
4823                                x)
4824                           (the (cons (or (and bit-vector (not simple-array))
4825                                          (simple-array character (*))))
4826                                y))))
4827               (list (string 'list))
4828               (list "lisT")))))
4829
4830 (with-test (:name (restart-case optimize speed compiler-note))
4831   (handler-bind ((compiler-note #'error))
4832     (compile nil '(lambda ()
4833                    (declare (optimize speed))
4834                    (restart-case () (c ()))))
4835     (compile nil '(lambda ()
4836                    (declare (optimize speed))
4837                    (let (x)
4838                      (restart-case (setf x (car (compute-restarts)))
4839                        (c ()))
4840                      x)))))
4841
4842 (with-test (:name :copy-more-arg
4843             :fails-on '(not (or :x86 :x86-64)))
4844   ;; copy-more-arg might not copy in the right direction
4845   ;; when there are more fixed args than stack frame slots,
4846   ;; and thus end up splatting a single argument everywhere.
4847   ;; Fixed on x86oids only, but other platforms still start
4848   ;; their stack frames at 8 slots, so this is less likely
4849   ;; to happen.
4850   (let ((limit 33))
4851     (labels ((iota (n)
4852                (loop for i below n collect i))
4853              (test-function (function skip)
4854                ;; function should just be (subseq x skip)
4855                (loop for i from skip below (+ skip limit) do
4856                  (let* ((values (iota i))
4857                         (f (apply function values))
4858                         (subseq (subseq values skip)))
4859                    (assert (equal f subseq)))))
4860              (make-function (n)
4861                (let ((gensyms (loop for i below n collect (gensym))))
4862                  (compile nil `(lambda (,@gensyms &rest rest)
4863                                  (declare (ignore ,@gensyms))
4864                                  rest)))))
4865       (dotimes (i limit)
4866         (test-function (make-function i) i)))))
4867
4868 (with-test (:name :apply-aref)
4869   (flet ((test (form)
4870            (let (warning)
4871              (handler-bind ((warning (lambda (c) (setf warning c))))
4872                (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
4873              (assert (not warning)))))
4874     (test `(lambda (x y) (setf (apply #'aref x y) 21)))
4875     (test `(lambda (x y) (setf (apply #'bit x y) 1)))
4876     (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
4877
4878 (with-test (:name :warn-on-the-values-constant)
4879   (multiple-value-bind (fun warnings-p failure-p)
4880       (compile nil
4881                ;; The compiler used to elide this test without
4882                ;; noting that the type demands multiple values.
4883                '(lambda () (the (values fixnum fixnum) 1)))
4884     (declare (ignore warnings-p))
4885     (assert (functionp fun))
4886     (assert failure-p)))
4887
4888 ;; quantifiers shouldn't cons themselves.
4889 (with-test (:name :quantifiers-no-consing)
4890   (let ((constantly-t (lambda (x) x t))
4891         (constantly-nil (lambda (x) x nil))
4892         (list (make-list 1000 :initial-element nil))
4893         (vector (make-array 1000 :initial-element nil)))
4894     (macrolet ((test (quantifier)
4895                  (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
4896                    `(flet ((,function (function sequence)
4897                              (,quantifier function sequence)))
4898                       (ctu:assert-no-consing (,function constantly-t list))
4899                       (ctu:assert-no-consing (,function constantly-nil vector))))))
4900       (test some)
4901       (test every)
4902       (test notany)
4903       (test notevery))))
4904
4905 (with-test (:name :propagate-complex-type-tests)
4906   (flet ((test (type value)
4907            (let ((ftype (sb-kernel:%simple-fun-type
4908                          (compile nil `(lambda (x)
4909                                          (if (typep x ',type)
4910                                              x
4911                                              ',value))))))
4912              (assert (typep ftype `(cons (eql function))))
4913              (assert (= 3 (length ftype)))
4914              (let* ((return (third ftype))
4915                     (rtype (second return)))
4916                (assert (typep return `(cons (eql values)
4917                                             (cons t
4918                                                   (cons (eql &optional)
4919                                                         null)))))
4920                (assert (and (subtypep rtype type)
4921                             (subtypep type rtype)))))))
4922     (mapc (lambda (params)
4923             (apply #'test params))
4924           `(((unsigned-byte 17) 0)
4925             ((member 1 3 5 7) 5)
4926             ((or symbol (eql 42)) t)))))
4927
4928 (with-test (:name :constant-fold-complex-type-tests)
4929   (assert (equal (sb-kernel:%simple-fun-type
4930                   (compile nil `(lambda (x)
4931                                   (if (typep x '(member 1 3))
4932                                       (typep x '(member 1 3 15))
4933                                       t))))
4934                  `(function (t) (values (member t) &optional))))
4935   (assert (equal (sb-kernel:%simple-fun-type
4936                   (compile nil `(lambda (x)
4937                                   (declare (type (member 1 3) x))
4938                                   (typep x '(member 1 3 15)))))
4939                  `(function ((or (integer 1 1) (integer 3 3)))
4940                             (values (member t) &optional)))))
4941
4942 (with-test (:name :quietly-row-major-index-no-dimensions)
4943   (assert (handler-case
4944               (compile nil `(lambda (x) (array-row-major-index x)))
4945             (warning () nil))))
4946
4947 (with-test (:name :array-rank-transform)
4948   (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
4949
4950 (with-test (:name (:array-rank-fold :bug-1252108))
4951   (let (noted)
4952     (handler-bind ((sb-ext::code-deletion-note
4953                      (lambda (x)
4954                        (setf noted x))))
4955       (compile nil
4956                `(lambda (a)
4957                   (typecase a
4958                     ((array t 2)
4959                      (when (= (array-rank a) 3)
4960                        (array-dimension a 2)))))))
4961     (assert noted)))