[Sbcl-commits] master: fix style-warnings for condition slot-accessors used in :REPORT

[Nikodemus S. <de...@us...>]

The branch "master" has been updated in SBCL:
       via  f37fd916aae6ecbb7341c1385c7113608b7816a5 (commit)
      from  741d910ca6f69a115905872ea84258baba5392c7 (commit)

- Log -----------------------------------------------------------------
commit f37fd916aae6ecbb7341c1385c7113608b7816a5
Author: Nikodemus Siivola <nik...@ra...>
Date:   Mon Nov 28 13:35:54 2011 +0200

    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))))))))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL