1 ;;;; This file is for compiler tests which are not about correctness
2 ;;;; of the compiler, but are "nice to have" features in a robust
3 ;;;; implementation of a compiler, such as detection of various style
4 ;;;; issues, with the nuanced meaning that it is SBCL's notion of poor style,
5 ;;;; such as things that don't emit as efficient code as possible
6 ;;;; because of <blah>.
8 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; While most of SBCL is derived from the CMU CL system, the test
12 ;;;; files (like this one) were written from scratch after the fork
15 ;;;; This software is in the public domain and is provided with
16 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
17 ;;;; more information.
19 (defun f-with-macro (arg) (list arg
))
20 (defun f2-with-macro (a b
) (list a b
))
21 (defun map-f-with-macro (l) (mapcar #'f-with-macro l
))
22 (defun use-f2-with-macro ()
23 (list (f2-with-macro 1 2) (f2-with-macro 3 4)))
26 ;; ignore that we don't know what F is
27 (declare (muffle-conditions style-warning
))
28 (defun just-call-f (x) (declare (notinline f
)) (f x
)))
30 (defun g-with-macro (arg) (list arg
))
31 (defun map-g-with-macro (l)
32 (declare (notinline g-with-macro
))
33 (mapcar #'g-with-macro l
))
35 (declaim (notinline h-with-macro
))
36 (defun h-with-macro (arg) (list arg
))
37 (defun map-h-with-macro (l) (mapcar #'h-with-macro l
))
39 (test-util:with-test
(:name
:compiler-macro-order-bug
)
40 ;; There is one explicit NOTINLINE, but we still get a warning.
42 (define-compiler-macro f-with-macro
(arg) `(list ,arg
))
43 sb-c
:compiler-macro-application-missed-warning
)
44 ;; To exercise both cases of the ~:P directive in the warning message.
46 (define-compiler-macro f2-with-macro
(a b
) `(list ,a
,b
))
47 sb-c
:compiler-macro-application-missed-warning
)
49 ;; There is a local notinline decl, so no warning about a compiler-macro.
51 (define-compiler-macro g-with-macro
(arg) `(list ,arg
)))
52 ;; There is a global notinline proclamation.
54 (define-compiler-macro h-with-macro
(arg) `(list ,arg
))))
58 (defun use-g (x) (g x
))
59 (defun use-h (x) (list (h x
) (h x
)))
60 (with-test (:name
:inline-failure-1
)
61 (assert-signal (declaim (inline g h
))
62 sb-c
:inlining-dependency-failure
2))
64 (declaim (inline fast-guy
))
65 (with-test (:name
:inline-failure-2a
)
66 (assert-signal (compile nil
'(lambda (x) (fast-guy x
)))
67 sb-c
:inlining-dependency-failure
))
70 (with-test (:name
:inline-failure-2b
)
72 (eval '(defun baz (arg) (declare (inline zippy
)) (zippy arg
)))
73 sb-c
:inlining-dependency-failure
))
75 (locally (declare (muffle-conditions style-warning
))
76 (defun foofy1 (x) (and (somestruct-p x
) 'hi
)))
78 (test-util:with-test
(:name
:structure-pred-inline-failure
)
79 (assert-signal (defstruct somestruct a b
)
80 sb-c
:inlining-dependency-failure
))
82 (test-util:with-test
(:name
:redef-macro-same-file
)
83 (let* ((lisp "compiler-impure-tmp.lisp")
84 (fasl (compile-file-pathname lisp
)))
86 (let ((redef-count 0))
87 (with-open-file (f lisp
:direction
:output
)
88 (dolist (form '((defmacro glork
(x) `(car ,x
))
89 (define-compiler-macro glorpy
(x) `(+ ,x
1))
90 (defmacro glork
(x) `(first ,x
))
91 (define-compiler-macro glorpy
(x) `(+ ,x
2))))
93 (multiple-value-bind (fasl warn fail
)
94 (handler-bind ((sb-int:same-file-redefinition-warning
95 (lambda (c) c
(incf redef-count
))))
96 (let ((*error-output
* (make-broadcast-stream)))
97 (compile-file lisp
:print nil
:verbose nil
)))
98 (declare (ignore fasl
))
99 (assert (and warn
(not fail
) (= redef-count
2)))))
100 (ignore-errors (delete-file lisp
))
101 (ignore-errors (delete-file fasl
)))))