grovel-headers.c: Put win32 stuff into grovel-headers-win32.h.
[sbcl.git] / tests / compiler.pure-cload.lisp
blobdbc462446ce828e311177fbf2e631b52684a6ff6
1 ;;;; miscellaneous tests of compiling toplevel forms
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
14 (in-package :cl-user)
16 ;;; Exercise a compiler bug (by causing a call to ERROR).
17 ;;;
18 ;;; This bug was in sbcl-0.6.11.6.
19 (let ((a 1) (b 1))
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.
30 ;;;
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
40 (let ((a 1))
41 (declare (special a))
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)))
46 '(1 (:a :b) 1)))
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)))
51 '(1 (:a :b) 1)))
52 (assert (not (boundp 'b))))
54 (let ((a 1) (b 2))
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)))
59 (symbol-value 'a))
60 a b)
61 '(1 2 :a 1 2))))
63 ;;; bug in LOOP, reported by ??? on c.l.l
64 (flet ((foo (l)
65 (loop for x in l
66 when (symbolp x) return x
67 while (numberp x)
68 collect (list 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)))
76 (logxor
77 (if (ldb-test (byte 27 4) d)
79 (max 55546856 -431))
80 (logorc2
81 (if (>= 0 b)
82 (if (> b c) (logandc2 c d) (if (> d 224002) 0 d))
83 (signum (logior c b)))
84 (logior a -1))))
86 (defun #:foo (b c)
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)))
94 (defun #:foo (x y)
95 (declare (type (integer -1 1000000000000000000000000) x y)
96 (optimize speed))
97 (* x (* y x)))
99 (defun #:foo (b)
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)))))
104 (defun #:foo (d)
105 (let ((v7 (flet ((%f16 () (labels ((%f3 () -8)) (%f3))))
106 (labels ((%f7 () (%f16))) d))))
107 132887443))
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))
112 :loop
113 (unless x (return :bad))))
114 (error () :good))
115 :good))
116 (assert (eq (handler-case (eval `(do* ((x '(1 2 3) (cdr x)))
117 ((endp x) (go :loop))
118 :loop
119 (unless x (return :bad))))
120 (error () :good))
121 :good))
123 ;;; bug 282
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.
128 (locally
129 (declare (optimize (safety 3)))
130 (flet ((bar (f a)
131 (declare (type (simple-array (unsigned-byte 32) (*)) a))
132 (declare (type (function (fixnum)) f))
133 (funcall f (aref a 0))))
134 #-64-bit
135 (assert
136 (eval `(let ((n (1+ most-positive-fixnum)))
137 (if (not (typep n '(unsigned-byte 32)))
138 (warn 'style-warning
139 "~@<This test is written for platforms with ~
140 ~@<(proper-subtypep 'fixnum '(unsigned-byte 32))~:@>.~:@>")
141 (block nil
142 (funcall ,#'bar
143 (lambda (x) (when (eql x n) (return t)))
144 (make-array 1 :element-type '(unsigned-byte 32)
145 :initial-element n))
146 nil)))))))
148 ;;; bug 261
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
153 ;;; of closures.
154 (flet ((test-case (test-pred x)
155 (let ((func (lambda () x)))
156 (list (eq func func)
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)))
164 (assert (= s 219)))
166 (with-test (:name :specialized-array-dumping)
167 (macrolet
168 ((make-tests ()
169 `(progn
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)
178 ',(type-of array))
179 (equalp ,array
180 ,make-array)))))))
181 (make-tests)))
183 (lambda () (the string (+ 1 x)))
185 (lambda ()
186 (macrolet ((x (&rest args)
187 (declare (ignore args))
188 'a))
189 (let (a)
190 (declare (type vector a))
191 (x #.#'list))))