1 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
2 (load "assertoid.lisp")
3 (use-package "ASSERTOID"))
5 ;;; bug 254: compiler falure
6 (defpackage :bug254
(:use
:cl
))
8 (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1)))
10 (uhw2 nil
:type
(or package null
)))
11 (macrolet ((defprojection (variant &key lexpr eexpr
)
13 `(defmethod uu ((foo foo
))
14 (let ((uhw2 (foo.uhw2 bar
)))
17 (baz (funcall ,lexpr south east
1)))))))))
19 :lexpr
(lambda (south east sched
)
20 (flet ((bd (x) (bref x sched
)))
21 (let ((avecname (gafp)))
22 (declare (type (vector t
) avecname
))
25 (setf (avec.count avecname
) (length rest
))
26 (setf (aref avecname
0) (bd (h south
)))
27 (setf (aref avecname
1) (bd (h east
)))
30 :eexpr
(lambda (south east
))))
32 (delete-package :bug254
)
35 (defpackage :bug255
(:use
:cl
))
37 (declaim (optimize (safety 3) (debug 2) (speed 2) (space 1)))
42 (defstruct yam
(v nil
:type
(or v null
)))
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
))
53 (flet ((project (x) (frob x
0)))
56 (progn (%pu avecname
))
59 (delete-package :bug255
)
62 (defpackage :bug148
(:use
:cl
))
67 (defstruct foo bar bletch
)
69 (labels ((kidify1 (kid)
77 (declare (inline kid-frob
))
80 (the simple-vector
(foo-bar perd
)))))
82 (declaim (optimize (safety 3) (speed 2) (space 1)))
85 (defun u-b-sra (x r ad0
&optional ad1
&rest ad-list
)
89 (vector-push-extend c0
*bar
*))))
92 (map nil
#'ad.frob
(the (vector t
) *bar
*))
95 (declare (inline c.frob ad.frob
)) ; 'til DYNAMIC-EXTENT
99 (declare (special *foo
* *bar
*))
100 (declare (optimize (safety 3) (speed 2) (space 1)))
104 (mapc #'ad.frob
*bar
*)
107 (declare (inline c.frob ad.frob
))
110 (defun bug148-4 (ad0)
111 (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
116 collect
(c.frob b
))))
117 (declare (inline c.frob ad.frob
))
119 (funcall (if (listp ad0
) #'ad.frob
#'print
) ad0
)
120 (funcall (if (listp ad0
) #'ad.frob
#'print
) (reverse ad0
)))))
122 (assert (equal (eval '(bug148-4 '(1 2 3)))
123 '((1 2 3) (7 14 21) (21 14 7))))
125 (in-package :cl-user
)
126 (delete-package :bug148
)
129 (defpackage :bug258
(:use
:cl
))
133 (declare (special *foo
* *bar
*))
134 (declare (optimize (safety 3) (speed 2) (space 1) (debug 1)))
138 (mapcar #'c.frob ad
)))
139 (declare (inline c.frob ad.frob
))
141 (funcall (if (listp ad0
) #'ad.frob
#'print
) ad0
)
142 (funcall (if (listp ad0
) #'ad.frob
#'print
) (reverse ad0
)))))
144 (assert (equal (u-b-sra '(4 9 7))
145 '((4 9 7) (3 8 6) (6 8 3))))
147 (in-package :cl-user
)
148 (delete-package :bug258
)
152 (declare (optimize (speed 2) (safety 3)))
158 (funcall (eval ''list
) y
(+ y
2d0
) (* y
3d0
)))))
159 (assert (raises-error?
(bug233a 4) type-error
))
163 (declare (type (double-float -
0d0
) x
))
164 (declare (optimize speed
))
165 (+ x
(sqrt (log (random 1d0
)))))
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)))
173 (abs (- (+ b
(logandc1 -
473949 (max 5165 (abs (logandc1 a
250775)))))))
174 (logcount (logeqv (max (logxor (abs c
) -
1) 0) -
4)))
178 (declare (type (integer -
8507 26755) a
)
179 (type (integer -
393314538 2084485) d
)
180 (optimize (speed 3) (safety 1) (debug 1)))
182 (if (= 0 a
) 10 (abs -
1))
185 (max (logand a
31365125) d
)))))
187 ;;; compiler failure "NIL is not of type LVAR"
189 (progn (truly-the integer x
)
193 (declare (type (integer -
5498929 389890) a
)
194 (type (integer -
5029571274946 48793670) b
)
195 (type (integer 9221496 260169518304) c
)
197 (optimize (speed 3) (safety 1) (debug 1)))
198 (- (mod 1020122 (min -
49 -
420))
200 (block b2
(mod c
(min -
49 (if t
(return-from b2
1582) b
))))
205 ;;; bug 291 reported by Nikodemus Siivola (modified version)
208 (defun update-window-imag (line)
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
))
223 #'(lambda (&optional g2740 g2741
&rest g2742
)
224 (declare (ignore g2742
))
226 (values (setq string g2740
) (setq underhang g2741
))))
228 (setf (dis-line-old-chars cc
) chars
)))))))
230 ;;; and similar cases found by Paul Dietz
232 (declare (optimize (speed 0) (safety 3) (debug 3)))
236 (IF (LDB-TEST (BYTE 27 14) V2
)
245 (declare (optimize (speed 0) (safety 3) (debug 3)))
249 (MIN A
(RETURN-FROM B8 C
))))))
252 ;;; bug 292, reported by Paul Dietz
254 (DECLARE (TYPE (INTEGER -
5945502333 12668542) C
)
255 (OPTIMIZE (SPEED 3)))
257 (- (MAX (IF (/= 109335113 V2
) -
26479 V2
)
260 (MIN (MAX 521326 C
) -
51))))))
262 ;;; zombie variables, arising from constraints
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
)))
269 ;;; let-conversion of a function into deleted one
271 (declare (type (integer -
883 1566) a
)
272 (type (integer -
1 0) c
)
273 (optimize (speed 3) (safety 1) (debug 1)))
277 (return-from %f5
(if (= -
4857 a
) (%f8
) (%f8
)))
279 (if (<= 11 c
) (%f5
) c
))))
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
)
289 (continue "return to hemlock's debug loop.")
290 (invoke-debugger condition
))
298 (labels ((bar (x &optional
(y (return-from u
)))
299 (list x y
(apply #'bar
(fee)))))
300 (list (bar 1) (bar 1 2))))
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)
311 ;;; bug 214: compiler failure
313 (declare (optimize (sb-ext:inhibit-warnings
0) (compilation-speed 2)))
314 (flet ((foo (&key
(x :vx x-p
)) (list x x-p
)))
318 (declare (optimize (sb-ext:inhibit-warnings
0) (compilation-speed 2)))
319 (lambda (x) (declare (fixnum x
)) (if (< x
0) 0 (1- x
))))
321 ;;; this one was reported by rydis on #lisp
324 (declare (optimize (speed 2) (space 3)))
328 ;;; bug reported by Brian Downing: incorrect detection of MV-LET
329 (DEFUN #:failure-testcase
(SESSION)
330 (LABELS ((CONTINUATION-1 ()
332 (IF (foobar-1 SESSION
)
334 (LET ((CONTINUATION-3
336 (MULTIPLE-VALUE-CALL #'CONTINUATION-2
338 (foobar-2 CONTINUATION-3
))))
339 (CONTINUATION-2 (&REST OTHER-1
)
340 (DECLARE (IGNORE OTHER-1
))))
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))
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
)
358 (values a b c d e f g h
))))
360 (let ((list (multiple-value-list (values-consumer #'values-producer
))))
361 (assert (= (length list
) 8))
362 (assert (null (nth 7 list
))))
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
375 0 1 2 3 4 5 6 7 8 9))
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
383 (defun srctran-lisp1-2 (caar) (funcall (sb-ext:truly-the function caar
) 1))
384 (assert (eql (funcall (eval #'srctran-lisp1-2
) #'identity
) 1))
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
))
395 ;;; broken inference of an upper bound of an iteration variable,
396 ;;; reported by Rajat Datta.
398 (let ((vec (make-array num
:initial-element
0))
402 (when (= (svref vec i
) 0)
403 (do ((j (* i i
) (+ j i
)))
405 (setf (svref vec j
) 1))
409 (assert (= (isieve 46349) 4792))
411 ;;; COERCE should not be constant-folded (reported by Nikodemus
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
)))))
419 (let ((x (coerce '(1 11) 'vector
)))
421 (assert (equalp x
#(2 11))))
423 ;;; and BIT-* too (reported by Paul F. Dietz)
424 (loop with v1
= #*0011
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
430 for form
= `(lambda ()
431 (let ((v (,f
,v1
,v2
)))
432 (setf (aref v
0) (- 1 (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
)))
439 (let ((v (bit-not ,v
)))
440 (setf (aref v
0) (- 1 (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
)))
446 (sb-ext:quit
:unix-status
104)