tests/compiler.impure-cload.lisp

   1 (eval-when (:compile-toplevel :load-toplevel :execute)
   2   (load "assertoid.lisp")
   3   (load "compiler-test-util.lisp")
   4   (load "test-util.lisp")
   5   (use-package "ASSERTOID"))
   6
   7 ;;; bug 254: compiler falure
   8 (defpackage :bug254 (:use :cl))
   9 (in-package :bug254)
  10 (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1)))
  11 (defstruct foo
  12   (uhw2 nil :type (or package null)))
  13 (macrolet ((defprojection (variant &key lexpr eexpr)
  14              (declare (ignore variant eexpr))
  15              (let ()
  16                `(defmethod uu ((foo foo))
  17                   (let ((uhw2 (foo.uhw2 bar)))
  18                     (let ()
  19                       (u-flunt uhw2
  20                                (baz (funcall ,lexpr south east 1)))))))))
  21   (defprojection h
  22       :lexpr (lambda (south east sched)
  23                (flet ((bd (x) (bref x sched)))
  24                  (let ((avecname (gafp)))
  25                    (declare (type (vector t) avecname))
  26                    (multiple-value-prog1
  27                        (progn
  28                          (setf (avec.count avecname) (length rest))
  29                          (setf (aref avecname 0) (bd (h south)))
  30                          (setf (aref avecname 1) (bd (h east)))
  31                          (stub avecname))
  32                      (paip avecname)))))
  33       :eexpr (lambda (south east))))
  34 (in-package :cl-user)
  35 (delete-package :bug254)
  36
  37 ;;; bug 255
  38 (defpackage :bug255 (:use :cl))
  39 (in-package :bug255)
  40 (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1)))
  41 (defvar *1*)
  42 (defvar *2*)
  43 (defstruct v a b)
  44 (defstruct w)
  45 (defstruct yam (v nil :type (or v null)))
  46 (defstruct un u)
  47 (defstruct (bod (:include un)) bo)
  48 (defstruct (bad (:include bod)) ba)
  49 (declaim (ftype (function ((or w bad) (or w bad)) (values)) %ufm))
  50 (defun %ufm (base bound) (froj base bound *1*) (values))
  51 (declaim (ftype (function ((vector t)) (or w bad)) %pu))
  52 (defun %pu (pds) (declare (ignore pds)) *2*)
  53 (defun uu (yam)
  54   (declare (ignore yam))
  55   (let ((v (yam-v az)))
  56     (%ufm v
  57           (flet ((project (x) (frob x 0)))
  58             (let ((avecname *1*))
  59               (multiple-value-prog1
  60                   (progn (%pu avecname))
  61                 (frob)))))))
  62 (in-package :cl-user)
  63 (delete-package :bug255)
  64
  65 ;;; bug 148
  66 (defpackage :bug148 (:use :cl))
  67 (in-package :bug148)
  68
  69 (defvar *thing*)
  70 (defvar *zoom*)
  71 (defstruct foo bar bletch)
  72 (defun %zeep ()
  73   (labels ((kidify1 (kid)
  74              (declare (ignore kid))
  75              )
  76            (kid-frob (kid)
  77              (if *thing*
  78                  (setf sweptm
  79                        (m+ (frobnicate kid)
  80                            sweptm))
  81                  (kidify1 kid))))
  82     (declare (inline kid-frob))
  83     (map nil
  84          #'kid-frob
  85          (the simple-vector (foo-bar perd)))))
  86
  87 (declaim (optimize (safety 3) (speed 2) (space 1)))
  88 (defvar *foo*)
  89 (defvar *bar*)
  90 (defun u-b-sra (x r ad0 &optional ad1 &rest ad-list)
  91   (labels ((c.frob (c0)
  92              (let ()
  93                (when *foo*
  94                  (vector-push-extend c0 *bar*))))
  95            (ad.frob (ad)
  96              (if *foo*
  97                  (map nil #'ad.frob (the (vector t) *bar*))
  98                  (dolist (b *bar*)
  99                    (c.frob b)))))
 100     (declare (inline c.frob ad.frob))   ; 'til DYNAMIC-EXTENT
 101     (ad.frob ad0)))
 102
 103 (defun bug148-3 (ad0)
 104   (declare (special *foo* *bar*))
 105   (declare (optimize (safety 3) (speed 2) (space 1)))
 106   (labels ((c.frob ())
 107            (ad.frob (ad)
 108              (declare (ignorable ad))
 109              (if *foo*
 110                  (mapc #'ad.frob *bar*)
 111                  (dolist (b *bar*)
 112                    (declare (ignore b))
 113                    (c.frob)))))
 114     (declare (inline c.frob ad.frob))
 115     (ad.frob ad0)))
 116
 117 (defun bug148-4 (ad0)
 118   (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
 119   (labels ((c.frob (x)
 120              (* 7 x))
 121            (ad.frob (ad)
 122              (loop for b in ad
 123                    collect (c.frob b))))
 124     (declare (inline c.frob ad.frob))
 125     (list (the list ad0)
 126           (funcall (if (listp ad0) #'ad.frob #'print) ad0)
 127           (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
 128
 129 (assert (equal (eval '(bug148-4 '(1 2 3)))
 130                '((1 2 3) (7 14 21) (21 14 7))))
 131
 132 (in-package :cl-user)
 133 (delete-package :bug148)
 134
 135 ;;; bug 258
 136 (defpackage :bug258 (:use :cl))
 137 (in-package :bug258)
 138
 139 (defun u-b-sra (ad0)
 140   (declare (special *foo* *bar*))
 141   (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
 142   (labels ((c.frob (x)
 143              (1- x))
 144            (ad.frob (ad)
 145              (mapcar #'c.frob ad)))
 146     (declare (inline c.frob ad.frob))
 147     (list (the list ad0)
 148           (funcall (if (listp ad0) #'ad.frob #'print) ad0)
 149           (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
 150
 151 (assert (equal (u-b-sra '(4 9 7))
 152                '((4 9 7) (3 8 6) (6 8 3))))
 153
 154 (in-package :cl-user)
 155 (delete-package :bug258)
 156
 157 ;;;
 158 (defun bug233a (x)
 159   (declare (optimize (speed 2) (safety 3)))
 160   (let ((y 0d0))
 161     (values
 162      (the double-float x)
 163      (setq y (+ x 1d0))
 164      (setq x 3d0)
 165      (funcall (eval ''list) y (+ y 2d0) (* y 3d0)))))
 166 (assert-error (bug233a 4) type-error)
 167
 168 ;;; compiler failure
 169 (defun bug145b (x)
 170   (declare (type (double-float -0d0) x))
 171   (declare (optimize speed))
 172   (+ x (sqrt (log (random 1d0)))))
 173
 174 ;;; compiler failures reported by Paul Dietz: inaccurate dealing with
 175 ;;; BLOCK-LAST in CONSTANT-FOLD-CALL and DO-NODES
 176 (defun #:foo (a b c d)
 177   (declare (type (integer -1 1000655) b)
 178            (optimize (speed 3) (safety 1) (debug 1)))
 179   (- (logior
 180       (abs (- (+ b (logandc1 -473949 (max 5165 (abs (logandc1 a 250775)))))))
 181       (logcount (logeqv (max (logxor (abs c) -1) 0) -4)))
 182      d))
 183
 184 (defun #:foo (a d)
 185   (declare (type (integer -8507 26755) a)
 186            (type (integer -393314538 2084485) d)
 187            (optimize (speed 3) (safety 1) (debug 1)))
 188   (gcd
 189    (if (= 0 a) 10 (abs -1))
 190    (logxor -1
 191            (min -7580
 192                 (max (logand a 31365125) d)))))
 193
 194 ;;; compiler failure "NIL is not of type LVAR"
 195 (defun #:foo (x)
 196   (progn (truly-the integer x)
 197          (1+ x)))
 198
 199 (defun #:foo (a b c)
 200   (declare (type (integer -5498929 389890) a)
 201            (type (integer -5029571274946 48793670) b)
 202            (type (integer 9221496 260169518304) c)
 203            (ignorable a b c)
 204            (optimize (speed 3) (safety 1) (debug 1)))
 205   (- (mod 1020122 (min -49 -420))
 206      (logandc1
 207       (block b2 (mod c (min -49 (if t (return-from b2 1582) b))))
 208       (labels ((%f14 ()
 209                  (mod a (max 76 8))))
 210         b))))
 211
 212 ;;; bug 291 reported by Nikodemus Siivola (modified version)
 213 (defstruct line
 214   (%chars ""))
 215 (defun update-window-imag (line)
 216   (tagbody
 217    TOP
 218      (if (null line)
 219          (go DONE)
 220          (go TOP))
 221    DONE
 222      (unless (eq current the-sentinel)
 223        (let* ((cc (car current))
 224               (old-line (dis-line-line cc)))
 225          (if (eq old-line line)
 226              (do ((chars (line-%chars line) nil))
 227                  (())
 228                (let* ()
 229                  (multiple-value-call
 230                      #'(lambda (&optional g2740 g2741 &rest g2742)
 231                          (declare (ignore g2742))
 232                          (catch 'foo
 233                            (values (setq string g2740) (setq underhang g2741))))
 234                    (foo)))
 235                (setf (dis-line-old-chars cc) chars)))))))
 236
 237 ;;; and similar cases found by Paul Dietz
 238 (defun #:foo (a b c)
 239   (declare (optimize (speed 0) (safety 3) (debug 3)))
 240   (FLET ((%F11 ()
 241            (BLOCK B6
 242              (LET ((V2 B))
 243                (IF (LDB-TEST (BYTE 27 14) V2)
 244                    (LET ((V6
 245                           (FLET ((%F7 ()
 246                                    B))
 247                             -1)))
 248                      (RETURN-FROM B6 V2))
 249                    C)))))
 250     A))
 251 (defun #:foo (a b c)
 252   (declare (optimize (speed 0) (safety 3) (debug 3)))
 253   (FLET ((%F15 ()
 254            (BLOCK B8
 255              (LET ((V5 B))
 256                (MIN A (RETURN-FROM B8 C))))))
 257     C))
 258
 259 ;;; bug 292, reported by Paul Dietz
 260 (defun #:foo (C)
 261   (DECLARE (TYPE (INTEGER -5945502333 12668542) C)
 262            (OPTIMIZE (SPEED 3)))
 263   (LET ((V2 (* C 12)))
 264     (- (MAX (IF (/= 109335113 V2) -26479 V2)
 265             (DEPOSIT-FIELD 311
 266                            (BYTE 14 28)
 267                            (MIN (MAX 521326 C) -51))))))
 268
 269 ;;; zombie variables, arising from constraints
 270 (defun #:foo (A B)
 271   (DECLARE (TYPE (INTEGER -40945116 24028306) B)
 272            (OPTIMIZE (SPEED 3)))
 273   (LET ((V5 (MIN 31883 (LOGCOUNT A))))
 274     (IF (/= B V5) (IF (EQL 122911784 V5) -43765 1487) B)))
 275
 276 ;;; let-conversion of a function into deleted one
 277 (defun #:foo (a c)
 278   (declare (type (integer -883 1566) a)
 279            (type (integer -1 0) c)
 280            (optimize (speed 3) (safety 1) (debug 1)))
 281   (flet ((%f8 () c))
 282     (flet ((%f5 ()
 283              (if (< c a)
 284                  (return-from %f5 (if (= -4857 a) (%f8) (%f8)))
 285                  c)))
 286       (if (<= 11 c) (%f5) c))))
 287
 288 ;;; two bugs: "aggressive" deletion of optional entries and problems
 289 ;;; of FIND-RESULT-TYPE in dealing with deleted code; reported by
 290 ;;; Nikodemus Siivola (simplified version)
 291 (defun lisp-error-error-handler (condition)
 292   (invoke-debugger condition)
 293   (handler-bind ()
 294     (unwind-protect
 295          (with-simple-restart
 296              (continue "return to hemlock's debug loop.")
 297            (invoke-debugger condition))
 298       (device))))
 299
 300 ;;;
 301 (defun #:foo ()
 302   (labels ((foo (x)
 303              (return-from foo x)
 304              (block u
 305                (labels ((bar (x &optional (y (return-from u)))
 306                           (list x y (apply #'bar (fee)))))
 307                  (list (bar 1) (bar 1 2))))
 308              (1+ x)))
 309     #'foo))
 310
 311 (defun #:foo (b c)
 312   (declare (type (integer 0 1) b) (optimize (speed 3)))
 313   (flet ((%f2 () (lognor (block b5 138) c)))
 314     (if (not (or (= -67399 b) b))
 315         (deposit-field (%f2) (byte 11 8) -3)
 316         c)))
 317
 318 ;;; bug 214: compiler failure
 319 (defun bug214a1 ()
 320   (declare (optimize (sb-ext:inhibit-warnings 0) (compilation-speed 2)))
 321   (flet ((foo (&key (x :vx x-p)) (list x x-p)))
 322     (foo :x 2)))
 323
 324 (defun bug214a2 ()
 325   (declare (optimize (sb-ext:inhibit-warnings 0) (compilation-speed 2)))
 326   (lambda (x) (declare (fixnum x)) (if (< x 0) 0 (1- x))))
 327
 328 ;;; this one was reported by rydis on #lisp
 329 (defun 214b (n)
 330   (declare (fixnum n))
 331   (declare (optimize (speed 2) (space 3)))
 332   (dotimes (k n)
 333     (princ k)))
 334
 335 ;;; bug reported by Brian Downing: incorrect detection of MV-LET
 336 (DEFUN #:failure-testcase (SESSION)
 337   (LABELS ((CONTINUATION-1 ()
 338              (PROGN
 339                (IF (foobar-1 SESSION)
 340                    (CONTINUATION-2))
 341                (LET ((CONTINUATION-3
 342                       #'(LAMBDA ()
 343                           (MULTIPLE-VALUE-CALL #'CONTINUATION-2
 344                             (CONTINUATION-1)))))
 345                  (foobar-2 CONTINUATION-3))))
 346            (CONTINUATION-2 (&REST OTHER-1)
 347              (DECLARE (IGNORE OTHER-1))))
 348     (continuation-1)))
 349
 350 ;;; reported by antifuchs/bdowning/etc on #lisp: ITERATE failure on
 351 ;;; (iter (for i in '(1 2 3)) (+ i 50))
 352 (defun values-producer () (values 1 2 3 4 5 6 7))
 353
 354 (defun values-consumer (fn)
 355   (let (a b c d e f g h)
 356     (multiple-value-bind (aa bb cc dd ee ff gg hh) (funcall fn)
 357       (setq a aa)
 358       (setq b bb)
 359       (setq c cc)
 360       (setq d dd)
 361       (setq e ee)
 362       (setq f ff)
 363       (setq g gg)
 364       (setq h hh)
 365       (values a b c d e f g h))))
 366
 367 (let ((list (multiple-value-list (values-consumer #'values-producer))))
 368   (assert (= (length list) 8))
 369   (assert (null (nth 7 list))))
 370
 371 ;;; failed on Alpha prior to sbcl-0.8.10.30
 372 (defun lotso-values ()
 373   (values 0 1 2 3 4 5 6 7 8 9
 374           0 1 2 3 4 5 6 7 8 9
 375           0 1 2 3 4 5 6 7 8 9
 376           0 1 2 3 4 5 6 7 8 9
 377           0 1 2 3 4 5 6 7 8 9
 378           0 1 2 3 4 5 6 7 8 9
 379           0 1 2 3 4 5 6 7 8 9
 380           0 1 2 3 4 5 6 7 8 9
 381           0 1 2 3 4 5 6 7 8 9
 382           0 1 2 3 4 5 6 7 8 9))
 383
 384 ;;; bug 313: source transforms were "lisp-1"
 385 (defun srctran-lisp1-1 (cadr) (if (functionp cadr) (funcall cadr 1) nil))
 386 (assert (eql (funcall (eval #'srctran-lisp1-1) #'identity) 1))
 387 (without-package-locks
 388    ;; this be a nasal demon, but test anyways
 389    (defvar caar))
 390 (defun srctran-lisp1-2 (caar) (funcall (sb-ext:truly-the function caar) 1))
 391 (assert (eql (funcall (eval #'srctran-lisp1-2) #'identity) 1))
 392
 393 ;;; partial bug 262: reference of deleted CTRAN (in RETURN-FROM)
 394 ;;; during inline expansion. Bug report by Peter Denno, simplified
 395 ;;; test case by David Wragg.
 396 (defun bug262-return-from (x &aux (y nil))
 397   (declare (ignore y))
 398   (labels ((foo-a (z) (return-from bug262-return-from z))
 399            (foo-b (z) (foo-a z)))
 400     (declare (inline foo-a))
 401     (foo-a x)))
 402
 403 ;;; broken inference of an upper bound of an iteration variable,
 404 ;;; reported by Rajat Datta.
 405 (defun isieve (num)
 406   (let ((vec (make-array num :initial-element 0))
 407         (acc 0))
 408     (do ((i 2 (+ i 1)))
 409         ((>= i num) 'done)
 410       (when (= (svref vec i) 0)
 411         (do ((j (* i i) (+ j i)))
 412             ((>= j num) 'done)
 413           (setf (svref vec j) 1))
 414         (incf acc)))
 415     acc))
 416
 417 (assert (= (isieve 46349) 4792))
 418
 419 ;;; COERCE should not be constant-folded (reported by Nikodemus
 420 ;;; Siivola)
 421 (let ((f (gensym)))
 422   (setf (fdefinition f) (lambda (x) x))
 423   (let ((g (compile nil `(lambda () (coerce ',f 'function)))))
 424     (setf (fdefinition f) (lambda (x) (1+ x)))
 425     (assert (eq (funcall g) (fdefinition f)))))
 426
 427 (let ((x (coerce '(1 11) 'vector)))
 428   (incf (aref x 0))
 429   (assert (equalp x #(2 11))))
 430
 431 ;;; and BIT-* too (reported by Paul F. Dietz)
 432 (loop with v1 = #*0011
 433       and  v2 = #*0101
 434       for f in '(bit-and bit-andc1 bit-andc2 bit-eqv
 435                  bit-ior bit-nand bit-nor bit-not
 436                  bit-orc1 bit-orc2 bit-xor
 437                  )
 438       for form = `(lambda ()
 439                     (let ((v (,f ,v1 ,v2)))
 440                       (setf (aref v 0) (- 1 (aref v 0)))
 441                       (aref v 0)))
 442       for compiled-res = (funcall (compile nil form))
 443       for real-res = (- 1 (aref (funcall f v1 v2) 0))
 444       do (assert (equal compiled-res real-res)))
 445 (let* ((v #*0011)
 446        (form `(lambda ()
 447                 (let ((v (bit-not ,v)))
 448                   (setf (aref v 0) (- 1 (aref v 0)))
 449                   (aref v 0))))
 450        (compiled-res (funcall (compile nil form)))
 451        (real-res (- 1 (aref (funcall (eval #'bit-not) v) 0))))
 452   (assert (equal compiled-res real-res)))
 453
 454 ;; bug reported on sbcl-devel by Hannu Koivisto on 2005-08-10
 455 (defvar *hannu-trap* nil)
 456 (progv '(*hannu-trap*) '()
 457   (setq *hannu-trap* t))
 458 (assert (not *hannu-trap*))
 459
 460 ;;; bug reported on sbcl-help by Vasile Rotaru
 461 (let* ((initial-size (expt 2 16))
 462        (prime-table (make-array initial-size
 463                                 :element-type 'integer))
 464        (first-primes #(5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71
 465        73
 466                       79 83 89 97 101 103 107 109 113 127 131 137 139 149
 467                       151 157 163 167 173 179 181 191 193 197 199 211 223
 468                       227 229 233 239 241 251 257 263 269 271 277 281))
 469        (count 0)
 470        (increment 2))
 471
 472   (defun largest-prime-so-far ()
 473     (aref prime-table (1- count)))
 474   (defun add-prime (prime)
 475     (setf (aref prime-table count) prime) (incf count))
 476   (defun init-table ()
 477     (map 'nil #'add-prime first-primes))
 478   (defun next-candidate (candidate)
 479     (prog1 (+ candidate increment)
 480       (ecase increment
 481         (2 (setf increment 4))
 482         (4 (setf increment 2)))))
 483   (defun prime-p (n)
 484     (let ((sqrt-n (truncate (sqrt n))))
 485       (dotimes (i count)
 486         (let ((prime (aref prime-table i)))
 487           (when (> prime sqrt-n)
 488             (return-from prime-p t))
 489           (when (zerop (mod n prime))
 490             (return-from prime-p nil))))
 491       (error "~&prime-table too small: ~A ~A~%" n
 492       (largest-prime-so-far))))
 493   (defun generate-primes (required)
 494     (do ((candidate (next-candidate (largest-prime-so-far))
 495                     (next-candidate candidate)))
 496         ((> candidate required))
 497       (when (prime-p candidate)
 498         (add-prime candidate))))
 499   ;;
 500   (init-table))
 501
 502 ;;; Bug in the fopcompiler's handling of LOCALLY pre-0.9.14.8
 503
 504 (defvar *a* 1)
 505
 506 (setf *a*
 507       (locally
 508           (declare)
 509         2))
 510
 511 ;;; Bug in the interaction of BIND-SENTINEL and UNBIND-TO-HERE, as
 512 ;;; used by PROGV.
 513
 514 (defvar *foo-1* nil)
 515 (defvar *foo-2* nil)
 516
 517 (defun foo ()
 518   (declare (optimize (debug 2)))
 519   (let ((*foo-1* nil))
 520     (progv
 521         (list '*foo-2*)
 522         (list nil)
 523       (write-line "foo-2"))
 524     (write-line "foo-1"))
 525   (write-line "foo-0"))
 526
 527 (foo)
 528
 529 ;;; LOAD-TIME-VALUE smartness
 530 (defun load-time-value-type-derivation-test-1 ()
 531   (ctu:compiler-derived-type (load-time-value (cons 'foo 0))))
 532 (defun load-time-value-type-derivation-test-2 ()
 533   (ctu:compiler-derived-type (load-time-value (+ (or *print-length* 0) 10))))
 534 (defun load-time-value-auto-read-only-p ()
 535   (load-time-value (random most-positive-fixnum)))
 536 (defun load-time-value-boring ()
 537   (load-time-value (cons t t)))
 538 (test-util:with-test (:name (load-time-value :type-smartness/cload))
 539   (assert (eq 'cons (load-time-value-type-derivation-test-1)))
 540   (assert (equal '(integer 10) (load-time-value-type-derivation-test-2)))
 541   (assert (not (ctu:find-value-cell-values #'load-time-value-auto-read-only-p)))
 542   (assert (ctu:find-value-cell-values #'load-time-value-boring)))
 543
 544 (defun regression-1.0.29.54 ()
 545   (logior (1+ most-positive-fixnum)
 546           (load-time-value (the fixnum (eval 1)) t)))
 547
 548 (test-util:with-test (:name :regression-1.0.29.54)
 549   (assert (= (+ most-positive-fixnum 2) (regression-1.0.29.54)))
 550   (assert (eq 42
 551               (funcall (compile nil
 552                                 `(lambda ()
 553                                    (load-time-value (values 42))))))))
 554
 555 (defun mv-call-regression-1.0.43.57-foo (a c d x y)
 556   (values a c d x y))
 557 (defun mv-call-regression-1.0.43.57-bar (a b c d)
 558   (declare (number a b c d))
 559   (values a b c d))
 560 (defun mv-call-regression-1.0.43.57-quux (a sxx sxy syy)
 561   (multiple-value-call #'mv-call-regression-1.0.43.57-foo
 562     (mv-call-regression-1.0.43.57-bar sxx sxy sxy syy)
 563     a))
 564 (test-util:with-test (:name :mv-call-regression-1.0.43.57)
 565   ;; This used to signal a bogus argument-count error.
 566   (mv-call-regression-1.0.43.57-quux 1s0 10s0 1s0 10s0))
 567
 568 (defun etypecase-failure-test (x)
 569   (etypecase x
 570     (bignum 'b)
 571     (character 'c)
 572     ((or fixnum float) 'f)))
 573 (locally
 574     (declare (muffle-conditions style-warning))
 575   (defun ecase-failure-test (x)
 576     (ecase x ((a b c) 1) ((b c d) 2) ((e d f) 3) ((c g h i) 4))))
 577
 578 (test-util:with-test (:name :case-failures)
 579   (assert (equal (handler-case (etypecase-failure-test 'hi)
 580                    (sb-kernel:case-failure (c)
 581                      (sb-kernel::case-failure-possibilities c)))
 582                  ;; In order as originally written
 583                  '(bignum character (or fixnum float))))
 584   (assert (equal (handler-case (ecase-failure-test 'hi)
 585                    (sb-kernel:case-failure (c)
 586                      (sb-kernel::case-failure-possibilities c)))
 587                  ;; In order as originally written, and no dups.
 588                  '(a b c d e f g h i))))
 589
 590 (defparameter *circular-cons-with-a-vector-cdr*
 591   #1=#((a .  #1#)))