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