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 ;;; bug 291 reported by Nikodemus Siivola (modified version)
 191 (defstruct line
 192   (%chars ""))
 193 (defun update-window-imag (line)
 194   (tagbody
 195    TOP
 196      (if (null line)
 197          (go DONE)
 198          (go TOP))
 199    DONE
 200      (unless (eq current the-sentinel)
 201        (let* ((cc (car current))
 202               (old-line (dis-line-line cc)))
 203          (if (eq old-line line)
 204              (do ((chars (line-%chars line) nil))
 205                  (())
 206                (let* ()
 207                  (multiple-value-call
 208                      #'(lambda (&optional g2740 g2741 &rest g2742)
 209                          (declare (ignore g2742))
 210                          (catch 'foo
 211                            (values (setq string g2740) (setq underhang g2741))))
 212                    (foo)))
 213                (setf (dis-line-old-chars cc) chars)))))))
 214
 215 ;;; and similar cases found by Paul Dietz
 216 (defun #:foo (a b c)
 217   (declare (optimize (speed 0) (safety 3) (debug 3)))
 218   (FLET ((%F11 ()
 219            (BLOCK B6
 220              (LET ((V2 B))
 221                (IF (LDB-TEST (BYTE 27 14) V2)
 222                    (LET ((V6
 223                           (FLET ((%F7 ()
 224                                    B))
 225                             -1)))
 226                      (RETURN-FROM B6 V2))
 227                    C)))))
 228     A))
 229 (defun #:foo (a b c)
 230   (declare (optimize (speed 0) (safety 3) (debug 3)))
 231   (FLET ((%F15 ()
 232            (BLOCK B8
 233              (LET ((V5 B))
 234                (MIN A (RETURN-FROM B8 C))))))
 235     C))
 236
 237 \f
 238 (sb-ext:quit :unix-status 104)