From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 12 Dec 2008 10:55:34 +0000 (+0000)
Subject: 1.0.23.35: CLOS tweaking
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=203b88cf40ed2e15ec0f36dc53ad188b091d9ab2;p=sbcl.git

1.0.23.35: CLOS tweaking

 * Muffle undefined function style-warning for slot-accessors. The
   slot-accessor name is an internal detail, and defining functions
   accessing slots before classes with such slots are defined is fine.

 * Don't double-fetch slot-definition-initfunction in
   SHARED-INITIALIZE (SLOT-OBJECT).

 * Don't double-fetch various slot-definition properties in
   COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS, and declare
   type-check-functions as functions.
---

diff --git a/NEWS b/NEWS
index 9e95efb..096f1e9 100644
--- a/NEWS
+++ b/NEWS
@@ -18,6 +18,9 @@
   * bug fix: direct superclasses of STANDARD-CLASS and
     FUNCALLABLE-STANDARD-CLASS now default to STANDARD-OBJECT and
     FUNCALLABLE-STANDARD-OBJECT as required by AMOP.
+  * bug fix: compiling a call to SLOT-VALUE with a constant slot-name
+    when no class with the named slot yet exists no longer causes a
+    compile-time style-warning.
 
 changes in sbcl-1.0.23 relative to 1.0.22:
   * enhancement: when disassembling method functions, disassembly
diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 4306079..912c197 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -108,27 +108,27 @@
          (initialize-slot-from-initfunction (class instance slotd)
            ;; CLHS: If a before method stores something in a slot,
            ;; that slot won't be initialized from its :INITFORM, if any.
-           (if (typep instance 'structure-object)
-               (when (eq (funcall
-                          ;; not SLOT-VALUE-USING-CLASS, as that
-                          ;; throws an error if the value is the
-                          ;; unbound marker.
-                          (slot-definition-internal-reader-function slotd)
-                          instance)
-                         +slot-unbound+)
-                 (setf (slot-value-using-class class instance slotd)
-                       (let ((initfn (slot-definition-initfunction slotd)))
-                         (when initfn
-                           (funcall initfn)))))
-               (unless (or (null (slot-definition-initfunction slotd))
-                           (slot-boundp-using-class class instance slotd))
-                 (setf (slot-value-using-class class instance slotd)
-                       (funcall (slot-definition-initfunction slotd)))))))
+           (let ((initfun (slot-definition-initfunction slotd)))
+             (if (typep instance 'structure-object)
+                 (when (eq (funcall
+                            ;; not SLOT-VALUE-USING-CLASS, as that
+                            ;; throws an error if the value is the
+                            ;; unbound marker.
+                            (slot-definition-internal-reader-function slotd)
+                            instance)
+                           +slot-unbound+)
+                   (setf (slot-value-using-class class instance slotd)
+                         (when initfun
+                           (funcall initfun))))
+                 (unless (or (not initfun)
+                             (slot-boundp-using-class class instance slotd))
+                  (setf (slot-value-using-class class instance slotd)
+                        (funcall initfun)))))))
     (let* ((class (class-of instance))
            (initfn-slotds
             (loop for slotd in (class-slots class)
                   unless (initialize-slot-from-initarg class instance slotd)
-                    collect slotd)))
+                  collect slotd)))
       (dolist (slotd initfn-slotds)
         (if (eq (slot-definition-allocation slotd) :class)
             (when (or (eq t slot-names)
diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index b2b1f21..c9fa220 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -64,7 +64,10 @@
                       (ensure-accessor 'reader ',reader-name ',slot-name))))
       (declare (ignore .ignore.))
       (truly-the (values t &optional)
-                 (funcall #',reader-name ,object)))))
+                 ;; Don't give a style-warning about undefined function here.
+                 (funcall (locally (declare (muffle-conditions style-warning))
+                            #',reader-name)
+                          ,object)))))
 
 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
   (aver (constantp slot-name env))
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index ab1406f..b07aa0c 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -1097,13 +1097,13 @@
           (setq name (slot-definition-name slotd)
                 namep t))
         (unless initp
-          (when (slot-definition-initfunction slotd)
+          (awhen (slot-definition-initfunction slotd)
             (setq initform (slot-definition-initform slotd)
-                  initfunction (slot-definition-initfunction slotd)
+                  initfunction it
                   initp t)))
         (unless documentationp
-          (when (%slot-definition-documentation slotd)
-            (setq documentation (%slot-definition-documentation slotd)
+          (awhen (%slot-definition-documentation slotd)
+            (setq documentation it
                   documentationp t)))
         (unless allocp
           (setq allocation (slot-definition-allocation slotd)
@@ -1115,6 +1115,7 @@
             (setf type-check-function
                   (if type-check-function
                       (let ((old-function type-check-function))
+                        (declare (function old-function fun))
                         (lambda (value)
                           (funcall old-function value)
                           (funcall fun value)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 160131f..7ed970b 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; 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".)
-"1.0.23.34"
+"1.0.23.35"