0.9.1.16:
[sbcl.git] / tests / compiler.pure-cload.lisp
1 ;;;; miscellaneous tests of compiling toplevel forms
2
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.
13
14 (in-package :cl-user)
15
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"))))
23
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*))
38
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)))
45                        a)
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)))
50                        a)
51                  '(1 (:a :b) 1)))
52   (assert (not (boundp 'b))))
53
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))))
62
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)))
71
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)
78        -1
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))))
85
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)))
93
94 (defun #:foo (x y)
95   (declare (type (integer -1 1000000000000000000000000) x y)
96            (optimize speed))
97   (* x (* y x)))
98
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)))))
103
104 (defun #:foo (d)
105   (let ((v7 (flet ((%f16 () (labels ((%f3 () -8)) (%f3))))
106               (labels ((%f7 () (%f16)))  d))))
107     132887443))
108
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))
122
123 ;;; bug 282
124 ;;;
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     #-x86-64
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)))))))
147
148 ;;; bug 261
149 (let ((x (list (the (values &optional fixnum) (eval '(values))))))
150   (assert (equal x '(nil))))
151
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))))
160
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)))