Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / tests / compiler.test.sh
1 #!/bin/sh
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 . ./expect.sh
15
16 use_test_subdirectory
17
18 tmpfilename="$TEST_FILESTEM.lisp"
19
20 # This should fail, as type inference should show that the call to FOO
21 # will return something of the wrong type.
22 cat > $tmpfilename <<EOF
23     (in-package :cl-user)
24     (defun foo (x) (list x))
25     (defun bar (x) (1+ (foo x)))
26 EOF
27 expect_failed_compile $tmpfilename
28
29 # This should fail, as type inference should show that the call to FOO
30 # has a wrong number of args.
31 cat > $tmpfilename <<EOF
32     (in-package :cl-user)
33     (defun foo (x) (or x (foo x x)))
34 EOF
35 expect_failed_compile $tmpfilename
36
37 # This should fail, as we define a function multiply in the same file
38 # (CLHS 3.2.2.3).
39 cat > $tmpfilename <<EOF
40     (in-package :cl-user)
41     (defun foo (x) (list x))
42     (defun foo (x) (cons x x))
43 EOF
44 expect_failed_compile $tmpfilename
45
46 # This shouldn't fail, as the inner FLETs should not be treated as
47 # having the same name.
48 cat > $tmpfilename <<EOF
49     (in-package :cl-user)
50     (defun foo (x)
51       (flet ((baz (y) (load y)))
52         (declare (notinline baz))
53         (baz x)))
54     (defun bar (x)
55       (flet ((baz (y) (load y)))
56         (declare (notinline baz))
57         (baz x)))
58 EOF
59 expect_clean_compile $tmpfilename
60
61 # This shouldn't fail because it's not really a multiple definition
62 cat > $tmpfilename <<EOF
63     (in-package :cl-user)
64     (eval-when (:compile-toplevel :load-toplevel :execute)
65       (defun foo (x) x))
66 EOF
67 expect_clean_compile $tmpfilename
68
69 # Likewise
70 cat > $tmpfilename <<EOF
71     (in-package :cl-user)
72     (eval-when (:compile-toplevel)
73       (defun foo (x) x))
74     (defun foo (x) x)
75 EOF
76 expect_clean_compile $tmpfilename
77
78 # This shouldn't fail despite the apparent type mismatch, because of
79 # the NOTINLINE declamation.
80 cat > $tmpfilename <<EOF
81     (in-package :cl-user)
82     (defun foo (x) (list x))
83     (declaim (notinline foo))
84     (defun bar (x) (1+ (foo x)))
85 EOF
86 expect_clean_compile $tmpfilename
87
88 # This shouldn't fail, but did until sbcl-0.8.10.4x
89 cat > $tmpfilename <<EOF
90     (in-package :cl-user)
91     (declaim (inline foo))
92     (defun foo (x)
93       (1+ x))
94     (defun bar (y)
95       (list (foo y) (if (> y 1) (funcall (if (> y 0) #'foo #'identity) y))))
96 EOF
97 expect_clean_compile $tmpfilename
98
99 # This shouldn't fail despite the apparent type mismatch, because of
100 # the NOTINLINE declaration.
101 cat > $tmpfilename <<EOF
102     (in-package :cl-user)
103     (defun foo (x) (list x))
104     (defun bar (x)
105       (declare (notinline foo))
106       (1+ (foo x)))
107 EOF
108 expect_clean_compile $tmpfilename
109
110 # This in an ideal world would fail (that is, return with FAILURE-P
111 # set), but at present it doesn't.
112 cat > $tmpfilename <<EOF
113     (in-package :cl-user)
114     (defun foo (x) (list x))
115     (defun bar (x)
116       (declare (notinline foo))
117       (locally
118         (declare (inline foo))
119         (1+ (foo x))))
120 EOF
121 # expect_failed_compile $tmpfilename
122
123 # This used to not warn, because the VALUES derive-type optimizer was
124 # insufficiently precise.
125 cat > $tmpfilename <<EOF
126     (in-package :cl-user)
127     (defun foo (x) (declare (ignore x)) (values))
128     (defun bar (x) (1+ (foo x)))
129 EOF
130 expect_failed_compile $tmpfilename
131
132 # Even after making the VALUES derive-type optimizer more precise, the
133 # following should still be clean.
134 cat > $tmpfilename <<EOF
135     (in-package :cl-user)
136     (defun foo (x) (declare (ignore x)) (values))
137     (defun bar (x) (car x))
138 EOF
139 expect_clean_compile $tmpfilename
140
141 # NOTINLINE on known functions shouldn't inhibit type inference
142 # (spotted by APD sbcl-devel 2003-06-14)
143 cat > $tmpfilename <<EOF
144     (in-package :cl-user)
145     (defun foo (x)
146       (declare (notinline list))
147       (1+ (list x)))
148 EOF
149 expect_failed_compile $tmpfilename
150
151 # ERROR wants to check its format string for sanity...
152 cat > $tmpfilename <<EOF
153     (in-package :cl-user)
154     (defun foo (x)
155       (when x
156         (error "~S")))
157 EOF
158 expect_failed_compile $tmpfilename
159
160 # ... but it (ERROR) shouldn't complain about being unable to optimize
161 # when it's uncertain about its argument's type
162 cat > $tmpfilename <<EOF
163     (in-package :cl-user)
164     (defun foo (x)
165       (error x))
166 EOF
167 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
168
169 # test case from Rudi for some CLOS WARNINGness that shouldn't have
170 # been there
171 cat > $tmpfilename <<EOF
172     #+sb-eval (eval-when (:compile-toplevel)
173                 (setf sb-ext:*evaluator-mode* :compile))
174
175     (eval-when (:compile-toplevel :load-toplevel :execute)
176       (defstruct buffer-state
177         (output-index 0)))
178
179     (defclass buffered-stream-mixin ()
180       ((buffer-state :initform (make-buffer-state))))
181
182     (defgeneric frob (stream))
183     (defmethod frob ((stream t))
184       nil)
185     (defmethod frob ((stream buffered-stream-mixin))
186       (symbol-macrolet
187             ((index (buffer-state-output-index (slot-value stream 'buffer-state))))
188           (setf index 0))
189       (call-next-method))
190 EOF
191 expect_clean_compile $tmpfilename
192
193 # undeclared unbound variables should cause a full warning, as they
194 # invoke undefined behaviour
195 cat > $tmpfilename <<EOF
196     (defun foo () x)
197 EOF
198 expect_failed_compile $tmpfilename
199
200 cat > $tmpfilename <<EOF
201     (declaim (special *x*))
202     (defun foo () *x*)
203 EOF
204 expect_clean_compile $tmpfilename
205
206 cat > $tmpfilename <<EOF
207     (defun foo () (declare (special x)) x)
208 EOF
209 expect_clean_compile $tmpfilename
210
211 # MUFFLE-CONDITIONS tests
212 cat > $tmpfilename <<EOF
213     (defun foo ()
214       (declare (muffle-conditions style-warning))
215       (bar))
216 EOF
217 expect_clean_compile $tmpfilename
218
219 cat > $tmpfilename <<EOF
220     (defun foo ()
221       (declare (muffle-conditions code-deletion-note))
222       (if t (foo) (foo)))
223 EOF
224 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
225
226 cat > $tmpfilename <<EOF
227     (defun foo (x y)
228       (declare (muffle-conditions compiler-note))
229       (declare (optimize speed))
230       (+ x y))
231 EOF
232 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
233
234 cat > $tmpfilename <<EOF
235     (declaim (muffle-conditions compiler-note))
236     (defun foo (x y)
237       (declare (optimize speed))
238       (+ x y))
239 EOF
240 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
241
242 cat > $tmpfilename <<EOF
243     (declaim (muffle-conditions compiler-note))
244     (defun foo (x y)
245       (declare (unmuffle-conditions compiler-note))
246       (declare (optimize speed))
247       (+ x y))
248 EOF
249 expect_condition_during_compile sb-ext:compiler-note $tmpfilename
250
251 # undefined variable causes a WARNING
252 cat > $tmpfilename <<EOF
253     (declaim (muffle-conditions warning))
254     (declaim (unmuffle-conditions style-warning))
255     (defun foo () x)
256 EOF
257 expect_clean_compile $tmpfilename
258
259 # top level LOCALLY behaves nicely
260 cat > $tmpfilename <<EOF
261     (locally
262       (declare (muffle-conditions warning))
263       (defun foo () x))
264 EOF
265 expect_clean_compile $tmpfilename
266
267 cat > $tmpfilename <<EOF
268     (locally
269       (declare (muffle-conditions warning))
270       (defun foo () x))
271     (defun bar () x)
272 EOF
273 expect_failed_compile $tmpfilename
274
275 # This should fail, and fail nicely -- not eg. loop trying to dump
276 # references to the unbound variable.
277 cat > $tmpfilename <<EOF
278 (defmacro macro-with-unbound-variables (foo)
279   \`(print ,bar))
280
281 (macro-with-unbound-variables 'xxx)
282 EOF
283 expect_failed_compile $tmpfilename
284
285 # This should fail, as the MAKE-LOAD-FORM must be used for
286 # externalizing conditions, and the method for CONDITION must signal
287 # an error.
288 cat > $tmpfilename <<EOF
289 (defvar *oops* #.(make-condition 'condition))
290 EOF
291 expect_failed_compile $tmpfilename
292
293 # This should fail, as the MAKE-LOAD-FORM must be used for objects,
294 # and the method for STANDARD.OBJECT is required to signal an error.
295 cat > $tmpfilename <<EOF
296 (defvar *oops* #.(make-instance 'standard-object))
297 EOF
298 expect_failed_compile $tmpfilename
299
300 # This should be clean
301 cat > $tmpfilename <<EOF
302 (defvar *string* (make-string 10 :element-type 'base-char))
303 EOF
304 expect_clean_compile $tmpfilename
305
306 # This should style-warn (but not warn or otherwise fail) as the call
307 # to FORMAT has too many arguments, which is bad style but not
308 # otherwise fatal.
309 cat > $tmpfilename <<EOF
310 (defun foo (a b)
311   (format nil "abc~~def" a b))
312 EOF
313 expect_warned_compile $tmpfilename
314
315 # Tests that destructive-functions on known-constant data cause
316 # compile-time warnings.
317 cat > $tmpfilename <<EOF
318 (let ((string "foo"))
319   (defun foo ()
320     (setf string "bar")))
321 EOF
322 expect_clean_compile $tmpfilename
323
324 cat > $tmpfilename <<EOF
325 (defun foo ()
326   (let (result)
327     (nreverse result)))
328 EOF
329 expect_clean_compile $tmpfilename
330
331 cat > $tmpfilename <<EOF
332 (defun bar ()
333   (let ((result ""))
334     (nreverse result)))
335 EOF
336 expect_clean_compile $tmpfilename
337
338 cat > $tmpfilename <<EOF
339 (let ((string "foo"))
340   (defun foo ()
341     (replace string "bar")))
342 EOF
343 expect_failed_compile $tmpfilename
344
345 cat > $tmpfilename <<EOF
346 (defun foo ()
347   (setf (char "bar" 0) #\1))
348 EOF
349 expect_failed_compile $tmpfilename
350
351 cat > $tmpfilename <<EOF
352 (let ((foo '(1 2 3)))
353   (defun foo ()
354     (nconc foo foo)))
355 EOF
356 expect_failed_compile $tmpfilename
357
358 cat > $tmpfilename <<EOF
359 x
360 y
361 z
362 EOF
363 expect_failed_compile $tmpfilename
364
365 cat > $tmpfilename <<EOF
366 (declaim (optimize (speed 3) (space 0) (safety 0)))
367
368 (defun foo (bar)
369   (last bar))
370 EOF
371 expect_clean_compile $tmpfilename
372
373 cat > $tmpfilename <<EOF
374 (defstruct foo
375   (bar #p"/tmp/"))
376 EOF
377 expect_clean_compile $tmpfilename
378
379 cat > $tmpfilename <<EOF
380 (eval-when (:compile-toplevel :load-toplevel :execute)
381   (defstruct foox)
382   (defmethod make-load-form ((foo foox) &optional env)
383     (declare (ignore env))
384     '(make-foox)))
385 (defstruct bar
386   (foo #.(make-foox)))
387 EOF
388 expect_clean_compile $tmpfilename
389
390 cat > $tmpfilename <<EOF
391 (defun something (x) x)
392 ...
393 (defun something-more (x) x)
394 EOF
395 expect_aborted_compile $tmpfilename
396
397 cat > $tmpfilename <<EOF
398 (if t (locally))
399 EOF
400 expect_clean_cload $tmpfilename
401
402 cat > $tmpfilename <<EOF
403 (defconstant cl-package (find-package :cl))
404 (defun cl-symbol-p (x)
405   (eq (symbol-package x) cl-package))
406 EOF
407 expect_clean_cload $tmpfilename
408
409 cat > $tmpfilename <<EOF
410 (and (eval-when (:compile-toplevel) (error "oops AND")))
411 (or (eval-when (:compile-toplevel) (error "oops OR")))
412 (cond (t (eval-when (:compile-toplevel) (error "oops COND"))))
413 EOF
414 expect_clean_cload $tmpfilename
415
416 # Test correct fasl-dumping of literals in arglist defaulting.
417 # (LP Bug #310132)
418 cat > $tmpfilename <<EOF
419 (in-package :cl-user)
420
421 ;; These are CLHS examples from the dictionary entry for MAKE-LOAD-FORM.
422 (eval-when (:compile-toplevel :load-toplevel :execute)
423   (defstruct my-struct a b c)
424   (defmethod make-load-form ((s my-struct) &optional environment)
425     (make-load-form-saving-slots s :environment environment))
426   (defclass my-class ()
427     ((x :initarg :x :reader obj-x)
428      (y :initarg :y :reader obj-y)
429      (dist :accessor obj-dist)))
430   (defmethod make-load-form ((self my-class) &optional environment)
431     (make-load-form-saving-slots self
432                                  :slot-names '(x y)
433                                  :environment environment)))
434
435 (defun bar1 (&optional (x #.(make-my-struct)))
436   x)
437
438 (defun bar2 (&optional (x #.(make-instance 'my-class)))
439   x)
440
441 ;; Packages are externalizable.
442 (defun bar3 (&optional (x #.*package*))
443   x)
444
445 (assert (typep (bar1) 'my-struct))
446 (assert (typep (bar2) 'my-class))
447 (assert (eq (bar3) *package*))
448
449 EOF
450 expect_clean_cload $tmpfilename
451
452 cat > $tmpfilename <<EOF
453 (in-package :cl-user)
454 (defmacro foo () (error "ERROR at macroexpansion time."))
455 (defun bar () (foo))
456 EOF
457 expect_condition_during_compile sb-c:compiler-error $tmpfilename
458
459 cat > $tmpfilename <<EOF
460 (eval-when (:compile-toplevel)
461   (error "ERROR within EVAL-WHEN."))
462 EOF
463 expect_condition_during_compile simple-error $tmpfilename
464
465 cat > $tmpfilename <<EOF
466 (defun slot-name-incf (s)
467   (with-slots (no-such-slot) s
468     (incf no-such-slot)))
469 EOF
470 expect_clean_cload $tmpfilename
471
472 cat > $tmpfilename <<EOF
473 (in-package :cl-user)
474
475 (defun foo ()
476   (declare (muffle-conditions warning))
477   (let ((em 0d0))
478     (declare (type double-float em))
479     (dotimes (i 42)
480       (setf em (float (1+ i))))))
481 EOF
482 expect_clean_compile $tmpfilename
483
484 cat > $tmpfilename <<EOF
485 (in-package :cl-user)
486
487 (defun foo ()
488   (declare (muffle-conditions warning))
489   (flet ((foo ()
490            (declare (values fixnum))
491            nil))
492     (foo)))
493 EOF
494 expect_clean_compile $tmpfilename
495
496 cat > $tmpfilename <<EOF
497 (in-package :cl-user)
498
499 (defun foo (x)
500   (declare (muffle-conditions warning)
501            (type (vector (mod 7) 1) x))
502   (setf (aref x 0) 8)
503   x)
504 EOF
505 expect_clean_compile $tmpfilename
506
507 cat > $tmpfilename <<EOF
508 (in-package :cl-user)
509
510 (declaim (notinline foo))
511 (let ((i 0)) (defun foo (x) (incf i x)))
512 (defun bar (x) (foo x))
513 EOF
514 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
515
516 # success
517 exit $EXIT_TEST_WIN