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