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