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 (delete-package :bug254)
  32
  33 ;;; bug 255
  34 (defpackage :bug255 (:use :cl))
  35 (in-package :bug255)
  36 (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1)))
  37 (defvar *1*)
  38 (defvar *2*)
  39 (defstruct v a b)
  40 (defstruct w)
  41 (defstruct yam (v nil :type (or v null)))
  42 (defstruct un u)
  43 (defstruct (bod (:include un)) bo)
  44 (defstruct (bad (:include bod)) ba)
  45 (declaim (ftype (function ((or w bad) (or w bad)) (values)) %ufm))
  46 (defun %ufm (base bound) (froj base bound *1*) (values))
  47 (declaim (ftype (function ((vector t)) (or w bad)) %pu))
  48 (defun %pu (pds) *2*)
  49 (defun uu (yam)
  50   (let ((v (yam-v az)))
  51     (%ufm v
  52           (flet ((project (x) (frob x 0)))
  53             (let ((avecname *1*))
  54               (multiple-value-prog1
  55                   (progn (%pu avecname))
  56                 (frob)))))))
  57 (delete-package :bug255)
  58
  59 ;;; bug 148
  60 (defpackage :bug148 (:use :cl))
  61 (in-package :bug148)
  62
  63 (defvar *thing*)
  64 (defvar *zoom*)
  65 (defstruct foo bar bletch)
  66 (defun %zeep ()
  67   (labels ((kidify1 (kid)
  68              )
  69            (kid-frob (kid)
  70              (if *thing*
  71                  (setf sweptm
  72                        (m+ (frobnicate kid)
  73                            sweptm))
  74                  (kidify1 kid))))
  75     (declare (inline kid-frob))
  76     (map nil
  77          #'kid-frob
  78          (the simple-vector (foo-bar perd)))))
  79
  80 (declaim (optimize (safety 3) (speed 2) (space 1)))
  81 (defvar *foo*)
  82 (defvar *bar*)
  83 (defun u-b-sra (x r ad0 &optional ad1 &rest ad-list)
  84   (labels ((c.frob (c0)
  85              (let ()
  86                (when *foo*
  87                  (vector-push-extend c0 *bar*))))
  88            (ad.frob (ad)
  89              (if *foo*
  90                  (map nil #'ad.frob (the (vector t) *bar*))
  91                  (dolist (b *bar*)
  92                    (c.frob b)))))
  93     (declare (inline c.frob ad.frob))   ; 'til DYNAMIC-EXTENT
  94     (ad.frob ad0)))
  95
  96 (defun bug148-3 (ad0)
  97   (declare (special *foo* *bar*))
  98   (declare (optimize (safety 3) (speed 2) (space 1)))
  99   (labels ((c.frob ())
 100            (ad.frob (ad)
 101              (if *foo*
 102                  (mapc #'ad.frob *bar*)
 103                  (dolist (b *bar*)
 104                    (c.frob)))))
 105     (declare (inline c.frob ad.frob))
 106     (ad.frob ad0)))
 107
 108 (defun bug148-4 (ad0)
 109   (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
 110   (labels ((c.frob (x)
 111              (* 7 x))
 112            (ad.frob (ad)
 113              (loop for b in ad
 114                    collect (c.frob b))))
 115     (declare (inline c.frob ad.frob))
 116     (list (the list ad0)
 117           (funcall (if (listp ad0) #'ad.frob #'print) ad0)
 118           (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
 119
 120 (assert (equal (eval '(bug148-4 '(1 2 3)))
 121                '((1 2 3) (7 14 21) (21 14 7))))
 122
 123 (delete-package :bug148)
 124
 125 ;;; bug 258
 126 (defpackage :bug258 (:use :cl))
 127 (in-package :bug258)
 128
 129 (defun u-b-sra (ad0)
 130   (declare (special *foo* *bar*))
 131   (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
 132   (labels ((c.frob (x)
 133              (1- x))
 134            (ad.frob (ad)
 135              (mapcar #'c.frob ad)))
 136     (declare (inline c.frob ad.frob))
 137     (list (the list ad0)
 138           (funcall (if (listp ad0) #'ad.frob #'print) ad0)
 139           (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0)))))
 140
 141 (assert (equal (u-b-sra '(4 9 7))
 142                '((4 9 7) (3 8 6) (6 8 3))))
 143
 144 (delete-package :bug258)
 145
 146 (in-package :cl-user)
 147
 148 ;;;
 149 (defun bug233a (x)
 150   (declare (optimize (speed 2) (safety 3)))
 151   (let ((y 0d0))
 152     (values
 153      (the double-float x)
 154      (setq y (+ x 1d0))
 155      (setq x 3d0)
 156      (funcall (eval ''list) y (+ y 2d0) (* y 3d0)))))
 157 (assert (raises-error? (bug233a 4) type-error))
 158
 159 ;;; compiler failure
 160 (defun bug145b (x)
 161   (declare (type (double-float -0d0) x))
 162   (declare (optimize speed))
 163   (+ x (sqrt (log (random 1d0)))))
 164
 165 ;;; compiler failures reported by Paul Dietz: inaccurate dealing with
 166 ;;; BLOCK-LAST in CONSTANT-FOLD-CALL and DO-NODES
 167 (defun #:foo (a b c d)
 168   (declare (type (integer -1 1000655) b)
 169            (optimize (speed 3) (safety 1) (debug 1)))
 170   (- (logior
 171       (abs (- (+ b (logandc1 -473949 (max 5165 (abs (logandc1 a 250775)))))))
 172       (logcount (logeqv (max (logxor (abs c) -1) 0) -4)))
 173      d))
 174
 175 (defun #:foo (a d)
 176   (declare (type (integer -8507 26755) a)
 177            (type (integer -393314538 2084485) d)
 178            (optimize (speed 3) (safety 1) (debug 1)))
 179   (gcd
 180    (if (= 0 a) 10 (abs -1))
 181    (logxor -1
 182            (min -7580
 183                 (max (logand a 31365125) d)))))
 184
 185 ;;; compiler failure "NIL is not of type LVAR"
 186 (defun #:foo (x)
 187   (progn (truly-the integer x)
 188          (1+ x)))
 189
 190 (defun #:foo (a b c)
 191   (declare (type (integer -5498929 389890) a)
 192            (type (integer -5029571274946 48793670) b)
 193            (type (integer 9221496 260169518304) c)
 194            (ignorable a b c)
 195            (optimize (speed 3) (safety 1) (debug 1)))
 196   (- (mod 1020122 (min -49 -420))
 197      (logandc1
 198       (block b2 (mod c (min -49 (if t (return-from b2 1582) b))))
 199       (labels ((%f14 ()
 200                  (mod a (max 76 8))))
 201         b))))
 202
 203 ;;; bug 291 reported by Nikodemus Siivola (modified version)
 204 (defstruct line
 205   (%chars ""))
 206 (defun update-window-imag (line)
 207   (tagbody
 208    TOP
 209      (if (null line)
 210          (go DONE)
 211          (go TOP))
 212    DONE
 213      (unless (eq current the-sentinel)
 214        (let* ((cc (car current))
 215               (old-line (dis-line-line cc)))
 216          (if (eq old-line line)
 217              (do ((chars (line-%chars line) nil))
 218                  (())
 219                (let* ()
 220                  (multiple-value-call
 221                      #'(lambda (&optional g2740 g2741 &rest g2742)
 222                          (declare (ignore g2742))
 223                          (catch 'foo
 224                            (values (setq string g2740) (setq underhang g2741))))
 225                    (foo)))
 226                (setf (dis-line-old-chars cc) chars)))))))
 227
 228 ;;; and similar cases found by Paul Dietz
 229 (defun #:foo (a b c)
 230   (declare (optimize (speed 0) (safety 3) (debug 3)))
 231   (FLET ((%F11 ()
 232            (BLOCK B6
 233              (LET ((V2 B))
 234                (IF (LDB-TEST (BYTE 27 14) V2)
 235                    (LET ((V6
 236                           (FLET ((%F7 ()
 237                                    B))
 238                             -1)))
 239                      (RETURN-FROM B6 V2))
 240                    C)))))
 241     A))
 242 (defun #:foo (a b c)
 243   (declare (optimize (speed 0) (safety 3) (debug 3)))
 244   (FLET ((%F15 ()
 245            (BLOCK B8
 246              (LET ((V5 B))
 247                (MIN A (RETURN-FROM B8 C))))))
 248     C))
 249
 250 ;;; bug 292, reported by Paul Dietz
 251 (defun #:foo (C)
 252   (DECLARE (TYPE (INTEGER -5945502333 12668542) C)
 253            (OPTIMIZE (SPEED 3)))
 254   (LET ((V2 (* C 12)))
 255     (- (MAX (IF (/= 109335113 V2) -26479 V2)
 256             (DEPOSIT-FIELD 311
 257                            (BYTE 14 28)
 258                            (MIN (MAX 521326 C) -51))))))
 259
 260 ;;; zombie variables, arising from constraints
 261 (defun #:foo (A B)
 262   (DECLARE (TYPE (INTEGER -40945116 24028306) B)
 263            (OPTIMIZE (SPEED 3)))
 264   (LET ((V5 (MIN 31883 (LOGCOUNT A))))
 265     (IF (/= B V5) (IF (EQL 122911784 V5) -43765 1487) B)))
 266
 267 ;;; let-conversion of a function into deleted one
 268 (defun #:foo (a c)
 269   (declare (type (integer -883 1566) a)
 270            (type (integer -1 0) c)
 271            (optimize (speed 3) (safety 1) (debug 1)))
 272   (flet ((%f8 () c))
 273     (flet ((%f5 ()
 274              (if (< c a)
 275                  (return-from %f5 (if (= -4857 a) (%f8) (%f8)))
 276                  c)))
 277       (if (<= 11 c) (%f5) c))))
 278
 279 ;;; two bugs: "aggressive" deletion of optional entries and problems
 280 ;;; of FIND-RESULT-TYPE in dealing with deleted code; reported by
 281 ;;; Nikodemus Siivola (simplified version)
 282 (defun lisp-error-error-handler (condition)
 283   (invoke-debugger condition)
 284   (handler-bind ()
 285     (unwind-protect
 286          (with-simple-restart
 287              (continue "return to hemlock's debug loop.")
 288            (invoke-debugger condition))
 289       (device))))
 290
 291 ;;;
 292 (defun #:foo ()
 293   (labels ((foo (x)
 294              (return-from foo x)
 295              (block u
 296                (labels ((bar (x &optional (y (return-from u)))
 297                           (list x y (apply #'bar (fee)))))
 298                  (list (bar 1) (bar 1 2))))
 299              (1+ x)))
 300     #'foo))
 301
 302 (defun #:foo (b c)
 303   (declare (type (integer 0 1) b) (optimize (speed 3)))
 304   (flet ((%f2 () (lognor (block b5 138) c)))
 305     (if (not (or (= -67399 b) b))
 306         (deposit-field (%f2) (byte 11 8) -3)
 307         c)))
 308
 309 \f
 310 (sb-ext:quit :unix-status 104)