From f37fd916aae6ecbb7341c1385c7113608b7816a5 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 28 Nov 2011 13:35:54 +0200 Subject: [PATCH 1/1] fix style-warnings for condition slot-accessors used in :REPORT Previously condition slot accessors used in :REPORT option signaled a style-warning under EVAL and LOAD (as source): the compiler saw the lambda before the accessor had been proclaimed as functions. Fixes lp#896379. --- NEWS | 3 +++ src/code/condition.lisp | 21 ++++++++++++++------- tests/condition.impure.lisp | 14 ++++++++++++++ 3 files changed, 31 insertions(+), 7 deletions(-) diff --git a/NEWS b/NEWS index 7a79191..3349f19 100644 --- a/NEWS +++ b/NEWS @@ -16,6 +16,9 @@ changes relative to sbcl-1.0.54: * bug fix: compiler error when typechecking a call to a function with non-constant keyword arguments. * bug fix: misoptimization of TRUNCATE causing erratic behaviour. + * bug fix: condition slot accessors no longer cause undefined function + style-warnings when used in the :REPORT clause of the DEFINE-CONDITION + form that defines them. (lp#896379) changes in sbcl-1.0.54 relative to sbcl-1.0.53: * minor incompatible changes: diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 8c410d4..2015a77 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -398,8 +398,12 @@ (defvar *define-condition-hooks* nil) +(defun %set-condition-report (name report) + (setf (condition-classoid-report (find-classoid name)) + report)) + (defun %define-condition (name parent-types layout slots documentation - report default-initargs all-readers all-writers + default-initargs all-readers all-writers source-location) (with-single-package-locked-error (:symbol name "defining ~A as a condition") @@ -409,7 +413,6 @@ source-location)) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) - (setf (condition-classoid-report class) report) (setf (condition-classoid-default-initargs class) default-initargs) (setf (fdocumentation name 'type) documentation) @@ -548,10 +551,10 @@ (setq report (if (stringp arg) `#'(lambda (condition stream) - (declare (ignore condition)) - (write-string ,arg stream)) + (declare (ignore condition)) + (write-string ,arg stream)) `#'(lambda (condition stream) - (funcall #',arg condition stream)))))) + (funcall #',arg condition stream)))))) (:default-initargs (do ((initargs (rest option) (cddr initargs))) ((endp initargs)) @@ -575,11 +578,15 @@ ',layout (list ,@(slots)) ,documentation - ,report (list ,@default-initargs) ',(all-readers) ',(all-writers) - (sb!c:source-location))))))) + (sb!c:source-location)) + ;; This needs to be after %DEFINE-CONDITION in case :REPORT + ;; is a lambda referring to condition slot accessors: + ;; they're not proclaimed as functions before it has run if + ;; we're under EVAL or loaded as source. + (%set-condition-report ',name ,report)))))) ;;;; various CONDITIONs specified by ANSI diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index 4722d92..b66ed3f 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -11,6 +11,8 @@ (cl:in-package :cl-user) +(use-package :test-util) + ;;; Bug from CLOCC. (defpackage :p1 (:use :cl) @@ -37,6 +39,8 @@ (assert (eql (code-msg code) 2)) (assert (eql (%code-msg code) 1))) +(in-package :cl-user) + ;;; Check that initializing the condition class metaobject doesn't create ;;; any instances. Reported by Marco Baringer on sbcl-devel Mon, 05 Jul 2004. (defvar *condition-count* 0) @@ -121,3 +125,13 @@ (when (find-restart 'bar) (invoke-restart 'bar)))) (assert (not (restart-test-finds-restarts))) + +(with-test (:name :bug-896379) + (let ((*evaluator-mode* :compile)) + (handler-bind ((style-warning #'error)) + (let ((reader (gensym "READER")) + (name (gensym "FOO-ERROR"))) + (eval `(define-condition ,name (error) + ((slot :initarg :slot :reader ,reader)) + (:report (lambda (c stream) + (format stream "Oops: ~S" (,reader c)))))))))) -- 1.7.10.4