tests/compiler-2.pure.lisp

   1 ;;;; various compiler tests without side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;;; This file of tests was added because the tests in 'compiler.pure.lisp'
  15 ;;;; are a total hodgepodge- there is often no hugely compelling reason for
  16 ;;;; their being tests of the compiler per se, such as whether
  17 ;;;; INPUT-ERROR-IN-COMPILED-FILE is a subclass of SERIOUS-CONDITION;
  18 ;;;; in addition to which it is near impossible to wade through the
  19 ;;;; ton of nameless, slow, and noisy tests.
  20
  21 ;;;; This file strives to do better on all fronts:
  22 ;;;; the tests should be fast, named, and not noisy.
  23
  24 (enable-test-parallelism)
  25
  26 (defun compiles-with-warning (lambda)
  27   (assert (nth-value 2 (checked-compile lambda :allow-warnings t))))
  28
  29 (with-test (:name :duplicate-labels)
  30   (dolist (operator '(labels flet macrolet))
  31     (multiple-value-bind (fun warn err)
  32         (let ((*error-output* (make-broadcast-stream)))
  33           (compile nil `(lambda (x)
  34                           (declare (ignorable x))
  35                           (,operator ((f (z) z 2)
  36                                       (f (z) z 3))
  37                             (f x)))))
  38       ;; I'm not asserting on the result of calling FUN
  39       ;; because I don't really care what it is.
  40       (declare (ignore fun))
  41       (assert (and warn err)))))
  42
  43 (with-test (:name (position :derive-type))
  44   (checked-compile '(lambda (x)
  45                       (ash 1 (position (the (member a b c) x) #(a b c )))))
  46   (checked-compile '(lambda (x)
  47                       (ash 1 (position x #(a b c ))))
  48                    :allow-style-warnings t)
  49   ;; The sequence must contain a mixture of symbols and non-symbols
  50   ;; to call %FIND-POSITION. If only symbols, it makes no calls.
  51   (let ((calls (ctu:ir1-funargs '(lambda (x) (position x '(1 2 3 a b c 4 5 6 d e f g))))))
  52     ;; Assert that the default :TEST of #'EQL was strength-reduced to #'EQ
  53     (assert (equal calls '((sb-kernel:%find-position identity eq)))))
  54   (checked-compile-and-assert ()
  55       '(lambda (x)
  56         (position x '(a b c d e d c b a) :from-end t))
  57     (('a) 8)
  58     (('b) 7)))
  59
  60 (with-test (:name (ldb :recognize-local-macros))
  61   ;; Should not call %LDB
  62   (assert (equal
  63            (ctu:ir1-named-calls
  64                 '(lambda (x)
  65                    (declare (optimize speed))
  66                    (macrolet ((b () '(byte 2 2)))
  67                      (ldb (b) (the fixnum x)))))
  68            '(sb-c::check-ds-list)))) ; why does this remain in the IR?
  69
  70 (with-test (:name (dpb :eval-order :lp-1458190))
  71   (sb-int:collect ((calls))
  72     (flet ((f (new old)
  73              (dpb (progn (calls 'eval-new) new)
  74                   (progn (calls 'eval-byte) (byte 10 10))
  75                   (progn (calls 'eval-old) old))))
  76       (f 20 0)
  77       (assert (equal (calls)
  78                      '(eval-new eval-byte eval-old))))))
  79
  80 ;; Best practice treats TRULY-THE as a special operator, not a macro,
  81 ;; in a context such as (DPB X (TRULY-THE SB-KERNEL:BYTE-SPECIFIER ...) Y).
  82 ;; DPB used to expand its second argument using MACROEXPAND and lose
  83 ;; the nuance of TRULY-THE. Strictly speaking, byte-specifier is not a
  84 ;; type specifier that users are supposed to know about, so portable code
  85 ;; should not care, but this might affect internal code.
  86 (with-test (:name (dpb :inner-macro))
  87   (flet ((source-xform (sexpr)
  88            (funcall (sb-int:info :function :source-transform (car sexpr))
  89                     sexpr (sb-kernel:make-null-lexenv))))
  90     (assert (equal-mod-gensyms
  91              (source-xform
  92               '(dpb (new) (truly-the sb-kernel:byte-specifier bspec) (old)))
  93              '(let ((new (new))
  94                     (byte (truly-the sb-kernel:byte-specifier bspec)))
  95                (sb-kernel:%dpb new (byte-size byte) (byte-position byte)
  96                                (old)))))))
  97
  98 (with-test (:name :inline-satisfies-predicate)
  99   ;; If we remove the indirections in these functions,
 100   ;; this test should visibly break so that we can write a new test
 101   ;; that asserts that inlining F works in (THE (SATISFIES F) obj).
 102   (assert (equal (sb-ext:typexpand 'sb-impl::function-name)
 103                  '(satisfies sb-int:legal-fun-name-p)))
 104   (let ((f `(lambda (x) (the sb-impl::function-name x))))
 105     (assert (equal (ctu:ir1-named-calls f) '(sb-int:valid-function-name-p))))
 106   (let ((f `(lambda (x)
 107               (declare (notinline sb-int:legal-fun-name-p))
 108               (the sb-impl::function-name x))))
 109     (assert (equal (ctu:ir1-named-calls f) '(sb-int:legal-fun-name-p)))))
 110
 111 (with-test (:name (make-array :untestable-type :no-warning))
 112   (checked-compile `(lambda () (make-array '(2 2)
 113                                            :element-type `(satisfies foofa)))))
 114
 115 (with-test (:name (make-array nil :no-warning))
 116   (checked-compile '(lambda () (make-array '(2 2) :element-type nil))))
 117
 118 (with-test (:name (nth-value :huge-n :works))
 119   (flet ((return-a-ton-of-values ()
 120            (values-list (loop for i below 5000 collect i))))
 121     (assert (= (nth-value 1 (return-a-ton-of-values)) 1))
 122     (assert (= (nth-value 4000 (return-a-ton-of-values)) 4000))))
 123
 124 (with-test (:name :internal-name-p :skipped-on :sb-xref-for-internals)
 125   (assert (sb-c::internal-name-p 'sb-int:neq)))
 126
 127 (with-test (:name (:coerce-callable-to-fun :note))
 128   (flet ((try (form what)
 129            (multiple-value-bind (fun failure-p warnings style-warnings notes)
 130                (checked-compile `(lambda (x)
 131                                   (declare (optimize speed))
 132                                   (funcall ,form)))
 133              (declare (ignore fun failure-p warnings style-warnings))
 134              (assert (search (format nil "~A is not known to be" what)
 135                              (princ-to-string (first notes)))))))
 136
 137     (try '(eval `(work-with ,x)) "callable expression")
 138     (try 'x "X")
 139     ;; For this I'd accept either Z or X in the message.
 140     (try '(progn (let ((z x)) (identity z))) "X")))
 141
 142 (with-test (:name (princ-to-string :unflushable))
 143   ;; Ordinary we'll flush it
 144   (assert (not (ctu:ir1-named-calls '(lambda (x) (princ-to-string x) x))))
 145   ;; But in high safety it should be called for effect
 146   (let ((f `(lambda (x)
 147               (declare (optimize safety)) (princ-to-string x) x)))
 148     (assert (equal (ctu:ir1-named-calls f) '(princ-to-string)))))
 149
 150 (with-test (:name :space-bounds-no-consing
 151             :serial t
 152             :skipped-on :interpreter)
 153   ;; Asking for the size of a heap space should not cost anything!
 154   (ctu:assert-no-consing (sb-vm:%space-bounds :static))
 155   (ctu:assert-no-consing (sb-vm:space-bytes :static)))
 156
 157 (with-test (:name (sb-vm:map-allocated-objects :no-consing)
 158             :serial t
 159             :fails-on (or :cheneygc (not :sb-thread))
 160             :skipped-on :interpreter)
 161   (let ((n 0))
 162     (sb-int:dx-flet ((f (obj type size)
 163                        (declare (ignore obj type size))
 164                        (incf n)))
 165       (ctu:assert-no-consing
 166        (sb-vm:map-allocated-objects #'f :dynamic)
 167        5))))
 168
 169 (with-test (:name :pack-varints-as-bignum
 170                   :skipped-on :interpreter) ; too slow
 171   (dotimes (i 500) ; do some random testing this many times
 172     (let* ((random-numbers (loop repeat (+ (random 20) 3)
 173                                  collect (1+ (random 4000))))
 174            (test-list (sort (delete-duplicates random-numbers) #'<))
 175            (packed-int (sb-c:pack-code-fixup-locs test-list nil nil))
 176            (result (make-array 1 :element-type '(unsigned-byte 32))))
 177       (sb-sys:with-pinned-objects (packed-int result)
 178         ;; Now exercise the C unpacker.
 179         ;; This hack of allocating 4 longs is terrible, but whatever.
 180         (let ((unpacker (make-alien long 4))
 181               (prev-loc 0))
 182           (alien-funcall (extern-alien "varint_unpacker_init"
 183                                        (function void (* long) unsigned))
 184                          unpacker
 185                          (sb-kernel:get-lisp-obj-address packed-int))
 186           (sb-int:collect ((unpacked))
 187             (loop
 188              (let ((status
 189                     (alien-funcall
 190                      (extern-alien "varint_unpack"
 191                                    (function int (* long) system-area-pointer))
 192                      unpacker (sb-sys:vector-sap result))))
 193                (let ((val (aref result 0)))
 194                  ;; status of 0 is EOF, val = 0 means a decoded value was 0,
 195                  ;; which can't happen, so it's effectively EOF.
 196                  (when (or (eql status 0) (eql val 0)) (return))
 197                  (let ((loc (+ prev-loc val)))
 198                    (unpacked loc)
 199                    (setq prev-loc loc)))))
 200             (assert (equal (unpacked) test-list))))))))
 201
 202 (with-test (:name (symbol-value symbol-global-value :quoted-constant))
 203   (let ((f (checked-compile '(lambda () (symbol-value 'char-code-limit)))))
 204     (assert (not (ctu:find-code-constants f :type 'symbol))))
 205   (let ((f (checked-compile '(lambda () (symbol-global-value 'char-code-limit)))))
 206     (assert (not (ctu:find-code-constants f :type 'symbol)))))
 207
 208 (with-test (:name (:set symbol-value :of defglobal))
 209   (let ((s 'sb-c::*recognized-declarations*))
 210     (assert (eq (sb-int:info :variable :kind s) :global)) ; verify precondition
 211     (let ((f (checked-compile `(lambda () (setf (symbol-value ',s) nil)))))
 212       ;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE>
 213       (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))))
 214
 215 (with-test (:name :alien-linkage-table-bogosity)
 216   (let ((strings (map 'list (lambda (x) (if (consp x) (car x) x))
 217                       sb-vm::+required-foreign-symbols+)))
 218     (assert (= (length (remove-duplicates strings :test 'string=))
 219                (length strings)))))
 220
 221 (with-test (:name (:no style-warning :for inline :cl-fun))
 222   (checked-compile '(lambda (x)
 223                       (declare (optimize (speed 3)) (inline length)
 224                       (muffle-conditions compiler-note))
 225                       (length x))))
 226
 227 (with-test (:name :deleted-return-use)
 228   (checked-compile-and-assert ()
 229       `(lambda ()
 230          (block nil
 231            (return 345)
 232            (let ((a (catch 'x)))
 233              (flet ((%f (a &optional b)
 234                       a))
 235                (%f 0 (%f 123))))))
 236     (() 345)))
 237
 238 (with-test (:name :shift-right-transform-nil-type)
 239   (checked-compile-and-assert (:optimize nil)
 240       `(lambda (b c)
 241          (declare (type (integer -10 -6) c)
 242                   (optimize (debug 2)))
 243          (catch 'c
 244            (flet ((f1 (a &optional (b (shiftf b 0)) c d)
 245                     (declare (ignore a b c d))
 246                     (throw 'c 780)))
 247              (flet ((f2 (a b)
 248                       (f1 a b 0)))
 249                (ash
 250                 (f1 (if t
 251                         c
 252                         (f1 (f2 1 0) 0))
 253                     b)
 254                 (+ c))))))
 255       ((-3 -7) 780)))
 256
 257 (with-test (:name :move-lvar-result-through-unused-cast)
 258   (checked-compile-and-assert (:optimize nil)
 259       `(lambda ()
 260          (declare (optimize (debug 0)))
 261          (labels ((f (a b)
 262                     a b)
 263                   (x ()
 264                     (apply #'f (list 2 3))))
 265            (declare (notinline f))
 266            (the integer (x)))
 267          132)
 268     (() 132)))
 269
 270 (with-test (:name (:type-conflict funcall :external-lambda))
 271   (compiles-with-warning `(lambda ()
 272                             (let ((x (lambda (x) (declare (fixnum x)) x)))
 273                               (funcall x 'a)))))
 274
 275 (with-test (:name (:type-conflict :callable :external-lambda))
 276   (compiles-with-warning `(lambda ()
 277                             (let ((x (lambda (x) (declare (fixnum x)) x)))
 278                               (find-if x "abca")))))
 279
 280 (with-test (:name (:type-conflict map :result-type))
 281   (compiles-with-warning `(lambda (str)
 282                             (map 'string (lambda (x) (declare (ignore x)) nil)
 283                                  str))))
 284
 285 (with-test (:name (:type-conflict :by-name))
 286   (compiles-with-warning `(lambda (str)
 287                             (map 'string 'evenp str))))
 288
 289 (with-test (:name (:type-conflict :callable :reporting))
 290   (multiple-value-bind (fun failure-p warnings)
 291       (checked-compile '(lambda (x) (map-into (make-string 10) #'evenp x))
 292                        :allow-warnings 'warning)
 293     (declare (ignore fun))
 294     (assert failure-p)
 295     (assert (= (length warnings) 1))
 296     (search "Derived type of EVENP is"
 297             (princ-to-string (first warnings)))))
 298
 299 (with-test (:name (:type-conflict string :union-type))
 300   (compiles-with-warning `(lambda (x)
 301                             (find-if #'evenp (the string x)))))
 302
 303 (with-test (:name (:type-conflict map-into :let))
 304   (compiles-with-warning `(lambda (z)
 305                             (let ((x "abc"))
 306                               (map-into z #'evenp x)))))
 307
 308 (with-test (:name (:type-conflict map-into :result))
 309   (compiles-with-warning `(lambda (z)
 310                             (map-into (make-string 10) #'evenp z))))
 311
 312 (with-test (:name (:type-conflict complement))
 313   (assert (nth-value 3
 314                      (checked-compile
 315                       `(lambda (z)
 316                          (find z "l" :test (complement #'=)))
 317                       :allow-style-warnings t))))
 318
 319 (with-test (:name :type-across-hairy-lambda-transforms)
 320   (assert (subtypep (sb-kernel:%simple-fun-type
 321                      (checked-compile `(lambda (x) (find 1 (the vector x)))))
 322                     '(function * (values (or (integer 1 1) null) &optional)))))
 323
 324 (with-test (:name :lea-type-derivation)
 325   (checked-compile-and-assert ()
 326       `(lambda (b)
 327          (declare ((integer -3755795408964870057 -3391381516052960895)
 328                    b))
 329          (ldb (byte 22 10) (* b 9)))
 330     ((-3391381516052980893) 2826685)))
 331
 332 (with-test (:name (:unused &optional :and &key))
 333   (checked-compile-and-assert (:allow-style-warnings t)
 334       `(lambda (&optional x &key)
 335          (declare (ignore x))
 336          10)
 337     (() 10)))
 338
 339 (with-test (:name (:unknown values :coercion))
 340   (checked-compile-and-assert ()
 341       `(lambda (a)
 342          (declare (notinline values typep))
 343          (the integer (values a 2305843009213693946 a -207)))
 344     ((123) (values 123 2305843009213693946 123 -207))))
 345
 346 (with-test (:name :deleted-block-during-generate-type-checks)
 347   (checked-compile-and-assert (:allow-warnings t)
 348       `(lambda (a b)
 349          (declare (notinline min ash conjugate oddp >=))
 350          (if (and (or t (>= a)) (oddp 0))
 351              (prog2 0
 352                  0
 353                (labels ((f (a b c &key)
 354                           (declare (ignore a b c))
 355                           6965670824543402))
 356                  (f a 0 b)))
 357              (conjugate
 358               (dotimes (i 0 0)
 359                 (catch 'c
 360                   (ash
 361                    (the integer
 362                         (ignore-errors
 363                           (ignore-errors (throw 'c 1))))
 364                    (min a)))))))
 365     ((1 2) 0)))
 366
 367 (with-test (:name :block-delete-twice)
 368   (checked-compile-and-assert ()
 369       `(lambda ()
 370          (declare (notinline >=))
 371          (block nil
 372            (lambda (x &key (key (if (>= 0 1)
 373                                     (return (catch 'ct5 0)))))
 374              (declare (ignore key))
 375              x)))
 376     (() 123 :test (lambda (values expected)
 377                     (equal (multiple-value-list
 378                             (funcall (first values) (first expected)))
 379                            expected)))))
 380
 381 (with-test (:name :dead-lvars-and-stack-analysis)
 382   (checked-compile-and-assert ()
 383     `(lambda (b)
 384        (catch 'ct2
 385          (block b5
 386            (return-from b5
 387              (multiple-value-prog1 19
 388                (if (or b t)
 389                    (return-from b5 333)))))))
 390     ((11) 333)))
 391
 392 (with-test (:name :mv-call-more-values)
 393   (checked-compile-and-assert ()
 394     `(lambda (z)
 395        (multiple-value-call (lambda (&optional x y &rest args)
 396                               (declare (ignore args))
 397                               (+ y x))
 398          2 (truncate z 30)))
 399     ((2345) 80)))
 400
 401 (with-test (:name :unused-casts-at-ir2-convert)
 402   (checked-compile-and-assert ()
 403     `(lambda ()
 404        (unwind-protect 123
 405          (the integer
 406               (labels ((%f (x &key)
 407                          (declare (ignore x))
 408                          (svref #(46 32) 0)))
 409                 (unwind-protect (%f (%f 0)))))))
 410     (() 123)))
 411
 412 (with-test (:name :cmov-constants-different-primitive-type)
 413   (checked-compile-and-assert ()
 414     `(lambda (b)
 415        (case b
 416          ((2030) 4611686018427387908)
 417          ((572) b)
 418          (t 0)))
 419     ((572) 572)
 420     ((123) 0)
 421     ((2030) 4611686018427387908)))
 422
 423 (with-test (:name :mv-bind-skipping-vars-on-reoptimize)
 424   (checked-compile-and-assert ()
 425     `(lambda ()
 426        (let (lv1)
 427          (apply (lambda (&rest args)
 428                   (declare (ignore args)))
 429                 0
 430                 (list 3 lv1))
 431          (setf lv1 10)))
 432     (() 10)))
 433
 434 (with-test (:name :transform-on-a-nil-arg)
 435   (checked-compile-and-assert ()
 436    `(lambda ()
 437       (block nil
 438         (logtest
 439          (multiple-value-prog1
 440              (unwind-protect (return 32))
 441            (catch 'tag (return 33)))
 442          1)
 443         34))
 444    (() 32)))
 445
 446 (with-test (:name :nesteted-dx-deleted-uses)
 447   (checked-compile-and-assert ()
 448     `(lambda (a)
 449        (block b2
 450          (let* ((v1 (make-array nil :initial-element
 451                                 (let ((a a))
 452                                   (return-from b2 a)))))
 453            (declare (dynamic-extent v1))
 454            (aref v1))))
 455     ((342) 342)))
 456
 457 (with-test (:name :deleted-during-locall-analyze-fun-1)
 458   (checked-compile-and-assert (:allow-warnings t)
 459     `(lambda ()
 460        (flet ((a ()))
 461          (a 1)
 462          (a 2)))
 463     (() (condition 'program-error))))
 464
 465 (with-test (:name :delete-return-without-flush-dest)
 466   (assert (eql
 467            (catch 'c
 468              (funcall (checked-compile
 469                        '(lambda ()
 470                          (labels ((%f () 40))
 471                            (multiple-value-prog1 *
 472                              (throw 'c (%f))
 473                              (%f)
 474                              30))))))
 475            40)))
 476
 477 (with-test (:name :let-conversion-inside-deleted-lambda.1)
 478   (checked-compile-and-assert ()
 479     `(lambda ()
 480        (block nil
 481          (catch 'c)
 482          (flet ((f (x &key)
 483                   (when x
 484                     (progv '(*) '(0)
 485                       (return)))))
 486            (f (return 123))
 487            (f 0))))
 488     (() 123)))
 489
 490 (with-test (:name :let-conversion-inside-deleted-lambda.2)
 491   (checked-compile-and-assert ()
 492     `(lambda ()
 493        (block nil
 494          (block nil
 495            (lambda () (return)))
 496          (labels ((l () (l))
 497                   (%f (a &key)
 498                     (l)
 499                     (return a)))
 500            (%f (return 321))
 501            (%f 1))))
 502     (() 321)))
 503
 504 (with-test (:name :assignment-conversion-inside-deleted-lambda)
 505   (checked-compile-and-assert
 506    (:allow-style-warnings t)
 507    `(lambda (b)
 508       (tagbody
 509          (labels ((%f13 (&optional (f13-1 0) &key &allow-other-keys)
 510                     (declare (ignore f13-1))
 511                     b))
 512            (if nil
 513                (%f13 (go tag8))
 514                (%f13)))
 515        tag8))
 516    ((1) nil)))
 517
 518 (with-test (:name :nil-type-derived-before-assignment-conversion)
 519   (checked-compile-and-assert ()
 520    `(lambda (a)
 521       (declare (ignore a))
 522       (tagbody
 523         (labels ((f (a)
 524                    (declare (ignore a))
 525                    (go tag1)))
 526           (apply #'f 1 (list))
 527           (apply #'f (catch 'ct (go tag1)) (list)))
 528        tag1))
 529    ((1) nil)))
 530
 531 (with-test (:name :assignment-convert-untail-outside-calls)
 532   (checked-compile-and-assert ()
 533    `(lambda ()
 534       (flet ((%f17 (&optional f17-1)
 535                (declare (ignore f17-1))
 536                (block block608
 537                  (block block606
 538                    (flet ((h0 ()
 539                             (return-from block606)))
 540                      (declare (dynamic-extent #'h0))
 541                      (return-from block608
 542                        (progn
 543                          (print #'h0 (make-broadcast-stream))
 544                          nil)))))))
 545         (when nil (%f17))
 546         (if t
 547             (%f17)
 548             (when nil
 549               (%f17)))))
 550     (() nil)))
 551
 552 (with-test (:name :assignment-convert-lambda-with-deleted-bind-block)
 553   (checked-compile-and-assert ()
 554    `(lambda ()
 555       (flet ((%f5 ()
 556                (flet ((%f2 (&optional (f2-2 (return-from %f5 1)))
 557                         0))
 558                  (let ((g624 1))
 559                    (cond ((eql g624 '1)
 560                           (%f2))
 561                          ((eql g624 '2)
 562                           (%f2)))))))
 563         0))
 564     (() 0)))
 565
 566 (with-test (:name :unconvert-tail-calls)
 567   (checked-compile-and-assert ()
 568     `(lambda ()
 569        (block nil
 570          (labels ((f (&optional (a (return))
 571                                 (b (if t (return)))
 572                                 c
 573                       &rest args)
 574                     (declare (ignore a b c args))
 575                     (return 0)))
 576            (let (x)
 577              (equal 10 (f 0 3))
 578              (f 123 0 0)
 579              (f 0)
 580              x))))
 581     (() 0)))
 582
 583 (with-test (:name :deleting-exits-with-multiple-users)
 584   (checked-compile-and-assert ()
 585     `(lambda (a b)
 586        (block nil
 587          (multiple-value-prog1 b
 588            (tagbody (return (multiple-value-prog1 3
 589                               (if a (go z)))) z))))
 590     ((nil :good) 3)
 591     ((t :good) :good)))
 592
 593 (with-test (:name :merge-tail-sets-deleted-functional)
 594   (checked-compile-and-assert ()
 595     `(lambda (a)
 596        (block nil
 597          (tagbody
 598             (go g549)
 599           g549
 600             (return-from nil
 601               (block b3
 602                 (let ((x (progn (lambda (&optional (x a)) x)
 603                                 (unwind-protect 10)
 604                                 (return-from b3 a))))
 605                   (unwind-protect x)))))))
 606     ((321) 321)))
 607
 608 (with-test (:name :float-remainders-rounding-errors)
 609   (loop for fun in '(ceiling truncate floor
 610                      fceiling ftruncate ffloor
 611                      round fround)
 612         do
 613         (assert (member (second
 614                          (third (sb-kernel:%simple-fun-type
 615                                  (checked-compile
 616                                   `(lambda (x)
 617                                      (nth-value 1 (,fun (the double-float x) 1/2)))))))
 618                         '(double-float real)))))
 619
 620 (with-test (:name :complex-float-contagion)
 621   (checked-compile-and-assert ()
 622     `(lambda (p1)
 623        (declare (type (or double-float integer) p1))
 624        (complex p1 2.0))
 625     ((1d0) #c(1d0 2d0))))
 626
 627 (with-test (:name :equal-transform-member-types)
 628   (let* ((s1 "abc")
 629          (s2 (copy-seq s1)))
 630     (checked-compile-and-assert ()
 631       `(lambda (p1 p2)
 632          (declare (type (member ,s1) p1)
 633                   (type (member ,s2 #*10) p2))
 634          (equal p1 p2))
 635       ((s1 s2) t))))
 636
 637 (with-test (:name :equalp-transform-numeric-types)
 638   (checked-compile-and-assert ()
 639     `(lambda (p1 p2)
 640        (declare (type (or fixnum list) p1)
 641                 (type double-float p2))
 642        (equalp p1 p2))
 643     ((1 1d0) t)))
 644
 645 (with-test (:name :equalp-transform-zero-array)
 646   (checked-compile-and-assert ()
 647     `(lambda (a b)
 648        (declare (simple-string a)
 649                 (simple-bit-vector b))
 650        (equalp a b))
 651     (("" #*) t)))
 652
 653 (with-test (:name :equalp-transform-zero-string)
 654   (checked-compile-and-assert
 655    ()
 656    `(lambda (a)
 657       (equalp "" a))
 658    ((#*) t)
 659    ((#()) t)))
 660
 661 (with-test (:name :fill-transform-returning-array-data)
 662   (let ((vector (make-array 10 :fill-pointer 2)))
 663     (checked-compile-and-assert ()
 664       `(lambda (v)
 665            (declare (type (vector t) v))
 666            (fill v nil))
 667       ((vector) vector))))
 668
 669 (with-test (:name :missing-error-context)
 670   (flet ((run ()
 671           (let ((string
 672                  (with-output-to-string (*error-output*)
 673                    (compile nil '(sb-int:named-lambda bob () (otherfun) 3)))))
 674             (assert (search "in: SB-INT:NAMED-LAMBDA BOB" string)))))
 675     (run)
 676     ;; Unrepeatability is confusing:
 677     ;; The first compiler invocation used to leave *last-format-string*
 678     ;; with a toplevel value, so the second would not print enough context
 679     ;; because the format control and args were the same.
 680     (run)))
 681
 682 (with-test (:name :cast-deletion-notes)
 683   (checked-compile-and-assert
 684       (:allow-notes nil)
 685       `(lambda (m)
 686          (setf m (list 1 2 3))
 687          (the simple-vector
 688               (coerce m 'vector)))
 689     ((nil) #(1 2 3) :test #'equalp)))
 690
 691 (with-test (:name :cast-deletion-notes.2)
 692   (multiple-value-bind (fun fail warn style notes)
 693       (checked-compile
 694        `(lambda (m)
 695           (setf m (list 1 2 3))
 696           (the simple-vector
 697                (if (vectorp m)
 698                    m
 699                    #(1)))))
 700     (declare (ignore fail warn style))
 701     (assert (equalp (funcall fun nil)
 702                     #(1)))
 703     (assert (= (length notes) 1))
 704     (assert (typep (car notes) 'code-deletion-note))))
 705
 706 (with-test (:name :array-call-type-deriver)
 707   (checked-compile-and-assert
 708       ()
 709       `(lambda (vector)
 710          (funcall (the (function (t t)) #'aref)
 711                   vector
 712                   0))
 713     (((vector 333)) 333)))
 714
 715 (with-test (:name :function-designator-cast-removal)
 716   (let ((fun (checked-compile
 717               `(lambda (vectors x)
 718                  (declare (list vectors x))
 719                  (map 'list #'svref vectors x)))))
 720     (assert (notany (lambda (c)
 721                       (typecase c
 722                         (sb-kernel:fdefn
 723                          (eq (sb-c::fdefn-name c) 'svref))
 724                         (function
 725                          (eq c #'svref))))
 726                     (ctu:find-code-constants fun)))
 727     (assert (equal (funcall fun '(#(44)) '(0)) '(44)))))
 728
 729 (with-test (:name :zombie-casts)
 730   (checked-compile-and-assert
 731       ()
 732       `(lambda ()
 733          (flet ((f (a b)
 734                   (declare (ignore a))
 735                   b))
 736            (multiple-value-call #'f
 737              (values (the integer (unwind-protect (f 10 20)))
 738                      322))))
 739     (() 322)))
 740
 741 (with-test (:name :zombie-casts.2)
 742   (let ((sb-c::*max-optimize-iterations* 1))
 743     (checked-compile-and-assert
 744         ()
 745         `(lambda (a b)
 746            (declare (type fixnum a b))
 747            (elt '(167992664 119771479)
 748                 (max 0
 749                      (catch 'ct2
 750                        (if (typep b '(integer -52))
 751                            a
 752                            0)))))
 753       ((1 2) 119771479))))
 754
 755
 756 (with-test (:name :find-dfo-on-deleted-lambda)
 757   (assert (= (funcall
 758               (funcall (checked-compile
 759                         `(lambda ()
 760                            (declare (notinline <))
 761                            (block nil
 762                              (lambda (&key (key
 763                                             (unwind-protect
 764                                                  (if (< 0)
 765                                                      34
 766                                                      (return (catch 'c))))))
 767                                key))))))
 768              34)))
 769
 770 (with-test (:name :ir1-ir2-dead-code-consistency)
 771   (checked-compile-and-assert
 772       ()
 773       `(lambda ()
 774          (loop for x below 2
 775                count (zerop (min x x x x x x x x x x))))
 776     (() 1)))
 777
 778 (with-test (:name :ir1-ir2-dead-code-consistency)
 779   (checked-compile-and-assert
 780       ()
 781       `(lambda ()
 782          (loop for x below 2
 783                count (zerop (min x x x x x x x x x x))))
 784     (() 1)))
 785
 786 (with-test (:name (setf svref :constant-modification))
 787   (assert
 788    (= (length (nth-value 2
 789                          (checked-compile
 790                           `(lambda (x)
 791                              (setf (svref #(a b c) 1) x))
 792                           :allow-warnings 'sb-int:constant-modified)))
 793             1)))
 794
 795 (with-test (:name (debug :constant-modification))
 796   (assert
 797    (= (length (nth-value 2
 798                          (checked-compile
 799                           `(lambda (x)
 800                              (declare (optimize (debug 2)))
 801                              (let ((m "abc"))
 802                                (delete x m)))
 803                           :allow-warnings 'sb-int:constant-modified)))
 804       1)))
 805
 806 (with-test (:name (debug :constant-modification.2))
 807   (assert
 808    (= (length (nth-value 2
 809                          (checked-compile
 810                           `(lambda (x)
 811                              (declare (optimize (debug 2)))
 812                              (let ((m (if x
 813                                           "abc"
 814                                           "fgh")))
 815                                (delete x m)))
 816                           :allow-warnings 'sb-int:constant-modified)))
 817       1)))
 818
 819 (with-test (:name (debug :unused-tn-long-arglist))
 820   (checked-compile-and-assert
 821       ()
 822       `(lambda (n x)
 823          (declare (sb-vm:word n))
 824          (log (float n))
 825          (nth-value 33 (funcall x . #.(loop for i to 35 collect i))))
 826     ((10 (lambda (&rest args) (values-list args))) 33)))
 827
 828 (with-test (:name (debug :unused-tn-very-long-arglist))
 829   (checked-compile-and-assert
 830       ()
 831       `(lambda (n x)
 832          (declare (sb-vm:word n))
 833          (log (float n))
 834          (nth-value 33 (funcall x . #.(loop for i to 350 collect i))))
 835     ((10 (lambda (&rest args) (values-list args))) 33)))
 836
 837 (with-test (:name (dynamic-extent :recursive-local-functions))
 838   (checked-compile
 839    `(lambda ()
 840       (let ((s (labels ((%f () (%f)))
 841                  (%f))))
 842         (declare (dynamic-extent s))
 843         (car s)))))
 844
 845 (with-test (:name (:ctypep :hairy-types))
 846   (checked-compile
 847    `(lambda ()
 848       (the (cons (satisfies error)) '("a"))))
 849   (assert
 850    (nth-value 3
 851               (checked-compile
 852                `(lambda () (the (array abc) #()))
 853                :allow-style-warnings t))))
 854
 855 (with-test (:name (catch :evaluate-tag-before-%catch))
 856   (checked-compile-and-assert
 857       (:allow-style-warnings t)
 858       `(lambda (z)
 859          (catch (multiple-value-call #'+
 860                   (if z 1 (values 1 2)))
 861            :done))
 862     ((t) :done)
 863       ((nil) :done)))
 864
 865 (with-test (:name :nested-catch-progv-compile)
 866   (checked-compile
 867    `(lambda (a b)
 868       (catch 'ct
 869         (flet ((f (x &key) x (throw 'ct b)))
 870           (dotimes (i 1)
 871             (if (< (progv '() (f a) 1) a)
 872                 a
 873                 (catch 'ct (f a)))))))))
 874
 875 (with-test (:name (tagbody :tag-dynamic-extent))
 876   (checked-compile-and-assert
 877    (:optimize '(:safety 3 :debug 2))
 878    `(lambda (b)
 879       (declare (optimize (safety 3) (debug 2)))
 880       (tagbody
 881          (labels ((f (x &key) x (go tag6)))
 882            (tagbody
 883               (catch 'ct2 (f b))
 884             2)
 885            (dotimes (i 1) (f 1))
 886            -1)
 887        tag6))
 888    ((1) nil)))
 889
 890 (with-test (:name :fewer-cast-conversions)
 891   (multiple-value-bind (fun failed)
 892       (checked-compile
 893        `(lambda ()
 894           (let* ((v (cons 0 (catch 'ct (the integer nil)))))
 895             (declare (dynamic-extent v))
 896             (flet ((%f (x) x))
 897               (%f (cdr v)))))
 898        :allow-warnings t)
 899     (assert failed)
 900     (handler-bind ((error (lambda (c) c (throw 'ct 33))))
 901       (assert (= (funcall fun) 33)))))
 902
 903 (with-test (:name :constant-folding-with-callable-args)
 904   (checked-compile '(lambda () (count #'%f '(a)))
 905                    :allow-style-warnings t))
 906
 907 (with-test (:name :flushable-with-callable-args)
 908   (assert (not (ctu:ir1-named-calls
 909                 '(lambda (y) (let ((x (count y '(1 2 3))))
 910                             (declare (ignore x))))))))
 911
 912 (with-test (:name (remove :count))
 913   (checked-compile-and-assert
 914    ()
 915    `(lambda (x)
 916       (remove x "aaa" :count 2))
 917    ((#\a) "a"))
 918   (checked-compile-and-assert
 919    ()
 920    `(lambda (x)
 921       (remove-if (lambda (y) (eql y x)) "aaa" :count 2))
 922    ((#\a) "a")))
 923
 924 (with-test (:name (:constant-fold :allow-other-keys))
 925   (checked-compile-and-assert
 926    ()
 927    `(lambda (x)
 928       (reduce #'+ '(1 2 3)  :allow-other-keys t :bad x))
 929    ((1) 6)))
 930
 931 (with-test (:name (:constant-fold :allow-other-keys.2))
 932   (checked-compile-and-assert
 933    ()
 934    `(lambda (x)
 935       (reduce #'+ '(1 2 3)  :allow-other-keys x))
 936    ((1) 6)))
 937
 938 (with-test (:name (:constant-fold :repeat-keys))
 939   (checked-compile-and-assert
 940    ()
 941    `(lambda (x)
 942       (member nil '(1 2 3) :key #'evenp :key x))
 943    ((1) '(1 2 3) :test #'equal)))
 944
 945
 946
 947 (with-test (:name :function-and-instance-primitive-type)
 948   (checked-compile-and-assert
 949       ()
 950       `(lambda (f)
 951          (declare (function f))
 952          (the standard-object f)
 953          (funcall f #'list t))
 954     ((#'documentation) (documentation #'list t))))
 955
 956 (with-test (:name :mv-call-safety-0)
 957   (checked-compile-and-assert
 958       ()
 959       `(lambda (a)
 960          (flet ((%f1 (x y) (+ x y)))
 961            (apply #'%f1 a (list 0))))
 962     ((3) 3)))
 963
 964 (with-test (:name :cast-type-check-external)
 965   (checked-compile-and-assert
 966       ()
 967       `(lambda (x)
 968          (declare (notinline +))
 969          (gcd
 970           (loop for lv2 below 1
 971                 count (logbitp 0
 972                                (if x
 973                                    (return x)
 974                                    1)))
 975           0))
 976     ((334) 334)))
 977
 978 (with-test (:name :flush-combination-non-fun-type)
 979   (checked-compile-and-assert
 980       ()
 981       `(lambda ()
 982          (rassoc-if-not #'values '((1 . a)) :allow-other-keys t)
 983          1)
 984     (() 1)))
 985
 986 (with-test (:name :symeval-nil)
 987   (checked-compile-and-assert
 988       ()
 989       `(lambda ()
 990          (symbol-value nil))
 991     (() nil)))
 992
 993 (with-test (:name (:environment-analyze :deleted-lambda))
 994   (checked-compile-and-assert
 995       ()
 996       `(lambda (log)
 997          (loop for str in nil
 998                for i from 0
 999                do
1000                (ignore-errors (format log ""))))
1001     ((t) nil)))
1002
1003 (with-test (:name (:ensure-lvar-fun-form :lvar-uses))
1004   (checked-compile-and-assert
1005       ()
1006       `(lambda (op) (funcall (case op (equal '=) (t '=)) 1 2))
1007     (('equal) nil)
1008     ((t) nil)))
1009
1010 (with-test (:name :substitute-let-funargs-during-find-initial-dfo)
1011   (checked-compile
1012    `(lambda ()
1013       (labels ((%r (f)
1014                  (loop)
1015                  (%r f)))
1016         (%r (lambda ()))))))
1017
1018 (with-test (:name :split-ir2-blocks-cmov)
1019   (checked-compile-and-assert
1020       ()
1021       `(lambda ()
1022          (let ((v (list 0)))
1023            (if (block nil
1024                  (eq v (cdr v)))
1025                1
1026                2)))
1027     (() 2)))
1028
1029 (with-test (:name :=-rational-complex-rational-fold)
1030   (let ((fun (checked-compile '(lambda (x)
1031                                 (declare ((complex integer) x))
1032                                 (= x 10))))
1033         (fun2 (checked-compile '(lambda (x)
1034                                 (declare ((complex rational) x))
1035                                 (= x 10d0)))))
1036     (assert (equal (sb-kernel:%simple-fun-type fun)
1037                    '(function ((complex integer)) (values null &optional))))
1038     (assert (not (funcall fun #C(10 10))))
1039     (assert (equal (sb-kernel:%simple-fun-type fun2)
1040                    '(function ((complex rational)) (values null &optional))))
1041     (assert (not (funcall fun2 #C(10 10))))))
1042
1043 (with-test (:name (:numeric float rational :contagion))
1044   (flet ((check (operator type argument)
1045            (let ((fun (checked-compile
1046                        `(lambda (x)
1047                           (declare (type ,type x))
1048                           ,(ecase argument
1049                              (1 `(,operator x 1/2))
1050                              (2 `(,operator 1/2 x)))))))
1051              (assert (null (ctu:find-code-constants fun :type 'ratio))))))
1052     (dolist (operator '(+ * / - = < > <= >=))
1053       (dolist (type '(single-float double-float))
1054         (check operator type 1)
1055         (check operator type 2)
1056         (when (member operator '(+ * / - =))
1057           (check operator `(complex ,type) 1)
1058           (check operator `(complex ,type) 2))))))
1059
1060 (with-test (:name (:numeric float float :contagion))
1061   (flet ((check (operator type argument)
1062            (let ((fun (checked-compile
1063                        `(lambda (x)
1064                           (declare (type ,type x))
1065                           ,(ecase argument
1066                              (1 `(,operator x 1.0f0))
1067                              (2 `(,operator 1.0f0 x)))))))
1068              (assert (null (ctu:find-code-constants fun :type 'single-float))))))
1069     (dolist (operator '(+ * / - = < > <= >=))
1070       (check operator 'double-float 1)
1071       (check operator 'double-float 2)
1072       (when (member operator '(+ * / - =))
1073         (check operator '(complex double-float) 1)
1074         (check operator '(complex double-float) 2)))))
1075
1076 (with-test (:name :find-type-deriver)
1077   (checked-compile-and-assert
1078       ()
1079       `(lambda (x)
1080          (find 1 x :key #'values))
1081     (('(1)) 1)))
1082
1083 (with-test (:name :tail-call-ltn-annotation)
1084   (checked-compile-and-assert
1085       ()
1086       `(lambda (x)
1087          (labels ((ff1 ()
1088                     (multiple-value-call #'print
1089                       (if x
1090                           (values t t)
1091                           nil))
1092                     (ff1)))
1093            (identity (ff1))))))
1094
1095 (with-test (:name (:substitute-lvar-uses :deleted-code-and-dx-lvars))
1096   (assert (nth-value 1
1097                      (checked-compile
1098                       `(lambda ()
1099                          (let ((v (values
1100                                    (the integer
1101                                         (flet ((%f5 (x) x))
1102                                           (%f5)))
1103                                    (unwind-protect 1))))
1104                            (declare (dynamic-extent v))
1105                            v))
1106                       :allow-warnings t))))
1107
1108 (with-test (:name (restart-case :declaration-processing))
1109   (checked-compile-and-assert
1110       ()
1111       `(lambda ()
1112          (restart-case (list)
1113            (my-restart (x) "foo" "bar" x)))
1114     (() ()))
1115   (checked-compile-and-assert
1116       ()
1117       `(lambda ()
1118          (restart-case (list)
1119            (my-restart () (declare))))
1120     (() ())))
1121
1122 (with-test (:name (handler-case :declaration-processing))
1123   (checked-compile-and-assert
1124       ()
1125       `(lambda ()
1126          (handler-case (list 1 2) (error (e) "foo" "bar" e)))
1127     (() '(1 2)))
1128   (assert (nth-value 1
1129                      (checked-compile
1130                       `(lambda ()
1131                          (handler-case (declare)))
1132                       :allow-failure t))))
1133
1134 (with-test (:name (:unconvert-tail-calls :deleted-call))
1135   (assert (nth-value 1
1136                      (checked-compile
1137                       '(lambda ()
1138                         (labels ((%f (&optional (x (* 2 nil (%f)))) x))
1139                           (%f)
1140                           (%f 1)))
1141                       :allow-warnings t))))
1142
1143 (with-test (:name (:equal-transform :nil-types))
1144   (assert (nth-value 1
1145                      (checked-compile
1146                       '(lambda ()
1147                         (loop for y below 3
1148                               count (or
1149                                      (not (or (>= y y) (equal y -787357528)))
1150                                      (the integer (or (>= y y) (equal y -787357528))))))
1151                       :allow-warnings t))))
1152
1153
1154
1155 (with-test (:name (:delete-recursive-optional))
1156   (checked-compile '(lambda (x)
1157                      (lambda ()
1158                        (labels ((f (&optional a) (values x a #'f))))))))
1159
1160 (with-test (:name (:combination-args-flow-cleanly-p :unused-result))
1161   (checked-compile-and-assert
1162       ()
1163       `(lambda ()
1164          (let ((v (flet ((%f (x)
1165                            (list x)
1166                            (list 1)))
1167                     (%f 2))))
1168            (declare (dynamic-extent v))
1169            (car v)))
1170     (() 1)))
1171
1172 (with-test (:name (:delete-ref :maintain-lambda-calls-or-closes))
1173   (checked-compile `(lambda (c y)
1174                       (labels ((f1 ()
1175                                  (if y
1176                                      (f3 2)))
1177                                (l () (loop))
1178                                (f2 ()
1179                                  (l)
1180                                  (f3 3))
1181                                (f3 (x)
1182                                  (f3 x))
1183                                (f4 ()
1184                                  (f1)
1185                                  (f2)))
1186                         (f4)
1187                         c))))
1188
1189 (with-test (:name (the :nil-type))
1190   (checked-compile
1191    `(lambda ()
1192       (flet ((f () (the nil 0)))
1193         (oddp (f))))))
1194
1195 (with-test (:name :concatenate-transform-hairy-type)
1196   (checked-compile
1197       '(lambda (x)
1198         (concatenate '(and string (satisfies eval)) x))))
1199
1200 (with-test (:name :make-array-transform-deletion-notes)
1201   (checked-compile
1202    `(lambda (vector)
1203       (let* ((length (length vector))
1204              (new (make-array length :adjustable t
1205                                      :fill-pointer length)))
1206         new))
1207    :allow-notes nil))
1208
1209 (with-test (:name :ltn-analyze-cast-unlink)
1210   (assert (nth-value 1 (checked-compile
1211                         `(lambda (n)
1212                            (* 2 n)
1213                            (let ((p (make-array n :element-type 'double-float)))
1214                              (dotimes (i n)
1215                                (setf (aref p i)
1216                                      (ignore-errors i)))))
1217                         :allow-warnings t))))
1218
1219 (with-test (:name :call-type-validation)
1220   (checked-compile
1221    `(lambda ()
1222       (funcall (the (or cons function) *debugger-hook*)))))
1223
1224 (with-test (:name :setf-schar-hairy-types)
1225   (checked-compile-and-assert
1226       ()
1227       `(lambda (s v)
1228          (setf (schar (the (satisfies eval) s) 0) v)
1229          s)
1230     (((copy-seq "abc") #\m) "mbc" :test #'equal)))
1231
1232 (with-test (:name :replace-zero-elements)
1233   (checked-compile-and-assert
1234       ()
1235       '(lambda (x)
1236         (declare ((simple-vector 2) x))
1237         (replace x x :start1 2))
1238     (((vector 1 2)) #(1 2) :test #'equalp))
1239   (checked-compile-and-assert
1240       ()
1241       '(lambda (x)
1242         (replace x x :start1 2))
1243     (((vector 1 2)) #(1 2) :test #'equalp)))
1244
1245 (with-test (:name :error-in-xep)
1246   (checked-compile-and-assert
1247       (:optimize :safe)
1248       '(lambda (x)
1249         (declare (type (satisfies error) x))
1250         x)
1251     (("") (condition 'error))))
1252
1253 (with-test (:name :lifetime-analyze-tn-overflow-unused-tns)
1254   (checked-compile-and-assert
1255    ()
1256    `(lambda (x)
1257       (multiple-value-bind (a b c)
1258           (funcall x 1 2 3 ,@(make-list 58))
1259         (declare (ignore b))
1260         (values a c)))
1261    ((#'values) (values 1 3))))
1262
1263 (with-test (:name :constraints-not-enough-args)
1264   (checked-compile-and-assert
1265    ()
1266    `(lambda (list)
1267       (delete-if #'> (the list list)))
1268    (((list 1)) nil)))
1269
1270 (with-test (:name :%coerce-callable-for-call-removal-order-mv-call)
1271   (checked-compile-and-assert
1272       ()
1273       `(lambda (fun args)
1274          (loop
1275           (let ((result (apply fun args)))
1276             (when result
1277               (return result))
1278             (setf args result))))
1279     (('list '(1)) '(1) :test #'equal)))
1280
1281 (with-test (:name :constraint-loop)
1282   (checked-compile-and-assert
1283       ()
1284       `(lambda (a b)
1285          (check-type a list)
1286          (when a
1287            (mapcar #'identity a)
1288            (loop for c from 0 do (loop for d in b do
1289                                        (loop for e in a)))))))
1290
1291 (with-test (:name :primitive-type-fun-designator)
1292   (checked-compile-and-assert
1293       ()
1294       `(lambda  (fun)
1295          (map 'vector fun '(1 2 3)))
1296     (('1+) #(2 3 4) :test #'equalp)))
1297
1298 (with-test (:name :mv-call-lambda-type-derivation)
1299   (assert
1300    (equal (sb-kernel:%simple-fun-type
1301            (checked-compile
1302             '(lambda (x)
1303               (multiple-value-call
1304                   (lambda () 133)
1305                 (funcall x)))))
1306           '(function (t) (values (integer 133 133) &optional)))))
1307
1308 (with-test (:name :mv-call-lambda-type-derivation.closure)
1309   (assert
1310    (equal (sb-kernel:%simple-fun-type
1311            (checked-compile
1312             '(lambda (x)
1313               (multiple-value-call
1314                   (lambda () (print x) 133)
1315                 (funcall x)))))
1316           '(function (t) (values (integer 133 133) &optional)))))
1317
1318 (with-test (:name :constant-folding-and-hairy-types)
1319   (checked-compile-and-assert
1320       ()
1321       '(lambda ()
1322         (> 0 (the (satisfies eval) (- 1))))
1323     (() t)))
1324
1325 (with-test (:name :type-approximate-interval-and-hairy-types)
1326   (checked-compile-and-assert
1327       ()
1328       '(lambda (x)
1329         (declare (fixnum x))
1330         (<= (the (satisfies eval) 65) x))
1331     ((66) t)))
1332
1333 (with-test (:name :remove-equivalent-blocks-constraints)
1334   (checked-compile-and-assert
1335       ()
1336       `(lambda (c)
1337          (declare (integer c))
1338          (= (case c
1339               ((-10) (abs c))
1340               (t c))
1341             -1))
1342     ((-1) t)))
1343
1344 (with-test (:name :typep-singleton-intersect-types)
1345   (checked-compile-and-assert
1346       ()
1347       `(lambda ()
1348          (keywordp t))
1349     (() nil)))
1350
1351 (with-test (:name :constants-and-cmp)
1352   (checked-compile-and-assert
1353       ()
1354       '(lambda (l)
1355         (declare (fixnum l))
1356         (let ((v 0))
1357           (labels ((change ()
1358                      (setf v 10)
1359                      #'change))
1360             (> v l))))
1361     ((1) nil))
1362   (checked-compile-and-assert
1363       ()
1364       '(lambda (l)
1365         (declare (fixnum l))
1366         (let ((v 0))
1367           (labels ((change ()
1368                      (setf v 10)
1369                      #'change))
1370             (> l v))))
1371     ((1) t)))
1372
1373 (with-test (:name :inlining-and-substituted-block-lvars)
1374   (checked-compile-and-assert
1375       ()
1376       `(lambda ()
1377          (let ((z (block nil
1378                     (labels ((f (x)
1379                                (return x)))
1380                       (declare (inline f))
1381                       (funcall (the function #'f) t)
1382                       (funcall (the function #'f) t)))))
1383            (and z
1384                 1)))
1385     (() 1)))
1386
1387 (with-test (:name :inlining-reanlyzing-optionals)
1388   (checked-compile-and-assert
1389       ()
1390       `(lambda ()
1391          (labels ((w (x)
1392                     x
1393                     #'s)
1394                   (fun2 (f x)
1395                     (funcall f x))
1396                   (s (&optional x)
1397                     (fun2 #'w x)))
1398            (declare (inline w))
1399            (s)))))
1400
1401 (with-test (:name :vector-fill/t-fast-safe)
1402   (let ((sb-c::*policy-min* sb-c::*policy-min*))
1403     (sb-ext:restrict-compiler-policy 'safety 1)
1404     (checked-compile-and-assert
1405      ()
1406      '(lambda ()
1407        (make-array 2 :initial-element 10))
1408      (() #(10 10) :test #'equalp))))
1409
1410 (with-test (:name :deleted-tail-sets)
1411   (checked-compile-and-assert
1412    ()
1413    '(lambda ()
1414      (labels ((f (&optional (a (catch t 6))
1415                             (b (error ""))
1416                             (c (unwind-protect 1)))
1417                 (+ a b c)))
1418        (unwind-protect (f 4))))
1419    (() (condition 'error))))
1420
1421 ;;; The SLEEP source transform barfed on float positive infinity
1422 ;;; values.
1423 (with-test (:name (compile sleep float :infinity :lp-1754081))
1424   (checked-compile '(lambda () (sleep single-float-positive-infinity)))
1425   (checked-compile '(lambda () (sleep double-float-positive-infinity))))
1426 ;;; And it didn't work at all after the fix for aforementioned
1427 (with-test (:name :sleep-float-transform
1428                   :skipped-on (and :win32 (not :sb-thread)))
1429   (let* ((xform (car (sb-c::fun-info-transforms (sb-int:info :function :info 'sleep))))
1430          (type (car (sb-kernel:fun-type-required (sb-c::transform-type xform)))))
1431     (assert (sb-kernel:constant-type-p type))
1432     ;; CONSTANT-TYPE isn't actually testable through CTYPEP.
1433     ;; So pull out the actual type as the compiler would do.
1434     (assert (sb-kernel:ctypep 1.5 (sb-kernel:constant-type-type type)))))
1435
1436 (with-test (:name :atanh-type-derivation)
1437   (checked-compile-and-assert
1438    ()
1439    '(lambda (x)
1440      (atanh (coerce x '(double-float * (0.0d0)))))))
1441
1442 (with-test (:name :ir1-optimize-combination-unknown-keys)
1443   (checked-compile-and-assert
1444       ()
1445       '(lambda (p x y)
1446         (let ((f (when p #'string-equal)))
1447           (when f
1448             (funcall f "a" "b" x y))))
1449     ((t :start1 0) nil)))
1450
1451 (with-test (:name :member-transform)
1452   (let ((list '(2 1 3)))
1453     (checked-compile-and-assert
1454      ()
1455      '(lambda (list &key key)
1456        (member 1 list :key key))
1457      ((list) (cdr list)))))
1458
1459 (with-test (:name :note-no-stack-allocation-casts)
1460   (checked-compile-and-assert
1461    ()
1462    `(lambda ()
1463      (let ((*s* (the integer (catch 'ct1 0))))
1464        (declare (dynamic-extent *s*)
1465                 (special *s*))))))
1466
1467 (with-test (:name :dxify-downward-funargs-variable-name)
1468   (checked-compile-and-assert
1469       ()
1470       '(lambda () ((lambda (map) (funcall map)) #'list))))
1471
1472 (with-test (:name :dxify-downward-funargs-malformed)
1473   (checked-compile
1474       '(lambda () (sb-debug:map-backtrace))
1475       :allow-style-warnings t))
1476
1477 (with-test (:name :dxify-downward-funargs-casts)
1478   (checked-compile-and-assert
1479    ()
1480    '(lambda (f x)
1481      (flet ((f (y) (funcall f y)))
1482        (funcall (the (satisfies eval) #'every) #'f x)))
1483    ((#'evenp '(2 2 4)) t)))
1484
1485 (with-test (:name :array-call-type-deriver-non-fun-type)
1486   (checked-compile-and-assert
1487       ()
1488       '(lambda (x) (funcall (the compiled-function #'aref) x))
1489     ((#0A123) 123)))
1490
1491 (with-test (:name :nth-&rest-overflow)
1492   (checked-compile-and-assert
1493       ()
1494       '(lambda (&rest s) (nth 536870908 s))
1495     (() nil)))
1496
1497
1498 (with-test (:name :array-in-bounds-p-transform-hairy-types)
1499   (checked-compile-and-assert
1500       ()
1501       '(lambda ()
1502         (let ((a (the (satisfies eval) (make-array 4 :fill-pointer 0))))
1503           (and (array-in-bounds-p a 0)
1504                (array-in-bounds-p a 1))))
1505     (() t)))
1506
1507 (with-test (:name :array-type-dimensions-or-give-up-hairy-types)
1508   (checked-compile-and-assert
1509       ()
1510       '(lambda (a i)
1511         (declare ((or (array * (1)) (satisfies eval)) a))
1512         (array-row-major-index a i))
1513     ((#(a b) 1) 1)))
1514
1515 (with-test (:name :array-type-dimensions-0-rank)
1516   (checked-compile-and-assert
1517       ()
1518       '(lambda (p1)
1519         (declare ((or (array bit 1) (array * 0)) p1))
1520         (array-total-size p1))
1521     ((#0a3) 1)))
1522
1523 (with-test (:name :type-derivation-hairy-types)
1524   (checked-compile-and-assert
1525    ()
1526    `(lambda (n s)
1527       (declare (fixnum n))
1528       (ash (the (satisfies eval) n)
1529            (the (integer * 0) s)))
1530    ((1234 -4) 77))
1531   (checked-compile-and-assert
1532    ()
1533    `(lambda (p)
1534       (declare (type (member #c(0.5d0 4.0d0) #c(0 -1)) p))
1535       (/ (the (satisfies eval) p)))
1536    ((#c(0 -1)) #C(0 1))))
1537
1538 (with-test (:name :assert-lvar-type-intersection)
1539   (checked-compile-and-assert
1540       ()
1541       `(lambda (x y)
1542          (write-sequence nil (the standard-object x) y nil))))
1543
1544 (with-test (:name :or-bignum-single-float-no-notes
1545             :skipped-on (not (or :arm64 ppc :x86 :x86-64)))
1546   (checked-compile
1547    '(lambda (x) (declare (optimize speed)) (typep x '(or bignum single-float)))
1548    :allow-notes nil))
1549
1550
1551 (with-test (:name :vertices-best-color/general-default-value)
1552   (checked-compile-and-assert
1553       ()
1554       `(lambda (a)
1555          (declare ((simple-array (complex double-float)) a))
1556          (* (aref a 0)
1557             (let ((z (aref a 0)))
1558               (complex (realpart z) (imagpart z)))))))
1559
1560 (with-test (:name :copy-list-inlined)
1561   (let ((f (checked-compile
1562             `(lambda (x) (declare (optimize speed)) (copy-list x)))))
1563     ;; Should not have a call to COPY-LIST (or anything)
1564     (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn)))))
1565
1566 (with-test (:name :move-from-fixnum+-1)
1567   (checked-compile-and-assert
1568    (:allow-notes nil)
1569    `(lambda (x)
1570       (declare (fixnum x))
1571       (1- x))
1572    ((0) -1)
1573    ((most-positive-fixnum) (1- most-positive-fixnum))
1574    ((most-negative-fixnum) (1- most-negative-fixnum)))
1575   (checked-compile-and-assert
1576    (:allow-notes nil)
1577    `(lambda (x)
1578       (declare (fixnum x))
1579       (1+ x))
1580    ((0) 1)
1581    ((most-positive-fixnum) (1+ most-positive-fixnum))
1582    ((most-negative-fixnum) (1+ most-negative-fixnum)))
1583   (checked-compile-and-assert
1584    (:allow-notes nil)
1585    `(lambda (a x)
1586       (declare (fixnum x))
1587       (if a
1588           10
1589           (1+ x)))
1590    ((nil 0) 1)
1591    ((t 0) 10)
1592    ((nil most-positive-fixnum) (1+ most-positive-fixnum))
1593    ((nil most-negative-fixnum) (1+ most-negative-fixnum))))
1594
1595 (with-test (:name :coalesce-more-ltn-numbers-constants)
1596   (checked-compile-and-assert
1597       ()
1598       `(lambda (x)
1599          (list 1 1 ,@(make-list 100 :initial-element 'x)))
1600     ((1) (make-list 102 :initial-element 1) :test #'equal)))
1601
1602 (with-test (:name (:lambda-var-ref-lvar :multiple-refs))
1603   (checked-compile-and-assert
1604    ()
1605    `(lambda (vector index)
1606       (labels ((update (index)
1607                  (let ((old (svref vector index)))
1608                    (if (eq old 10)
1609                        (update index)
1610                        old)))
1611                (wrap (index)
1612                  (update index)))
1613         (wrap index)))
1614    ((#(1 2 3) 1) 2)))
1615
1616 (with-test (:name :string-type-unparsing)
1617   (checked-compile-and-assert
1618       ()
1619       `(lambda (s)
1620          (declare (type (string 1) s))
1621          (the (or simple-array (member 1/2 "ba" 0 #\3)) s))
1622     ((#1="a") #1#)))
1623
1624 (with-test (:name :primitive-type-function)
1625   (checked-compile-and-assert
1626       ()
1627       `(lambda (x)
1628          (funcall (the (and atom (not null)) x))
1629          )
1630     ((#'list) nil)
1631     (('list) nil)))
1632
1633 (with-test (:name :copyprop-sc-mismatch-between-moves
1634             :serial t
1635             :skipped-on :interpreter)
1636   (let ((f (checked-compile
1637             '(lambda (f x)
1638               (let ((x (the double-float x)))
1639                 (values (funcall f x) (> x 1d0)))))))
1640     (ctu:assert-no-consing (funcall f #'identity 1d0))))
1641
1642 (with-test (:name (:infer-iteration-var-type :step-is-range))
1643   (let ((f (checked-compile
1644             '(lambda (s)
1645               (declare ((integer 1 2) s))
1646               (let ((r 16))
1647                 (loop for i from 16 below 32 by s
1648                       do (setf r i))
1649                 r)))))
1650     (assert (equal (sb-impl::%simple-fun-type f)
1651                    '(function ((integer 1 2)) (values (integer 16 31) &optional))))))
1652
1653 (with-test (:name (:infer-iteration-var-type :multiple-sets))
1654   (let ((f (checked-compile
1655             '(lambda (x)
1656                (declare (optimize speed)
1657                         (type (integer 3 10) x))
1658                (let ((y x))
1659                  (tagbody
1660                   :start
1661                     (when (plusp y)
1662                       (decf y)
1663                       (when (plusp y)
1664                         (decf y)
1665                         (go :start))))
1666                  y))
1667             :allow-notes nil)))
1668     (assert (equal (sb-impl::%simple-fun-type f)
1669                    '(function ((integer 3 10)) (values (integer 0 0) &optional))))))
1670
1671 (with-test (:name (:infer-iteration-var-type :incompatible-sets))
1672   (checked-compile-and-assert ()
1673       '(lambda (input-total missing-amount)
1674          (declare (fixnum input-total) (fixnum missing-amount))
1675          (loop with tot = 0
1676                repeat 1
1677                do (let ((difference input-total))
1678                     (setq difference (max difference 0))
1679                     (setq tot (+ tot difference)))
1680                finally (when (plusp missing-amount)
1681                          (decf tot missing-amount))
1682                        (return (if (plusp tot) :good :bad))))
1683     ((0 0) :bad)
1684     ((1 0) :good)
1685     ((0 1) :bad)
1686     ((1 1) :bad)))
1687
1688 (with-test (:name :delay-transform-until-constraint-loop)
1689   (checked-compile-and-assert
1690       ()
1691       `(lambda (str)
1692          (declare (string str))
1693          (when (plusp (length str))
1694            (make-array (1- (length str))
1695                        :element-type (array-element-type str)
1696                        :displaced-to str)))
1697     (("abc") "ab" :test #'equal)))
1698
1699 (with-test (:name :lambda-var-ref-lvar-loop)
1700   (checked-compile-and-assert
1701       ()
1702       `(lambda ()
1703          (labels ((z (a)
1704                     (when (>= 0 (the integer a))
1705                       (values #'z a))))))
1706     (() nil)))
1707
1708 (with-test (:name :vector-length-fill-pointer-type-derivation)
1709   (checked-compile-and-assert
1710       ()
1711       `(lambda (s)
1712          (= (length (the (string 1) s)) 1))
1713     (((make-array 1 :element-type 'character :fill-pointer 0)) nil)))
1714
1715 (with-test (:name :function-designator-loop)
1716   (checked-compile-and-assert
1717       ()
1718       `(lambda (p1 p3 p4)
1719          (declare (type (or (eql #.#'oddp)
1720                             (satisfies eval)) p1))
1721          (find-if-not p1 nil p3 p4))
1722        ((#'oddp :from-end t) nil)))
1723
1724 (with-test (:name :lvar-constants-nested-funs)
1725   (checked-compile-and-assert
1726       ()
1727       `(lambda (x)
1728          (labels ((f (x &optional result)
1729                     (if x
1730                         (f x result)
1731                         (nreverse result))))
1732            (f x)))
1733       ((nil) nil)))
1734
1735 (with-test (:name :nested-indirect-var-fp-coalescence)
1736   (checked-compile-and-assert
1737    ()
1738    `(lambda ()
1739       (let ((x 1)
1740             (j 2))
1741         (labels ((m ()
1742                    (incf x 32)
1743                    (incf j 44)
1744                    (let ((z 1))
1745                      (labels ((m ()
1746                                 (incf x 32)
1747                                 (incf z)))
1748                        (declare (notinline m))
1749                        (m)
1750                        (incf j z)))))
1751           (declare (notinline m))
1752           (m)
1753           (values x j))))
1754     (() (values 65 48))))
1755
1756 (with-test (:name :non-returning-functions-conflict)
1757   (checked-compile-and-assert
1758    ()
1759    `(lambda (x) (map nil #'error x))
1760     ((nil) nil)))
1761
1762 (with-test (:name :array-typep-other-pointer-widetag)
1763   (checked-compile-and-assert
1764       ()
1765       `(lambda (x)
1766          (typep x '(and base-string (not simple-array))))
1767     ((10) nil)
1768     (((make-array 10 :element-type 'base-char :adjustable t)) t)))
1769
1770 (with-test (:name :constraint-after-checkgen)
1771   (let ((v #(10 20)))
1772     (checked-compile-and-assert
1773         ()
1774         `(lambda (p1 p2 p3 p4)
1775            (declare (type (satisfies eval) p2)
1776                     (type (member :from-end 2) p3))
1777            (position p1
1778                      (the (member ,v 3) p2)
1779                      (the (member 1 :from-end) p3) nil
1780                      :test-not p4))
1781       ((20 v :from-end #'/=) 1))))
1782
1783 (with-test (:name :cast-multiple-uses-no-dest)
1784   (checked-compile-and-assert
1785       (:allow-style-warnings t)
1786       `(lambda (x)
1787          (the integer
1788               (when x
1789                 (if (> x 0) 1 2)))
1790          (the integer x))
1791     ((23) 23))
1792   (checked-compile-and-assert
1793       (:allow-style-warnings t)
1794       `(lambda (a b)
1795          (declare (optimize (debug 1)))
1796          (logand
1797           (when b
1798             (if (> (the integer a) 0) 10 20))
1799           0)
1800          (the integer b))
1801     ((24 23) 23)))
1802
1803
1804 (with-test (:name :maybe-delete-exit-after-let-conversion)
1805   (checked-compile-and-assert
1806       ()
1807       `(lambda (m)
1808          (flet ((out ()
1809                   (flet ((in (a)
1810                            (dotimes (i 3 a)
1811                              (if m
1812                                  (return-from out)
1813                                  (return-from out)))
1814                            (labels ((f (&optional (a m))
1815                                       a
1816                                       m)))))
1817                     (in (in 10)))))
1818
1819            (out)
1820            33))
1821     ((t) 33))
1822   (checked-compile-and-assert
1823       ()
1824       `(lambda ()
1825          (unwind-protect
1826               (flet ((f (a b &optional c)
1827                        (values a b c)))
1828                 (f 1 2 (f 0 0)))))
1829     (() (values 1 2 0))))
1830
1831 (with-test (:name :make-array-hairy-cons)
1832   (checked-compile-and-assert
1833       ()
1834       `(lambda (type)
1835          (make-array 4 :element-type type :initial-element 0))
1836     (('(or (cons (satisfies eval)) atom)) #(0 0 0 0) :test #'equalp)))
1837
1838 (with-test (:name :substitute-single-use-lvar-exit-cleanups)
1839   (checked-compile-and-assert
1840       ()
1841       `(lambda (z)
1842          (block nil
1843            (let ((b (1+ (funcall z))))
1844              (catch 'c (return b)))))
1845     (((constantly 33)) 34)))
1846
1847 (with-test (:name :substitute-single-use-lvar-unknown-exits)
1848   (checked-compile-and-assert
1849       ()
1850       `(lambda (f)
1851          (block nil
1852            (let ((x (evenp (funcall f)))
1853                  (y (catch 'c
1854                       (return (catch 'c (block nil 11))))))
1855              (declare (ignore y))
1856              x)))
1857     (((constantly 33)) 11)))
1858
1859 (with-test (:name :substitute-single-use-lvar-unknown-exits.2)
1860   (checked-compile-and-assert
1861       ()
1862       `(lambda (b)
1863          (block nil
1864            (if (catch 'c 0)
1865                (return
1866                  (let ((x (the real b)))
1867                    (let ((* (list 1)))
1868                      (declare (dynamic-extent *))
1869                      (catch 'ct5
1870                        (if t (return 34))))
1871                    x))
1872                (catch 'c 0))))
1873     ((1) 34)))
1874
1875 (with-test (:name :substitute-single-use-lvar-unknown-exits.3)
1876   (checked-compile-and-assert
1877       ()
1878       `(lambda (b)
1879          (let ((a b))
1880            (block nil
1881              (let ((* (list 1)))
1882                (declare (dynamic-extent *))
1883                (if b
1884                    (let ((j a))
1885                      (let ((* (list 1)))
1886                        (declare (dynamic-extent *))
1887                        (if b (return 44))
1888                        (setf a nil))
1889                      (let ((z j)) z))
1890                    (eval 2))))))
1891       ((33) 44)))
1892
1893 (with-test (:name :substitute-single-use-lvar-unknown-exits.4)
1894   (checked-compile-and-assert
1895    ()
1896    `(lambda (a)
1897       (block nil
1898         (flet ((f ()
1899                  (let ((p (1+ a)))
1900                    (let ((* (list 1)))
1901                      (declare (dynamic-extent *))
1902                      (if a
1903                          (return 45)))
1904                    p)))
1905           (let ((* (lambda ()
1906                      (return (eval a)))))
1907             (f)))))
1908    ((33) 45)))
1909
1910 (with-test (:name :substitute-single-use-lvar-unknown-exits.5)
1911   (checked-compile-and-assert
1912    ()
1913    `(lambda (b c)
1914       (block nil
1915         (flet ((f ()
1916                  (return (catch 'c (block b b)))))
1917           (return
1918             (block b5
1919               (let ((o c))
1920                 (setf c
1921                       (catch 'c
1922                         (flet ((g ()
1923                                  (return)))
1924                           (f))))
1925                 (let ((x o)) x)))))))
1926    ((10 20) 10)))
1927
1928 (with-test (:name :substitute-single-use-lvar-unknown-exits.6)
1929   (checked-compile-and-assert
1930    ()
1931    `(lambda ()
1932       (block b
1933         (return-from b
1934           (let ((lv3 (random 10))
1935                 *)
1936             (boole boole-1 lv3
1937                    (the integer
1938                         (catch 'ct4
1939                           (let ((x (list '*)))
1940                             (declare (dynamic-extent x))
1941                             (return-from b (eval x))))))))))
1942    (() 1)))
1943
1944 (with-test (:name :lambda-let-inline)
1945   (let ((fun (checked-compile
1946               `(lambda ()
1947                  (let ((x (lambda () 1)))
1948                    (funcall x))))))
1949     (assert (null (ctu:find-anonymous-callees fun)))
1950     (assert (= (funcall fun) 1))))
1951
1952 (with-test (:name :external-cast-deletion)
1953   (checked-compile-and-assert
1954    ()
1955    `(lambda (a c)
1956       (declare (notinline elt logior))
1957       (logior
1958        (if c
1959            (the integer (elt '(10 20) a))
1960            (let ((v1 (loop repeat 3 count t)))
1961              (declare (dynamic-extent v1))
1962              v1))))
1963    ((0 t) 10)
1964    ((1 nil) 3)))
1965
1966 (with-test (:name :fixnump-instance-ref-immediately-used)
1967   (checked-compile-and-assert
1968    ()
1969    `(lambda (a b c)
1970       (let (z)
1971         (and
1972          (typep
1973           (let ((y (let ((s (cons a b)))
1974                      (declare (dynamic-extent s))
1975                      (cdr s))))
1976             (unwind-protect
1977                  (let ((s (list c)))
1978                    (declare (dynamic-extent s))
1979                    (setf z (car s))))
1980             y)
1981           'fixnum)
1982          z)))
1983    ((1 2 'a) 'a)))
1984
1985 (with-test (:name :fixnump-instance-ref-immediately-used.2)
1986   (checked-compile-and-assert
1987    ()
1988    `(lambda (a b c)
1989       (let* ((l (cons a b))
1990              (cdr (cdr l)))
1991         (setf (cdr l) c)
1992         (typep cdr 'fixnum)))
1993    ((1 2 'a) t)))
1994
1995 (with-test (:name :round-numeric-bound)
1996   (checked-compile-and-assert
1997    ()
1998    `(lambda (a c f)
1999       (declare (type (integer -1111868182375 1874303539234) a))
2000       (- (rem (funcall f) (max 23 (* 45092832376540563 a -4469591966)))
2001          (signum c)))
2002    ((1874303539234 2 (constantly 123)) 7)))
2003
2004 (with-test (:name :ir2-optimize-jumps-to-nowhere)
2005   (checked-compile-and-assert
2006    ()
2007    `(lambda (a)
2008       (declare (type fixnum a))
2009       (if (< a 0 a)
2010           (block a (shiftf a 1))
2011           0))
2012    ((0) 0)))
2013
2014 (with-test (:name :double-float-bits-stub)
2015   (checked-compile-and-assert
2016    ()
2017    `(lambda (x)
2018      (float-sign 5.0d0 (the double-float x)))
2019    ((3d0) 3d0)))
2020
2021 (with-test (:name :typep-word)
2022   (checked-compile-and-assert
2023    ()
2024    `(lambda (x)
2025       (typep x 'sb-vm:word))
2026    ((1) t)
2027    (((1- (expt 2 sb-vm:n-word-bits))) t)
2028    (((expt 2 sb-vm:n-word-bits)) nil)
2029    ((-1) nil)
2030    (('a) nil)
2031    ((()) nil)
2032    (((1- most-negative-fixnum)) nil)))
2033
2034 (with-test (:name :fixnum-mod-p-word-descriptor)
2035   (checked-compile-and-assert
2036    ()
2037    `(lambda (a)
2038       (declare (type sb-vm:signed-word a))
2039       (typep a '(integer 0 ,(1- most-positive-fixnum))))
2040    (((1- most-positive-fixnum)) t)
2041    ((0) t)
2042    ((1) t)
2043    ((most-positive-fixnum) nil)
2044    (((1+ most-positive-fixnum)) nil)
2045    ((most-negative-fixnum) nil)
2046    (((1+ most-negative-fixnum)) nil)
2047    (((1- (expt 2 (1- sb-vm:n-word-bits)))) nil)
2048    ((-1) nil)))
2049
2050 (with-test (:name :check-bound-zero-safety-notes)
2051   (checked-compile-and-assert
2052       (:allow-notes nil
2053        :optimize '(:speed 3 :safety 0))
2054       `(lambda (a x y z)
2055          (declare (fixnum x y z)
2056                   ((simple-array t (*)) a)
2057                   (optimize (speed 3) (safety 0)))
2058          (aref a (+ x (- y z))))
2059     ((#(1 2 3) 1 0 0) 2)))
2060
2061 (with-test (:name :convert-mv-bind-to-let-multiple-uses)
2062   (checked-compile-and-assert
2063    ()
2064    `(lambda (f)
2065       (let* ((a (eval 1))
2066              (b (eval 2)))
2067         (multiple-value-bind (x y) (if f
2068                                        (values a 1)
2069                                        (values b 2))
2070           (values x y))))
2071    ((t) (values 1 1))
2072    ((nil) (values 2 2))))
2073
2074 (with-test (:name :substitute-single-use-lvar-multiple-uses)
2075   (checked-compile-and-assert
2076    ()
2077    `(lambda (f)
2078       (let* ((a (eval 1))
2079              (b (eval 2))
2080              (m (if f
2081                     (values a)
2082                     (values b))))
2083         m))
2084    ((t) 1)
2085    ((nil) 2)))
2086
2087 (with-test (:name :tn-ref-type-multiple-moves)
2088   (checked-compile-and-assert
2089    ()
2090    `(lambda  (a c)
2091       (declare (type (integer 546181490258163 937632934000433) c))
2092       (let ((v8 c))
2093         (multiple-value-bind (v9 v6)
2094             (if (/= a v8)
2095                 (values 0 10983313414045189807)
2096                 (values 0 c))
2097           (declare (ignore v9))
2098           (loop repeat 2
2099                 do (eval v6))
2100           v6)))
2101    ((0 571816791704489) 10983313414045189807)))
2102
2103 (with-test (:name :substitute-single-use-lvar-cast-chains)
2104   (checked-compile-and-assert
2105    ()
2106    `(lambda (f a b)
2107       (labels ((fun (z)
2108                  (let ((m z))
2109                    ;; delays type derivation of FUN as FIXNUM until constraint propagation
2110                    ;; making sure SUBSTITUTE-SINGLE-USE-LVAR runs first.
2111                    (if (typep m 'fixnum)
2112                        m
2113                        0))))
2114         (declare (inline fun))
2115         (let* ((a (fun a))
2116                (b (fun b)))
2117           (let ((m
2118                   (if f
2119                       (the fixnum (the integer a))
2120                       (the fixnum (the integer b)))))
2121             m))))
2122    ((t 1 2) 1)
2123    ((nil 1 2) 2)))
2124
2125 (with-test (:name :m-v-bind-multi-use-unused-values.1)
2126   (multiple-value-bind (calls f)
2127       (ctu:ir1-named-calls
2128             '(lambda (z m)
2129               (multiple-value-bind (a b)
2130                   (if z
2131                       10
2132                       (values (sxhash m) m))
2133                 (declare (ignore a))
2134                 b)))
2135     (assert (eql (funcall f t 33) nil))
2136     (assert (eql (funcall f nil 33) 33))
2137     (assert (not calls))))
2138
2139 (with-test (:name :m-v-bind-multi-use-unused-values.2)
2140   (multiple-value-bind (calls f)
2141       (ctu:ir1-named-calls
2142            '(lambda (z m)
2143               (multiple-value-bind (a b c)
2144                   (if z
2145                       (values 10)
2146                       (values (sxhash m) m))
2147                 (declare (ignore a))
2148                 (list b c))))
2149     (assert (equal (funcall f t 33) '(nil nil)))
2150     (assert (equal (funcall f nil 33) '(33 nil)))
2151     (assert (not calls))))
2152
2153 (with-test (:name :m-v-bind-multi-use-unused-values.3)
2154   (multiple-value-bind (calls f)
2155       (ctu:ir1-named-calls
2156            '(lambda (z m)
2157               (multiple-value-bind (a b)
2158                   (if z
2159                       10
2160                       (values m (sxhash m)))
2161                 (declare (ignore b))
2162                 a)))
2163     (assert (eql (funcall f t 33) 10))
2164     (assert (eql (funcall f nil 33) 33))
2165     (assert (not calls))))
2166
2167 (with-test (:name :m-v-bind-multi-use-unused-values.4
2168             :skipped-on :sbcl)
2169   (multiple-value-bind (calls f)
2170       (ctu:ir1-named-calls
2171             '(lambda (z m)
2172               (nth-value 1
2173                (if z
2174                    (funcall (the function z))
2175                    (values (sxhash m) m)))))
2176     (assert (eql (funcall f (lambda () (values 1 22)) 33) 22))
2177     (assert (eql (funcall f nil 34) 34))
2178     (assert (not calls))))
2179
2180 (with-test (:name :m-v-bind-multi-use-unused-values.5
2181             :skipped-on :sbcl)
2182   (multiple-value-bind (calls f)
2183       (ctu:ir1-named-calls
2184             '(lambda (z m)
2185               (nth-value 1
2186                (if z
2187                    (funcall (the function z))
2188                    (sxhash m)))))
2189     (assert (eql (funcall f (lambda () (values 1 22)) 33) 22))
2190     (assert (eql (funcall f nil 34) nil))
2191     (assert (not calls))))
2192
2193 (with-test (:name :m-v-bind-multi-use-variable-type-change)
2194   (checked-compile-and-assert
2195    ()
2196    '(lambda (p)
2197      (when (position #\a (the (or (simple-string 1) (simple-string 2)) p))
2198        nil))
2199    (("a") nil)
2200    (("ab") nil)))
2201
2202 (with-test (:name :array-element-type-cons.1)
2203   (checked-compile-and-assert
2204    (:allow-notes nil)
2205    '(lambda (vector)
2206      (declare ((or (simple-array (unsigned-byte 32) (2))
2207                    (simple-array (unsigned-byte 32) (4))) vector))
2208      (make-array 10 :element-type (array-element-type vector)))
2209    (((make-array 2 :element-type '(unsigned-byte 32)))
2210     '(unsigned-byte 32) :test (lambda (x y)
2211                                 (equal (array-element-type (car x)) (car y))))))
2212
2213 (with-test (:name :array-element-type-cons.2)
2214   (checked-compile-and-assert
2215    (:allow-notes nil)
2216    '(lambda (vector)
2217      (declare ((and (simple-array (unsigned-byte 32) (2))
2218                 (satisfies eval)) vector))
2219      (make-array 10 :element-type (array-element-type vector)))
2220    (((make-array 2 :element-type '(unsigned-byte 32)))
2221     '(unsigned-byte 32) :test (lambda (x y)
2222                                 (equal (array-element-type (car x)) (car y))))))
2223
2224 (with-test (:name :about-to-modify-symbol-value-relax-fun-type)
2225   (let* ((compiled-lambda (compile nil '(lambda (&rest x) x 'hi)))
2226          (sb-c::*compiler-error-bailout*
2227           (lambda (&optional c) (error c))))
2228     (declare (notinline set))
2229     (set 'sb-c::*compiler-error-bailout* compiled-lambda)))
2230
2231 (with-test (:name :self-evaluating-p-not)
2232   (let ((s (gensym)))
2233     (set s 9)
2234     (unintern s)
2235     (import s 'keyword)
2236     (assert (not (sb-int:self-evaluating-p s)))))
2237
2238 (with-test (:name :lea-modfx-constant-folding)
2239   (checked-compile-and-assert
2240       ()
2241       '(lambda (c)
2242         (if (if c
2243                 c
2244                 (if 444
2245                     nil
2246                     99))
2247             11
2248             (logand 3
2249                     (logxor
2250                      (* 5
2251                         (if c
2252                             0
2253                             (ash most-positive-fixnum -2)))
2254                      3))))
2255     ((t) 11)
2256     ((nil) 0)))
2257
2258 (with-test (:name :setup-environment-tn-conflicts)
2259   (checked-compile-and-assert
2260       ()
2261       '(lambda (z)
2262         (let ((c 0))
2263           (flet ((bar ()
2264                    (let ((m (eval :bad)))
2265                      (eval m)
2266                      (and m c))))
2267             (declare (notinline bar))
2268             (cond (z
2269                    (setf c 10)
2270                    (bar))
2271                   (44)))))
2272     ((t) 10)
2273     ((nil) 44)))
2274
2275 (with-test (:name :setup-environment-tn-conflicts.2)
2276   (checked-compile-and-assert
2277       ()
2278       '(lambda (z)
2279         (let ((c 0)
2280               (b 0)
2281               (a 0)
2282               (d 0))
2283           (labels ((bar ()
2284                      (let ((m (eval :bad)))
2285                        (eval m)
2286                        (if m
2287                            (values a b c d))))
2288                    (jam ()
2289                      (multiple-value-list (bar))))
2290             (declare (notinline bar
2291                                 jam))
2292             (cond (z
2293                    (setf a 10
2294                          c 10
2295                          b 10
2296                          d 10)
2297                    (jam))
2298                   (44)))))
2299     ((t) '(10 10 10 10) :test #'equal)
2300     ((nil) 44)))
2301
2302 (with-test (:name :setup-environment-tn-conflicts.3)
2303   (checked-compile-and-assert
2304       ()
2305       '(lambda (b)
2306         (flet ((%f7 ()
2307                  (flet ((%f10 ()
2308                           (setf b b)))
2309                    (declare (dynamic-extent #'%f10))
2310                    (funcall (eval #'%f10)))))
2311           (declare (notinline %f7))
2312           (%f7)))
2313     ((10) 10)))
2314
2315 (with-test (:name :dead-sets)
2316   (checked-compile-and-assert
2317       ()
2318       `(lambda ()
2319          (logtest
2320           ((lambda (v &rest args)
2321              (declare (ignore args))
2322              (setf v
2323                    ((lambda (&rest args) (declare (ignore args)) (error "")) v)))
2324            1)
2325           1))
2326     (() (condition 'simple-error))))
2327
2328 (with-test (:name :inlining-multiple-refs)
2329   (checked-compile
2330    `(lambda (x)
2331       (labels ((%s (y &rest r)
2332                  (some
2333                   (lambda (r) (apply #'%s (1+ y) r))
2334                   (apply #'eql x r))))
2335         (%s 1)))))
2336
2337 (with-test (:name :update-lvar-dependencies-delete-lvar)
2338   (checked-compile-and-assert
2339       ()
2340       '(lambda (x y)
2341         (let ((x x))
2342           (block nil
2343             (flet ((proc (thing)
2344                      (when thing
2345                        (return (eval thing)))))
2346               (declare (inline proc))
2347               (if x
2348                   (proc y)
2349                   (proc y)))))
2350         t)
2351     ((1 2) t)))
2352
2353 (with-test (:name :car-type-on-or-null)
2354   (assert
2355    (equal (sb-kernel:%simple-fun-type
2356            (checked-compile
2357             '(lambda (x)
2358               (declare (type (or null (cons fixnum)) x))
2359               (if x
2360                   (car x)
2361                   0))))
2362           '(function ((or null (cons fixnum t))) (values fixnum &optional)))))
2363
2364 (with-test (:name :nlx-entry-zero-values)
2365   (checked-compile-and-assert
2366       ()
2367       '(lambda (x)
2368         (multiple-value-call (lambda (&optional x) x)
2369           (block nil
2370             (funcall (eval (lambda ()
2371                              (return (if x
2372                                          (values)
2373                                          10))))))))
2374     ((t) nil)
2375     ((nil) 10)))
2376
2377 (with-test (:name :find-test-to-eq-with-key)
2378   (checked-compile-and-assert
2379    ()
2380    '(lambda (x)
2381      (position (1- (expt x 64)) '((#xFFFFFFFFFFFFFFFF)) :key #'car))
2382    ((2) 0)
2383    ((1) nil)))
2384
2385 (with-test (:name :maybe-infer-iteration-var-type-on-union)
2386   (checked-compile-and-assert
2387       (:allow-notes nil :optimize '(:speed 3 :compilation-speed 1 :space 1))
2388       `(lambda (a)
2389          (loop repeat (if a 2 0) count 1))
2390     ((t) 2)
2391     ((nil) 0)))
2392
2393 (with-test (:name :maybe-infer-iteration-var-type-on-union.2)
2394   (checked-compile-and-assert
2395       ()
2396       `(lambda (a)
2397          (let ((v4 (the (or (single-float (1.0) (3.0)) (single-float 4.0 5.0)) a)))
2398            (incf v4 1.0)))
2399       ((4.0) 5.0)))
2400
2401 (with-test (:name :derive-array-rank-negation)
2402   (checked-compile-and-assert
2403    ()
2404    `(lambda (a)
2405       (declare ((not (simple-array * (* *))) a))
2406       (eql (array-rank a) 2))
2407    (((make-array '(2 2) :adjustable t)) t))
2408   (checked-compile-and-assert
2409    ()
2410    `(lambda (a)
2411       (declare ((not (simple-array fixnum (* *))) a))
2412       (eql (array-rank a) 2))
2413    (((make-array '(2 2))) t))
2414   (checked-compile-and-assert
2415    ()
2416    `(lambda (a)
2417       (declare ((not (and (array * (* *)) (not simple-array))) a))
2418       (eql (array-rank a) 2))
2419    (((make-array '(2 2))) t)))
2420
2421 (with-test (:name :derive-array-rank-negation.2)
2422   (assert
2423    (type-specifiers-equal
2424           (sb-kernel:%simple-fun-type
2425            (checked-compile
2426             '(lambda (x)
2427               (declare ((and simple-array
2428                          (not (simple-array * (* *))))
2429                         x))
2430               (eql (array-rank x) 2))))
2431           '(function ((and simple-array (not (simple-array * (* *)))))
2432             (values null &optional)))))
2433
2434 (with-test (:name :known-fun-no-fdefn)
2435   (assert (equal (ctu:find-code-constants (checked-compile '(lambda () #'+))
2436                                           :type 'function)
2437                  (list #'+))))
2438
2439 (with-test (:name :double-float-p-weakening)
2440   (checked-compile-and-assert
2441    (:optimize '(:speed 3 :safety 1))
2442    '(lambda (x)
2443      (declare (double-float x))
2444      x)
2445    ((0.0) (condition 'type-error))
2446       ((1d0) 1d0)))
2447
2448 (declaim (inline inline-fun-arg-mismatch))
2449 (defun inline-fun-arg-mismatch (x)
2450   (declare (optimize (debug 0)))
2451   x)
2452
2453 (with-test (:name :inline-fun-arg-mismatch)
2454   (checked-compile-and-assert
2455       (:allow-warnings '(or sb-int:local-argument-mismatch
2456                          #+interpreter simple-warning)) ;; why?
2457       '(lambda ()
2458         (multiple-value-call #'inline-fun-arg-mismatch 1 2))
2459     (() (condition 'program-error))))
2460
2461 (with-test (:name :principal-lvar-ref-use-loop)
2462   (checked-compile-and-assert ()
2463    '(lambda (vector)
2464      (labels ((f (count)
2465                 (when (< (aref vector 0) count)
2466                   (f count))))))
2467    ((1) nil)))
2468
2469 (with-test (:name (:mv-call :more-arg))
2470   (checked-compile-and-assert
2471    ()
2472    '(lambda (&rest rest)
2473      (multiple-value-bind (a b c) (values-list rest)
2474        (declare (ignore c))
2475        (list a b)))
2476    ((1 3) '(1 3) :test #'equal)))
2477
2478 (with-test (:name (:mv-call :more-arg-unused))
2479   (checked-compile-and-assert
2480    ()
2481    '(lambda (&rest rest)
2482      (multiple-value-bind (a b) (values-list rest)
2483        (list a b)))
2484    (() '(nil nil) :test #'equal)
2485    ((1) '(1 nil) :test #'equal)
2486    ((1 3) '(1 3) :test #'equal)))
2487
2488 (with-test (:name :truncate-deriver-on-number-type)
2489   (checked-compile-and-assert
2490    ()
2491    '(lambda (i)
2492      (truncate
2493       (labels ((f (&optional (o i))
2494                  (declare (ignore o))
2495                  (complex 0 0)))
2496         (declare (dynamic-extent (function f)))
2497         (the integer
2498              (multiple-value-call #'f (values))))
2499       3))
2500    ((0) (values 0 0))))
2501
2502 (with-test (:name :signum-type-deriver)
2503   (checked-compile-and-assert
2504    ()
2505    '(lambda (n)
2506      (typep (signum n) 'complex))
2507    ((#C(1 2)) t)
2508    ((1d0) nil)
2509    ((10) nil)))
2510
2511 (with-test (:name :array-header-p-derivation)
2512   (checked-compile-and-assert
2513    ()
2514    '(lambda (q)
2515      (and (typep q '(not simple-array))
2516       (sb-kernel:array-header-p q)))
2517    ((10) nil)
2518    (((make-array 10 :adjustable t)) t)))
2519
2520 (with-test (:name :phase-type-derivation)
2521   (checked-compile-and-assert
2522    ()
2523    '(lambda (x)
2524      (= (phase (the (integer -1 0) x))
2525       (coerce pi 'single-float)))
2526    ((-1) t)
2527    ((0) nil)))
2528
2529 (with-test (:name :maybe-negate-check-fun-type)
2530   (checked-compile-and-assert
2531    ()
2532    '(lambda (m)
2533      (declare ((or (function (number)) (eql #.#'symbolp)) m))
2534      (the (member 3/4 4/5 1/2 #.#'symbolp) m))
2535    ((#'symbolp) #'symbolp)))
2536
2537 (with-test (:name :equal-to-eql)
2538   (let ((f (checked-compile
2539             `(lambda (x y)
2540                (equal (the hash-table x) y)))))
2541     (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))
2542   (let ((f (checked-compile
2543             `(lambda (x y)
2544                (equalp (the function x) y)))))
2545     (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn)))))
2546
2547 (with-test (:name :multiway-branch-duplicate-case)
2548   (let ((f (checked-compile '(lambda (b)
2549                               (case b
2550                                 ((1 2) :good)
2551                                 ((3 2) :bad)))
2552                             :allow-style-warnings t)))
2553     (assert (eq (funcall f 2) :good))))
2554
2555 (with-test (:name :modular-arith-type-derivers
2556                   :fails-on :ppc64)
2557   (let ((f (checked-compile
2558             `(lambda (x)
2559                (declare ((and fixnum
2560                               unsigned-byte) x)
2561                         (optimize speed))
2562                (rem x 10)))))
2563         (assert (not (ctu:find-code-constants f :type 'bignum)))))
2564
2565 (with-test (:name :deduplicated-fdefns)
2566   (flet ((scan-range (c start end)
2567            (let (dup-fdefns names)
2568              (loop for i from start below end
2569                    do (let ((obj (sb-kernel:code-header-ref c i)))
2570                         (when (sb-kernel:fdefn-p obj)
2571                           (let ((name (sb-kernel:fdefn-name obj)))
2572                             (when (member name names)
2573                               (push obj dup-fdefns))
2574                             (push name names)))))
2575              (assert (not dup-fdefns)))))
2576     (dolist (c (sb-vm:list-allocated-objects :all :type sb-vm:code-header-widetag))
2577       (sb-int:binding* (((start count) (sb-kernel:code-header-fdefn-range c))
2578                         (end (+ start count)))
2579         ;; Within each subset of FDEFNs there should be no duplicates
2580         ;; by name. But there could be an fdefn that is in the union of the two sets.
2581         (scan-range c start end)
2582         (scan-range c end (sb-kernel:code-header-words c))))))
2583
2584 (with-test (:name :map-all-lvar-dests)
2585   (checked-compile-and-assert
2586    ()
2587    `(lambda (&key (pred (constantly 44)))
2588       (declare (type function pred))
2589       (funcall pred))
2590    (() 44)))
2591
2592 (with-test (:name (:lvar-fun-name :constant-leaf-not-constant-lvar-p))
2593   (assert (nth-value 1
2594                      (checked-compile
2595                       `(lambda ()
2596                          (funcall
2597                           (the (function (t) t)
2598                                ,(checked-compile '(lambda ())))))
2599                       :allow-warnings t
2600                       :allow-style-warnings t))))
2601
2602 (with-test (:name (:%logbitp :signed-and-unsigned))
2603   (checked-compile-and-assert
2604       ()
2605       `(lambda (p2)
2606          (declare (type (integer ,(expt -2 (1- sb-vm:n-word-bits))
2607                                  ,(1- (expt 2 sb-vm:n-word-bits))) p2))
2608          (logbitp 26 p2))
2609     ((3) nil)
2610     (((ash 1 26)) t)))
2611
2612 (with-test (:name :vop-return-constant-boxing)
2613   (checked-compile
2614    `(lambda (x)
2615       (declare (optimize speed))
2616       (setf (aref (the (simple-array double-float (*)) x) 0)
2617             10d0))
2618    :allow-notes nil)
2619   (checked-compile
2620    `(lambda (x)
2621       (declare (optimize speed))
2622       (setf (aref (the (simple-array sb-vm:word (*)) x) 0)
2623             (1- (expt 2 sb-vm:n-word-bits))))
2624    :allow-notes nil)
2625   (checked-compile
2626    `(lambda (x y)
2627       (declare (optimize speed))
2628       (setf (svref y 0)
2629             (setf (aref (the (simple-array double-float (*)) x) 0)
2630                   10d0)))
2631    :allow-notes nil)
2632   (checked-compile
2633    `(lambda (f a)
2634       (declare (optimize speed))
2635       (funcall (the function f)
2636                1 2 3 4 5 6 7 8 9 10
2637                (setf (aref (the (simple-array double-float (*)) a) 0)
2638                      10d0)))
2639    :allow-notes nil))
2640
2641 (with-test (:name :make-constant-tn-force-boxed)
2642   (checked-compile-and-assert
2643    ()
2644    `(lambda (c)
2645       (declare (type character c))
2646       (list 1 1 1 1 1 1 1 1 1 1 1 (the (eql #\() c)))
2647    ((#\() '(1 1 1 1 1 1 1 1 1 1 1 #\() :test #'equal)))
2648
2649 (with-test (:name :jump-over-move-coercion
2650             :serial t
2651             :skipped-on :interpreter)
2652   (let ((f (checked-compile
2653             '(lambda (number)
2654               (declare ((or fixnum double-float single-float) number))
2655               (cond ((typep number 'double-float)
2656                      number)
2657                     ((typep number 'single-float)
2658                      (coerce number 'double-float))
2659                     ((typep number 'fixnum)
2660                      (coerce number 'double-float)))))))
2661     (ctu:assert-no-consing (funcall f 1d0)))
2662   (let ((f (checked-compile
2663             '(lambda (v number)
2664               (declare ((or fixnum double-float single-float) number))
2665               (setf (svref v 0)
2666                (cond ((typep number 'double-float)
2667                       number)
2668                      ((typep number 'single-float)
2669                       (coerce number 'double-float))
2670                      ((typep number 'fixnum)
2671                       (coerce number 'double-float))))))))
2672     (let ((v (vector 0)))
2673       (ctu:assert-no-consing (funcall f v 1d0)))))
2674
2675 (with-test (:name :jump-over-move-coercion-match-type)
2676   (checked-compile-and-assert
2677       ()
2678       `(lambda (a b)
2679          (declare (type (or sb-vm:word sb-vm:signed-word) a))
2680          (declare (type (and fixnum unsigned-byte) b))
2681          (lognand (max 0 a) b))
2682     (((expt 2 (1- sb-vm:n-word-bits)) #xFFFFFF) -1)
2683     (((1- (expt 2 (1- sb-vm:n-word-bits))) #xFFFFFF) -16777216)))
2684
2685 #+#.(cl:if (cl:gethash 'sb-c:jump-table sb-c::*backend-template-names*)
2686            '(:and)
2687            '(:or))
2688 (with-test (:name :typecase-to-case-preserves-type)
2689   (let ((f (checked-compile
2690             '(lambda (x)
2691               ;; This illustrates another possible improvement-
2692               ;; there are not actually 6 different slot indices
2693               ;; that we might load. Some of them are the same
2694               (typecase x
2695                 (sb-pretty:pprint-dispatch-table (sb-pretty::pp-dispatch-entries x))
2696                 (sb-impl::comma (sb-impl::comma-expr x))
2697                 (sb-vm:primitive-object (sb-vm:primitive-object-slots x))
2698                 (sb-kernel:defstruct-description (sb-kernel::dd-name x))
2699                 (sb-kernel:lexenv (sb-c::lexenv-vars x))
2700                 (broadcast-stream (broadcast-stream-streams x))
2701                 (t :none))))))
2702     ;; There should be no #<layout> referenced directly from the code header
2703     ;; (which implies that no type-check occurs when accessing a structure instance).
2704     ;; There is of course a vector of layouts in there to compare against.
2705     (assert (not (ctu:find-code-constants f :type 'sb-kernel:layout)))
2706     ;; The function had better work.
2707     (assert (eq (funcall f 'wat) :none))
2708     (assert (equal (funcall f (make-broadcast-stream *error-output*))
2709                    (list *error-output*)))))
2710
2711
2712 (with-test (:name :=-interval-derivation-and-complex)
2713   (checked-compile-and-assert
2714       ()
2715       `(lambda (p1)
2716          (declare ((complex (integer -1 -1)) p1))
2717          (= -1 p1))
2718     ((#C(-1 -1)) nil)))
2719
2720 (with-test (:name :cmov-move-hoisting)
2721   (checked-compile-and-assert
2722       ()
2723       `(lambda (p)
2724          (declare ((or (eql 0.0)
2725                        sb-vm:word) p))
2726          (if (> p 51250)
2727              p
2728              1))
2729     ((0.0) 1)
2730       ((#1=(1- (expt 2 sb-vm:n-word-bits))) #1#))
2731   (checked-compile-and-assert
2732    ()
2733    `(lambda (p)
2734       (declare (type (member 4801112936349103672 -9474680540642044437) p))
2735       (max 0 p -1.0))
2736    ((4801112936349103672) 4801112936349103672)
2737    ((-9474680540642044437) 0)))
2738
2739 (with-test (:name :logior-derive-type-widening-tail-set-types)
2740   (checked-compile-and-assert
2741       ()
2742       `(lambda (a b c)
2743          (labels ((q (x y)
2744                     (let ((* (lambda () x y)))
2745                       (the integer a)))
2746                   (p ()
2747                     (logior (apply #'q (list a b))
2748                             (if b
2749                                 (return-from p (q b c))
2750                                 1))))
2751            (if c
2752                0.0
2753                (p))))
2754     ((44 nil nil) 45)
2755     ((3 2 1) 0.0)
2756     ((30 2 nil) 30)))
2757
2758 (with-test (:name :if-eq-optimization-consistency)
2759   (let ((sb-c::*check-consistency* t))
2760     (checked-compile-and-assert
2761      ()
2762      `(lambda ()
2763         (eval (and (if (eval 0) (eval 0) (eval 0)) t)))
2764      (() t))))
2765
2766 (with-test (:name :make-array-half-finished-transform)
2767   (checked-compile-and-assert
2768       (:allow-warnings t)
2769       `(lambda ()
2770          (make-array 6 :fill-pointer 33))
2771     (() (condition '(not program-error)))))
2772
2773 (with-test (:name :nested-if+let)
2774   (checked-compile-and-assert
2775       ()
2776       `(lambda ()
2777          (let (x)
2778            (when x
2779              (setq x 1))
2780            (let ((y (if x
2781                         t
2782                         nil)))
2783              (if y
2784                  y
2785                  (let ((x x))
2786                    x)))))
2787       (() nil)))
2788
2789 (with-test (:name :let-var-immediately-used-p-deleted-lambda)
2790   (checked-compile-and-assert
2791    ()
2792    `(lambda (c)
2793       (if (and nil
2794                (or
2795                 (zerop (count (unwind-protect 1) '(1)))
2796                 c))
2797           1
2798           0))
2799    ((2) 0)))
2800
2801 (with-test (:name :dce-local-functions)
2802   (checked-compile-and-assert
2803       ()
2804       `(lambda ()
2805          (block out
2806            (labels ((mmm (z vars)
2807                       (when vars
2808                         (mmm z vars))))
2809              (mmm 1 (progn
2810                       (dotimes (a 1) (return-from out 10))
2811                       (dotimes (b 3) (catch 'b))))
2812              (dotimes (c 3) (catch 'c)))))
2813     (() 10)))
2814
2815 (with-test (:name :dce-more-often)
2816   (checked-compile-and-assert
2817    ()
2818    `(lambda (a)
2819       (+ 1
2820          (if t
2821              0
2822              (progn
2823                (tagbody
2824                 p
2825                   (tagbody
2826                      (let ((a (lambda () (go o))))
2827                        (declare (special a)))
2828                    o)
2829                   (when (< a 1)
2830                     (go p)))
2831                2))))
2832     ((1) 1)
2833     (:return-type (values (integer 1 1) &optional))))
2834
2835 (with-test (:name :dce-more-often.2)
2836   (checked-compile-and-assert
2837    ()
2838    `(lambda (b)
2839       (declare (fixnum b))
2840       (- (case 0
2841            (1
2842             (dotimes (i 1 b) (ignore-errors)))
2843            (t 0))))
2844     ((3) 0)
2845     (:return-type (values (integer 0 0) &optional))))
2846
2847 (with-test (:name :ir1-optimize-constant-fold-before-giving-up)
2848   (checked-compile-and-assert
2849    ()
2850    `(lambda (a)
2851       (+ 2 (- (let ((sum 0))
2852                 (declare (type fixnum sum))
2853                 (block nil
2854                   (tagbody
2855                    next
2856                      (cond ((>= sum '0)
2857                             (go end))
2858                            (a
2859                             (ceiling 1 (unwind-protect 2))
2860                             (incf sum)))
2861                      (go next)
2862                    end))
2863                 sum))))
2864    ((1) 2)))
2865
2866 (with-test (:name :position-case-otherwise)
2867   (checked-compile-and-assert
2868       ()
2869       `(lambda (x)
2870          (position x '(a otherwise b t nil)))
2871     (('a) 0)
2872     (('otherwise) 1)
2873     ((nil) 4)
2874     ((t) 3)))
2875
2876 (with-test (:name :unreachable-component-propagate-let-args)
2877   (checked-compile-and-assert
2878       ()
2879       `(lambda ()
2880          (let ((p 0))
2881            (flet ((f (&key)
2882                     (flet ((g (&optional
2883                                  (z
2884                                   (return-from f (+ (dotimes (i 0 0)) p))))
2885                              p))))))
2886            p))
2887     (() 0)))
2888
2889 (with-test (:name :dce-through-optional-dispatch)
2890   (checked-compile-and-assert
2891       ()
2892       `(lambda (x)
2893          (flet ((z (&optional a)
2894                   (declare (ignore a))
2895                   123))
2896            (let ((z #'z))
2897              (when x
2898                (unless x
2899                  (setf z 10)))
2900                    (funcall z))))
2901     ((nil) 123)
2902     ((t) 123)))
2903
2904 (with-test (:name :values-list+cons)
2905   (assert
2906    (equal (sb-kernel:%simple-fun-type
2907            (checked-compile
2908             `(lambda ()
2909                (values-list (cons 1 nil)))))
2910           '(function () (values (integer 1 1) &optional))))
2911   (assert
2912    (equal (sb-kernel:%simple-fun-type
2913            (checked-compile
2914             `(lambda (x) (values-list (list* x 1 x nil)))))
2915           '(function (t) (values t (integer 1 1) t &optional)))))
2916
2917 (with-test (:name :xeps-and-inlining)
2918   (checked-compile-and-assert
2919    ()
2920    `(lambda (args)
2921       (flet ((fun () args))
2922         (declare (inline fun))
2923         (multiple-value-call #'fun (values-list args))
2924         #'fun))))
2925
2926 (with-test (:name :split-let-ctran-kind)
2927   (checked-compile-and-assert
2928    ()
2929    `(lambda (a b)
2930       (let ((a-n (null a))
2931             (b-n (null b)))
2932         (cond (b-n 1)
2933               (a-n a)
2934               (t a))))
2935    ((nil nil) 1)
2936    ((nil t) nil)))
2937
2938 (with-test (:name :dead-component-unused-closure)
2939   (checked-compile-and-assert
2940    ()
2941    `(lambda ()
2942       (labels ((%f1 ())
2943                (%f2 (&key)
2944                  (flet ((%f3 ()
2945                           (unwind-protect 1)
2946                           (return-from %f2 (%f1)))))))
2947         (%f1)))
2948    (() nil)))
2949
2950 (with-test (:name :references-to-inline-funs-copied)
2951   (checked-compile-and-assert
2952       ()
2953       `(lambda ()
2954          (and (inline-fun-arg-mismatch t)
2955               #'inline-fun-arg-mismatch))
2956     (() #'inline-fun-arg-mismatch)))
2957
2958 (with-test (:name :eliminate-dead-code-before-initial-dfo)
2959   (checked-compile-and-assert
2960       ()
2961       `(lambda ()
2962          (block nil
2963           (flet ((f (&key (k1 (catch 'c)))
2964                    (max 0
2965                         (let ((v9 10))
2966                           (return))))))))
2967     (() nil)))
2968
2969 (with-test (:name :%coerce-callable-to-fun-movement)
2970   (checked-compile-and-assert
2971    ()
2972    `(lambda (y x)
2973       (let ((x (sb-kernel:%coerce-callable-to-fun x)))
2974         (when y
2975           (funcall x))))
2976     ((nil (make-symbol "UNDEF")) (condition 'undefined-function))))
2977
2978 (with-test (:name :jump-table-use-labels)
2979   (checked-compile-and-assert
2980    ()
2981    `(lambda (x m)
2982       (case x
2983         ((a b c)
2984          (if m
2985              (error ""))
2986          x)
2987         ((d e f)
2988          (eval 10)
2989          x)))
2990     (('a nil) 'a)
2991     (('d 30) 'd)))
2992
2993 (with-test (:name :dfo-deleted-lambda-home)
2994   (assert
2995    (nth-value 5 (checked-compile
2996                  `(lambda (c)
2997                     (flet ((f (&optional (o c))
2998                              (lambda (&key)
2999                                (+ (restart-bind nil (go missing-tag))
3000                                   (progv nil nil o)))))))
3001                  :allow-failure t))))
3002
3003
3004 (with-test (:name :split-let-unused-vars)
3005   (checked-compile-and-assert
3006       ()
3007       `(lambda (x y)
3008          (let ((a
3009                  (if x y))
3010                (b)
3011                (c
3012                  (if y
3013                      x)))
3014            (declare (ignore b))
3015            (if c (if a a c))))
3016     ((t t) t)
3017     ((t nil) nil)
3018     ((nil t) nil)
3019     ((nil nil) nil)))
3020
3021 (with-test (:name :sequence-lvar-dimensions-on-arrays)
3022   (checked-compile-and-assert
3023       ()
3024       `(lambda (x a)
3025          (count a (make-string x :initial-element a)))
3026     ((10 #\a) 10)))
3027
3028 (with-test (:name :length-transform-on-arrays)
3029   (checked-compile-and-assert
3030    ()
3031    `(lambda () (length (make-sequence '(string *) 10 :initial-element #\a)))
3032    (() 10)))
3033
3034 (with-test (:name :constant-fold-unknown-types)
3035   (checked-compile-and-assert
3036    (:allow-style-warnings t)
3037    `(lambda ()
3038       (oddp (the (or a b) -1)))))
3039
3040 (with-test (:name :dead-code-no-constant-fold-errors)
3041   (assert
3042    (typep (nth-value 4
3043                      (checked-compile
3044                       `(lambda (z)
3045                          (when (and (eq z 0)
3046                                     (not (eq z 0)))
3047                            (/ 10 0)))))
3048           '(cons sb-ext:code-deletion-note null))))
3049
3050 (with-test (:name :unused-assignment)
3051   (flet ((try (expr &aux (warned 0))
3052            (handler-bind ((style-warning
3053                            (lambda (c)
3054                             (if (search "assigned but never read" (princ-to-string c))
3055                                 (incf warned)
3056                                 (error "That's unexpected")))))
3057              (multiple-value-bind (fun warn error)
3058                (let ((*error-output* (make-broadcast-stream))) (compile nil expr))
3059                (declare (ignore fun))
3060                (assert (and warn (not error) (eql warned 1)))))))
3061     (try '(lambda (x) (let* ((a (+ x 5)) (b a)) (setq b 3) (eval ''z))))
3062     ;; Even if the initializer is necessary to call, it's still warning-worthy.
3063     (try '(lambda (x) (let* ((a (+ x 5))
3064                              (b (opaque-identity a)))
3065                         (setq b 3)
3066                         (eval ''z))))
3067     (try '(lambda (x) (let* ((a (+ x 5)) (b a))
3068                         (setq b (opaque-identity 3))
3069                         (eval ''z)))))
3070   ;; This one uses the value of B
3071   (checked-compile '(lambda (x) (let* ((a (+ x 5)) (b a))
3072                                   (setq b (opaque-identity 3))))))
3073
3074 (with-test (:name :unconvert-tail-calls-terminate-block)
3075   (checked-compile-and-assert
3076    ()
3077    `(lambda (x y)
3078       (flet ((f ()
3079                (labels ((a ()
3080                           (error "~a" x))
3081                         (b ()
3082                           (a)))
3083                  (if nil
3084                      (b)
3085                      (if y
3086                          (a)
3087                          (b))))))
3088         (block nil
3089           (return (f)))))
3090    ((t t) (condition 'error))))
3091
3092 (with-test (:name :unconvert-tail-calls-terminate-block.2)
3093   (checked-compile-and-assert
3094    ()
3095    `(lambda (x)
3096       (flet ((f ()
3097                (labels ((a ()
3098                           (error "foo ~a" x))
3099                         (b ()
3100                           (let (*)
3101                             (a))))
3102                  (if nil
3103                      (b)
3104                      (if nil
3105                          (a)
3106                          (if x
3107                              (a)
3108                              (b)))))))
3109         (f)
3110         10))
3111    ((t t) (condition 'error))))
3112
3113 (with-test (:name :fixnum-checking-boxing
3114                   :skipped-on (not :x86-64))
3115   (checked-compile
3116    `(lambda (x y)
3117       (declare (optimize speed)
3118                (fixnum x y))
3119       (the fixnum (+ x y)))
3120    :allow-notes nil))
3121
3122 (with-test (:name :ltn-analyze-mv-bind)
3123   (checked-compile-and-assert
3124    ()
3125    `(lambda ()
3126       (multiple-value-call #'list
3127         10 (apply #'values '(44 33d0))))
3128    (() '(10 44  33d0) :test #'equal)))
3129
3130
3131 (with-test (:name :lp719585)
3132   ;; Iteration variables are always "used"
3133   (checked-compile '(lambda () (do (var) (t))))
3134   (checked-compile '(lambda () (do* (var) (t))))
3135   (checked-compile '(lambda () (do-all-symbols (var))))
3136   (checked-compile '(lambda () (do-external-symbols (var))))
3137   (checked-compile '(lambda () (do-symbols (var))))
3138   (checked-compile '(lambda () (dolist (var '(1 2 3))))))
3139
3140 (with-test (:name :key-default-type)
3141   (let ((name (gensym)))
3142     (proclaim `(ftype (function (double-float &key (:y double-float))) ,name))
3143     (checked-compile-and-assert
3144         (:optimize :default)
3145         `(sb-int:named-lambda ,name (x &key (y x))
3146            (values x y))
3147         ((1d0 :y nil) (condition 'error)))))
3148
3149 (with-test (:name :deleting-unreachable-floats)
3150   (let ((name (gensym)))
3151     (proclaim `(inline ,name))
3152     (eval `(defun ,name (&key (k (eval 0f0)))
3153              k))
3154     (checked-compile-and-assert
3155      (:allow-notes nil)
3156      `(lambda ()
3157         (,name :k 0f0))
3158      (() 0f0))))
3159
3160 (with-test (:name :no-*-as-type)
3161   (multiple-value-bind (fun errorp warnings)
3162       (checked-compile '(lambda (x) (the * x))
3163                        :allow-failure t :allow-warnings t)
3164     (declare (ignore fun))
3165     (assert errorp)
3166     (assert (= (length warnings) 1)))
3167   ;; (values t) parses into *wild-type* and has to be allowed
3168   ;; even though * which parses into *wild-type* isn't.
3169   (checked-compile '(lambda () (the (values t) t))))
3170
3171 (with-test (:name :hairy-data-vector-set-t-upgrade)
3172   (checked-compile
3173    '(lambda (x) (sb-kernel:hairy-data-vector-set
3174                  (the (simple-array symbol) x) 1 'hey))))
3175
3176 (with-test (:name :ir2-convert-reffer-no-lvar)
3177   (checked-compile-and-assert
3178    (:allow-style-warnings t)
3179    `(lambda (a)
3180       (/ (unwind-protect (if a
3181                              (values nil (cdr a))
3182                              (values 1 0))
3183            a)
3184          1))
3185    ((nil) 1)))
3186
3187 (with-test (:name :%eql-integer-fold)
3188   (checked-compile-and-assert
3189    ()
3190    `(lambda (d)
3191       (declare (type fixnum d))
3192       (or (find d '(-98 27749116333474161060))
3193           t))
3194    ((-98) -98)
3195    ((95) t)))
3196
3197 (with-test (:name :svref-with-addend+if-eq-immediate)
3198   (checked-compile-and-assert
3199    ()
3200    `(lambda (a d)
3201       (eql (svref a d) -276932090860495638))
3202    ((#(1 0) 0) nil)
3203    ((#(-276932090860495638) 0) t)))
3204
3205 (with-test (:name :zeroize-stack-tns)
3206   (checked-compile-and-assert
3207    ()
3208    `(lambda (a b d e)
3209       (declare (type fixnum a))
3210       (dpb
3211        (ash
3212         (truncate 562949953421316  (max 97 d))
3213         (min 81 (expt (boole boole-and e b) 2)))
3214        (byte 7 5)
3215        (dotimes (i 2 a)
3216          (count i #(61) :test '>=))))
3217    ((1 2 3 4) 1985)))
3218
3219 (with-test (:name :logtest-derive-type-nil)
3220   (checked-compile-and-assert
3221    (:allow-warnings t)
3222    `(lambda (c)
3223       (block nil
3224         (evenp (the integer (ignore-errors (return c))))))
3225    ((1) 1)))
3226
3227 (with-test (:name :cast-filter-lvar)
3228   (checked-compile-and-assert
3229    (:allow-warnings t)
3230    `(lambda ()
3231       (block nil
3232         (equal
3233          (the integer (tagbody
3234                          (let ((* (lambda () (go tag))))
3235                            (return))
3236                        tag))
3237          (the integer (block nil
3238                         (return))))))
3239    (() nil)))
3240
3241 ;;; EXPLICIT-CHECK + ETYPECASE should not produce a error message
3242 ;;; which reveals whether type-checking on entry to a standard function
3243 ;;; was performed this way or that way.
3244 (with-test (:name :etypecase-error-simplify)
3245   (let ((x (nth-value 1 (ignore-errors (logcount (opaque-identity #\a)))))
3246         (y (nth-value 1 (ignore-errors (oddp (opaque-identity #\a))))))
3247     (assert (string= (princ-to-string x) (princ-to-string y)))))
3248
3249 (with-test (:name :set-exclusive-or-inlined)
3250   (checked-compile-and-assert
3251    ()
3252    `(lambda (set1 set2)
3253       (declare (inline set-exclusive-or))
3254       (set-exclusive-or set1 set2))))
3255
3256 (declaim (inline inline-deletion-note))
3257 (defun inline-deletion-note (x y)
3258   (if y
3259       10
3260       x))
3261
3262 (with-test (:name :inline-deletion-note)
3263   (checked-compile-and-assert
3264    (:allow-notes nil)
3265    `(lambda (x)
3266       (inline-deletion-note x t))
3267    ((t) 10)))
3268
3269 (with-test (:name :inline-type-mismatch)
3270   (checked-compile-and-assert
3271       (:allow-notes nil)
3272       `(lambda (x y)
3273          (car (inline-deletion-note x y)))
3274     (('(a) nil) 'a))
3275   (checked-compile-and-assert
3276       ()
3277       `(lambda (x y)
3278          (1+ (position x (the list y))))
3279     ((1 '(1)) 1)))
3280
3281 (with-test (:name :lvar-annotation-inline-type-mismatch)
3282   (checked-compile-and-assert
3283       ()
3284       `(lambda (x y)
3285          (sb-kernel:the* (float :use-annotations t) (inline-deletion-note x y)))
3286     ((1.0 nil) 1.0)))
3287
3288 (with-test (:name :cast-type-preservation)
3289   (assert
3290    (equal (caddr
3291            (sb-kernel:%simple-fun-type
3292             (checked-compile
3293              `(lambda (b)
3294                 (declare ((integer 1 1000) b))
3295                 (declare (optimize (space 0)))
3296                 (gcd 2 b)))))
3297           '(values (integer 1 2) &optional))))
3298
3299 (with-test (:name :lvar-substituting-non-deletable-casts)
3300   (checked-compile-and-assert
3301    ()
3302    `(lambda (b)
3303       (the integer
3304            (let (*)
3305              (rem 2
3306                   (let ((m
3307                           (flet ((f ()
3308                                    (truncate (the (integer -10 0) b) -4)))
3309                             (f))))
3310                     (if (> m 1)
3311                         1
3312                         m)))))
3313       10)
3314    ((-10) 10)))
3315
3316 (with-test (:name :convert-mv-bind-to-let-no-casts)
3317   (checked-compile-and-assert
3318    ()
3319    `(lambda (a)
3320       (declare (type (integer 7693489 168349189459797431) a))
3321       (max
3322        (floor a
3323               (min -14
3324                    (loop for lv3 below 3
3325                          sum (mod 77196223293181
3326                                   (max 75 (mod a (min -57 lv3)))))))))
3327    ((8000000) -571429)))
3328
3329 (with-test (:name :values-length-mismatch)
3330   (checked-compile-and-assert
3331    (:allow-style-warnings t :optimize :default)
3332    `(lambda (a)
3333       (declare (values t &optional))
3334       (when a
3335         (values 1 2)))
3336    ((nil) nil)
3337    ((t) (condition 'type-error))))
3338
3339 (with-test (:name :substitute-single-use-lvar-type-cast-movement)
3340   (checked-compile-and-assert
3341    ()
3342    `(lambda (a)
3343       (block nil
3344         (let ((x (multiple-value-prog1 a)))
3345           (when (< a 0)
3346             (return :good))
3347           (if (minusp x)
3348               1
3349               (+ x 1)))))
3350    ((-1) :good)
3351    ((0) 1)))
3352
3353 (with-test (:name :fold-ash-mod-0)
3354   (checked-compile-and-assert
3355       ()
3356       `(lambda ()
3357          (loop for i below 3 sum
3358                (ldb (byte 6 6)
3359                     (ash i (mask-field (byte 5 8) i)))))
3360     (() 0)))
3361
3362 (with-test (:name :substitute-single-use-lvar-type-multiple-uses)
3363   (checked-compile-and-assert
3364    ()
3365    `(lambda (c)
3366       (let ((z
3367               (ceiling
3368                (truncate 655
3369                          (min -7
3370                               (if c
3371                                   -1000
3372                                   3)))
3373                3)))
3374         z))
3375    ((t) 0)
3376    ((nil) -31)))
3377
3378 (with-test (:name :division-by-multiplication-type-derivation)
3379   (assert
3380    (type-specifiers-equal
3381     (caddr
3382      (sb-kernel:%simple-fun-type
3383       (checked-compile
3384        `(lambda (c)
3385           (declare (optimize speed))
3386           (ceiling
3387            (truncate 65527
3388                      (min -78
3389                           (if c
3390                               -913097464
3391                               5)))
3392            39)))))
3393     '(values (or (integer -21 -21) (integer 0 0)) (integer #+(or arm64 x86-64) -21
3394                                                    #-(or arm64 x86-64) -38 0)
3395       &optional)))
3396   (assert
3397    (type-specifiers-equal
3398     (caddr
3399      (sb-kernel:%simple-fun-type
3400       (checked-compile
3401        `(lambda (c)
3402           (declare (optimize speed))
3403           (ceiling
3404            (truncate 65527
3405                      (min 78
3406                           (if c
3407                               913097464
3408                               5)))
3409            39)))))
3410     '(values (or (integer 22 22) (integer 337 337)) (integer -38 -1) &optional))))
3411
3412 (with-test (:name :boundp-ir2-optimizer)
3413   (checked-compile-and-assert
3414    ()
3415    `(lambda (v)
3416       (flet ((f (s)
3417                (when (boundp s)
3418                  (symbol-value s))))
3419         (f v)
3420         (f v)
3421         v))
3422    ((t) t)))
3423
3424 (with-test (:name :nfp-in-unwinding)
3425   (catch 'z
3426     (checked-compile-and-assert
3427         ()
3428         `(lambda (x y f)
3429            (declare (double-float x y))
3430            (block nil
3431              (let ((z (+ x y)))
3432                (unwind-protect  (funcall f)
3433                  (return (+ z 1d0))))))
3434       ((4d0 1d0 (lambda () (throw 'z 1))) 6d0))))
3435
3436 (with-test (:name :ir1-optimize-if-same-target-type-derivation)
3437   (checked-compile-and-assert
3438       ()
3439       `(lambda (b c)
3440          (declare (notinline equal))
3441          (multiple-value-bind (v7 v2)
3442              (if (equal 0 0)
3443                  (values c 0)
3444                  (values b 0))
3445            (declare (ignore v2))
3446            (tagbody (progn v7))
3447            b))
3448     ((1 2) 1)))
3449
3450 (with-test (:name :delete-let-source-paths)
3451   (checked-compile-and-assert
3452       ()
3453       `(lambda (a)
3454          (declare (type (member -3 -54972 3) a))
3455          (values (floor -98740440 a)))
3456     ((-3) 32913480)
3457     ((3) -32913480)
3458     ((-54972) 1796)))
3459
3460 (with-test (:name :unused-debug-tns)
3461   (checked-compile-and-assert
3462       ()
3463       `(lambda (d)
3464          (flet ((f (x)
3465                   (unwind-protect d
3466                     (eval x))))
3467            (dotimes (i 3)
3468              (f (1+ most-positive-fixnum)))))
3469     ((3) nil)))
3470
3471 (with-test (:name :exit-becomes-single-value)
3472   (checked-compile-and-assert
3473       ()
3474       `(lambda (x z)
3475          (max
3476           (block nil
3477             (flet ((x () (return (floor 1020 z))))
3478               (funcall x #'x))
3479             nil)
3480           10))
3481     (((lambda (x) (funcall x)) 4) 255)))
3482
3483 (with-test (:name :principal-lvar-single-valuify-exit)
3484   (checked-compile-and-assert
3485    ()
3486    `(lambda ()
3487       ((lambda (a)
3488          (flet ((a ()
3489                   (let ((v3 a))
3490                     (block nil (truncate (flet ((b ()
3491                                                   (return (block b3 (values 1 v3)))))
3492                                            (declare (inline b))
3493                                            (b)))))))
3494            (declare (inline a))
3495            (values (a))))
3496        t))
3497    (() 1)))
3498
3499 (with-test (:name :%coerce-callable-for-call-with-casts
3500             :skipped-on (not :call-symbol))
3501   (multiple-value-bind (calls f)
3502       (ctu:ir1-named-calls
3503             `(lambda (x y)
3504               (apply x 1 2 y)))
3505     (assert (equal (funcall f #'list '(3)) '(1 2 3)))
3506     (assert (equal calls '(x)))))
3507
3508 (with-test (:name :local-fun-type-check-eliminatetion)
3509   (let ((fun (checked-compile '(lambda ()
3510                                 (flet ((f (x)
3511                                          (declare (fixnum x))
3512                                          (1+ x)))
3513                                   (declare (inline f))
3514                                   (funcall
3515                                    (the (function (&optional fixnum)) #'f)
3516                                    10))))))
3517     (assert (= (sb-kernel:code-n-entries (sb-kernel:fun-code-header fun))
3518                1))))
3519
3520 (with-test (:name :%cleanup-point-transform)
3521   (checked-compile-and-assert
3522    ()
3523    `(lambda (a b c)
3524       (declare ((integer -14 49702337) a)
3525                ((integer -5376440588342 5921272101558) b)
3526                ((integer 3395101368955 8345185767296289) c))
3527       (if (and (< c b) (> a b))
3528           (progv nil
3529               (list 288230376151711735 c)
3530             (restart-bind nil a))
3531           c))
3532    ((49702337 5921272101558 8345185767296289) 8345185767296289)))
3533
3534 ;;; Test from git rev e47ffa8855d4139f88f5982fe4b82a05c3498ed3.
3535 ;;; I have absolutely zero understanding of what this was doing,
3536 ;;; but the are bunch of "undefined variable" warnings, so it can't
3537 ;;; go at toplevel in a .cload test.
3538 (with-test (:name :bug-226)
3539   (with-scratch-file (lisp "lisp")
3540     (with-open-file (f lisp :direction :output)
3541       (write '(defun bug226 ()
3542   (declare (optimize (speed 0) (safety 3) (debug 3)))
3543   (flet ((safe-format (stream string &rest r)
3544            (unless (ignore-errors (progn
3545                                     (apply #'format stream string r)
3546                                     t))
3547              (format stream "~&foo ~S" string))))
3548     (cond
3549       ((eq my-result :ERROR)
3550        (cond
3551          ((ignore-errors (typep condition result))
3552           (safe-format t "~&bar ~S" result))
3553          (t
3554           (safe-format t "~&baz ~S (~A) ~S" condition condition result)))))))
3555              :stream f :readably t))
3556     (with-scratch-file (fasl "fasl")
3557       (compile-file lisp :output-file fasl))))
3558
3559 ;;; I think these tests had to be present in a COMPILE-FILE (as opposed to COMPILE)
3560 ;;; to prove that the bug was fixed.
3561 ;;; Anway it's no longer going to be allowed to have deliberately bad code in '.cload'
3562 ;;; files, because any condition of type warnings or error is considered failure
3563 ;;; of the compile step.
3564 (with-test (:name :lp-1276282)
3565   (with-scratch-file (lisp "lisp")
3566     (with-open-file (f lisp :direction :output)
3567       ;; from git rev feb31fb6cfc8f89e2d75b5f2cc2ee569ac975033
3568       (format f "(lambda () (the string (+ 1 x)))~%")
3569       ;; from git rev fbea35e879891723259dfa55589b498228390bb9
3570       (format f
3571 "(lambda ()
3572   (macrolet ((x (&rest args)
3573                (declare (ignore args))
3574                'a))
3575     (let (a)
3576       (declare (type vector a))
3577       (x #.#'list))))~%"))
3578     (with-scratch-file (fasl "fasl")
3579       (compile-file lisp :output-file fasl))))
3580
3581 (with-test (:name :substitute-single-use-lvar-mv-cast)
3582   (checked-compile-and-assert
3583       ()
3584       `(lambda ()
3585          (let ((r (random 10))
3586                (x (list 1)))
3587            (declare (special x)
3588                     (dynamic-extent x))
3589            (throw 'c (the (integer 0 10) r))))))
3590
3591 (with-test (:name :list-ir2-convert)
3592   (checked-compile '(lambda ()
3593                      (declare (notinline list +))
3594                      (list (loop for i below 2 count t)))))
3595
3596 (with-test (:name :bignump-integer-<)
3597   (checked-compile-and-assert
3598    ()
3599    `(lambda (a)
3600       (declare (type integer a))
3601       (if (and (typep a 'bignum) (< a 0))
3602           t
3603           nil))
3604    ((-1) nil)
3605    (((- (expt 2 300))) t)))
3606
3607 (with-test (:name :cmov-branch)
3608   (checked-compile-and-assert
3609    ()
3610    `(lambda (x y)
3611       (assert
3612        (let ((res nil))
3613          (when x (setf res (not res)))
3614          (when y (setf res (not res)))
3615          (not res))))
3616    ((1 2) nil)
3617    ((nil nil) nil)))
3618
3619 (with-test (:name :constant-type-proclamation)
3620   (ctu:file-compile
3621    `((defconstant +foo+ 4)
3622
3623      (defun bar () +foo+)
3624
3625      (declaim (type integer +foo+)))
3626    :load t)
3627   (assert (eq (funcall 'bar) 4)))
3628
3629 (with-test (:name :if-split-let-blocks)
3630   (checked-compile-and-assert
3631       ()
3632       `(lambda (a e)
3633          (labels ((f1 (b)
3634                     (map nil
3635                          (lambda (n)
3636                            (return-from f1 n))
3637                          b)
3638                     nil)
3639                   (f (n)
3640                     (let ((x (eval e))
3641                           (y (f1 n)))
3642                       (if y
3643                           y
3644                           x))))
3645            (f a)))
3646     ((() 1) 1)
3647     (('(2) 1) 2)))
3648
3649 (with-test (:name :duplicate-more-local-tn-overflow)
3650   (let ((vars (loop repeat 200 collect (gensym)))
3651         (args (loop repeat 201 for i from (random 30000)
3652                     collect i)))
3653     (assert
3654      (equal
3655       (apply
3656        (compile
3657         ()
3658         `(lambda (a ,@vars)
3659            (list a a ,@vars)))
3660        args)
3661       (cons (car args) args)))))
3662
3663 (with-test (:name :aref-single-value-type)
3664   (checked-compile-and-assert
3665    ()
3666    `(lambda (x)
3667       (aref (the (values (and (not simple-array) vector)) x) 0))
3668    (((make-array 10 :adjustable t :initial-element 3)) 3)))
3669
3670 (with-test (:name :restoring-tns-after-cleanups)
3671   (checked-compile-and-assert
3672       ()
3673       `(lambda ()
3674          (declare (notinline values))
3675          (unwind-protect 1
3676            (let ((a (list 'list)))
3677              (declare (dynamic-extent a))
3678              (unwind-protect 1 (eval a)))
3679            (eval 1)
3680            (eval 2)))
3681     (() 1)))
3682
3683 (defun noflush-symbol-function ()
3684   (declare (optimize safety))
3685   (if (functionp (symbol-function '#:notathing)) 1))
3686 (defun flush-symbol-function ()
3687   (if (functionp (symbol-function '#:notathing)) 1))
3688 (with-test (:name :flush-symbol-function :skipped-on :interpreter)
3689   (assert (ctu:find-code-constants #'noflush-symbol-function))
3690   (assert (not (ctu:find-code-constants #'flush-symbol-function))))
3691
3692 (with-test (:name :symbolp-other-pointer)
3693   (checked-compile-and-assert
3694       ()
3695       `(lambda (x)
3696          (declare ((or symbol bit-vector) x))
3697          (the symbol x))
3698     ((t) t)))
3699
3700 (with-test (:name :non-nil-symbolp-other-pointer)
3701   (checked-compile-and-assert
3702       ()
3703       `(lambda (x)
3704          (declare ((or bignum symbol) x))
3705          (sb-kernel:non-null-symbol-p x))
3706     ((t) t)
3707     (((1+ most-positive-fixnum)) nil)
3708     ((nil) nil)))
3709
3710 (with-test (:name :list-constant-coalesce)
3711   (checked-compile-and-assert
3712       ()
3713       `(lambda ()
3714          (list -13303942049971317088
3715                -6714119381493
3716                -13303942049971317088))
3717     (() '(-13303942049971317088 -6714119381493 -13303942049971317088) :test #'equal)))
3718
3719 (with-test (:name :list-constant-coalesce.2)
3720   (checked-compile-and-assert
3721       ()
3722       `(lambda ()
3723          (list -3819610816126750017 -7639221632253500034))
3724     (() '(-3819610816126750017 -7639221632253500034) :test #'equal))
3725   (checked-compile-and-assert
3726       ()
3727       `(lambda ()
3728          (list -7639221632253500034 -3819610816126750017))
3729     (() '(-7639221632253500034 -3819610816126750017) :test #'equal)))
3730
3731 (with-test (:name :constraint-loop)
3732   (checked-compile-and-assert
3733       ()
3734       `(lambda (b)
3735          (let ((v (elt '(2444 2740 3237 8155 3296 7304 7612 2949) b)))
3736            (progv '(*) (list (ceiling v 40))
3737              *)))
3738     ((3) 204)))
3739
3740 (with-test (:name :unused-local-fun-results)
3741   (let ((f  `(lambda (x)
3742                (flet ((x ()
3743                         (expt x x)))
3744                  (x)
3745                  (x)
3746                  10))))
3747     (assert (not (ctu:ir1-named-calls f)))))
3748
3749 (with-test (:name :ir2opt-tns-without-sc)
3750   (checked-compile-and-assert
3751       ()
3752       `(lambda (a)
3753          (boole boole-set (the rational a) a))
3754     ((1) -1)))
3755
3756 (with-test (:name set-slot-old-p-optionals)
3757   (checked-compile-and-assert
3758    ()
3759    `(lambda (x &key)
3760       (let ((list (list 1)))
3761         (setf (car list) x)
3762         list))
3763    ((2) '(2) :test #'equal)))
3764
3765 (with-test (:name :tn-ref-type-ir2opt)
3766   (checked-compile-and-assert
3767    ()
3768    `(lambda (p)
3769       (the unsigned-byte
3770            (the (or (array * (1)) real) p)))
3771    ((5) 5)))
3772
3773 (with-test (:name :qword-to-dword-cut)
3774   (checked-compile-and-assert
3775    (:allow-warnings t)
3776    `(lambda (a b)
3777       (declare (fixnum b))
3778       (logxor
3779        (lognor (setq a -336272099380508247)
3780                (shiftf b (logorc1 1073741832 a)))
3781        (the (integer -504635362412860905 -99686857090873309) (lognand b 11))))))
3782
3783 (with-test (:name :not-folded-vops)
3784   (assert
3785    (type-specifiers-equal
3786     (caddr
3787      (sb-kernel:%simple-fun-type
3788       (checked-compile
3789        `(lambda ()
3790           (floor
3791            (dpb 42
3792                 (byte 15 7)
3793                 (block b
3794                   (loop for lv below 1 count
3795                         (floor
3796                          (flet ((%f (f1)
3797                                   (- (floor f1 f1) (return-from b -9))))
3798                            (multiple-value-call #'%f (values (block b3 lv))))
3799                          42))))
3800            42)))))
3801     '(values (integer -99734 -99734) (integer 19 19) &optional))))
3802
3803 (with-test (:name :bit-ir2opt)
3804   (checked-compile-and-assert
3805    ()
3806    `(lambda (a c)
3807       (declare (fixnum c))
3808       (setf a -14)
3809       (logior
3810        (shiftf a (bit #*01 (max 0 c)))
3811        (max 0 c)))
3812    ((1 1) -13)))
3813
3814 (with-test (:name :find-initial-dfo-ignore-let-converted-funs)
3815   (checked-compile-and-assert
3816    ()
3817    `(lambda (c)
3818       (tagbody
3819          (flet ((%f7 (f7-3
3820                       &optional (f7-4 (go tag5))
3821                                 (f7-5 ((lambda (&rest args) (go tag5))))
3822                                 (f7-6 0))
3823                   0))
3824            ((lambda (v10) (%f7 (go tag5) -63522127 v10)) c))
3825        tag5))
3826    ((9) nil)))
3827
3828 (with-test (:name :find-initial-dfo-ignore-assignment-converted-funs)
3829   (checked-compile-and-assert
3830    ()
3831    `(lambda ()
3832       (values
3833        (catch 'c 0)
3834        (labels ((%f (&optional (x 0) (y 0)) y))
3835          (case 0
3836            ((1) (%f 0))
3837            ((2) (%f))))))
3838    (() (values 0 nil))))
3839
3840 (with-test (:name :find-initial-dfo-ignore-assignment-converted-funs.2)
3841   (checked-compile-and-assert
3842    (:allow-style-warnings t)
3843    `(lambda (a)
3844       (let ((v (make-array 1 :initial-element (catch 'ct 42))))
3845         (labels ((f (&optional (x 4) &key (k a)) x))
3846           (if nil (f) (f a)))))
3847    ((9) 9)))
3848
3849 (with-test (:name :if-eq-optimizer-nil)
3850   (checked-compile-and-assert
3851       ()
3852       `(lambda (x)
3853          (let (b)
3854            (unless (eq x b)
3855              (error ""))
3856            x))
3857     ((nil) nil)))
3858
3859 (with-test (:name :assignment-convert-check-same-lvar)
3860   (checked-compile-and-assert
3861    (:allow-style-warnings t)
3862    `(lambda (c)
3863       (flet ((%f9 (f9-1 f9-2 &optional (key1 0))
3864                f9-2))
3865         (multiple-value-prog1 (%f9 701021570480035 c)
3866           (if t
3867               0
3868               (progn
3869                 (%f9 1048572 2385880201)
3870                 (if t
3871                     (%f9 777238289903386671 -15131644893)
3872                     0))))))
3873    ((10) 10)))
3874
3875 (with-test (:name :range<)
3876   (checked-compile-and-assert
3877       ()
3878       `(lambda (l h v)
3879          (declare (fixnum l h))
3880          (if (< l v)
3881              (if (> h v)
3882                  :bad
3883                  :good)
3884              :bad))
3885     ((-1 -1 0) :good)))
3886
3887 (with-test (:name :range<.2)
3888   (checked-compile-and-assert
3889       ()
3890       `(lambda (a h)
3891          (declare (fixnum h))
3892          (and (>= a 0)
3893               (not (> h a))))
3894     ((1 0) t)
3895     ((-1 0) nil)))
3896
3897 (with-test (:name :range<.3)
3898   (checked-compile-and-assert
3899       ()
3900       `(lambda (b c)
3901          (and (or (not b) (< 0 c)) (<= c 0)))
3902     ((nil -1) t)
3903     ((t -1) nil)
3904     ((nil 1) nil)))
3905
3906 (with-test (:name :range<.4)
3907   (checked-compile-and-assert
3908       ()
3909       `(lambda (f m)
3910          (declare (fixnum f))
3911          (<= (truncate 10 f) m 0))
3912     ((-1 0) t)
3913     ((1 0) nil)
3914     ((-1 10) nil)))
3915
3916 (with-test (:name :range<-equal-bounds)
3917   (checked-compile-and-assert
3918       ()
3919       `(lambda (l x h)
3920          (sb-kernel:range< l x h))
3921     ((0 0 0) nil)
3922     ((0 0.5 0) nil)
3923     ((0 -0.5 0) nil)
3924     ((0 1/2 0) nil)
3925     ((0 -1/2 0) nil))
3926   (checked-compile-and-assert
3927       ()
3928       `(lambda (l x h)
3929          (sb-kernel:range<<= l x h))
3930     ((0 0 0) nil)
3931     ((0 0.5 0) nil)
3932     ((0 -0.5 0) nil)
3933     ((0 1/2 0) nil)
3934     ((0 -1/2 0) nil))
3935   (checked-compile-and-assert
3936       ()
3937       `(lambda (l x h)
3938          (sb-kernel:range<=< l x h))
3939     ((0 0 0) nil)
3940     ((0 0.5 0) nil)
3941     ((0 -0.5 0) nil)
3942     ((0 1/2 0) nil)
3943     ((0 -1/2 0) nil))
3944   (checked-compile-and-assert
3945       ()
3946       `(lambda (l x h)
3947          (sb-kernel:range<= l x h))
3948     ((0 0 0) t)
3949     ((0 0.5 0) nil)
3950     ((0 -0.5 0) nil)
3951     ((0 1/2 0) nil)
3952     ((0 -1/2 0) nil)))
3953
3954 (with-test (:name :move-from-word/fixnum-ir2opt)
3955   (checked-compile-and-assert
3956    ()
3957    `(lambda (c)
3958       (declare (type (integer -10 10) c))
3959       (let ((v5 (logior 2305843195621877482 c)))
3960         (values v5
3961                 (abs (shiftf v5 (+ v5 1))))))
3962    ((-10) (values -2 2))))
3963
3964 (with-test (:name :values-list-type-check
3965             :skipped-on (not (or :x86-64 :arm64)))
3966   (assert (find-if (lambda (line)
3967                      (search "BOGUS-ARG-TO-VALUES-LIST-ERROR" line :test #'equal))
3968                    (ctu:disassembly-lines
3969                     (checked-compile
3970                      `(lambda (l)
3971                         (let (*)
3972                           (values-list l)))))))
3973   (assert (not (find-if (lambda (line)
3974                           (search "BOGUS-ARG-TO-VALUES-LIST-ERROR" line :test #'equal))
3975                         (ctu:disassembly-lines
3976                          (checked-compile
3977                           `(lambda (l)
3978                              (declare (optimize (safety 0)))
3979                              (let (*)
3980                                (values-list l)))))))))
3981
3982 (with-test (:name :explicit-value-cell-top-level)
3983   (ctu:file-compile
3984    `((defvar *x*)
3985      (let ((v 0))
3986        (loop repeat 1
3987              do
3988              (setf *x* (lambda () (incf v)))))
3989      (assert (eql (funcall *x*) 1))
3990      (assert (eql (funcall *x*) 2)))
3991    :load t))
3992
3993 (with-test (:name :load-store-two-words-reused-load-tn)
3994   (checked-compile-and-assert
3995    ()
3996    `(lambda (x)
3997       (funcall x 1 2 3 4 'a t t))
3998    (('list) '(1 2 3 4 a t t) :test #'equal)))
3999
4000 (with-test (:name :closures-unreachable-components)
4001   (checked-compile-and-assert
4002       ()
4003       `(lambda (f)
4004          (catch 'c
4005            (block nil
4006              (labels ((f11 () f)
4007                       (b (&key)
4008                         (catch 'd
4009                           (lambda () #'f11))
4010                         (return #'f11)))))))))
4011
4012 (with-test (:name :flushable-nil-funs)
4013   (checked-compile-and-assert
4014       ()
4015       `(lambda (a b)
4016          (eq (the (or) (car a))
4017              (the (or) (car b))))))
4018
4019 (with-test (:name :cmov-modifying-input)
4020   (checked-compile-and-assert
4021       ()
4022       `(lambda (a b d)
4023          (declare (double-float d))
4024          (values (if (not (> d 10d0))
4025                      b
4026                      a)
4027                  a))
4028     ((1 2 1d0) (values 2 1))))
4029
4030 (with-test (:name :ir1-optimize-return-type-widening)
4031   (checked-compile-and-assert
4032       ()
4033       `(lambda (a b)
4034          (flet ((f ()
4035                   (ceiling a b)))
4036            (values (the integer (f)))))
4037     ((1 2) 1)))
4038
4039 (with-test (:name :reuse-coercion)
4040   (multiple-value-bind (fun fail warn style notes)
4041       (checked-compile `(lambda (x d)
4042                           (declare (double-float d)
4043                                    (fixnum x)
4044                                    (optimize speed))
4045                           (cond ((= x 1)
4046                                  (+ d 1))
4047                                 ((= x 2)
4048                                  (+ d 2))
4049                                 ((= x 3)
4050                                  (+ d 3)))))
4051     (declare (ignore fail warn style))
4052     (assert (= (length notes) 1))
4053     (assert (= (funcall fun 1 0d0) 1d0))
4054     (assert (= (funcall fun 2 0d0) 2d0))
4055     (assert (= (funcall fun 3 0d0) 3d0))
4056     (assert (null (funcall fun 4 0d0)))))
4057
4058 (with-test (:name :reorder-keywordp)
4059   (checked-compile-and-assert
4060       ()
4061       `(lambda (a)
4062          (cond ((stringp a)
4063                 1)
4064                ((keywordp a)
4065                 2)
4066                ((symbolp a)
4067                 3)))
4068     (("a") 1)
4069     ((:a) 2)
4070     (('m) 3)
4071     ((1) nil)))
4072
4073 (with-test (:name :reorder-same-block)
4074   (checked-compile-and-assert
4075       ()
4076       `(lambda (a)
4077          (typecase a
4078            (double-float 1)
4079            (fixnum 2)
4080            (bignum 3)
4081            (t 2)))
4082     ((1d0) 1)
4083     ((1) 2)
4084     (((1+ most-positive-fixnum)) 3)
4085     ((t) 2)))
4086
4087 (with-test (:name :unlink-node-in-delete-block)
4088   (checked-compile-and-assert
4089    ()
4090    `(lambda (b)
4091       (tagbody
4092          ((lambda (v)
4093             (declare (ignore v))
4094             ((lambda (a b &rest c)
4095                a b c
4096                (go 7))
4097              (catch 'c 0)
4098              (case b ((-424 -278) b) (t 0))))
4099           ((lambda () (go 7))))
4100        7))))
4101
4102 (with-test (:name :multiple-call-unboxed-calls)
4103   (checked-compile-and-assert
4104    ()
4105    `(lambda (m j)
4106       (declare (double-float m))
4107       (let (*)
4108         (if j
4109             (funcall j)
4110             (truncate m))))
4111    ((1d0 nil) (values 1 0d0))
4112    ((4d38 nil) (values 399999999999999990995239293824136118272 0d0)))
4113   (checked-compile-and-assert
4114    ()
4115    `(lambda (m j)
4116       (declare (ratio m))
4117       (let (*)
4118         (if j
4119             (funcall j)
4120             (coerce m 'double-float))))
4121    ((1/2 nil) 0.5d0))
4122   (checked-compile-and-assert
4123    ()
4124    `(lambda (m j)
4125       (declare (double-float m))
4126       (let (*)
4127         (if j
4128             (funcall j)
4129             (scale-float m 2))))
4130    ((1d0 nil) 4d0)
4131    ((2d0 nil) 8d0)))
4132
4133 (with-test (:name :structure-typep*-deleted-branch)
4134   (checked-compile-and-assert
4135       ()
4136       `(lambda (x)
4137          (cond
4138            ((typep x 'random-state)
4139             1)
4140            ((typep x 'hash-table)
4141             2)
4142            (t x)))
4143     ((*random-state*) 1)
4144     (((make-hash-table)) 2)
4145     ((423444) 423444)))
4146
4147 (with-test (:name :deleted-call-type)
4148   (checked-compile-and-assert
4149    ()
4150    `(lambda (x)
4151       (labels ((foo (x)
4152                  x))
4153         (foo 1)
4154         (when x
4155           (unless x
4156             (foo 3)))
4157         (foo 2)))
4158     (:return-type (values (integer 1 2) &optional))))
4159
4160 (with-test (:name :optional-type-propagation)
4161   (checked-compile-and-assert
4162       ()
4163       `(lambda ()
4164          (labels ((foo (&optional x)
4165                     x))
4166            (foo 1)
4167            (foo 2)))
4168     (:return-type (values (integer 1 2) &optional)))
4169   (checked-compile-and-assert
4170       ()
4171       `(lambda ()
4172          (labels ((foo (&key x)
4173                     x))
4174            (foo :x 1)
4175            (foo :x 2)))
4176     (:return-type (values (integer 1 2) &optional))))
4177
4178 (with-test (:name :local-function-declaration)
4179   (checked-compile-and-assert
4180       (:optimize :safe)
4181       `(lambda (n)
4182          (declare ((function * fixnum) n))
4183          (typep (funcall n) 'fixnum))
4184     ((#'list) (condition 'type-error))))
4185
4186 (declaim (inline member-type-derivation))
4187 (defun member-type-derivation (x)
4188   (member x '(a b c d)))
4189
4190 (with-test (:name :member-type-derivation)
4191   (checked-compile-and-assert
4192    ()
4193    `(lambda (n)
4194       (when (member-type-derivation n)
4195         t))
4196    (('a) t)
4197    (('b) t)
4198    (('c) t)
4199    (('d) t)
4200    (('e) nil)))
4201
4202 (with-test (:name :equal-not-null-transform)
4203   (checked-compile-and-assert
4204       ()
4205       `(lambda (x y)
4206          (declare (atom x) (list y))
4207          (equalp x y))
4208     ((nil nil) t)
4209     ((nil '(1)) nil)
4210     ((1 nil) nil))
4211   (checked-compile-and-assert
4212       ()
4213       `(lambda (x y)
4214          (declare (atom x) (list y))
4215          (equal y x))
4216     ((nil nil) t)
4217     ((nil '(1)) nil)
4218     ((1 nil) nil)))
4219
4220 (with-test (:name :optimize-return-deleted-lambda)
4221   (checked-compile-and-assert
4222       ()
4223       `(lambda (x)
4224          (labels ((f1 ()
4225                     (case x (:star (f1))))
4226                   (f2 (d n)
4227                     (case x (:open (f1))))
4228                   (f3 (d n)
4229                     (case x
4230                       (:backquote (f4 d 0))
4231                       (:nest
4232                        (f3 d n))
4233                       (t (f2 d n))))
4234                   (f4 (d n)
4235                     (case x
4236                       (:nest (f3 d n))
4237                       (t (f2 d n))))
4238                   (f5 (d)
4239                     (case x
4240                       (:backquote (f4 d 0))
4241                       (:nest (f5 d)))))))
4242     ((1) nil)))
4243
4244 (with-test (:name :type-derivers-type-widening)
4245   (checked-compile-and-assert
4246       ()
4247       `(lambda (b c)
4248          (logbitp 0
4249                   (if (eql c 0)
4250                       (max (ignore-errors c) 0)
4251                       b)))
4252       ((1 2) t)
4253       ((0 0) nil)))
4254
4255 (with-test (:name :propagate-to-refs-hairy)
4256   (checked-compile-and-assert
4257       ()
4258       `(lambda (y)
4259          (declare (fixnum y))
4260          (let ((d (max 1 (the (satisfies eval) y))))
4261            (the fixnum (* d 8))))
4262       ((2) 16)))
4263
4264 (with-test (:name :complicated-cons-function-unions)
4265   (checked-compile-and-assert
4266       ()
4267       `(lambda (w)
4268          (car (member w '#.(list #'< #'= #'eql #'equalp))))
4269     ((#'=) #'=)))
4270
4271
4272 (with-test (:name :tail-calls-terminated-blocks)
4273   (prog* ((f (checked-compile `(lambda (f)
4274                                  (declare (optimize  (debug 1)))
4275                                  (labels ((f1 (f)
4276                                             (funcall f)
4277                                             (f1 f)))
4278                                    (f1 (f1 f))))))
4279           (x 0))
4280      (assert (funcall f (lambda () (when (= (incf x) 2) (return t)))))))
4281
4282 (with-test (:name :the*-exits)
4283   (checked-compile-and-assert
4284    ()
4285    `(lambda (x)
4286       (if x
4287           10
4288           (block nil
4289             (hash-table-test (return)))))
4290    ((t) 10)
4291    ((nil) nil)))
4292
4293 (with-test (:name :inlining-deleted-go-tag)
4294   (checked-compile-and-assert
4295    ()
4296    `(lambda (a)
4297      (tagbody
4298         (labels ((f () (go t)))
4299           (declare (inline f))
4300           (funcall a #'f)
4301           (multiple-value-call #'f (values)))
4302       t)
4303      2)
4304    ((#'list) 2)))
4305
4306 (with-test (:name :inling-non-convertible-locals)
4307   (checked-compile-and-assert
4308    ()
4309    `(lambda (x)
4310       (labels ((f (&key m)
4311                  (values m x)))
4312         (declare (inline f))
4313         (eval (f))
4314         (f x 30)))
4315    ((:m) (values 30 :m))
4316    ((:allow-other-keys) (values nil :allow-other-keys))))
4317
4318 (with-test (:name :undeleted-exits)
4319   (checked-compile-and-assert
4320    ()
4321    `(lambda ()
4322       (tagbody
4323          (flet ((f (a) a (go 5)))
4324            (print (list #'f (loop for i in (f 1)
4325                                   do (print i)))))
4326        5))
4327    (() nil)))
4328
4329 (with-test (:name :unused-initial-values)
4330   (checked-compile-and-assert
4331     (:allow-notes nil :optimize '(:debug 2 :speed 3 :safety 1))
4332     `(lambda (v)
4333        (declare ((simple-array double-float (*)) v))
4334        (loop for e across v count (> e 0)))
4335     (((make-array 9 :element-type 'double-float :initial-element 1d0)) 9)))
4336
4337 (with-test (:name :consecutive-cast)
4338   (checked-compile-and-assert
4339    ()
4340    `(lambda (f)
4341       (the fixnum (the integer (funcall f))))
4342    ((#'+) 0))
4343   (checked-compile-and-assert
4344    ()
4345    `(lambda (a)
4346       (abs (catch 'c (the (satisfies eval) a))))
4347    ((-1) 1))
4348   (checked-compile-and-assert
4349    ()
4350    `(lambda (f x)
4351       (the fixnum
4352            (if f
4353                (funcall f)
4354                (the real x))))
4355    ((#'* 0) 1)
4356    ((nil 2) 2))
4357   (checked-compile-and-assert
4358    (:optimize :safe)
4359    `(lambda (x)
4360       (the vector (the array x)))
4361    ((1) (condition 'type-error)))
4362   (checked-compile-and-assert
4363    (:optimize :safe)
4364    `(lambda (x)
4365       (let ((m (the array x)))
4366         (values (the vector m)
4367                 m)))
4368    ((1) (condition 'type-error)))
4369   (checked-compile-and-assert
4370    (:optimize :safe)
4371    `(lambda (c d m)
4372       (declare (type fixnum c d m))
4373       (the (unsigned-byte 62)
4374            (values
4375             (let ((v (logxor c -7322529 d 9223372036854775805)))
4376               (if (> v 0)
4377                   (the unsigned-byte m)
4378                   (logior 80827861226 v))))))
4379    ((-3462512952 -77 0) (condition 'type-error)))
4380   (checked-compile-and-assert
4381     (:optimize :safe)
4382     `(lambda (x m)
4383        (the fixnum
4384             (if x
4385                 (let ((j (the integer m)))
4386                   j)
4387                 m)))
4388     ((nil 'a) (condition 'type-error))
4389     ((t 1d0) (condition 'type-error))
4390     ((nil 1) 1)
4391     ((t 2) 2))
4392   (checked-compile-and-assert
4393     (:optimize :safe)
4394    `(lambda (f x)
4395      (the (values fixnum &optional) (the (values integer &rest t) (funcall f x))))
4396     ((#'identity .0) (condition 'type-error))
4397     ((#'identity 1) 1)
4398     ((#'identity (expt 2 1000)) (condition 'type-error))))
4399
4400 (with-test (:name :pop-values-unused)
4401   (checked-compile-and-assert
4402    ()
4403    `(lambda (j l r)
4404       (declare ((function (fixnum &rest t)) j))
4405       (apply j l r))
4406    ((#'+ 1 '(2)) 3)))