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 (cl:in-package :cl-user)
  25
  26 (load "compiler-test-util.lisp")
  27
  28 (defun compiles-with-warning (lambda)
  29   (assert (nth-value 2 (checked-compile lambda :allow-warnings t))))
  30
  31 (with-test (:name (ldb :recognize-local-macros))
  32   ;; Should not call %LDB
  33   (assert (not (ctu:find-named-callees
  34                 (checked-compile
  35                  '(lambda (x)
  36                    (declare (optimize speed))
  37                    (macrolet ((b () '(byte 2 2)))
  38                      (ldb (b) (the fixnum x)))))))))
  39
  40 (with-test (:name (dpb :eval-order :lp-1458190))
  41   (sb-int:collect ((calls))
  42     (flet ((f (new old)
  43              (dpb (progn (calls 'eval-new) new)
  44                   (progn (calls 'eval-byte) (byte 10 10))
  45                   (progn (calls 'eval-old) old))))
  46       (f 20 0)
  47       (assert (equal (calls)
  48                      '(eval-new eval-byte eval-old))))))
  49
  50 ;; Best practice treats TRULY-THE as a special operator, not a macro,
  51 ;; in a context such as (DPB X (TRULY-THE SB-KERNEL:BYTE-SPECIFIER ...) Y).
  52 ;; DPB used to expand its second argument using MACROEXPAND and lose
  53 ;; the nuance of TRULY-THE. Strictly speaking, byte-specifier is not a
  54 ;; type specifier that users are supposed to know about, so portable code
  55 ;; should not care, but this might affect internal code.
  56 (with-test (:name (dpb :inner-macro))
  57   (flet ((source-xform (sexpr)
  58            (funcall (sb-int:info :function :source-transform (car sexpr))
  59                     sexpr (sb-kernel:make-null-lexenv))))
  60     (assert (equal-mod-gensyms
  61              (source-xform
  62               '(dpb (new) (truly-the sb-kernel:byte-specifier bspec) (old)))
  63              '(let ((new (new))
  64                     (byte (truly-the sb-kernel:byte-specifier bspec)))
  65                (sb-kernel:%dpb new (byte-size byte) (byte-position byte)
  66                                (old)))))))
  67
  68 (with-test (:name :inline-satisfies-predicate)
  69   ;; If we remove the indirections in these functions,
  70   ;; this test should visibly break so that we can write a new test
  71   ;; that asserts that inlining F works in (THE (SATISFIES F) obj).
  72   (assert (equal (sb-ext:typexpand 'sb-impl::function-name)
  73                  '(satisfies sb-int:legal-fun-name-p)))
  74   (let ((f (checked-compile '(lambda (x) (the sb-impl::function-name x)))))
  75     (assert (equal (list (symbol-function 'sb-int:valid-function-name-p))
  76                    (ctu:find-named-callees f))))
  77   (let ((f (checked-compile '(lambda (x)
  78                                (declare (notinline sb-int:legal-fun-name-p))
  79                                (the sb-impl::function-name x)))))
  80     (assert (equal (list (symbol-function 'sb-int:legal-fun-name-p))
  81                    (ctu:find-named-callees f)))))
  82
  83 (with-test (:name (make-array :untestable-type :no-warning))
  84   (checked-compile `(lambda () (make-array '(2 2)
  85                                            :element-type `(satisfies foofa)))))
  86
  87 (with-test (:name (make-array nil :no-warning))
  88   (checked-compile '(lambda () (make-array '(2 2) :element-type nil))))
  89
  90 (with-test (:name (nth-value :huge-n :works))
  91   (flet ((return-a-ton-of-values ()
  92            (values-list (loop for i below 5000 collect i))))
  93     (assert (= (nth-value 1 (return-a-ton-of-values)) 1))
  94     (assert (= (nth-value 4000 (return-a-ton-of-values)) 4000))))
  95
  96 (defstruct (a-test-structure-foo
  97             (:constructor make-a-foo-1)
  98             (:constructor make-a-foo-2 (b &optional a)))
  99   (a 0 :type symbol)
 100   (b nil :type integer))
 101
 102 (with-test (:name :improperly-initialized-slot-warns)
 103   ;; should warn because B's default is NIL, not an integer.
 104   (compiles-with-warning '(lambda () (make-a-foo-1 :a 'what)))
 105   ;; should warn because A's default is 0
 106   (compiles-with-warning '(lambda () (make-a-foo-2 3))))
 107
 108 (with-test (:name (inline structure :ctor :no declaim))
 109   (let ((f (checked-compile '(lambda ()
 110                                (make-a-foo-1 :a 'wat :b 3)))))
 111     (assert (ctu:find-named-callees f)))
 112   (let ((f (checked-compile '(lambda ()
 113                                (declare (inline make-a-foo-1))
 114                                (make-a-foo-1 :a 'wat :b 3)))))
 115     (assert (not (ctu:find-named-callees f)))))
 116
 117 (with-test (:name :internal-name-p :skipped-on :sb-xref-for-internals)
 118   (assert (sb-c::internal-name-p 'sb-int:neq)))
 119
 120 (with-test (:name (:coerce-callable-to-fun :note))
 121   (flet ((try (form what)
 122            (multiple-value-bind (fun failure-p warnings style-warnings notes)
 123                (checked-compile `(lambda (x)
 124                                   (declare (optimize speed))
 125                                   (funcall ,form)))
 126              (declare (ignore fun failure-p warnings style-warnings))
 127              (assert (search (format nil "~A is not known to be" what)
 128                              (princ-to-string (first notes)))))))
 129
 130     (try '(eval `(work-with ,x)) "callable expression")
 131     (try 'x "X")
 132     ;; For this I'd accept either Z or X in the message.
 133     (try '(progn (let ((z x)) (identity z))) "X")))
 134
 135 (with-test (:name (princ-to-string :unflushable))
 136   ;; Ordinary we'll flush it
 137   (let ((f (checked-compile '(lambda (x) (princ-to-string x) x))))
 138     (assert (not (ctu:find-named-callees f :name 'princ-to-string))))
 139   ;; But in high safety it should be called for effect
 140   (let ((f (checked-compile '(lambda (x)
 141                                (declare (optimize safety)) (princ-to-string x) x))))
 142     (assert (ctu:find-named-callees f :name 'princ-to-string))))
 143
 144 (with-test (:name :space-bounds-no-consing
 145                   :skipped-on :interpreter)
 146   ;; Asking for the size of a heap space should not cost anything!
 147   (ctu:assert-no-consing (sb-vm::%space-bounds :static))
 148   (ctu:assert-no-consing (sb-vm::space-bytes :static)))
 149
 150 (with-test (:name (sb-vm::map-allocated-objects :no-consing)
 151                   :skipped-on :interpreter
 152                   :fails-on :ppc)
 153   (let ((n 0))
 154     (sb-int:dx-flet ((f (obj type size)
 155                        (declare (ignore obj type size))
 156                        (incf n)))
 157       (ctu:assert-no-consing
 158        (sb-vm::map-allocated-objects #'f :dynamic)
 159        5))))
 160
 161 (with-test (:name :pack-varints-as-bignum)
 162   (dotimes (i 500) ; do some random testing this many times
 163     (let* ((random-numbers (loop repeat (+ (random 20) 3)
 164                                  collect (1+ (random 4000))))
 165            (test-list (sort (delete-duplicates random-numbers) #'<))
 166            (packed-int (sb-c::pack-code-fixup-locs test-list))
 167            (result (make-array 1 :element-type 'sb-ext:word)))
 168       ;; The packer intrinsically self-checks the packing
 169       ;; so we don't need to assert anything about that.
 170       (sb-sys:with-pinned-objects (packed-int result)
 171         ;; Now exercise the C unpacker.
 172         ;; This hack of allocating 4 longs is terrible, but whatever.
 173         (let ((unpacker (make-alien long 4))
 174               (prev-loc 0))
 175           (alien-funcall (extern-alien "varint_unpacker_init"
 176                                        (function void (* long) unsigned))
 177                          unpacker
 178                          (sb-kernel:get-lisp-obj-address packed-int))
 179           (sb-int:collect ((unpacked))
 180             (loop
 181              (let ((status
 182                     (alien-funcall
 183                      (extern-alien "varint_unpack"
 184                                    (function int (* long) system-area-pointer))
 185                      unpacker (sb-sys:vector-sap result))))
 186                (let ((val (aref result 0)))
 187                  ;; status of 0 is EOF, val = 0 means a decoded value was 0,
 188                  ;; which can't happen, so it's effectively EOF.
 189                  (when (or (eql status 0) (eql val 0)) (return))
 190                  (let ((loc (+ prev-loc val)))
 191                    (unpacked loc)
 192                    (setq prev-loc loc)))))
 193             (assert (equal (unpacked) test-list))))))))
 194
 195 (with-test (:name (symbol-value symbol-global-value :quoted-constant))
 196   (let ((f (checked-compile '(lambda () (symbol-value 'char-code-limit)))))
 197     (assert (not (ctu:find-code-constants f :type 'symbol))))
 198   (let ((f (checked-compile '(lambda () (symbol-global-value 'char-code-limit)))))
 199     (assert (not (ctu:find-code-constants f :type 'symbol)))))
 200
 201 (with-test (:name (:set symbol-value :of defglobal))
 202   (let ((s 'sb-c::*recognized-declarations*))
 203     (assert (eq (sb-int:info :variable :kind s) :global)) ; verify precondition
 204     (let ((f (checked-compile `(lambda () (setf (symbol-value ',s) nil)))))
 205       ;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE>
 206       (assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))))
 207
 208 (with-test (:name :layout-constants
 209                   :skipped-on (not (and :x86-64 :immobile-space)))
 210   (let ((addr-of-pathname-layout
 211          (write-to-string
 212           (sb-kernel:get-lisp-obj-address (sb-kernel:find-layout 'pathname))
 213           :base 16 :radix t))
 214         (count 0))
 215     ;; The constant should appear in two CMP instructions
 216     (dolist (line (split-string
 217                    (with-output-to-string (s)
 218                      (let ((sb-disassem:*disassem-location-column-width* 0))
 219                        (disassemble 'pathnamep :stream s)))
 220                    #\newline))
 221       (when (and (search "CMP" line) (search addr-of-pathname-layout line))
 222         (incf count)))
 223     (assert (= count 2))))
 224
 225 (with-test (:name :set-symbol-value-imm :skipped-on (not :x86-64))
 226   (let (success)
 227     (dolist (line (split-string
 228                    (with-output-to-string (s)
 229                      (let ((sb-disassem:*disassem-location-column-width* 0))
 230                        (disassemble '(lambda () (setq *print-base* 8)) :stream s)))
 231                    #\newline))
 232       (when (and #+sb-thread (search "MOV QWORD PTR [R" line)
 233                  #-sb-thread (search "MOV QWORD PTR [" line)
 234                  (search (format nil ", ~D" (ash 8 sb-vm:n-fixnum-tag-bits)) line))
 235         (setq success t)))
 236     (assert success)))
 237
 238 (with-test (:name :linkage-table-bogosity :skipped-on (not :sb-dynamic-core))
 239   (let ((strings (map 'list (lambda (x) (if (consp x) (car x) x))
 240                       #+sb-dynamic-core sb-vm::+required-foreign-symbols+
 241                       #-sb-dynamic-core '())))
 242     (assert (= (length (remove-duplicates strings :test 'string=))
 243                (length strings)))))
 244
 245 (with-test (:name (:no style-warning :for inline :cl-fun))
 246   (checked-compile '(lambda (x)
 247                       (declare (optimize (speed 3)) (inline length)
 248                       (muffle-conditions compiler-note))
 249                       (length x))))
 250
 251 (with-test (:name :deleted-return-use)
 252   (checked-compile-and-assert ()
 253       `(lambda ()
 254          (block nil
 255            (return 345)
 256            (let ((a (catch 'x)))
 257              (flet ((%f (a &optional b)
 258                       a))
 259                (%f 0 (%f 123))))))
 260     (() 345)))
 261
 262 (with-test (:name :shift-right-transform-nil-type)
 263   (checked-compile-and-assert (:optimize nil)
 264       `(lambda (b c)
 265          (declare (type (integer -10 -6) c)
 266                   (optimize (debug 2)))
 267          (catch 'c
 268            (flet ((f1 (a &optional (b (shiftf b 0)) c d)
 269                     (declare (ignore a b c d))
 270                     (throw 'c 780)))
 271              (flet ((f2 (a b)
 272                       (f1 a b 0)))
 273                (ash
 274                 (f1 (if t
 275                         c
 276                         (f1 (f2 1 0) 0))
 277                     b)
 278                 (+ c))))))
 279       ((-3 -7) 780)))
 280
 281 (with-test (:name :move-lvar-result-through-unused-cast)
 282   (checked-compile-and-assert (:optimize nil)
 283       `(lambda ()
 284          (declare (optimize (debug 0)))
 285          (labels ((f (a b)
 286                     a b)
 287                   (x ()
 288                     (apply #'f (list 2 3))))
 289            (declare (notinline f))
 290            (the integer (x)))
 291          132)
 292     (() 132)))
 293
 294 (with-test (:name (:type-conflict funcall :external-lambda))
 295   (compiles-with-warning `(lambda ()
 296                             (let ((x (lambda (x) (declare (fixnum x)) x)))
 297                               (funcall x 'a)))))
 298
 299 (with-test (:name (:type-conflict :callable :external-lambda))
 300   (compiles-with-warning `(lambda ()
 301                             (let ((x (lambda (x) (declare (fixnum x)) x)))
 302                               (find-if x "abca")))))
 303
 304 (with-test (:name (:type-conflict map :result-type))
 305   (compiles-with-warning `(lambda (str)
 306                             (map 'string (lambda (x) (declare (ignore x)) nil)
 307                                  str))))
 308
 309 (with-test (:name (:type-conflict :by-name))
 310   (compiles-with-warning `(lambda (str)
 311                             (map 'string 'evenp str))))
 312
 313 (with-test (:name (:type-conflict :callable :reporting))
 314   (multiple-value-bind (fun failure-p warnings)
 315       (checked-compile '(lambda (x) (map-into (make-string 10) #'evenp x))
 316                        :allow-warnings 'warning)
 317     (declare (ignore fun))
 318     (assert failure-p)
 319     (assert (= (length warnings) 1))
 320     (search "Derived type of EVENP is"
 321             (princ-to-string (first warnings)))))
 322
 323 (with-test (:name (:type-conflict string :union-type))
 324   (compiles-with-warning `(lambda (x)
 325                             (find-if #'evenp (the string x)))))
 326
 327 (with-test (:name (:type-conflict map-into :let))
 328   (compiles-with-warning `(lambda (z)
 329                             (let ((x "abc"))
 330                               (map-into z #'evenp x)))))
 331
 332 (with-test (:name (:type-conflict map-into :result))
 333   (compiles-with-warning `(lambda (z)
 334                             (map-into (make-string 10) #'evenp z))))
 335
 336 (with-test (:name (:type-conflict complement))
 337   (assert (nth-value 3
 338                      (checked-compile
 339                       `(lambda (z)
 340                          (find z "l" :test (complement #'=)))
 341                       :allow-style-warnings t))))
 342
 343 (with-test (:name :type-across-hairy-lambda-transforms)
 344   (assert (subtypep (sb-kernel:%simple-fun-type (lambda (x) (find 1 (the vector x))))
 345                     '(function * (values (or (integer 1 1) null) &optional)))))
 346
 347 (with-test (:name :lea-type-derivation)
 348   (checked-compile-and-assert ()
 349       `(lambda (b)
 350          (declare ((integer -3755795408964870057 -3391381516052960895)
 351                    b))
 352          (ldb (byte 22 10) (* b 9)))
 353     ((-3391381516052980893) 2826685)))
 354
 355 (with-test (:name (:unused &optional :and &key))
 356   (checked-compile-and-assert (:allow-style-warnings t)
 357       `(lambda (&optional x &key)
 358          (declare (ignore x))
 359          10)
 360     (() 10)))
 361
 362 (with-test (:name (:unknown values :coercion))
 363   (checked-compile-and-assert ()
 364       `(lambda (a)
 365          (declare (notinline values typep))
 366          (the integer (values a 2305843009213693946 a -207)))
 367     ((123) (values 123 2305843009213693946 123 -207))))
 368
 369 (with-test (:name :deleted-block-during-generate-type-checks)
 370   (checked-compile-and-assert (:allow-warnings t)
 371       `(lambda (a b)
 372          (declare (notinline min ash conjugate oddp >=))
 373          (if (and (or t (>= a)) (oddp 0))
 374              (prog2 0
 375                  0
 376                (labels ((f (a b c &key)
 377                           (declare (ignore a b c))
 378                           6965670824543402))
 379                  (f a 0 b)))
 380              (conjugate
 381               (dotimes (i 0 0)
 382                 (catch 'c
 383                   (ash
 384                    (the integer
 385                         (ignore-errors
 386                           (ignore-errors (throw 'c 1))))
 387                    (min a)))))))
 388     ((1 2) 0)))
 389
 390 (with-test (:name :block-delete-twice)
 391   (checked-compile-and-assert ()
 392       `(lambda ()
 393          (declare (notinline >=))
 394          (block nil
 395            (lambda (x &key (key (if (>= 0 1)
 396                                     (return (catch 'ct5 0)))))
 397              (declare (ignore key))
 398              x)))
 399     (() 123 :test (lambda (values expected)
 400                     (equal (multiple-value-list
 401                             (funcall (first values) (first expected)))
 402                            expected)))))
 403
 404 (with-test (:name :dead-lvars-and-stack-analysis)
 405   (checked-compile-and-assert ()
 406     `(lambda (b)
 407        (catch 'ct2
 408          (block b5
 409            (return-from b5
 410              (multiple-value-prog1 19
 411                (if (or b t)
 412                    (return-from b5 333)))))))
 413     ((11) 333)))
 414
 415 (with-test (:name :mv-call-more-values)
 416   (checked-compile-and-assert ()
 417     `(lambda (z)
 418        (multiple-value-call (lambda (&optional x y &rest args)
 419                               (declare (ignore args))
 420                               (+ y x))
 421          2 (truncate z 30)))
 422     ((2345) 80)))
 423
 424 (with-test (:name :unused-casts-at-ir2-convert)
 425   (checked-compile-and-assert ()
 426     `(lambda ()
 427        (unwind-protect 123
 428          (the integer
 429               (labels ((%f (x &key)
 430                          (declare (ignore x))
 431                          (svref #(46 32) 0)))
 432                 (unwind-protect (%f (%f 0)))))))
 433     (() 123)))
 434
 435 (with-test (:name :cmov-constants-different-primitive-type)
 436   (checked-compile-and-assert ()
 437     `(lambda (b)
 438        (case b
 439          ((2030) 4611686018427387908)
 440          ((572) b)
 441          (t 0)))
 442     ((572) 572)
 443     ((123) 0)
 444     ((2030) 4611686018427387908)))
 445
 446 (with-test (:name :mv-bind-skipping-vars-on-reoptimize)
 447   (checked-compile-and-assert ()
 448     `(lambda ()
 449        (let (lv1)
 450          (apply (lambda (&rest args)
 451                   (declare (ignore args)))
 452                 0
 453                 (list 3 lv1))
 454          (setf lv1 10)))
 455     (() 10)))
 456
 457 (with-test (:name :transform-on-a-nil-arg)
 458   (checked-compile-and-assert ()
 459    `(lambda ()
 460       (block nil
 461         (logtest
 462          (multiple-value-prog1
 463              (unwind-protect (return 32))
 464            (catch 'tag (return 33)))
 465          1)
 466         34))
 467    (() 32)))
 468
 469 (with-test (:name :nesteted-dx-deleted-uses)
 470   (checked-compile-and-assert ()
 471     `(lambda (a)
 472        (block b2
 473          (let* ((v1 (make-array nil :initial-element
 474                                 (let ((a a))
 475                                   (return-from b2 a)))))
 476            (declare (dynamic-extent v1))
 477            (aref v1))))
 478     ((342) 342)))
 479
 480 (with-test (:name :deleted-during-locall-analyze-fun-1)
 481   (checked-compile-and-assert (:allow-warnings t)
 482     `(lambda ()
 483        (flet ((a ()))
 484          (a 1)
 485          (a 2)))
 486     (() (condition 'program-error))))
 487
 488 (with-test (:name :delete-return-without-flush-dest)
 489   (assert (eql
 490            (catch 'c
 491              (funcall (checked-compile
 492                        '(lambda ()
 493                          (labels ((%f () 40))
 494                            (multiple-value-prog1 *
 495                              (throw 'c (%f))
 496                              (%f)
 497                              30))))))
 498            40)))
 499
 500 (with-test (:name :let-conversion-inside-deleted-lambda.1)
 501   (checked-compile-and-assert ()
 502     `(lambda ()
 503        (block nil
 504          (catch 'c)
 505          (flet ((f (x &key)
 506                   (when x
 507                     (progv '(*) '(0)
 508                       (return)))))
 509            (f (return 123))
 510            (f 0))))
 511     (() 123)))
 512
 513 (with-test (:name :let-conversion-inside-deleted-lambda.2)
 514   (checked-compile-and-assert ()
 515     `(lambda ()
 516        (block nil
 517          (block nil
 518            (lambda () (return)))
 519          (labels ((l () (l))
 520                   (%f (a &key)
 521                     (l)
 522                     (return a)))
 523            (%f (return 321))
 524            (%f 1))))
 525     (() 321)))
 526
 527 (with-test (:name :unconvert-tail-calls)
 528   (checked-compile-and-assert ()
 529     `(lambda ()
 530        (block nil
 531          (labels ((f (&optional (a (return))
 532                                 (b (if t (return)))
 533                                 c
 534                       &rest args)
 535                     (declare (ignore a b c args))
 536                     (return 0)))
 537            (let (x)
 538              (equal 10 (f 0 3))
 539              (f 123 0 0)
 540              (f 0)
 541              x))))
 542     (() 0)))
 543
 544 (with-test (:name :deleting-exits-with-multiple-users)
 545   (checked-compile-and-assert ()
 546     `(lambda (a b)
 547        (block nil
 548          (multiple-value-prog1 b
 549            (tagbody (return (multiple-value-prog1 3
 550                               (if a (go z)))) z))))
 551     ((nil :good) 3)
 552     ((t :good) :good)))
 553
 554 (with-test (:name :merge-tail-sets-deleted-functional)
 555   (checked-compile-and-assert ()
 556     `(lambda (a)
 557        (block nil
 558          (tagbody
 559             (go g549)
 560           g549
 561             (return-from nil
 562               (block b3
 563                 (let ((x (progn (lambda (&optional (x a)) x)
 564                                 (unwind-protect 10)
 565                                 (return-from b3 a))))
 566                   (unwind-protect x)))))))
 567     ((321) 321)))
 568
 569 (with-test (:name :interval-div-zero)
 570   (checked-compile-and-assert (:optimize :safe)
 571     `(lambda (x y)
 572        (truncate (the (integer 0 0) x)
 573                  (the (rational (1) (2)) y)))
 574    ((0 3/2) (values 0 0))))
 575
 576 (with-test (:name :float-remainders-rounding-errors)
 577   (loop for fun in '(ceiling truncate floor
 578                      fceiling ftruncate ffloor
 579                      round fround)
 580         do
 581         (assert (member (second
 582                          (third (sb-kernel:%simple-fun-type
 583                                  (checked-compile
 584                                   `(lambda (x)
 585                                      (nth-value 1 (,fun (the double-float x) 1/2)))))))
 586                         '(double-float real)))))
 587
 588 (with-test (:name :float-quotient-rounding-errors)
 589   (checked-compile-and-assert (:optimize :safe)
 590    `(lambda ()
 591       (floor -114658225103614 84619.58))
 592     (() (values -1354984705 8473228.0)))
 593   (checked-compile-and-assert (:optimize :safe)
 594    `(lambda ()
 595       (ceiling 114658225103614 84619.58))
 596     (() (values 1354984705 -8473228.0))))
 597
 598 (with-test (:name :complex-float-contagion)
 599   (checked-compile-and-assert ()
 600     `(lambda (p1)
 601        (declare (type (or double-float integer) p1))
 602        (complex p1 2.0))
 603     ((1d0) #c(1d0 2d0))))
 604
 605 (with-test (:name :equal-transform-member-types)
 606   (let* ((s1 "abc")
 607          (s2 (copy-seq s1)))
 608     (checked-compile-and-assert ()
 609       `(lambda (p1 p2)
 610          (declare (type (member ,s1) p1)
 611                   (type (member ,s2 #*10) p2))
 612          (equal p1 p2))
 613       ((s1 s2) t))))
 614
 615 (with-test (:name :equalp-transform-numeric-types)
 616   (checked-compile-and-assert ()
 617     `(lambda (p1 p2)
 618        (declare (type (or fixnum list) p1)
 619                 (type double-float p2))
 620        (equalp p1 p2))
 621     ((1 1d0) t)))
 622
 623 (with-test (:name :equalp-transform-zero-array)
 624   (checked-compile-and-assert ()
 625     `(lambda (a b)
 626        (declare (simple-string a)
 627                 (simple-bit-vector b))
 628        (equalp a b))
 629     (("" #*) t)))
 630
 631 (with-test (:name :fill-transform-returning-array-data)
 632   (let ((vector (make-array 10 :fill-pointer 2)))
 633     (checked-compile-and-assert ()
 634       `(lambda (v)
 635            (declare (type (vector t) v))
 636            (fill v nil))
 637       ((vector) vector))))
 638
 639 (with-test (:name :missing-error-context)
 640   (flet ((run ()
 641           (let ((string
 642                  (with-output-to-string (*error-output*)
 643                    (compile nil '(sb-int:named-lambda bob () (otherfun) 3)))))
 644             (assert (search "in: SB-INT:NAMED-LAMBDA BOB" string)))))
 645     (run)
 646     ;; Unrepeatability is confusing:
 647     ;; The first compiler invocation used to leave *last-format-string*
 648     ;; with a toplevel value, so the second would not print enough context
 649     ;; because the format control and args were the same.
 650     (run)))
 651
 652 (with-test (:name :cast-deletion-notes)
 653   (checked-compile-and-assert
 654       (:allow-notes nil)
 655       `(lambda (m)
 656          (setf m (list 1 2 3))
 657          (the simple-vector
 658               (coerce m 'vector)))
 659     ((nil) #(1 2 3) :test #'equalp)))
 660
 661 (with-test (:name :cast-deletion-notes.2)
 662   (multiple-value-bind (fun fail warn style notes)
 663       (checked-compile
 664        `(lambda (m)
 665           (setf m (list 1 2 3))
 666           (the simple-vector
 667                (if (vectorp m)
 668                    m
 669                    #(1)))))
 670     (declare (ignore fail warn style))
 671     (assert (equalp (funcall fun nil)
 672                     #(1)))
 673     (assert (= (length notes) 1))
 674     (assert (typep (car notes) 'code-deletion-note))))