SB-EXT:MUFFLE-CONDITIONS. Go wild.
... rejig the implementation a bit more from the latest CSR
sbcl-devel patch: new SB-C::*HANDLED-CONDITIONS*
variable analogous to SB-C::*POLICY* (and treated with
the same kinds of hack, too, with rebindings and other
fakery to get the right semantics);
... more test cases;
... documentation;
... since we're in the general area, make
SB-CLTL2:DECLARATION-INFORMATION work on it...
... and write test cases for this and OPTIMIZE.
to Bruno Haible)
changes in sbcl-0.8.11 relative to sbcl-0.8.10:
+ * new feature: the SB-EXT:MUFFLE-CONDITIONS declaration should be
+ used to control emission of compiler diagnostics, rather than the
+ SB-EXT:INHIBIT-WARNINGS OPTIMIZE quality. See the manual for
+ documentation on this feature. The SB-EXT:INHIBIT-WARNINGS
+ quality should be considered deprecated.
* fixed bug 320: Shared to local slot value transfers in class
redefinitions now happen corrently from superclasses as
well. (reported by Bruno Haible)
(declaim (ftype (sfunction (symbol &optional (or null lexenv)) t)
declaration-information))
(defun declaration-information (declaration-name &optional env)
- (let ((policy (sb-c::lexenv-policy (or env (make-null-lexenv)))))
+ (let ((env (or env (make-null-lexenv))))
(case declaration-name
- (optimize (collect ((res))
- (dolist (name sb-c::*policy-qualities*)
- (res (list name (cdr (assoc name policy)))))
- (loop for (name . nil) in sb-c::*policy-dependent-qualities*
- do (res (list name (sb-c::policy-quality policy name))))
- (res)))
+ (optimize
+ (let ((policy (sb-c::lexenv-policy env)))
+ (collect ((res))
+ (dolist (name sb-c::*policy-qualities*)
+ (res (list name (cdr (assoc name policy)))))
+ (loop for (name . nil) in sb-c::*policy-dependent-qualities*
+ do (res (list name (sb-c::policy-quality policy name))))
+ (res))))
+ (sb-ext:muffle-conditions
+ (car (rassoc 'muffle-warning
+ (sb-c::lexenv-handled-conditions env))))
(t (error "Unsupported declaration ~S." declaration-name)))))
(defun parse-macro (name lambda-list body &optional env)
(deftest macroexpand-all.4
(macroexpand-all '(symbol-macrolet ((srlt '(nil zool))) (testr)))
(symbol-macrolet ((srlt '(nil zool))) 'zool))
+
+(defmacro dinfo (thing &environment env)
+ `',(declaration-information thing env))
+
+(macrolet ((def (x)
+ `(macrolet ((frob (suffix answer &optional declaration)
+ `(deftest ,(intern (concatenate 'string
+ "DECLARATION-INFORMATION."
+ (symbol-name ',x)
+ suffix))
+ (locally (declare ,@(when declaration
+ (list declaration)))
+ (cadr (assoc ',',x (dinfo optimize))))
+ ,answer)))
+ (frob ".DEFAULT" 1)
+ (frob ".0" 0 (optimize (,x 0)))
+ (frob ".1" 1 (optimize (,x 1)))
+ (frob ".2" 2 (optimize (,x 2)))
+ (frob ".3" 3 (optimize (,x 3)))
+ (frob ".IMPLICIT" 3 (optimize ,x)))))
+ (def speed)
+ (def safety)
+ (def debug)
+ (def compilation-speed)
+ (def space))
+
+(deftest declaration-information.muffle-conditions.default
+ (dinfo sb-ext:muffle-conditions)
+ nil)
+(deftest declaration-information.muffle-conditions.1
+ (locally (declare (sb-ext:muffle-conditions warning))
+ (dinfo sb-ext:muffle-conditions))
+ warning)
+(deftest declaration-information.muffle-conditions.2
+ (locally (declare (sb-ext:muffle-conditions warning))
+ (locally (declare (sb-ext:unmuffle-conditions style-warning))
+ (let ((dinfo (dinfo sb-ext:muffle-conditions)))
+ (not
+ (not
+ (and (subtypep dinfo '(and warning (not style-warning)))
+ (subtypep '(and warning (not style-warning)) dinfo)))))))
+ t)
@printindex vr
+@node Type Index
+@comment node-name, next, previous, up
+@appendix Type Index
+
+@printindex tp
+
@node Colophon
@comment node-name, next, previous, up
@unnumbered Colophon
following way:
@include fun-common-lisp-require.texinfo
-
@include var-sb-ext-star-module-provider-functions-star.texinfo
-
@node Tools To Help Developers
@comment node-name, next, previous, up
@subsection Tools To Help Developers
Documentation for @code{inspect} is accessed by typing @kbd{help} at
the @code{inspect} prompt.
-
@node Interface To Low-Level SBCL Implementation
@comment node-name, next, previous, up
@subsection Interface To Low-Level SBCL Implementation
@subsection Error Severity
@cindex Severity of compiler errors
@cindex compiler error severity
+@tindex error
+@tindex warning
+@tindex style-warning
+@tindex compiler-note
+@tindex code-deletion-note
There are four levels of compiler error severity: @emph{error},
@emph{warning}, @emph{style warning}, and @emph{note}. The first three
@code{compile} and @code{compile-file} functions. These levels of
compiler error severity occur when the compiler handles conditions of
these classes. The fourth level of compiler error severity,
-@emph{note}, is used for problems which are too mild for the standard
-condition classes, typically hints about how efficiency might be
-improved.
-@comment mention sb-ext:compiler-note
+@emph{note}, corresponds to the @code{sb-ext:compiler-note}, and is
+used for problems which are too mild for the standard condition
+classes, typically hints about how efficiency might be improved. The
+@code{sb-ext:code-deletion-note}, a subtype of @code{compiler-note},
+is signalled when the compiler deletes user-supplied code, usually
+after proving that the code in question is unreachable.
+
+@include condition-sb-ext-compiler-note.texinfo
+@include condition-sb-ext-code-deletion-note.texinfo
@node Errors During Macroexpansion
@comment node-name, next, previous, up
system.
Compiler policy is controlled by the @code{optimize} declaration. The
-compiler supports the ANSI optimization qualities, and also an
-extension @code{sb-ext:inhibit-warnings}.
+compiler supports the ANSI optimization qualities, and also a
+deprecated extension @code{sb-ext:inhibit-warnings}.
Ordinarily, when the @code{speed} quality is high, the compiler emits
notes to notify the programmer about its inability to apply various
arithmetic, which is not helpful for code which by design supports
arbitrary-sized integers instead of being limited to fixnums.)
-@quotation
-Note: The basic functionality of the @code{optimize
-inhibit-warnings} extension will probably be supported in all future
-versions of the system, but it will probably be renamed when the
-compiler and its interface are cleaned up. The current name is
-misleading, because it mostly inhibits optimization notes, not
-warnings. And making it an optimization quality is misleading, because
-it shouldn't affect the resulting code at all. It may become a
-declaration identifier with a name like
-@code{sb-ext:inhibit-notes}, so that what's currently written.
-
+The recommended way to inhibit compiler diagnostics (of any severity
+other than @code{error}: @pxref{Error Severity}) is to use the
+@code{sb-ext:muffle-conditions} declaration, specifying the type of
+condition that is to be muffled (using an associated
+@code{muffle-warning} restart). Thus, what was previously written
@lisp
(declaim (optimize (sb-ext:inhibit-warnings 2)))
@end lisp
-
-would become something like
-
+becomes something like
@lisp
-(declaim (sb-ext:inhibit-notes 2))
+(declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
+@end lisp
+to muffle all compiler notes. Compiler diagnostics can be muffled in
+the lexical scope of a declaration, and also lexically unmuffled by
+the use of the sb-ext:unmuffle-conditions, for instance
+@lisp
+(defun foo (x)
+ (declare (optimize speed) (fixnum x))
+ (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+ (values (* x 5) ; no compiler note from this
+ (locally
+ (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
+ ;; this one gives a compiler note
+ (* x -5))))
@end lisp
-
-@end quotation
In early versions of SBCL, a @code{speed} value of zero was used to
enable byte compilation, but since version 0.7.0, SBCL only supports
* Concept Index::
* Function Index::
* Variable Index::
+* Type Index::
* Colophon::
@end menu
;; verbosity
"CODE-DELETION-NOTE" "COMPILER-NOTE"
+ ;; and a mechanism for controlling same at compile time
+ "MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS"
+
;; FIXME: This name doesn't match the DEFFOO - vs. -
;; DEFINE-FOO convention used in the ANSI spec, and so
;; was deprecated in sbcl-0.pre7, ca. 2001-12-12. After
(defvar *current-path*)
(defvar *current-component*)
(defvar *delayed-ir1-transforms*)
+(defvar *handled-conditions*)
(defvar *policy*)
(defvar *dynamic-counts-tn*)
(defvar *elsewhere*)
;; the file position at which the top level form starts, if applicable
(file-position nil :type (or index null))
;; the original source part of the source path
- (original-source-path nil :type list))
+ (original-source-path nil :type list)
+ ;; the lexenv active at the time
+ (lexenv nil :type (or null lexenv)))
;;; If true, this is the node which is used as context in compiler warning
;;; messages.
(declare (ignore ignore))
pos)
:original-source-path
- (source-path-original-source path))))))))))
+ (source-path-original-source path)
+ :lexenv (if context
+ (node-lexenv context)
+ (if (boundp '*lexenv*) *lexenv* nil)))))))))))
\f
;;;; printing error messages
;; Check for boundness so we don't blow up if we're called
;; when IR1 conversion isn't going on.
(boundp '*lexenv*)
- ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
- ;; isn't a good idea; we should have INHIBIT-WARNINGS
- ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
- ;; sure what the BOUNDP '*LEXENV* test above is for; it's
- ;; likely a good idea, but it probably deserves an
- ;; explanatory comment.
- (policy *lexenv* (= inhibit-warnings 3)))
+ (or
+ ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
+ ;; isn't a good idea; we should have INHIBIT-WARNINGS
+ ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
+ ;; sure what the BOUNDP '*LEXENV* test above is for; it's
+ ;; likely a good idea, but it probably deserves an
+ ;; explanatory comment.
+ (policy *lexenv* (= inhibit-warnings 3))
+ ;; KLUDGE: weird decoupling between here and where we're
+ ;; going to signal the condition. I don't think we can
+ ;; rewrite this using SIGNAL and RESTART-CASE (to take
+ ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
+ ;; handler, because if that doesn't handle it the ordinary
+ ;; compiler handlers will trigger.
+ (typep
+ (ecase kind
+ (:variable (make-condition 'warning))
+ ((:function :type) (make-condition 'style-warning)))
+ (car
+ (rassoc 'muffle-warning
+ (lexenv-handled-conditions *lexenv*))))))
(let* ((found (dolist (warning *undefined-warnings* nil)
(when (and (equal (undefined-warning-name warning) name)
(eq (undefined-warning-kind warning) kind))
(make-lexenv
:default res
:policy (process-optimize-decl spec (lexenv-policy res))))
+ (muffle-conditions
+ (make-lexenv
+ :default res
+ :handled-conditions (process-muffle-conditions-decl
+ spec (lexenv-handled-conditions res))))
+ (unmuffle-conditions
+ (make-lexenv
+ :default res
+ :handled-conditions (process-unmuffle-conditions-decl
+ spec (lexenv-handled-conditions res))))
(type
(process-type-decl (cdr spec) res vars))
(values
type-restrictions
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
+ (handled-conditions (lexenv-handled-conditions default))
(policy (lexenv-policy default)))
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
- lambda cleanup policy)))
+ lambda cleanup handled-conditions policy)))
;;; Makes a LEXENV, suitable for using in a MACROLET introduced
;;; macroexpander
(lexenv-type-restrictions lexenv) ; XXX
nil
nil
+ (lexenv-handled-conditions lexenv)
(lexenv-policy lexenv))))
\f
;;;; flow/DFO/component hackery
(in-package "SB!C")
-#!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place
-
;;; The LEXENV represents the lexical environment used for IR1 conversion.
;;; (This is also what shows up as an ENVIRONMENT value in macroexpansion.)
#!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place
(:constructor internal-make-lexenv
(funs vars blocks tags
type-restrictions
- lambda cleanup policy)))
+ lambda cleanup handled-conditions
+ policy)))
;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a
;; local function), a DEFINED-FUN, representing an
;; INLINE/NOTINLINE declaration, or a list (MACRO . <function>) (a
;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard
;; to get CLAMBDA defined in time for the cross-compiler.
(lambda nil)
- ;; the lexically enclosing cleanup, or NIL if none enclosing within Lambda
+ ;; the lexically enclosing cleanup, or NIL if none enclosing within LAMBDA
(cleanup nil)
+ ;; condition types we handle with a handler around the compiler
+ (handled-conditions *handled-conditions*)
;; the current OPTIMIZE policy
(policy *policy* :type policy))
;;; *TOPLEVEL-LAMBDAS* instead.
(defun convert-and-maybe-compile (form path)
(declare (list path))
- (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (let* ((*lexenv* (make-lexenv :policy *policy*
+ :handled-conditions *handled-conditions*))
(tll (ir1-toplevel form path nil)))
(cond ((eq *block-compile* t) (push tll *toplevel-lambdas*))
(t (compile-toplevel (list tll) nil)))))
;; FIXME: Ideally, something should be done so that DECLAIM
;; inside LOCALLY works OK. Failing that, at least we could
;; issue a warning instead of silently screwing up.
- (*policy* (lexenv-policy *lexenv*)))
+ (*policy* (lexenv-policy *lexenv*))
+ ;; This is probably also a hack
+ (*handled-conditions* (lexenv-handled-conditions *lexenv*)))
(process-toplevel-progn forms path compile-time-too))))
;;; Parse an EVAL-WHEN situations list, returning three flags,
'(original-source-start 0 0)))
(when name
(legal-fun-name-or-type-error name))
- (let* ((*lexenv* (make-lexenv :policy *policy*))
+ (let* ((*lexenv* (make-lexenv :policy *policy*
+ :handled-conditions *handled-conditions*))
(fun (make-functional-from-toplevel-lambda lambda-expression
:name name
:path path)))
(setq *block-compile* nil)
(setq *entry-points* nil)))
+(defun handle-condition-p (condition)
+ (let ((lexenv
+ (etypecase *compiler-error-context*
+ (node
+ (node-lexenv *compiler-error-context*))
+ (compiler-error-context
+ (let ((lexenv (compiler-error-context-lexenv
+ *compiler-error-context*)))
+ (aver lexenv)
+ lexenv))
+ (null *lexenv*))))
+ (let ((muffles (lexenv-handled-conditions lexenv)))
+ (if (null muffles) ; common case
+ nil
+ (dolist (muffle muffles nil)
+ (destructuring-bind (typespec . restart-name) muffle
+ (when (and (typep condition typespec)
+ (find-restart restart-name condition))
+ (return t))))))))
+
+(defun handle-condition-handler (condition)
+ (let ((lexenv
+ (etypecase *compiler-error-context*
+ (node
+ (node-lexenv *compiler-error-context*))
+ (compiler-error-context
+ (let ((lexenv (compiler-error-context-lexenv
+ *compiler-error-context*)))
+ (aver lexenv)
+ lexenv))
+ (null *lexenv*))))
+ (let ((muffles (lexenv-handled-conditions lexenv)))
+ (aver muffles)
+ (dolist (muffle muffles (bug "fell through"))
+ (destructuring-bind (typespec . restart-name) muffle
+ (when (typep condition typespec)
+ (awhen (find-restart restart-name condition)
+ (invoke-restart it))))))))
+
;;; Read all forms from INFO and compile them, with output to OBJECT.
;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
(defun sub-compile-file (info)
(sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE
(*policy* *policy*)
+ (*handled-conditions* *handled-conditions*)
(*lexenv* (make-null-lexenv))
(*block-compile* *block-compile-arg*)
(*source-info* info)
(*info-environment* *info-environment*)
(*gensym-counter* 0))
(handler-case
- (with-compilation-values
- (sb!xc:with-compilation-unit ()
- (clear-stuff)
-
- (sub-sub-compile-file info)
-
- (finish-block-compilation)
- (let ((object *compile-object*))
- (etypecase object
- (fasl-output (fasl-dump-source-info info object))
- (core-object (fix-core-source-info info object))
- (null)))
- nil))
+ (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
+ (with-compilation-values
+ (sb!xc:with-compilation-unit ()
+ (clear-stuff)
+
+ (sub-sub-compile-file info)
+
+ (finish-block-compilation)
+ (let ((object *compile-object*))
+ (etypecase object
+ (fasl-output (fasl-dump-source-info info object))
+ (core-object (fix-core-source-info info object))
+ (null)))
+ nil)))
;; Some errors are sufficiently bewildering that we just fail
;; immediately, without trying to recover and compile more of
;; the input file.
;;; alists instead.
(def!type policy () 'list)
-;;; FIXME: the original implementation of this was protected by
-;;;
-;;; (eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute)
-;;;
-;;; but I don't know why. This seems to work, but I don't understand
-;;; why the original wasn't this in the first place. -- CSR,
-;;; 2003-05-04
(defstruct policy-dependent-quality
name
expression
;;; names of recognized optimization policy qualities
(defvar *policy-qualities*) ; (initialized at cold init)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *policy-dependent-qualities* nil)) ; alist of POLICY-DEPENDENT-QUALITYs
+(defvar *policy-dependent-qualities* nil) ; alist of POLICY-DEPENDENT-QUALITYs
;;; Is X the name of an optimization policy quality?
(defun policy-quality-name-p (x)
inhibit-warnings))
(setf *policy*
(mapcar (lambda (name)
- ;; CMU CL didn't use 1 as the default for everything,
- ;; but since ANSI says 1 is the ordinary value, we do.
+ ;; CMU CL didn't use 1 as the default for
+ ;; everything, but since ANSI says 1 is the ordinary
+ ;; value, we do.
(cons name 1))
- *policy-qualities*)))
+ *policy-qualities*))
+ ;; not actually POLICY, but very similar
+ (setf *handled-conditions* nil))
+
;;; On the cross-compilation host, we initialize immediately (not
;;; waiting for "cold init", since cold init doesn't exist on
;;; cross-compilation host).
;;; called by compiler code for known-valid QUALITY-NAMEs, e.g. SPEED;
;;; it's an error if it's called for a quality which isn't defined.
(defun policy-quality (policy quality-name)
+ (aver (policy-quality-name-p quality-name))
(let* ((acons (assoc quality-name policy))
(result (or (cdr acons) 1)))
result))
(compiler-warn "ignoring bad optimization value ~S in ~S"
raw-value spec))
(t
+ ;; we can't do this yet, because CLOS macros expand
+ ;; into code containing INHIBIT-WARNINGS.
+ #+nil
+ (when (eql quality 'sb!ext:inhibit-warnings)
+ (compiler-style-warn "~S is deprecated: use ~S instead"
+ quality 'sb!ext:muffle-conditions))
(push (cons quality raw-value)
result)))))
;; Add any nonredundant entries from old POLICY.
;; Voila.
result))
+(declaim (ftype (function (list list) list)
+ process-handle-conditions-decl))
+(defun process-handle-conditions-decl (spec list)
+ (let ((new (copy-alist list)))
+ (dolist (clause (cdr spec))
+ (destructuring-bind (typespec restart-name) clause
+ (let ((ospec (rassoc restart-name new :test #'eq)))
+ (if ospec
+ (setf (car ospec)
+ (type-specifier
+ (type-union (specifier-type (car ospec))
+ (specifier-type typespec))))
+ (push (cons (type-specifier (specifier-type typespec))
+ restart-name)
+ new)))))
+ new))
+(declaim (ftype (function (list list) list)
+ process-muffle-conditions-decl))
+(defun process-muffle-conditions-decl (spec list)
+ (process-handle-conditions-decl
+ (cons 'handle-conditions
+ (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec)))
+ list))
+
+(declaim (ftype (function (list list) list)
+ process-unhandle-conditions-decl))
+(defun process-unhandle-conditions-decl (spec list)
+ (let ((new (copy-alist list)))
+ (dolist (clause (cdr spec))
+ (destructuring-bind (typespec restart-name) clause
+ (let ((ospec (rassoc restart-name new :test #'eq)))
+ (if ospec
+ (let ((type-specifier
+ (type-specifier
+ (type-intersection
+ (specifier-type (car ospec))
+ (specifier-type `(not ,typespec))))))
+ (if type-specifier
+ (setf (car ospec) type-specifier)
+ (setq new
+ (delete restart-name new :test #'eq :key #'cdr))))
+ ;; do nothing?
+ nil))))
+ new))
+(declaim (ftype (function (list list) list)
+ process-unmuffle-conditions-decl))
+(defun process-unmuffle-conditions-decl (spec list)
+ (process-unhandle-conditions-decl
+ (cons 'unhandle-conditions
+ (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec)))
+ list))
+
;;; ANSI defines the declaration (FOO X Y) to be equivalent to
;;; (TYPE FOO X Y) when FOO is a type specifier. This function
;;; implements that by converting (FOO X Y) to (TYPE FOO X Y).
(setf (classoid-state subclass) :sealed))))))))
(optimize
(setq *policy* (process-optimize-decl form *policy*)))
+ (muffle-conditions
+ (setq *handled-conditions*
+ (process-muffle-conditions-decl form *handled-conditions*)))
+ (unmuffle-conditions
+ (setq *handled-conditions*
+ (process-unmuffle-conditions-decl form *handled-conditions*)))
((inline notinline maybe-inline)
(dolist (name args)
(proclaim-as-fun-name name) ; since implicitly it is a function
;; call %COMPILE with a core-object, not a fasl-stream,
;; but caveat future maintainers. -- CSR, 2002-10-27
(*policy* (lexenv-policy *lexenv*))
+ ;; see above
+ (*handled-conditions* (lexenv-handled-conditions *lexenv*))
;; FIXME: ANSI doesn't say anything about CL:COMPILE
;; interacting with these variables, so we shouldn't. As
;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
;; controlled by function arguments and lexical variables.
(*compile-verbose* nil)
(*compile-print* nil))
- (clear-stuff)
- (find-source-paths form 0)
- (%compile form (make-core-object)
- :name name
- :path '(original-source-start 0 0))))))
+ (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
+ (clear-stuff)
+ (find-source-paths form 0)
+ (%compile form (make-core-object)
+ :name name
+ :path '(original-source-start 0 0)))))))
(defun compile-in-lexenv (name definition lexenv)
(multiple-value-bind (compiled-definition warnings-p failure-p)
(type-error (c)
(return-from return :good))))
:good))
-
+\f
+;;;; MUFFLE-CONDITIONS test (corresponds to the test in the manual)
+(defvar *compiler-note-count* 0)
+(handler-bind ((sb-ext:compiler-note (lambda (c)
+ (declare (ignore c))
+ (incf *compiler-note-count*))))
+ (let ((fun
+ (compile nil
+ '(lambda (x)
+ (declare (optimize speed) (fixnum x))
+ (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+ (values (* x 5) ; no compiler note from this
+ (locally
+ (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
+ ;; this one gives a compiler note
+ (* x -5)))))))
+ (assert (= *compiler-note-count* 1))
+ (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5)))))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
EOF
expect_clean_compile $tmpfilename
+# MUFFLE-CONDITIONS tests
+cat > $tmpfilename <<EOF
+ (defun foo ()
+ (declare (muffle-conditions style-warning))
+ (bar))
+EOF
+expect_clean_compile $tmpfilename
+
+cat > $tmpfilename <<EOF
+ (defun foo ()
+ (declare (muffle-conditions code-deletion-note))
+ (if t (foo) (foo)))
+EOF
+fail_on_compiler_note $tmpfilename
+
+cat > $tmpfilename <<EOF
+ (defun foo (x y)
+ (declare (muffle-conditions compiler-note))
+ (declare (optimize speed))
+ (+ x y))
+EOF
+fail_on_compiler_note $tmpfilename
+
+cat > $tmpfilename <<EOF
+ (declaim (muffle-conditions compiler-note))
+ (defun foo (x y)
+ (declare (optimize speed))
+ (+ x y))
+EOF
+fail_on_compiler_note $tmpfilename
+
+cat > $tmpfilename <<EOF
+ (declaim (muffle-conditions compiler-note))
+ (defun foo (x y)
+ (declare (unmuffle-conditions compiler-note))
+ (declare (optimize speed))
+ (+ x y))
+EOF
+expect_compiler_note $tmpfilename
+
+# undefined variable causes a WARNING
+cat > $tmpfilename <<EOF
+ (declaim (muffle-conditions warning))
+ (declaim (unmuffle-conditions style-warning))
+ (defun foo () x)
+EOF
+expect_clean_compile $tmpfilename
+
+# top level LOCALLY behaves nicely
+cat > $tmpfilename <<EOF
+ (locally
+ (declare (muffle-conditions warning))
+ (defun foo () x))
+EOF
+expect_clean_compile $tmpfilename
+
+cat > $tmpfilename <<EOF
+ (locally
+ (declare (muffle-conditions warning))
+ (defun foo () x))
+ (defun bar () x)
+EOF
+expect_failed_compile $tmpfilename
+
rm $tmpfilename
rm $compiled_tmpfilename
# Test that a file compiles cleanly, with no ERRORs, WARNINGs or
# STYLE-WARNINGs.
-#
-# Maybe this wants to be in a compiler.test.sh script? This function
-# was originally written to test APD's patch for slot readers and
-# writers not being known to the compiler. -- CSR, 2002-08-14
expect_clean_compile ()
{
$SBCL <<EOF
(sb-ext:quit :unix-status 52))
EOF
if [ $? != 52 ]; then
- echo compiler-note $1 test failed: $?
+ echo fail-on-compiler-note $1 test failed: $?
exit 1
fi
}
+expect_compiler_note ()
+{
+ $SBCL <<EOF
+ (handler-bind ((sb-ext:compiler-note (lambda (c)
+ (declare (ignore c))
+ (sb-ext:quit :unix-status 52))))
+ (compile-file "$1"))
+EOF
+ if [ $? != 52 ]; then
+ echo expect-compiler-note $1 test failed: $?
+ exit 1
+ fi
+}
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.10.28"
+"0.8.10.29"
projects / sbcl.git / commitdiff