1 ;;;; miscellaneous tests of compiling toplevel forms
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
16 ;;; Exercise a compiler bug (by causing a call to ERROR).
18 ;;; This bug was in sbcl-0.6.11.6.
20 (declare (type (mod 1000) a b
))
21 (let ((tmp (= 10 (+ (incf a
) (incf a
) (incf b
) (incf b
)))))
22 (or tmp
(error "TMP not true"))))
24 ;;; Exercise a (byte-)compiler bug by causing a call to ERROR, not
25 ;;; because the symbol isn't defined as a variable, but because
26 ;;; TYPE-ERROR in SB-KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
27 ;;; 0 is not of type (OR FUNCTION SB-KERNEL:FDEFN).
28 ;;; Correct behavior is to warn at compile time because the symbol
29 ;;; isn't declared as a variable, but to set its SYMBOL-VALUE anyway.
31 ;;; This bug was in sbcl-0.6.11.13.
32 (print (setq improperly-declared-var
'(1 2)))
33 (assert (equal (symbol-value 'improperly-declared-var
) '(1 2)))
34 (makunbound 'improperly-declared-var
)
35 ;;; This is a slightly different way of getting the same symptoms out
36 ;;; of the sbcl-0.6.11.13 byte compiler bug.
37 (print (setq *print-level
* *print-level
*))
39 ;;; PROGV with different numbers of variables and values
42 (assert (equal (list a
(progv '(a b
) '(:a
:b
:c
)
43 (assert (eq (symbol-value 'nil
) nil
))
44 (list (symbol-value 'a
) (symbol-value 'b
)))
47 (assert (equal (list a
(progv '(a b
) '(:a
:b
)
48 (assert (eq (symbol-value 'nil
) nil
))
49 (list (symbol-value 'a
) (symbol-value 'b
)))
52 (assert (not (boundp 'b
))))
55 (declare (special a b
))
56 (assert (equal (list a b
(progv '(a b
) '(:a
)
57 (assert (eq (symbol-value 'nil
) nil
))
58 (assert (not (boundp 'b
)))
63 ;;; bug in LOOP, reported by ??? on c.l.l
66 when
(symbolp x
) return x
69 (assert (equal (foo '(1 2 #\a 3)) '((1) (2))))
70 (assert (equal (foo '(1 2 x
3)) 'x
)))
72 ;;; compiler failure found by Paul Dietz' randomized tortuter
73 (defun #:foo
(a b c d
)
74 (declare (type (integer 240 100434465) a
)
75 (optimize (speed 3) (safety 1) (debug 1)))
77 (if (ldb-test (byte 27 4) d
)
82 (if (> b c
) (logandc2 c d
) (if (> d
224002) 0 d
))
83 (signum (logior c b
)))
87 (declare (type (integer -
23228343 2) b
)
88 (type (integer -
115581022 512244512) c
)
89 (optimize (speed 3) (safety 1) (debug 1)))
90 (* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b
))
91 (deposit-field b
(byte 25 27) -
30424886))
92 (dpb b
(byte 23 29) c
)))
95 (declare (type (integer -
1 1000000000000000000000000) x y
)
100 (declare (type (integer -
290488443 2) b
)
101 (optimize (speed 3) (safety 1) (debug 1)))
102 (let ((v3 (min -
1720 b
))) (max v3
(logcount (if (= v3 b
) b b
)))))
105 (let ((v7 (flet ((%f16
() (labels ((%f3
() -
8)) (%f3
))))
106 (labels ((%f7
() (%f16
))) d
))))
109 ;;; RESULT-FORM in DO is not contained in the implicit TAGBODY
110 (assert (eq (handler-case (eval `(do ((x '(1 2 3) (cdr x
)))
111 ((endp x
) (go :loop
))
113 (unless x
(return :bad
))))
116 (assert (eq (handler-case (eval `(do* ((x '(1 2 3) (cdr x
)))
117 ((endp x
) (go :loop
))
119 (unless x
(return :bad
))))
125 ;;; Verify type checking policy in full calls: the callee is supposed
126 ;;; to perform check, but the results should not be used before the
127 ;;; check will be actually performed.
129 (declare (optimize (safety 3)))
131 (declare (type (simple-array (unsigned-byte 32) (*)) a
))
132 (declare (type (function (fixnum)) f
))
133 (funcall f
(aref a
0))))
136 (eval `(let ((n (1+ most-positive-fixnum
)))
137 (if (not (typep n
'(unsigned-byte 32)))
139 "~@<This test is written for platforms with ~
140 ~@<(proper-subtypep 'fixnum '(unsigned-byte 32))~:@>.~:@>")
143 (lambda (x) (when (eql x n
) (return t
)))
144 (make-array 1 :element-type
'(unsigned-byte 32)
149 (let ((x (list (the (values &optional fixnum
) (eval '(values))))))
150 (assert (equal x
'(nil))))
152 ;;; Bug 125, reported by Gabe Garza: Python did not preserve identity
154 (flet ((test-case (test-pred x
)
155 (let ((func (lambda () x
)))
157 (funcall test-pred func func
)
158 (delete func
(list func
))))))
159 (assert (equal '(t t nil
) (funcall (eval #'test-case
) #'eq
3))))
161 ;;; compiler failure reported by Alan Shields:
162 ;;; MAYBE-INFER-ITERATION-VAR-TYPE did not deal with types (REAL * (n)).
163 (let ((s (loop for x from
(- pi
) below
(floor (* 2 pi
)) by
(/ pi
75) count t
)))
166 (with-test (:name
:specialized-array-dumping
)
170 ,@(loop for saetp across
171 sb-vm
:*specialized-array-element-type-properties
*
172 for specifier
= (sb-vm:saetp-specifier saetp
)
173 for array
= (make-array (if specifier
10 0)
174 :element-type specifier
)
175 for make-array
= `(make-array ,(if specifier
10 0)
176 :element-type
',specifier
)
177 collect
`(assert (and (equal (type-of ,array
)
183 (lambda () (the string
(+ 1 x
)))
186 (macrolet ((x (&rest args
)
187 (declare (ignore args
))
190 (declare (type vector a
))