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 ;; The tests in this file assume that EVAL will use the compiler
  17 (when (eq sb-ext:*evaluator-mode* :interpret)
  18   (invoke-restart 'run-tests::skip-file))
  19
  20 ;;; Exercise a compiler bug (by crashing the compiler).
  21 ;;;
  22 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
  23 ;;; (2000-09-06 on cmucl-imp).
  24 ;;;
  25 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
  26 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
  27 (funcall (compile nil
  28                   '(lambda ()
  29                      (labels ((fun1 ()
  30                                 (fun2))
  31                               (fun2 ()
  32                                 (when nil
  33                                   (tagbody
  34                                    tag
  35                                    (fun2)
  36                                    (go tag)))
  37                                 (when nil
  38                                   (tagbody
  39                                    tag
  40                                    (fun1)
  41                                    (go tag)))))
  42
  43                        (fun1)
  44                        nil))))
  45
  46 ;;; Exercise a compiler bug (by crashing the compiler).
  47 ;;;
  48 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
  49 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
  50 (funcall (compile nil
  51                   '(lambda (x)
  52                      (or (integerp x)
  53                          (block used-by-some-y?
  54                            (flet ((frob (stk)
  55                                     (dolist (y stk)
  56                                       (unless (rejected? y)
  57                                         (return-from used-by-some-y? t)))))
  58                              (declare (inline frob))
  59                              (frob (rstk x))
  60                              (frob (mrstk x)))
  61                            nil))))
  62          13)
  63
  64 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
  65 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
  66 ;;; Alexey Dejneka 2002-01-27
  67 (assert (= 1 ; (used to give 0 under bug 112)
  68            (let ((x 0))
  69              (declare (special x))
  70              (let ((x 1))
  71                (let ((y x))
  72                  (declare (special x)) y)))))
  73 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
  74            (let ((x 0))
  75              (declare (special x))
  76              (let ((x 1))
  77                (let ((y x) (x 5))
  78                  (declare (special x)) y)))))
  79
  80 ;;; another LET-related bug fixed by Alexey Dejneka at the same
  81 ;;; time as bug 112
  82 (multiple-value-bind (fun warnings-p failure-p)
  83     ;; should complain about duplicate variable names in LET binding
  84     (compile nil
  85              '(lambda ()
  86                (let (x
  87                      (x 1))
  88                  (list x))))
  89   (declare (ignore warnings-p))
  90   (assert (functionp fun))
  91   (assert failure-p))
  92
  93 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
  94 ;;; Lichteblau 2002-05-21)
  95 (progn
  96   (multiple-value-bind (fun warnings-p failure-p)
  97       (compile nil
  98                ;; Compiling this code should cause a STYLE-WARNING
  99                ;; about *X* looking like a special variable but not
 100                ;; being one.
 101                '(lambda (n)
 102                   (let ((*x* n))
 103                     (funcall (symbol-function 'x-getter))
 104                     (print *x*))))
 105     (assert (functionp fun))
 106     (assert warnings-p)
 107     (assert (not failure-p)))
 108   (multiple-value-bind (fun warnings-p failure-p)
 109       (compile nil
 110                ;; Compiling this code should not cause a warning
 111                ;; (because the DECLARE turns *X* into a special
 112                ;; variable as its name suggests it should be).
 113                '(lambda (n)
 114                   (let ((*x* n))
 115                     (declare (special *x*))
 116                     (funcall (symbol-function 'x-getter))
 117                     (print *x*))))
 118     (assert (functionp fun))
 119     (assert (not warnings-p))
 120     (assert (not failure-p))))
 121
 122 ;;; a bug in 0.7.4.11
 123 (dolist (i '(a b 1 2 "x" "y"))
 124   ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
 125   ;; TYPEP here but got confused and died, doing
 126   ;;   (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
 127   ;;          *BACKEND-TYPE-PREDICATES*
 128   ;;          :TEST #'TYPE=)
 129   ;; and blowing up because TYPE= tried to call PLUSP on the
 130   ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
 131   (when (typep i '(and integer (satisfies oddp)))
 132     (print i)))
 133 (dotimes (i 14)
 134   (when (typep i '(and integer (satisfies oddp)))
 135     (print i)))
 136
 137 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
 138 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
 139 ;;; interactively-compiled functions was broken by sleaziness and
 140 ;;; confusion in the assault on 0.7.0, so this expression used to
 141 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
 142 (eval '(function-lambda-expression #'(lambda (x) x)))
 143
 144 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
 145 ;;; variable is not optional.
 146 (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12))))))
 147
 148 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
 149 ;;; a while; fixed by CSR 2002-07-18
 150 (multiple-value-bind (value error)
 151     (ignore-errors (some-undefined-function))
 152   (assert (null value))
 153   (assert (eq (cell-error-name error) 'some-undefined-function)))
 154
 155 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
 156 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
 157 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
 158 (assert (ignore-errors (eval '(lambda (foo) 12))))
 159 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
 160 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
 161 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
 162 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
 163 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
 164 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
 165 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
 166 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
 167 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
 168 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
 169
 170 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
 171 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
 172 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
 173 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
 174            17))
 175
 176 ;;; bug 181: bad type specifier dropped compiler into debugger
 177 (assert (list (compile nil '(lambda (x)
 178                              (declare (type (0) x))
 179                              x))))
 180
 181 (let ((f (compile nil '(lambda (x)
 182                         (make-array 1 :element-type '(0))))))
 183   (assert (null (ignore-errors (funcall f)))))
 184
 185 ;;; the following functions must not be flushable
 186 (dolist (form '((make-sequence 'fixnum 10)
 187                 (concatenate 'fixnum nil)
 188                 (map 'fixnum #'identity nil)
 189                 (merge 'fixnum nil nil #'<)))
 190   (assert (not (eval `(locally (declare (optimize (safety 0)))
 191                         (ignore-errors (progn ,form t)))))))
 192
 193 (dolist (form '((values-list (car (list '(1 . 2))))
 194                 (fboundp '(set bet))
 195                 (atan #c(1 1) (car (list #c(2 2))))
 196                 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
 197                 (nthcdr (car (list 5)) '(1 2 . 3))))
 198   (assert (not (eval `(locally (declare (optimize (safety 3)))
 199                         (ignore-errors (progn ,form t)))))))
 200
 201 ;;; feature: we shall complain if functions which are only useful for
 202 ;;; their result are called and their result ignored.
 203 (loop for (form expected-des) in
 204         '(((progn (nreverse (list 1 2)) t)
 205            "The return value of NREVERSE should not be discarded.")
 206           ((progn (nreconc (list 1 2) (list 3 4)) t)
 207            "The return value of NRECONC should not be discarded.")
 208           ((locally
 209              (declare (inline sort))
 210              (sort (list 1 2) #'<) t)
 211            ;; FIXME: it would be nice if this warned on non-inlined sort
 212            ;; but the current simple boolean function attribute
 213            ;; can't express the condition that would be required.
 214            "The return value of STABLE-SORT-LIST should not be discarded.")
 215           ((progn (sort (vector 1 2) #'<) t)
 216            ;; Apparently, SBCL (but not CL) guarantees in-place vector
 217            ;; sort, so no warning.
 218            nil)
 219           ((progn (delete 2 (list 1 2)) t)
 220            "The return value of DELETE should not be discarded.")
 221           ((progn (delete-if #'evenp (list 1 2)) t)
 222            ("The return value of DELETE-IF should not be discarded."))
 223           ((progn (delete-if #'evenp (vector 1 2)) t)
 224            ("The return value of DELETE-IF should not be discarded."))
 225           ((progn (delete-if-not #'evenp (list 1 2)) t)
 226            "The return value of DELETE-IF-NOT should not be discarded.")
 227           ((progn (delete-duplicates (list 1 2)) t)
 228            "The return value of DELETE-DUPLICATES should not be discarded.")
 229           ((progn (merge 'list (list 1 3) (list 2 4) #'<) t)
 230            "The return value of MERGE should not be discarded.")
 231           ((progn (nreconc (list 1 3) (list 2 4)) t)
 232            "The return value of NRECONC should not be discarded.")
 233           ((progn (nunion (list 1 3) (list 2 4)) t)
 234            "The return value of NUNION should not be discarded.")
 235           ((progn (nintersection (list 1 3) (list 2 4)) t)
 236            "The return value of NINTERSECTION should not be discarded.")
 237           ((progn (nset-difference (list 1 3) (list 2 4)) t)
 238            "The return value of NSET-DIFFERENCE should not be discarded.")
 239           ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t)
 240            "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
 241       for expected = (if (listp expected-des)
 242                        expected-des
 243                        (list expected-des))
 244       do
 245   (multiple-value-bind (fun warnings-p failure-p)
 246       (handler-bind ((style-warning (lambda (c)
 247                       (if expected
 248                         (let ((expect-one (pop expected)))
 249                           (assert (search expect-one
 250                                           (with-standard-io-syntax
 251                                             (let ((*print-right-margin* nil))
 252                                               (princ-to-string c))))
 253                                   ()
 254                                   "~S should have warned ~S, but instead warned: ~A"
 255                                   form expect-one c))
 256                         (error "~S shouldn't give a(nother) warning, but did: ~A" form c)))))
 257         (compile nil `(lambda () ,form)))
 258   (declare (ignore warnings-p))
 259   (assert (functionp fun))
 260   (assert (null expected)
 261           ()
 262           "~S should have warned ~S, but didn't."
 263           form expected)
 264   (assert (not failure-p))))
 265
 266 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
 267 ;;; to cause errors in the compiler.  Fixed by CSR in 0.7.8.10
 268 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x)))))
 269
 270 ;;; bug 129: insufficient syntax checking in MACROLET
 271 (multiple-value-bind (result error)
 272     (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3))))
 273   (assert (null result))
 274   (assert (typep error 'error)))
 275
 276 ;;; bug 124: environment of MACROLET-introduced macro expanders
 277 (assert (equal
 278          (macrolet ((mext (x) `(cons :mext ,x)))
 279            (macrolet ((mint (y) `'(:mint ,(mext y))))
 280              (list (mext '(1 2))
 281                    (mint (1 2)))))
 282          '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
 283
 284 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
 285 ;;; symbol is declared to be SPECIAL
 286 (multiple-value-bind (result error)
 287     (ignore-errors (funcall (lambda ()
 288                               (symbol-macrolet ((s '(1 2)))
 289                                   (declare (special s))
 290                                 s))))
 291   (assert (null result))
 292   (assert (typep error 'program-error)))
 293
 294 ;;; ECASE should treat a bare T as a literal key
 295 (multiple-value-bind (result error)
 296     (ignore-errors (ecase 1 (t 0)))
 297   (assert (null result))
 298   (assert (typep error 'type-error)))
 299
 300 (multiple-value-bind (result error)
 301     (ignore-errors (ecase 1 (t 0) (1 2)))
 302   (assert (eql result 2))
 303   (assert (null error)))
 304
 305 ;;; FTYPE should accept any functional type specifier
 306 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
 307
 308 ;;; FUNCALL of special operators and macros should signal an
 309 ;;; UNDEFINED-FUNCTION error
 310 (multiple-value-bind (result error)
 311     (ignore-errors (funcall 'quote 1))
 312   (assert (null result))
 313   (assert (typep error 'undefined-function))
 314   (assert (eq (cell-error-name error) 'quote)))
 315 (multiple-value-bind (result error)
 316     (ignore-errors (funcall 'and 1))
 317   (assert (null result))
 318   (assert (typep error 'undefined-function))
 319   (assert (eq (cell-error-name error) 'and)))
 320
 321 ;;; PSETQ should behave when given complex symbol-macro arguments
 322 (multiple-value-bind (sequence index)
 323     (symbol-macrolet ((x (aref a (incf i)))
 324                       (y (aref a (incf i))))
 325         (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
 326               (i 0))
 327           (psetq x (aref a (incf i))
 328                  y (aref a (incf i)))
 329           (values a i)))
 330   (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
 331   (assert (= index 4)))
 332
 333 (multiple-value-bind (result error)
 334     (ignore-errors
 335       (let ((x (list 1 2)))
 336         (psetq (car x) 3)
 337         x))
 338   (assert (null result))
 339   (assert (typep error 'program-error)))
 340
 341 ;;; COPY-SEQ should work on known-complex vectors:
 342 (assert (equalp #(1)
 343                 (let ((v (make-array 0 :fill-pointer 0)))
 344                   (vector-push-extend 1 v)
 345                   (copy-seq v))))
 346
 347 ;;; to support INLINE functions inside MACROLET, it is necessary for
 348 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
 349 ;;; certain circumstances, one of which is when compile is called from
 350 ;;; top-level.
 351 (assert (equal
 352          (function-lambda-expression
 353           (compile nil '(lambda (x) (block nil (print x)))))
 354          '(lambda (x) (block nil (print x)))))
 355
 356 ;;; bug 62: too cautious type inference in a loop
 357 (assert (nth-value
 358          2
 359          (compile nil
 360                   '(lambda (a)
 361                     (declare (optimize speed (safety 0)))
 362                     (typecase a
 363                       (array (loop (print (car a)))))))))
 364
 365 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
 366 ;;; failure
 367 (compile nil
 368          '(lambda (key tree collect-path-p)
 369            (let ((lessp (key-lessp tree))
 370                  (equalp (key-equalp tree)))
 371              (declare (type (function (t t) boolean) lessp equalp))
 372              (let ((path '(nil)))
 373                (loop for node = (root-node tree)
 374                   then (if (funcall lessp key (node-key node))
 375                            (left-child node)
 376                            (right-child node))
 377                   when (null node)
 378                   do (return (values nil nil nil))
 379                   do (when collect-path-p
 380                        (push node path))
 381                   (when (funcall equalp key (node-key node))
 382                     (return (values node path t))))))))
 383
 384 ;;; CONSTANTLY should return a side-effect-free function (bug caught
 385 ;;; by Paul Dietz' test suite)
 386 (let ((i 0))
 387   (let ((fn (constantly (progn (incf i) 1))))
 388     (assert (= i 1))
 389     (assert (= (funcall fn) 1))
 390     (assert (= i 1))
 391     (assert (= (funcall fn) 1))
 392     (assert (= i 1))))
 393
 394 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
 395 (loop for (fun warns-p) in
 396      '(((lambda (&optional *x*) *x*) t)
 397        ((lambda (&optional *x* &rest y) (values *x* y)) t)
 398        ((lambda (&optional *print-length*) (values *print-length*)) nil)
 399        ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil)
 400        ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
 401        ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
 402    for real-warns-p = (nth-value 1 (compile nil fun))
 403    do (assert (eq warns-p real-warns-p)))
 404
 405 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
 406 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
 407                         '(1 2))
 408                '((2) 1)))
 409
 410 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
 411 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
 412 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
 413
 414 (assert
 415  (raises-error? (multiple-value-bind (a b c)
 416                     (eval '(truncate 3 4))
 417                   (declare (integer c))
 418                   (list a b c))
 419                 type-error))
 420
 421 (assert (equal (multiple-value-list (the (values &rest integer)
 422                                       (eval '(values 3))))
 423                '(3)))
 424
 425 ;;; Bug relating to confused representation for the wild function
 426 ;;; type:
 427 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
 428
 429 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
 430 ;;; test suite)
 431 (assert (eql (macrolet ((foo () 1))
 432                (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
 433                             x))
 434                  (%f)))
 435              1))
 436
 437 ;;; MACROLET should check for duplicated names
 438 (dolist (ll '((x (z x))
 439               (x y &optional z x w)
 440               (x y &optional z z)
 441               (x &rest x)
 442               (x &rest (y x))
 443               (x &optional (y nil x))
 444               (x &optional (y nil y))
 445               (x &key x)
 446               (x &key (y nil x))
 447               (&key (y nil z) (z nil w))
 448               (&whole x &optional x)
 449               (&environment x &whole x)))
 450   (assert (nth-value 2
 451                      (handler-case
 452                          (compile nil
 453                                   `(lambda ()
 454                                      (macrolet ((foo ,ll nil)
 455                                                 (bar (&environment env)
 456                                                   `',(macro-function 'foo env)))
 457                                        (bar))))
 458                        (error (c)
 459                          (values nil t t))))))
 460
 461 (assert (typep (eval `(the arithmetic-error
 462                            ',(make-condition 'arithmetic-error)))
 463                'arithmetic-error))
 464
 465 (assert (not (nth-value
 466               2 (compile nil '(lambda ()
 467                                (make-array nil :initial-element 11))))))
 468
 469 (assert (raises-error? (funcall (eval #'open) "assertoid.lisp"
 470                                 :external-format '#:nonsense)))
 471 (assert (raises-error? (funcall (eval #'load) "assertoid.lisp"
 472                                 :external-format '#:nonsense)))
 473
 474 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
 475
 476 (let ((f (compile nil
 477                   '(lambda (v)
 478                     (declare (optimize (safety 3)))
 479                     (list (the fixnum (the (real 0) (eval v))))))))
 480   (assert (raises-error? (funcall f 0.1) type-error))
 481   (assert (raises-error? (funcall f -1) type-error)))
 482
 483 ;;; the implicit block does not enclose lambda list
 484 (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#))))
 485                #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#))))))
 486                (define-compiler-macro #3=#:foo (&optional (x (return-from #3#))))
 487                (deftype #4=#:foo (&optional (x (return-from #4#))))
 488                (define-setf-expander #5=#:foo (&optional (x (return-from #5#))))
 489                (defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
 490   (dolist (form forms)
 491     (assert (nth-value 2 (compile nil `(lambda () ,form))))))
 492
 493 (assert (nth-value 2 (compile nil
 494                               '(lambda ()
 495                                 (svref (make-array '(8 9) :adjustable t) 1)))))
 496
 497 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
 498 (raises-error? (funcall (compile nil '(lambda (x y z) (char= x y z)))
 499                         #\a #\b nil)
 500                type-error)
 501 (raises-error? (funcall (compile nil
 502                                  '(lambda (x y z)
 503                                    (declare (optimize (speed 3) (safety 3)))
 504                                    (char/= x y z)))
 505                         nil #\a #\a)
 506                type-error)
 507
 508 ;;; Compiler lost return type of MAPCAR and friends
 509 (dolist (fun '(mapcar mapc maplist mapl))
 510   (assert (nth-value 2 (compile nil
 511                                 `(lambda (x)
 512                                    (1+ (,fun #'print x)))))))
 513
 514 (assert (nth-value 2 (compile nil
 515                               '(lambda ()
 516                                 (declare (notinline mapcar))
 517                                 (1+ (mapcar #'print '(1 2 3)))))))
 518
 519 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
 520 ;;; index was effectless
 521 (let ((f (compile nil '(lambda (a v)
 522                         (declare (type simple-bit-vector a) (type bit v))
 523                         (declare (optimize (speed 3) (safety 0)))
 524                         (setf (aref a 0) v)
 525                         a))))
 526   (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
 527     (assert (equal y #*00))
 528     (funcall f y 1)
 529     (assert (equal y #*10))))
 530
 531 (handler-bind ((sb-ext:compiler-note #'error))
 532   (compile nil '(lambda (x)
 533                  (declare (type (simple-array (simple-string 3) (5)) x))
 534                  (aref (aref x 0) 0))))
 535
 536 ;;; compiler failure
 537 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
 538   (assert (funcall f 1d0)))
 539
 540 (compile nil '(lambda (x)
 541                (declare (double-float x))
 542                (let ((y (* x pi)))
 543                  (atan y y))))
 544
 545 ;;; bogus optimization of BIT-NOT
 546 (multiple-value-bind (result x)
 547     (eval '(let ((x (eval #*1001)))
 548             (declare (optimize (speed 2) (space 3))
 549                      (type (bit-vector) x))
 550             (values (bit-not x nil) x)))
 551   (assert (equal x #*1001))
 552   (assert (equal result #*0110)))
 553
 554 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
 555 (handler-bind ((sb-ext:compiler-note #'error))
 556   (assert (equalp (funcall
 557                    (compile
 558                     nil
 559                     '(lambda ()
 560                       (let ((x (make-sequence 'vector 10 :initial-element 'a)))
 561                         (setf (aref x 4) 'b)
 562                         x))))
 563                   #(a a a a b a a a a a))))
 564
 565 ;;; this is not a check for a bug, but rather a test of compiler
 566 ;;; quality
 567 (dolist (type '((integer 0 *)           ; upper bound
 568                 (real (-1) *)
 569                 float                   ; class
 570                 (real * (-10))          ; lower bound
 571                 ))
 572   (assert (nth-value
 573            1 (compile nil
 574                       `(lambda (n)
 575                          (declare (optimize (speed 3) (compilation-speed 0)))
 576                          (loop for i from 1 to (the (integer -17 10) n) by 2
 577                                collect (when (> (random 10) 5)
 578                                          (the ,type (- i 11)))))))))
 579
 580 ;;; bug 278b
 581 ;;;
 582 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
 583 ;;; compiler has an optimized VOP for +; so this code should cause an
 584 ;;; efficiency note.
 585 (assert (eq (block nil
 586               (handler-case
 587                   (compile nil '(lambda (i)
 588                                  (declare (optimize speed))
 589                                  (declare (type integer i))
 590                                  (+ i 2)))
 591                 (sb-ext:compiler-note (c) (return :good))))
 592             :good))
 593
 594 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
 595 ;;; symbol macros
 596 (assert (not (nth-value 1 (compile nil '(lambda (u v)
 597                                          (symbol-macrolet ((x u)
 598                                                            (y v))
 599                                              (declare (ignore x)
 600                                                       (ignorable y))
 601                                            (list u v)))))))
 602
 603 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
 604 (loop for (x type) in
 605       '((14 integer)
 606         (14 rational)
 607         (-14/3 (rational -8 11))
 608         (3s0 short-float)
 609         (4f0 single-float)
 610         (5d0 double-float)
 611         (6l0 long-float)
 612         (14 real)
 613         (13/2 real)
 614         (2s0 real)
 615         (2d0 real)
 616         (#c(-3 4) (complex fixnum))
 617         (#c(-3 4) (complex rational))
 618         (#c(-3/7 4) (complex rational))
 619         (#c(2s0 3s0) (complex short-float))
 620         (#c(2f0 3f0) (complex single-float))
 621         (#c(2d0 3d0) (complex double-float))
 622         (#c(2l0 3l0) (complex long-float))
 623         (#c(2d0 3s0) (complex float))
 624         (#c(2 3f0) (complex real))
 625         (#c(2 3d0) (complex real))
 626         (#c(-3/7 4) (complex real))
 627         (#c(-3/7 4) complex)
 628         (#c(2 3l0) complex))
 629       do (dolist (zero '(0 0s0 0f0 0d0 0l0))
 630            (dolist (real-zero (list zero (- zero)))
 631              (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
 632                     (fun (compile nil src))
 633                     (result (1+ (funcall (eval #'*) x real-zero))))
 634                (assert (eql result (funcall fun x)))))))
 635
 636 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
 637 ;;; wasn't recognized as a good type specifier.
 638 (let ((fun (lambda (x y)
 639              (declare (type (integer -1 0) x y) (optimize speed))
 640              (logxor x y))))
 641   (assert (= (funcall fun 0 0) 0))
 642   (assert (= (funcall fun 0 -1) -1))
 643   (assert (= (funcall fun -1 -1) 0)))
 644
 645 ;;; from PFD's torture test, triggering a bug in our effective address
 646 ;;; treatment.
 647 (compile
 648  nil
 649  `(lambda (a b)
 650     (declare (type (integer 8 22337) b))
 651     (logandc2
 652      (logandc2
 653       (* (logandc1 (max -29303 b) 4) b)
 654       (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
 655      (logeqv (max a 0) b))))
 656
 657 ;;; Alpha floating point modes weren't being reset after an exception,
 658 ;;; leading to an exception on the second compile, below.
 659 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
 660 (handler-case (/ 1.0 0.0)
 661   ;; provoke an exception
 662   (arithmetic-error ()))
 663 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
 664
 665 ;;; bug reported by Paul Dietz: component last block does not have
 666 ;;; start ctran
 667 (compile nil
 668          '(lambda ()
 669            (declare (notinline + logand)
 670             (optimize (speed 0)))
 671            (LOGAND
 672             (BLOCK B5
 673               (FLET ((%F1 ()
 674                        (RETURN-FROM B5 -220)))
 675                 (LET ((V7 (%F1)))
 676                   (+ 359749 35728422))))
 677             -24076)))
 678
 679 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
 680 (assert (= (funcall (compile nil `(lambda (b)
 681                                     (declare (optimize (speed 3))
 682                                              (type (integer 2 152044363) b))
 683                                     (rem b (min -16 0))))
 684                     108251912)
 685            8))
 686
 687 (assert (= (funcall (compile nil `(lambda (c)
 688                                     (declare (optimize (speed 3))
 689                                              (type (integer 23062188 149459656) c))
 690                                     (mod c (min -2 0))))
 691                     95019853)
 692            -1))
 693
 694 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
 695 (compile nil
 696          '(LAMBDA (A B C)
 697            (BLOCK B6
 698              (LOGEQV (REM C -6758)
 699                      (REM B (MAX 44 (RETURN-FROM B6 A)))))))
 700
 701 (compile nil '(lambda ()
 702                (block nil
 703                  (flet ((foo (x y) (if (> x y) (print x) (print y))))
 704                    (foo 1 2)
 705                    (bar)
 706                    (foo (return 14) 2)))))
 707
 708 ;;; bug in Alpha backend: not enough sanity checking of arguments to
 709 ;;; instructions
 710 (assert (= (funcall (compile nil
 711                              '(lambda (x)
 712                                 (declare (fixnum x))
 713                                 (ash x -257)))
 714                     1024)
 715            0))
 716
 717 ;;; bug found by WHN and pfdietz: compiler failure while referencing
 718 ;;; an entry point inside a deleted lambda
 719 (compile nil '(lambda ()
 720                (let (r3533)
 721                  (flet ((bbfn ()
 722                           (setf r3533
 723                                 (progn
 724                                   (flet ((truly (fn bbd)
 725                                            (let (r3534)
 726                                              (let ((p3537 nil))
 727                                                (unwind-protect
 728                                                     (multiple-value-prog1
 729                                                         (progn
 730                                                           (setf r3534
 731                                                                 (progn
 732                                                                   (bubf bbd t)
 733                                                                   (flet ((c-3536 ()
 734                                                                            (funcall fn)))
 735                                                                     (cdec #'c-3536
 736                                                                           (vector bbd))))))
 737                                                       (setf p3537 t))
 738                                                  (unless p3537
 739                                                    (error "j"))))
 740                                              r3534))
 741                                          (c (pd) (pdc pd)))
 742                                     (let ((a (smock a))
 743                                           (b (smock b))
 744                                           (b (smock c)))))))))
 745                    (wum #'bbfn "hc3" (list)))
 746                  r3533)))
 747 (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
 748
 749 ;;; the strength reduction of constant multiplication used (before
 750 ;;; sbcl-0.8.4.x) to lie to the compiler.  This meant that, under
 751 ;;; certain circumstances, the compiler would derive that a perfectly
 752 ;;; reasonable multiplication never returned, causing chaos.  Fixed by
 753 ;;; explicitly doing modular arithmetic, and relying on the backends
 754 ;;; being smart.
 755 (assert (= (funcall
 756             (compile nil
 757                      '(lambda (x)
 758                         (declare (type (integer 178956970 178956970) x)
 759                                  (optimize speed))
 760                         (* x 24)))
 761             178956970)
 762            4294967280))
 763
 764 ;;; bug in modular arithmetic and type specifiers
 765 (assert (= (funcall (compile nil (lambda (x) (logand x x 0)))
 766                     -1)
 767            0))
 768
 769 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
 770 ;;; produced wrong result for shift >=32 on X86
 771 (assert (= 0 (funcall
 772               (compile nil
 773                        '(lambda (a)
 774                          (declare (type (integer 4303063 101130078) a))
 775                          (mask-field (byte 18 2) (ash a 77))))
 776               57132532)))
 777
 778 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
 779 ;;; type check regeneration
 780 (assert (eql (funcall
 781               (compile nil '(lambda (a c)
 782                              (declare (type (integer 185501219873 303014665162) a))
 783                              (declare (type (integer -160758 255724) c))
 784                              (declare (optimize (speed 3)))
 785                              (let ((v8
 786                                     (- -554046873252388011622614991634432
 787                                        (ignore-errors c)
 788                                        (unwind-protect 2791485))))
 789                                (max (ignore-errors a)
 790                                     (let ((v6 (- v8 (restart-case 980))))
 791                                       (min v8 v6))))))
 792               259448422916 173715)
 793              259448422916))
 794 (assert (eql (funcall
 795               (compile nil '(lambda (a b)
 796                              (min -80
 797                               (abs
 798                                (ignore-errors
 799                                  (+
 800                                   (logeqv b
 801                                           (block b6
 802                                             (return-from b6
 803                                               (load-time-value -6876935))))
 804                                   (if (logbitp 1 a) b (setq a -1522022182249))))))))
 805               -1802767029877 -12374959963)
 806              -80))
 807
 808 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
 809 (assert (eql (funcall (compile nil '(lambda (c)
 810                                      (declare (type (integer -3924 1001809828) c))
 811                                      (declare (optimize (speed 3)))
 812                                      (min 47 (if (ldb-test (byte 2 14) c)
 813                                                  -570344431
 814                                                  (ignore-errors -732893970)))))
 815                       705347625)
 816              -570344431))
 817 (assert (eql (funcall
 818               (compile nil '(lambda (b)
 819                              (declare (type (integer -1598566306 2941) b))
 820                              (declare (optimize (speed 3)))
 821                              (max -148949 (ignore-errors b))))
 822               0)
 823              0))
 824 (assert (eql (funcall
 825               (compile nil '(lambda (b c)
 826                              (declare (type (integer -4 -3) c))
 827                              (block b7
 828                                (flet ((%f1 (f1-1 f1-2 f1-3)
 829                                         (if (logbitp 0 (return-from b7
 830                                                          (- -815145138 f1-2)))
 831                                             (return-from b7 -2611670)
 832                                             99345)))
 833                                  (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
 834                                    b)))))
 835               2950453607 -4)
 836              -815145134))
 837 (assert (eql (funcall
 838               (compile nil
 839                        '(lambda (b c)
 840                          (declare (type (integer -29742055786 23602182204) b))
 841                          (declare (type (integer -7409 -2075) c))
 842                          (declare (optimize (speed 3)))
 843                          (floor
 844                           (labels ((%f2 ()
 845                                      (block b6
 846                                        (ignore-errors (return-from b6
 847                                                         (if (= c 8) b 82674))))))
 848                             (%f2)))))
 849               22992834060 -5833)
 850              82674))
 851 (assert (equal (multiple-value-list
 852                 (funcall
 853                  (compile nil '(lambda (a)
 854                                 (declare (type (integer -944 -472) a))
 855                                 (declare (optimize (speed 3)))
 856                                 (round
 857                                  (block b3
 858                                    (return-from b3
 859                                      (if (= 55957 a) -117 (ignore-errors
 860                                                             (return-from b3 a))))))))
 861                  -589))
 862                '(-589 0)))
 863
 864 ;;; MISC.158
 865 (assert (zerop (funcall
 866                 (compile nil
 867                          '(lambda (a b c)
 868                            (declare (type (integer 79828 2625480458) a))
 869                            (declare (type (integer -4363283 8171697) b))
 870                            (declare (type (integer -301 0) c))
 871                            (if (equal 6392154 (logxor a b))
 872                                1706
 873                                (let ((v5 (abs c)))
 874                                  (logand v5
 875                                          (logior (logandc2 c v5)
 876                                                  (common-lisp:handler-case
 877                                                      (ash a (min 36 22477)))))))))
 878                 100000 0 0)))
 879
 880 ;;; MISC.152, 153: deleted code and iteration var type inference
 881 (assert (eql (funcall
 882               (compile nil
 883                        '(lambda (a)
 884                          (block b5
 885                            (let ((v1 (let ((v8 (unwind-protect 9365)))
 886                                        8862008)))
 887                              (*
 888                               (return-from b5
 889                                 (labels ((%f11 (f11-1) f11-1))
 890                                   (%f11 87246015)))
 891                               (return-from b5
 892                                 (setq v1
 893                                       (labels ((%f6 (f6-1 f6-2 f6-3) v1))
 894                                         (dpb (unwind-protect a)
 895                                              (byte 18 13)
 896                                              (labels ((%f4 () 27322826))
 897                                                (%f6 -2 -108626545 (%f4))))))))))))
 898               -6)
 899              87246015))
 900
 901 (assert (eql (funcall
 902               (compile nil
 903                        '(lambda (a)
 904                          (if (logbitp 3
 905                                       (case -2
 906                                         ((-96879 -1035 -57680 -106404 -94516 -125088)
 907                                          (unwind-protect 90309179))
 908                                         ((-20811 -86901 -9368 -98520 -71594)
 909                                          (let ((v9 (unwind-protect 136707)))
 910                                            (block b3
 911                                              (setq v9
 912                                                    (let ((v4 (return-from b3 v9)))
 913                                                      (- (ignore-errors (return-from b3 v4))))))))
 914                                         (t -50)))
 915                              -20343
 916                              a)))
 917               0)
 918              -20343))
 919
 920 ;;; MISC.165
 921 (assert (eql (funcall
 922               (compile
 923                nil
 924                '(lambda (a b c)
 925                  (block b3
 926                    (flet ((%f15
 927                               (f15-1 f15-2 f15-3
 928                                      &optional
 929                                      (f15-4
 930                                       (flet ((%f17
 931                                                  (f17-1 f17-2 f17-3
 932                                                         &optional (f17-4 185155520) (f17-5 c)
 933                                                         (f17-6 37))
 934                                                c))
 935                                         (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
 936                                      (f15-5 a) (f15-6 -40))
 937                             (return-from b3 -16)))
 938                      (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
 939               0 0 -5)
 940              -16))
 941
 942 ;;; MISC.172
 943 (assert (eql (funcall
 944               (compile
 945                nil
 946                '(lambda (a b c)
 947                  (declare (notinline list apply))
 948                  (declare (optimize (safety 3)))
 949                  (declare (optimize (speed 0)))
 950                  (declare (optimize (debug 0)))
 951                  (labels ((%f12 (f12-1 f12-2)
 952                             (labels ((%f2 (f2-1 f2-2)
 953                                        (flet ((%f6 ()
 954                                                 (flet ((%f18
 955                                                            (f18-1
 956                                                             &optional (f18-2 a)
 957                                                             (f18-3 -207465075)
 958                                                             (f18-4 a))
 959                                                          (return-from %f12 b)))
 960                                                   (%f18 -3489553
 961                                                         -7
 962                                                         (%f18 (%f18 150 -64 f12-1)
 963                                                               (%f18 (%f18 -8531)
 964                                                                     11410)
 965                                                               b)
 966                                                         56362666))))
 967                                          (labels ((%f7
 968                                                       (f7-1 f7-2
 969                                                             &optional (f7-3 (%f6)))
 970                                                     7767415))
 971                                            f12-1))))
 972                               (%f2 b -36582571))))
 973                    (apply #'%f12 (list 774 -4413)))))
 974               0 1 2)
 975              774))
 976
 977 ;;; MISC.173
 978 (assert (eql (funcall
 979               (compile
 980                nil
 981                '(lambda (a b c)
 982                  (declare (notinline values))
 983                  (declare (optimize (safety 3)))
 984                  (declare (optimize (speed 0)))
 985                  (declare (optimize (debug 0)))
 986                  (flet ((%f11
 987                             (f11-1 f11-2
 988                                    &optional (f11-3 c) (f11-4 7947114)
 989                                    (f11-5
 990                                     (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
 991                                              8134))
 992                                       (multiple-value-call #'%f3
 993                                         (values (%f3 -30637724 b) c)))))
 994                           (setq c 555910)))
 995                    (if (and nil (%f11 a a))
 996                        (if (%f11 a 421778 4030 1)
 997                            (labels ((%f7
 998                                         (f7-1 f7-2
 999                                               &optional
1000                                               (f7-3
1001                                                (%f11 -79192293
1002                                                      (%f11 c a c -4 214720)
1003                                                      b
1004                                                      b
1005                                                      (%f11 b 985)))
1006                                               (f7-4 a))
1007                                       b))
1008                              (%f11 c b -25644))
1009                            54)
1010                        -32326608))))
1011               1 2 3)
1012              -32326608))
1013
1014 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1015 ;;; local lambda argument
1016 (assert
1017  (equal
1018   (funcall
1019    (compile nil
1020             '(lambda (a b c)
1021               (declare (type (integer 804561 7640697) a))
1022               (declare (type (integer -1 10441401) b))
1023               (declare (type (integer -864634669 55189745) c))
1024               (declare (ignorable a b c))
1025               (declare (optimize (speed 3)))
1026               (declare (optimize (safety 1)))
1027               (declare (optimize (debug 1)))
1028               (flet ((%f11
1029                          (f11-1 f11-2)
1030                        (labels ((%f4 () (round 200048 (max 99 c))))
1031                          (logand
1032                           f11-1
1033                           (labels ((%f3 (f3-1) -162967612))
1034                             (%f3 (let* ((v8 (%f4)))
1035                                    (setq f11-1 (%f4)))))))))
1036                 (%f11 -120429363 (%f11 62362 b)))))
1037    6714367 9645616 -637681868)
1038   -264223548))
1039
1040 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1041 ;;; transform
1042 (assert (equal (multiple-value-list
1043                 (funcall
1044                  (compile nil '(lambda ()
1045                                 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1046                                 (ceiling
1047                                  (ceiling
1048                                   (flet ((%f16 () 0)) (%f16))))))))
1049                '(0 0)))
1050
1051 ;;; MISC.184
1052 (assert (zerop
1053          (funcall
1054           (compile
1055            nil
1056            '(lambda (a b c)
1057              (declare (type (integer 867934833 3293695878) a))
1058              (declare (type (integer -82111 1776797) b))
1059              (declare (type (integer -1432413516 54121964) c))
1060              (declare (optimize (speed 3)))
1061              (declare (optimize (safety 1)))
1062              (declare (optimize (debug 1)))
1063              (if nil
1064                  (flet ((%f15 (f15-1 &optional (f15-2 c))
1065                           (labels ((%f1 (f1-1 f1-2) 0))
1066                             (%f1 a 0))))
1067                    (flet ((%f4 ()
1068                             (multiple-value-call #'%f15
1069                               (values (%f15 c 0) (%f15 0)))))
1070                      (if nil (%f4)
1071                          (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
1072                                   f8-3))
1073                            0))))
1074                  0)))
1075           3040851270 1664281 -1340106197)))
1076
1077 ;;; MISC.249
1078 (assert (zerop
1079          (funcall
1080           (compile
1081            nil
1082            '(lambda (a b)
1083              (declare (notinline <=))
1084              (declare (optimize (speed 2) (space 3) (safety 0)
1085                        (debug 1) (compilation-speed 3)))
1086              (if (if (<= 0) nil nil)
1087                  (labels ((%f9 (f9-1 f9-2 f9-3)
1088                             (ignore-errors 0)))
1089                    (dotimes (iv4 5 a) (%f9 0 0 b)))
1090                  0)))
1091           1 2)))
1092
1093 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1094 (assert
1095  (= (funcall
1096      (compile
1097       nil
1098       '(lambda (a)
1099          (declare (type (integer 177547470 226026978) a))
1100          (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1101                             (compilation-speed 1)))
1102          (logand a (* a 438810))))
1103      215067723)
1104     13739018))
1105
1106 \f
1107 ;;;; Bugs in stack analysis
1108 ;;; bug 299 (reported by PFD)
1109 (assert
1110  (equal (funcall
1111          (compile
1112           nil
1113           '(lambda ()
1114             (declare (optimize (debug 1)))
1115             (multiple-value-call #'list
1116               (if (eval t) (eval '(values :a :b :c)) nil)
1117               (catch 'foo (throw 'foo (values :x :y)))))))
1118         '(:a :b :c :x :y)))
1119 ;;; bug 298 (= MISC.183)
1120 (assert (zerop (funcall
1121                 (compile
1122                  nil
1123                  '(lambda (a b c)
1124                    (declare (type (integer -368154 377964) a))
1125                    (declare (type (integer 5044 14959) b))
1126                    (declare (type (integer -184859815 -8066427) c))
1127                    (declare (ignorable a b c))
1128                    (declare (optimize (speed 3)))
1129                    (declare (optimize (safety 1)))
1130                    (declare (optimize (debug 1)))
1131                    (block b7
1132                      (flet ((%f3 (f3-1 f3-2 f3-3) 0))
1133                        (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
1134                 0 6000 -9000000)))
1135 (assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
1136                '(1 2)))
1137 (let ((f (compile
1138           nil
1139           '(lambda (x)
1140             (block foo
1141               (multiple-value-call #'list
1142                 :a
1143                 (block bar
1144                   (return-from foo
1145                     (multiple-value-call #'list
1146                       :b
1147                       (block quux
1148                         (return-from bar
1149                           (catch 'baz
1150                             (if x
1151                                 (return-from quux 1)
1152                                 (throw 'baz 2))))))))))))))
1153   (assert (equal (funcall f t) '(:b 1)))
1154   (assert (equal (funcall f nil) '(:a 2))))
1155
1156 ;;; MISC.185
1157 (assert (equal
1158          (funcall
1159           (compile
1160            nil
1161            '(lambda (a b c)
1162              (declare (type (integer 5 155656586618) a))
1163              (declare (type (integer -15492 196529) b))
1164              (declare (type (integer 7 10) c))
1165              (declare (optimize (speed 3)))
1166              (declare (optimize (safety 1)))
1167              (declare (optimize (debug 1)))
1168              (flet ((%f3
1169                         (f3-1 f3-2 f3-3
1170                               &optional (f3-4 a) (f3-5 0)
1171                               (f3-6
1172                                (labels ((%f10 (f10-1 f10-2 f10-3)
1173                                           0))
1174                                  (apply #'%f10
1175                                         0
1176                                         a
1177                                         (- (if (equal a b) b (%f10 c a 0))
1178                                            (catch 'ct2 (throw 'ct2 c)))
1179                                         nil))))
1180                       0))
1181                (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
1182          0))
1183 ;;; MISC.186
1184 (assert (eq
1185          (eval
1186           '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
1187                           (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
1188                   (vars '(b c))
1189                   (fn1 `(lambda ,vars
1190                           (declare (type (integer -2 19) b)
1191                                    (type (integer -1520 218978) c)
1192                                    (optimize (speed 3) (safety 1) (debug 1)))
1193                           ,form))
1194                   (fn2 `(lambda ,vars
1195                           (declare (notinline logeqv apply)
1196                                    (optimize (safety 3) (speed 0) (debug 0)))
1197                           ,form))
1198                   (cf1 (compile nil fn1))
1199                   (cf2 (compile nil fn2))
1200                   (result1 (multiple-value-list (funcall cf1 2 18886)))
1201                   (result2 (multiple-value-list (funcall cf2 2 18886))))
1202             (if (equal result1 result2)
1203                 :good
1204                 (values result1 result2))))
1205          :good))
1206
1207 ;;; MISC.290
1208 (assert (zerop
1209          (funcall
1210           (compile
1211            nil
1212            '(lambda ()
1213              (declare
1214               (optimize (speed 3) (space 3) (safety 1)
1215                (debug 2) (compilation-speed 0)))
1216              (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
1217
1218 ;;; MISC.292
1219 (assert (zerop (funcall
1220                 (compile
1221                  nil
1222                  '(lambda (a b)
1223                    (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1224                              (compilation-speed 2)))
1225                    (apply (constantly 0)
1226                     a
1227                     0
1228                     (catch 'ct6
1229                       (apply (constantly 0)
1230                              0
1231                              0
1232                              (let* ((v1
1233                                      (let ((*s7* 0))
1234                                        b)))
1235                                0)
1236                              0
1237                              nil))
1238                     0
1239                     nil)))
1240                 1 2)))
1241
1242 ;;; misc.295
1243 (assert (eql
1244          (funcall
1245           (compile
1246            nil
1247            '(lambda ()
1248              (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1249              (multiple-value-prog1
1250                  (the integer (catch 'ct8 (catch 'ct7 15867134)))
1251                (catch 'ct1 (throw 'ct1 0))))))
1252          15867134))
1253
1254 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1255 ;;; could transform known-values LVAR to UVL
1256 (assert (zerop (funcall
1257    (compile
1258     nil
1259     '(lambda (a b c)
1260        (declare (notinline boole values denominator list))
1261        (declare
1262         (optimize (speed 2)
1263                   (space 0)
1264                   (safety 1)
1265                   (debug 0)
1266                   (compilation-speed 2)))
1267        (catch 'ct6
1268          (progv
1269              '(*s8*)
1270              (list 0)
1271            (let ((v9 (ignore-errors (throw 'ct6 0))))
1272              (denominator
1273               (progv nil nil (values (boole boole-and 0 v9)))))))))
1274    1 2 3)))
1275
1276 ;;; non-continuous dead UVL blocks
1277 (defun non-continuous-stack-test (x)
1278   (multiple-value-call #'list
1279     (eval '(values 11 12))
1280     (eval '(values 13 14))
1281     (block ext
1282       (return-from non-continuous-stack-test
1283         (multiple-value-call #'list
1284           (eval '(values :b1 :b2))
1285           (eval '(values :b3 :b4))
1286           (block int
1287             (return-from ext
1288               (multiple-value-call (eval #'values)
1289                 (eval '(values 1 2))
1290                 (eval '(values 3 4))
1291                 (block ext
1292                   (return-from int
1293                     (multiple-value-call (eval #'values)
1294                       (eval '(values :a1 :a2))
1295                       (eval '(values :a3 :a4))
1296                       (block int
1297                         (return-from ext
1298                           (multiple-value-call (eval #'values)
1299                             (eval '(values 5 6))
1300                             (eval '(values 7 8))
1301                             (if x
1302                                 :ext
1303                                 (return-from int :int))))))))))))))))
1304 (assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
1305 (assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
1306
1307 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1308 ;;; if ENTRY.
1309 (assert (equal (multiple-value-list (funcall
1310    (compile
1311     nil
1312     '(lambda (b g h)
1313        (declare (optimize (speed 3) (space 3) (safety 2)
1314                           (debug 2) (compilation-speed 3)))
1315        (catch 'ct5
1316          (unwind-protect
1317              (labels ((%f15 (f15-1 f15-2 f15-3)
1318                             (rational (throw 'ct5 0))))
1319                (%f15 0
1320                      (apply #'%f15
1321                             0
1322                             h
1323                             (progn
1324                               (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
1325                               0)
1326                             nil)
1327                      0))
1328            (common-lisp:handler-case 0)))))
1329    1 2 3))
1330  '(0)))
1331
1332 \f
1333 ;;; MISC.275
1334 (assert
1335  (zerop
1336   (funcall
1337    (compile
1338     nil
1339     '(lambda (b)
1340       (declare (notinline funcall min coerce))
1341       (declare
1342        (optimize (speed 1)
1343         (space 2)
1344         (safety 2)
1345         (debug 1)
1346         (compilation-speed 1)))
1347       (flet ((%f12 (f12-1)
1348                (coerce
1349                 (min
1350                  (if f12-1 (multiple-value-prog1
1351                                b (return-from %f12 0))
1352                      0))
1353                 'integer)))
1354         (funcall #'%f12 0))))
1355    -33)))
1356
1357 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1358 ;;; potential problem: optimizers and type derivers for MAX and MIN
1359 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1360 (dolist (f '(min max))
1361   (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
1362         for complex-arg = `(if x ,@complex-arg-args)
1363         do
1364         (loop for args in `((1 ,complex-arg)
1365                             (,complex-arg 1))
1366               for form = `(,f ,@args)
1367               for f1 = (compile nil `(lambda (x) ,form))
1368               and f2 = (compile nil `(lambda (x) (declare (notinline min max))
1369                                              ,form))
1370               do
1371               (dolist (x '(nil t))
1372                 (assert (eql (funcall f1 x) (funcall f2 x)))))))
1373
1374 ;;;
1375 (handler-case (compile nil '(lambda (x)
1376                              (declare (optimize (speed 3) (safety 0)))
1377                              (the double-float (sqrt (the double-float x)))))
1378   (sb-ext:compiler-note ()
1379     (error "Compiler does not trust result type assertion.")))
1380
1381 (let ((f (compile nil '(lambda (x)
1382                         (declare (optimize speed (safety 0)))
1383                         (block nil
1384                           (the double-float
1385                             (multiple-value-prog1
1386                                 (sqrt (the double-float x))
1387                               (when (< x 0)
1388                                 (return :minus)))))))))
1389   (assert (eql (funcall f -1d0) :minus))
1390   (assert (eql (funcall f 4d0) 2d0)))
1391
1392 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1393 (handler-case
1394     (compile nil '(lambda (a i)
1395                    (locally
1396                      (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1397                                         (inhibit-warnings 0)))
1398                      (declare (type (alien (* (unsigned 8))) a)
1399                               (type (unsigned-byte 32) i))
1400                      (deref a i))))
1401   (compiler-note () (error "The code is not optimized.")))
1402
1403 (handler-case
1404     (compile nil '(lambda (x)
1405                    (declare (type (integer -100 100) x))
1406                    (declare (optimize speed))
1407                    (declare (notinline identity))
1408                    (1+ (identity x))))
1409   (compiler-note () (error "IDENTITY derive-type not applied.")))
1410
1411 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
1412
1413 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1414 ;;; LVAR; here the first write may be cleared before the second is
1415 ;;; made.
1416 (assert
1417  (zerop
1418   (funcall
1419    (compile
1420     nil
1421     '(lambda ()
1422       (declare (notinline complex))
1423       (declare (optimize (speed 1) (space 0) (safety 1)
1424                 (debug 3) (compilation-speed 3)))
1425       (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
1426         (complex (%f) 0)))))))
1427
1428 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1429 (assert (zerop (funcall
1430   (compile
1431    nil
1432    '(lambda (a c)
1433      (declare (type (integer -1294746569 1640996137) a))
1434      (declare (type (integer -807801310 3) c))
1435      (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1436      (catch 'ct7
1437        (if
1438         (logbitp 0
1439                  (if (/= 0 a)
1440                      c
1441                      (ignore-errors
1442                        (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
1443         0 0))))
1444    391833530 -32785211)))
1445
1446 ;;; efficiency notes for ordinary code
1447 (macrolet ((frob (arglist &body body)
1448              `(progn
1449                (handler-case
1450                    (compile nil '(lambda ,arglist ,@body))
1451                  (sb-ext:compiler-note (e)
1452                    (error "bad compiler note for ~S:~%  ~A" ',body e)))
1453                (catch :got-note
1454                  (handler-case
1455                      (compile nil '(lambda ,arglist (declare (optimize speed))
1456                                     ,@body))
1457                    (sb-ext:compiler-note (e) (throw :got-note nil)))
1458                  (error "missing compiler note for ~S" ',body)))))
1459   (frob (x) (funcall x))
1460   (frob (x y) (find x y))
1461   (frob (x y) (find-if x y))
1462   (frob (x y) (find-if-not x y))
1463   (frob (x y) (position x y))
1464   (frob (x y) (position-if x y))
1465   (frob (x y) (position-if-not x y))
1466   (frob (x) (aref x 0)))
1467
1468 (macrolet ((frob (style-warn-p form)
1469              (if style-warn-p
1470                  `(catch :got-style-warning
1471                    (handler-case
1472                        (eval ',form)
1473                      (style-warning (e) (throw :got-style-warning nil)))
1474                    (error "missing style-warning for ~S" ',form))
1475                  `(handler-case
1476                    (eval ',form)
1477                    (style-warning (e)
1478                     (error "bad style-warning for ~S: ~A" ',form e))))))
1479   (frob t (lambda (x &optional y &key z) (list x y z)))
1480   (frob nil (lambda (x &optional y z) (list x y z)))
1481   (frob nil (lambda (x &key y z) (list x y z)))
1482   (frob t (defgeneric #:foo (x &optional y &key z)))
1483   (frob nil (defgeneric #:foo (x &optional y z)))
1484   (frob nil (defgeneric #:foo (x &key y z)))
1485   (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
1486
1487 ;;; this was a bug in the LOGXOR type deriver.  The top form gave a
1488 ;;; note, because the system failed to derive the fact that the return
1489 ;;; from LOGXOR was small and negative, though the bottom one worked.
1490 (handler-bind ((sb-ext:compiler-note #'error))
1491   (compile nil '(lambda ()
1492                  (declare (optimize speed (safety 0)))
1493                  (lambda (x y)
1494                    (declare (type (integer 3 6) x)
1495                             (type (integer -6 -3) y))
1496                    (+ (logxor x y) most-positive-fixnum)))))
1497 (handler-bind ((sb-ext:compiler-note #'error))
1498   (compile nil '(lambda ()
1499                  (declare (optimize speed (safety 0)))
1500                  (lambda (x y)
1501                    (declare (type (integer 3 6) y)
1502                             (type (integer -6 -3) x))
1503                    (+ (logxor x y) most-positive-fixnum)))))
1504
1505 ;;; check that modular ash gives the right answer, to protect against
1506 ;;; possible misunderstandings about the hardware shift instruction.
1507 (assert (zerop (funcall
1508                 (compile nil '(lambda (x y)
1509                                (declare (optimize speed)
1510                                         (type (unsigned-byte 32) x y))
1511                                (logand #xffffffff (ash x y))))
1512                 1 257)))
1513
1514 ;;; code instrumenting problems
1515 (compile nil
1516   '(lambda ()
1517     (declare (optimize (debug 3)))
1518     (list (the integer (if nil 14 t)))))
1519
1520 (compile nil
1521   '(LAMBDA (A B C D)
1522     (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
1523     (DECLARE
1524      (OPTIMIZE (SPEED 1)
1525       (SPACE 1)
1526       (SAFETY 1)
1527       (DEBUG 3)
1528       (COMPILATION-SPEED 0)))
1529     (MASK-FIELD (BYTE 7 26)
1530      (PROGN
1531        (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
1532        B))))
1533
1534 (compile nil
1535   '(lambda (buffer i end)
1536     (declare (optimize (debug 3)))
1537     (loop (when (not (eql 0 end)) (return)))
1538     (let ((s (make-string end)))
1539       (setf (schar s i) (schar buffer i))
1540       s)))
1541
1542 ;;; check that constant string prefix and suffix don't cause the
1543 ;;; compiler to emit code deletion notes.
1544 (handler-bind ((sb-ext:code-deletion-note #'error))
1545   (compile nil '(lambda (s x)
1546                  (pprint-logical-block (s x :prefix "(")
1547                    (print x s))))
1548   (compile nil '(lambda (s x)
1549                  (pprint-logical-block (s x :per-line-prefix ";")
1550                    (print x s))))
1551   (compile nil '(lambda (s x)
1552                  (pprint-logical-block (s x :suffix ">")
1553                    (print x s)))))
1554
1555 ;;; MISC.427: loop analysis requires complete DFO structure
1556 (assert (eql 17 (funcall
1557   (compile
1558    nil
1559    '(lambda (a)
1560      (declare (notinline list reduce logior))
1561      (declare (optimize (safety 2) (compilation-speed 1)
1562                (speed 3) (space 2) (debug 2)))
1563      (logior
1564       (let* ((v5 (reduce #'+ (list 0 a))))
1565         (declare (dynamic-extent v5))
1566         v5))))
1567     17)))
1568
1569 ;;;  MISC.434
1570 (assert (zerop (funcall
1571    (compile
1572     nil
1573     '(lambda (a b)
1574        (declare (type (integer -8431780939320 1571817471932) a))
1575        (declare (type (integer -4085 0) b))
1576        (declare (ignorable a b))
1577        (declare
1578         (optimize (space 2)
1579                   (compilation-speed 0)
1580                   #+sbcl (sb-c:insert-step-conditions 0)
1581                   (debug 2)
1582                   (safety 0)
1583                   (speed 3)))
1584        (let ((*s5* 0))
1585          (dotimes (iv1 2 0)
1586            (let ((*s5*
1587                   (elt '(1954479092053)
1588                        (min 0
1589                             (max 0
1590                                  (if (< iv1 iv1)
1591                                      (lognand iv1 (ash iv1 (min 53 iv1)))
1592                                    iv1))))))
1593              0)))))
1594    -7639589303599 -1368)))
1595
1596 (compile
1597  nil
1598  '(lambda (a b)
1599    (declare (type (integer) a))
1600    (declare (type (integer) b))
1601    (declare (ignorable a b))
1602    (declare (optimize (space 2) (compilation-speed 0)
1603              (debug 0) (safety 0) (speed 3)))
1604    (dotimes (iv1 2 0)
1605      (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
1606      (print (if (< iv1 iv1)
1607                 (logand (ash iv1 iv1) 1)
1608                 iv1)))))
1609
1610 ;;; MISC.435: lambda var substitution in a deleted code.
1611 (assert (zerop (funcall
1612    (compile
1613     nil
1614     '(lambda (a b c d)
1615        (declare (notinline aref logandc2 gcd make-array))
1616        (declare
1617         (optimize (space 0) (safety 0) (compilation-speed 3)
1618                   (speed 3) (debug 1)))
1619        (progn
1620          (tagbody
1621           (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
1622             (declare (dynamic-extent v2))
1623             (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
1624           tag2)
1625          0)))
1626    3021871717588 -866608 -2 -17194)))
1627
1628 ;;; MISC.436, 438: lost reoptimization
1629 (assert (zerop (funcall
1630    (compile
1631     nil
1632     '(lambda (a b)
1633        (declare (type (integer -2917822 2783884) a))
1634        (declare (type (integer 0 160159) b))
1635        (declare (ignorable a b))
1636        (declare
1637         (optimize (compilation-speed 1)
1638                   (speed 3)
1639                   (safety 3)
1640                   (space 0)
1641                   ; #+sbcl (sb-c:insert-step-conditions 0)
1642                   (debug 0)))
1643        (if
1644            (oddp
1645             (loop for
1646                   lv1
1647                   below
1648                   2
1649                   count
1650                   (logbitp 0
1651                            (1-
1652                             (ash b
1653                                  (min 8
1654                                       (count 0
1655                                              '(-10197561 486 430631291
1656                                                          9674068))))))))
1657            b
1658          0)))
1659    1265797 110757)))
1660
1661 (assert (zerop (funcall
1662    (compile
1663     nil
1664     ' (lambda (a)
1665         (declare (type (integer 0 1696) a))
1666         ; (declare (ignorable a))
1667         (declare (optimize (space 2) (debug 0) (safety 1)
1668                    (compilation-speed 0) (speed 1)))
1669         (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
1670    805)))
1671
1672 ;;; bug #302
1673 (assert (compile
1674          nil
1675          '(lambda (s ei x y)
1676            (declare (type (simple-array function (2)) s) (type ei ei))
1677            (funcall (aref s ei) x y))))
1678
1679 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1680 ;;; a DEFINED-FUN.
1681 (assert (eql 102 (funcall
1682   (compile
1683    nil
1684    '(lambda ()
1685      (declare (optimize (speed 3) (space 0) (safety 2)
1686                (debug 2) (compilation-speed 0)))
1687      (catch 'ct2
1688        (elt '(102)
1689             (flet ((%f12 () (rem 0 -43)))
1690               (multiple-value-call #'%f12 (values))))))))))
1691
1692 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1693 (assert (zerop (funcall
1694   (compile
1695    nil
1696    '(lambda (a b c d e)
1697      (declare (notinline values complex eql))
1698      (declare
1699       (optimize (compilation-speed 3)
1700        (speed 3)
1701        (debug 1)
1702        (safety 1)
1703        (space 0)))
1704      (flet ((%f10
1705                 (f10-1 f10-2 f10-3
1706                        &optional (f10-4 (ignore-errors 0)) (f10-5 0)
1707                        &key &allow-other-keys)
1708               (if (or (eql 0 0) t) 0 (if f10-1 0 0))))
1709        (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0))))
1710    80043 74953652306 33658947 -63099937105 -27842393)))
1711
1712 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1713 ;;; resulting from SETF of LET.
1714 (dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops)))
1715                    (compile nil '(lambda () (let* :bogus-let* :oops)))
1716                    (compile nil '(lambda (x) (push x (let ((y 0)) y))))))
1717   (assert (functionp fun))
1718   (multiple-value-bind (res err) (ignore-errors (funcall fun))
1719     (assert (not res))
1720     (assert (typep err 'program-error))))
1721
1722 (let ((fun (compile nil '(lambda (x) (random (if x 10 20))))))
1723   (dotimes (i 100 (error "bad RANDOM distribution"))
1724     (when (> (funcall fun nil) 9)
1725       (return t)))
1726   (dotimes (i 100)
1727     (when (> (funcall fun t) 9)
1728       (error "bad RANDOM event"))))
1729
1730 ;;; 0.8.17.28-sma.1 lost derived type information.
1731 (with-test (:name "0.8.17.28-sma.1" :fails-on :sparc)
1732   (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
1733     (compile nil
1734       '(lambda (x y v)
1735         (declare (optimize (speed 3) (safety 0)))
1736         (declare (type (integer 0 80) x)
1737          (type (integer 0 11) y)
1738          (type (simple-array (unsigned-byte 32) (*)) v))
1739         (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
1740         nil))))
1741
1742 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1743 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1744 (let ((f (compile nil '(lambda ()
1745                         (declare (optimize (debug 3)))
1746                         (with-simple-restart (blah "blah") (error "blah"))))))
1747   (handler-bind ((error (lambda (c) (invoke-restart 'blah))))
1748     (assert (equal (multiple-value-list (funcall f)) '(nil t)))))
1749
1750 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1751 ;;; constant index and value.
1752 (loop for n-bits = 1 then (* n-bits 2)
1753       for type = `(unsigned-byte ,n-bits)
1754       and v-max = (1- (ash 1 n-bits))
1755       while (<= n-bits sb-vm:n-word-bits)
1756       do
1757       (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
1758              (array1 (make-array n :element-type type))
1759              (array2 (make-array n :element-type type)))
1760         (dotimes (i n)
1761           (dolist (v (list 0 v-max))
1762             (let ((f (compile nil `(lambda (a)
1763                                      (declare (type (simple-array ,type (,n)) a))
1764                                      (setf (aref a ,i) ,v)))))
1765               (fill array1 (- v-max v))
1766               (fill array2 (- v-max v))
1767               (funcall f array1)
1768               (setf (aref array2 i) v)
1769               (assert (every #'= array1 array2)))))))
1770
1771 (let ((fn (compile nil '(lambda (x)
1772                           (declare (type bit x))
1773                           (declare (optimize speed))
1774                           (let ((b (make-array 64 :element-type 'bit
1775                                                :initial-element 0)))
1776                             (count x b))))))
1777   (assert (= (funcall fn 0) 64))
1778   (assert (= (funcall fn 1) 0)))
1779
1780 (let ((fn (compile nil '(lambda (x y)
1781                           (declare (type simple-bit-vector x y))
1782                           (declare (optimize speed))
1783                           (equal x y)))))
1784   (assert (funcall
1785            fn
1786            (make-array 64 :element-type 'bit :initial-element 0)
1787            (make-array 64 :element-type 'bit :initial-element 0)))
1788   (assert (not
1789            (funcall
1790             fn
1791             (make-array 64 :element-type 'bit :initial-element 0)
1792             (let ((b (make-array 64 :element-type 'bit :initial-element 0)))
1793               (setf (sbit b 63) 1)
1794               b)))))
1795
1796 ;;; MISC.535: compiler failure
1797 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
1798     (assert (not (funcall
1799      (compile
1800       nil
1801       `(lambda (p1 p2)
1802          (declare (optimize speed (safety 1))
1803                   (type (eql ,c0) p1)
1804                   (type number p2))
1805          (eql (the (complex double-float) p1) p2)))
1806      c0 #c(12 612/979)))))
1807
1808 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1809 ;;; simple-bit-vector functions.
1810 (handler-bind ((sb-ext:compiler-note #'error))
1811   (compile nil '(lambda (x)
1812                  (declare (type simple-bit-vector x))
1813                  (count 1 x))))
1814 (handler-bind ((sb-ext:compiler-note #'error))
1815   (compile nil '(lambda (x y)
1816                  (declare (type simple-bit-vector x y))
1817                  (equal x y))))
1818
1819 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1820 ;;; code transformations.
1821 (assert (eql (funcall
1822   (compile
1823    nil
1824    '(lambda (p1 p2)
1825      (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1826       (type atom p1)
1827       (type symbol p2))
1828      (or p1 (the (eql t) p2))))
1829    nil t)
1830   t))
1831
1832 ;;; MISC.548: type check weakening converts required type into
1833 ;;; optional
1834 (assert (eql t
1835   (funcall
1836    (compile
1837     nil
1838     '(lambda (p1)
1839       (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1840       (atom (the (member f assoc-if write-line t w) p1))))
1841    t)))
1842
1843 ;;; Free special bindings only apply to the body of the binding form, not
1844 ;;; the initialization forms.
1845 (assert (eq :good
1846             (funcall (compile 'nil
1847                               (lambda ()
1848                                 (let ((x :bad))
1849                                   (declare (special x))
1850                                   (let ((x :good))
1851                                     ((lambda (&optional (y x))
1852                                        (declare (special x)) y)))))))))
1853
1854 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1855 ;;; a rational was zero, but didn't do the substitution, leading to a
1856 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1857 ;;; machine's ASH instruction's immediate field) that the compiler
1858 ;;; thought was legitimate.
1859 ;;;
1860 ;;; FIXME: this has been recorded as bug 383.  The attempted fix (sbcl
1861 ;;; 0.9.2.6) led to lots of spurious optimization notes.  So the bug stil
1862 ;;; exist and this test case serves as a reminder of the problem.
1863 ;;;   --njf, 2005-07-05
1864 #+nil
1865 (compile 'nil
1866          (LAMBDA (B)
1867            (DECLARE (TYPE (INTEGER -2 14) B))
1868            (DECLARE (IGNORABLE B))
1869            (ASH (IMAGPART B) 57)))
1870
1871 ;;; bug reported by Eduardo Mu\~noz
1872 (multiple-value-bind (fun warnings failure)
1873     (compile nil '(lambda (struct first)
1874                    (declare (optimize speed))
1875                    (let* ((nodes (nodes struct))
1876                           (bars (bars struct))
1877                           (length (length nodes))
1878                           (new (make-array length :fill-pointer 0)))
1879                      (vector-push first new)
1880                      (loop with i fixnum = 0
1881                            for newl fixnum = (length new)
1882                            while (< newl length) do
1883                            (let ((oldl (length new)))
1884                              (loop for j fixnum from i below newl do
1885                                    (dolist (n (node-neighbours (aref new j) bars))
1886                                      (unless (find n new)
1887                                        (vector-push n new))))
1888                              (setq i oldl)))
1889                      new)))
1890   (declare (ignore fun warnings failure))
1891   (assert (not failure)))
1892
1893 ;;; bug #389: "0.0 can't be converted to type NIL."  (Brian Rowe
1894 ;;; sbcl-devel)
1895 (compile nil '(lambda (x y a b c)
1896                (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
1897
1898 ;;; Type inference from CHECK-TYPE
1899 (let ((count0 0) (count1 0))
1900   (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0))))
1901     (compile nil '(lambda (x)
1902                    (declare (optimize (speed 3)))
1903                    (1+ x))))
1904   ;; forced-to-do GENERIC-+, etc
1905   (assert (> count0 0))
1906   (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
1907     (compile nil '(lambda (x)
1908                    (declare (optimize (speed 3)))
1909                    (check-type x fixnum)
1910                    (1+ x))))
1911   (assert (= count1 0)))
1912
1913 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
1914 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
1915 (with-test (:name :sap-ref-float)
1916   (compile nil '(lambda (sap)
1917                  (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0)))
1918                    (1+ x))))
1919   (compile nil '(lambda (sap)
1920                  (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
1921                    (1+ x)))))
1922
1923 ;;; bug #399
1924 (with-test (:name :string-union-types)
1925   (compile nil '(lambda (x)
1926                  (declare (type (or (simple-array character (6))
1927                                     (simple-array character (5))) x))
1928                  (aref x 0))))
1929
1930 ;;; MISC.623: missing functions for constant-folding
1931 (assert (eql 0
1932              (funcall
1933               (compile
1934                nil
1935                '(lambda ()
1936                  (declare (optimize (space 2) (speed 0) (debug 2)
1937                            (compilation-speed 3) (safety 0)))
1938                  (loop for lv3 below 1
1939                     count (minusp
1940                            (loop for lv2 below 2
1941                               count (logbitp 0
1942                                              (bit #*1001101001001
1943                                                   (min 12 (max 0 lv3))))))))))))
1944
1945 ;;; MISC.624: erronous AVER in x86's %LOGBITP VOPs
1946 (assert (eql 0
1947              (funcall
1948               (compile
1949                nil
1950                '(lambda (a)
1951                  (declare (type (integer 21 28) a))
1952                  (declare       (optimize (compilation-speed 1) (safety 2)
1953                                  (speed 0) (debug 0) (space 1)))
1954                  (let* ((v7 (flet ((%f3 (f3-1 f3-2)
1955                                      (loop for lv2 below 1
1956                                         count
1957                                         (logbitp 29
1958                                                  (sbit #*10101111
1959                                                        (min 7 (max 0 (eval '0))))))))
1960                               (%f3 0 a))))
1961                    0)))
1962               22)))
1963
1964 ;;; MISC.626: bandaged AVER was still wrong
1965 (assert (eql -829253
1966              (funcall
1967               (compile
1968                nil
1969                '(lambda (a)
1970                   (declare (type (integer -902970 2) a))
1971                   (declare (optimize (space 2) (debug 0) (compilation-speed 1)
1972                                      (speed 0) (safety 3)))
1973                   (prog2 (if (logbitp 30 a) 0 (block b3 0)) a)))
1974               -829253)))
1975
1976 ;; MISC.628: constant-folding %LOGBITP was buggy
1977 (assert (eql t
1978              (funcall
1979               (compile
1980                nil
1981                '(lambda ()
1982                   (declare (optimize (safety 3) (space 3) (compilation-speed 3)
1983                                      (speed 0) (debug 1)))
1984                   (not (not (logbitp 0 (floor 2147483651 (min -23 0))))))))))
1985
1986 ;; mistyping found by random-tester
1987 (assert (zerop
1988   (funcall
1989    (compile
1990     nil
1991     '(lambda ()
1992       (declare (optimize (speed 1) (debug 0)
1993                 (space 2) (safety 0) (compilation-speed 0)))
1994       (unwind-protect 0
1995         (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
1996
1997 ;; aggressive constant folding (bug #400)
1998 (assert
1999  (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
2000
2001 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
2002   (assert
2003    (handler-case
2004        (compile nil '(lambda (x y)
2005                        (when (eql x (length y))
2006                          (locally
2007                              (declare (optimize (speed 3)))
2008                            (1+ x)))))
2009      (compiler-note () (error "The code is not optimized.")))))
2010
2011 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
2012   (assert
2013    (handler-case
2014        (compile nil '(lambda (x y)
2015                        (when (eql (length y) x)
2016                          (locally
2017                              (declare (optimize (speed 3)))
2018                            (1+ x)))))
2019      (compiler-note () (error "The code is not optimized.")))))
2020
2021 (with-test (:name (:compiler :constraint-propagation :float-bounds-1))
2022   (handler-case
2023       (compile nil '(lambda (x)
2024                       (declare (type (single-float * (3.0)) x))
2025                       (when (<= x 2.0)
2026                         (when (<= 2.0 x)
2027                           x))))
2028     (compiler-note () (error "Deleted reachable code."))))
2029
2030 (with-test (:name (:compiler :constraint-propagation :float-bounds-2))
2031   (catch :note
2032     (handler-case
2033         (compile nil '(lambda (x)
2034                         (declare (type single-float x))
2035                         (when (< 1.0 x)
2036                           (when (<= x 1.0)
2037                             (error "This is unreachable.")))))
2038       (compiler-note () (throw :note nil)))
2039     (error "Unreachable code undetected.")))
2040
2041 ;; Reported by John Wiseman, sbcl-devel
2042 ;; Subject: [Sbcl-devel] float type derivation bug?
2043 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2044 (with-test (:name (:type-derivation :float-bounds))
2045   (compile nil '(lambda (bits)
2046                  (let* ((s (if (= (ash bits -31) 0) 1 -1))
2047                         (e (logand (ash bits -23) #xff))
2048                         (m (if (= e 0)
2049                                (ash (logand bits #x7fffff) 1)
2050                                (logior (logand bits #x7fffff) #x800000))))
2051                    (float (* s m (expt 2 (- e 150))))))))
2052
2053 ;; Reported by James Knight
2054 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2055 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2056 (with-test (:name :logbitp-vop)
2057   (compile nil
2058            '(lambda (days shift)
2059              (declare (type fixnum shift days))
2060              (let* ((result 0)
2061                     (canonicalized-shift (+ shift 1))
2062                     (first-wrapping-day (- 1 canonicalized-shift)))
2063                (declare (type fixnum result))
2064                (dotimes (source-day 7)
2065                  (declare (type (integer 0 6) source-day))
2066                  (when (logbitp source-day days)
2067                    (setf result
2068                          (logior result
2069                                  (the fixnum
2070                                    (if (< source-day first-wrapping-day)
2071                                        (+ source-day canonicalized-shift)
2072                                        (- (+ source-day
2073                                              canonicalized-shift) 7)))))))
2074                result))))
2075
2076 ;;; MISC.637: incorrect delaying of conversion of optional entries
2077 ;;; with hairy constant defaults
2078 (let ((f '(lambda ()
2079   (labels ((%f11 (f11-2 &key key1)
2080              (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0)))
2081                         :bad1))
2082                (%f8 (%f8 0)))
2083              :bad2))
2084     :good))))
2085   (assert (eq (funcall (compile nil f)) :good)))
2086
2087 ;;; MISC.555: new reference to an already-optimized local function
2088 (let* ((l '(lambda (p1)
2089     (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1))
2090     (keywordp p1)))
2091        (f (compile nil l)))
2092   (assert (funcall f :good))
2093   (assert (nth-value 1 (ignore-errors (funcall f 42)))))
2094
2095 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2096 (let* ((state (make-random-state))
2097        (*random-state* (make-random-state state))
2098        (a (random most-positive-fixnum)))
2099   (setf *random-state* state)
2100   (compile nil `(lambda (x a)
2101                   (declare (single-float x)
2102                            (type (simple-array double-float) a))
2103                   (+ (loop for i across a
2104                            summing i)
2105                      x)))
2106   (assert (= a (random most-positive-fixnum))))
2107
2108 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2109 (let ((form '(lambda ()
2110               (declare (optimize (speed 1) (space 0) (debug 2)
2111                            (compilation-speed 0) (safety 1)))
2112               (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #())))
2113                           0))
2114                    (apply #'%f3 0 nil)))))
2115   (assert (zerop (funcall (compile nil form)))))
2116
2117 ;;;  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
2118 (compile nil '(lambda ()
2119                (let ((x (make-array '(1) :element-type '(signed-byte 32))))
2120                  (setf (aref x 0) 1))))
2121
2122 ;;; step instrumentation confusing the compiler, reported by Faré
2123 (handler-bind ((warning #'error))
2124   (compile nil '(lambda ()
2125                  (declare (optimize (debug 2))) ; not debug 3!
2126                  (let ((val "foobar"))
2127                    (map-into (make-array (list (length val))
2128                                          :element-type '(unsigned-byte 8))
2129                              #'char-code val)))))
2130
2131 ;;; overconfident primitive type computation leading to bogus type
2132 ;;; checking.
2133 (let* ((form1 '(lambda (x)
2134                 (declare (type (and condition function) x))
2135                 x))
2136        (fun1 (compile nil form1))
2137        (form2 '(lambda (x)
2138                 (declare (type (and standard-object function) x))
2139                 x))
2140        (fun2 (compile nil form2)))
2141   (assert (raises-error? (funcall fun1 (make-condition 'error))))
2142   (assert (raises-error? (funcall fun1 fun1)))
2143   (assert (raises-error? (funcall fun2 fun2)))
2144   (assert (eq (funcall fun2 #'print-object) #'print-object)))
2145
2146 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2147 ;;; and possibly a non-conforming extension, as long as we do support
2148 ;;; it, we might as well get it right.
2149 ;;;
2150 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2151 (compile nil '(lambda () (let* () (declare (values list)))))