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