1.0.42.24: print symbols with fully qualified names in critical places

[sbcl.git] / src / pcl / std-class.lisp

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index bf80f1b..b1a60df 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -69,8 +69,8 @@
               (the fixnum (logand (the fixnum (lognot mask)) flags)))))
   value)
 
-(defmethod initialize-internal-slot-functions ((slotd
-                                                effective-slot-definition))
+(defmethod initialize-internal-slot-functions
+    ((slotd effective-slot-definition))
   (let* ((name (slot-value slotd 'name))
          (class (slot-value slotd '%class)))
     (dolist (type '(reader writer boundp))
@@ -79,6 +79,33 @@
                               (writer '(setf slot-value-using-class))
                               (boundp 'slot-boundp-using-class)))
              (gf (gdefinition gf-name)))
+        ;; KLUDGE: this logic is cut'n'pasted from
+        ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is
+        ;; only called later, because it does things that can't be
+        ;; computed this early in class finalization; however, we need
+        ;; this bit as early as possible.  -- CSR, 2009-11-05
+        (setf (slot-accessor-std-p slotd type)
+              (let* ((std-method (standard-svuc-method type))
+                     (str-method (structure-svuc-method type))
+                     (types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
+                     (types (if (eq type 'writer) `(t ,@types1) types1))
+                     (methods (compute-applicable-methods-using-types gf types)))
+                (null (cdr methods))))
+        (setf (slot-accessor-function slotd type)
+              (lambda (&rest args)
+                ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P
+                ;; work here (see KLUDGE comment above).
+                (let ((fun (compute-slot-accessor-info slotd type gf)))
+                  (apply fun args))))))))
+
+(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition))
+  (let* ((name (slot-value slotd 'name)))
+    (dolist (type '(reader writer boundp))
+      (let* ((gf-name (ecase type
+                              (reader 'slot-value-using-class)
+                              (writer '(setf slot-value-using-class))
+                              (boundp 'slot-boundp-using-class)))
+             (gf (gdefinition gf-name)))
         (compute-slot-accessor-info slotd type gf)))))
 
 ;;; CMUCL (Gerd PCL 2003-04-25) comment:
@@ -98,12 +125,9 @@
 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
                                        type gf)
   (let* ((name (slot-value slotd 'name))
-         (class (slot-value slotd '%class))
-         (old-slotd (when (class-finalized-p class)
-                      (find-slot-definition class name)))
-         (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
+         (class (slot-value slotd '%class)))
     (multiple-value-bind (function std-p)
-        (if (eq *boot-state* 'complete)
+        (if (eq **boot-state** 'complete)
             (get-accessor-method-function gf type class slotd)
             (get-optimized-std-accessor-method-function class slotd type))
       (setf (slot-accessor-std-p slotd type) std-p)
@@ -181,13 +205,13 @@
 (defmethod add-direct-method :around ((specializer specializer) method)
   ;; All the actions done under this lock are done in an order
   ;; that is safe to unwind at any point.
-  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+  (sb-thread::with-recursive-system-spinlock (*specializer-lock*)
     (call-next-method)))
 
 (defmethod remove-direct-method :around ((specializer specializer) method)
   ;; All the actions done under this lock are done in an order
   ;; that is safe to unwind at any point.
-  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+  (sb-thread::with-recursive-system-spinlock (*specializer-lock*)
     (call-next-method)))
 
 (defmethod add-direct-method ((specializer class) (method method))
@@ -353,7 +377,7 @@
       (without-package-locks
         (setf (find-class name) class))))
   ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq *boot-state* 'complete)
+  (unless (eq **boot-state** 'complete)
     (%set-class-type-translation class name))
   class)
 
@@ -367,7 +391,7 @@
       (without-package-locks
         (setf (find-class name) class))))
   ;; After boot (SETF FIND-CLASS) does this.
-  (unless (eq *boot-state* 'complete)
+  (unless (eq **boot-state** 'complete)
     (%set-class-type-translation class name))
   class)
 
@@ -615,7 +639,7 @@
 
 (defmethod compute-slots :around ((class condition-class))
   (let ((eslotds (call-next-method)))
-    (mapc #'initialize-internal-slot-functions eslotds)
+    (mapc #'finalize-internal-slot-functions eslotds)
     eslotds))
 
 (defmethod shared-initialize :after
@@ -939,7 +963,7 @@
               (style-warn
                "~@<slot names with the same SYMBOL-NAME but ~
                   different SYMBOL-PACKAGE (possible package problem) ~
-                  for class ~S:~4I~@:_~<~@{~S~^~:@_~}~:>~@:>"
+                  for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
                class dupes)))
         (let* ((slot (car slots))
                (oslots (remove (slot-definition-name slot) (cdr slots)
@@ -1095,7 +1119,7 @@
 
 (defmethod compute-slots :around ((class structure-class))
   (let ((eslotds (call-next-method)))
-    (mapc #'initialize-internal-slot-functions eslotds)
+    (mapc #'finalize-internal-slot-functions eslotds)
     eslotds))
 
 (defmethod compute-effective-slot-definition ((class slot-class) name dslotds)