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