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