tests/compiler.pure.lisp

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