tests/compiler.impure-cload.lisp

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