0.7.7.38:
[sbcl.git] / tests / compiler.pure.lisp
1 ;;;; various compiler tests without side effects
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 (cl:in-package :cl-user)
15
16 ;;; Exercise a compiler bug (by crashing the compiler).
17 ;;;
18 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
19 ;;; (2000-09-06 on cmucl-imp).
20 ;;;
21 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
22 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
23 (funcall (compile nil
24                   '(lambda ()
25                      (labels ((fun1 ()
26                                 (fun2))
27                               (fun2 ()
28                                 (when nil
29                                   (tagbody
30                                    tag
31                                    (fun2)
32                                    (go tag)))
33                                 (when nil
34                                   (tagbody
35                                    tag
36                                    (fun1)
37                                    (go tag)))))
38
39                        (fun1)
40                        nil))))
41
42 ;;; Exercise a compiler bug (by crashing the compiler).
43 ;;;
44 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on 
45 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
46 (funcall (compile nil
47                   '(lambda (x)
48                      (or (integerp x)
49                          (block used-by-some-y?
50                            (flet ((frob (stk)
51                                     (dolist (y stk)
52                                       (unless (rejected? y)
53                                         (return-from used-by-some-y? t)))))
54                              (declare (inline frob))
55                              (frob (rstk x))
56                              (frob (mrstk x)))
57                            nil))))
58          13)
59
60 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
61 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
62 ;;; Alexey Dejneka 2002-01-27
63 (assert (= 1 ; (used to give 0 under bug 112)
64            (let ((x 0))
65              (declare (special x))
66              (let ((x 1))
67                (let ((y x))
68                  (declare (special x)) y)))))
69 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
70            (let ((x 0))
71              (declare (special x))
72              (let ((x 1))
73                (let ((y x) (x 5))
74                  (declare (special x)) y)))))
75
76 ;;; another LET-related bug fixed by Alexey Dejneka at the same
77 ;;; time as bug 112
78 (multiple-value-bind (value error)
79     (ignore-errors
80       ;; should complain about duplicate variable names in LET binding
81       (compile nil
82                '(lambda ()
83                   (let (x
84                         (x 1))
85                     (list x)))))
86   (assert (null value))
87   (assert (typep error 'error)))
88
89 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
90 ;;; Lichteblau 2002-05-21)
91 (progn
92   (multiple-value-bind (fun warnings-p failure-p)
93       (compile nil
94                ;; Compiling this code should cause a STYLE-WARNING
95                ;; about *X* looking like a special variable but not
96                ;; being one.
97                '(lambda (n)
98                   (let ((*x* n))
99                     (funcall (symbol-function 'x-getter))
100                     (print *x*))))
101     (assert (functionp fun))
102     (assert warnings-p)
103     (assert (not failure-p)))
104   (multiple-value-bind (fun warnings-p failure-p)
105       (compile nil
106                ;; Compiling this code should not cause a warning
107                ;; (because the DECLARE turns *X* into a special
108                ;; variable as its name suggests it should be).
109                '(lambda (n)
110                   (let ((*x* n))
111                     (declare (special *x*))
112                     (funcall (symbol-function 'x-getter))
113                     (print *x*))))
114     (assert (functionp fun))
115     (assert (not warnings-p))
116     (assert (not failure-p))))
117
118 ;;; a bug in 0.7.4.11
119 (dolist (i '(a b 1 2 "x" "y"))
120   ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
121   ;; TYPEP here but got confused and died, doing
122   ;;   (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
123   ;;          *BACKEND-TYPE-PREDICATES*
124   ;;          :TEST #'TYPE=)
125   ;; and blowing up because TYPE= tried to call PLUSP on the
126   ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
127   (when (typep i '(and integer (satisfies oddp)))
128     (print i)))
129 (dotimes (i 14)
130   (when (typep i '(and integer (satisfies oddp)))
131     (print i)))
132
133 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
134 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
135 ;;; interactively-compiled functions was broken by sleaziness and
136 ;;; confusion in the assault on 0.7.0, so this expression used to
137 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
138 (eval '(function-lambda-expression #'(lambda (x) x)))
139
140 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
141 ;;; variable is not optional.
142 (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12))))))
143
144 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
145 ;;; a while; fixed by CSR 2002-07-18
146 (multiple-value-bind (value error)
147     (ignore-errors (some-undefined-function))
148   (assert (null value))
149   (assert (eq (cell-error-name error) 'some-undefined-function)))
150
151 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
152 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
153 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
154 (assert (ignore-errors (eval '(lambda (foo) 12))))
155 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
156 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
157 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
158 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
159 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
160 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
161 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
162 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
163 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
164 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
165
166 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
167 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
168 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
169 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
170            17))
171
172 ;;; bug 181: bad type specifier dropped compiler into debugger
173 (assert (list (compile nil '(lambda (x)
174                              (declare (type (0) x))
175                              x))))
176
177 (let ((f (compile nil '(lambda (x)
178                         (make-array 1 :element-type '(0))))))
179   (assert (null (ignore-errors (funcall f)))))
180
181 ;;; the following functions must not be flushable
182 (dolist (form '((make-sequence 'fixnum 10)
183                 (concatenate 'fixnum nil)
184                 (map 'fixnum #'identity nil)
185                 (merge 'fixnum nil nil #'<)))
186   (assert (not (eval `(locally (declare (optimize (safety 0)))
187                         (ignore-errors (progn ,form t)))))))
188
189 (dolist (form '(#+nil(values-list '(1 . 2)) ; This case still fails
190                 (fboundp '(set bet))
191                 (atan #c(1 1) (car (list #c(2 2))))
192                 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
193                 (nthcdr (car (list 5)) '(1 2 . 3))))
194   (assert (not (eval `(locally (declare (optimize (safety 3)))
195                         (ignore-errors (progn ,form t)))))))