tests/compiler.pure.lisp

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