1.0.39: will be tagged as sbcl_1_0_39
[sbcl.git] / 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 (eq 'number (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))))))))