tests/compiler.impure-cload.lisp

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