tests/compiler.pure.lisp

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