1.0.6.3: thread and interrupt safe CLOS cache

[sbcl.git] / src / pcl / methods.lisp

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index d0e5c04..d8ce44c 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -610,7 +610,7 @@
    ))
 \f
 (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
-  nil)
+  (eql specl1 specl2))
 
 (defmethod same-specializer-p ((specl1 class) (specl2 class))
   (eq specl1 specl2))
@@ -629,6 +629,24 @@
 (defmethod specializer-class ((specializer eql-specializer))
   (class-of (slot-value specializer 'object)))
 
+;;; KLUDGE: this is needed to allow for user-defined specializers in
+;;; RAISE-METATYPE; however, the list of methods is maintained by
+;;; hand, which is error-prone.  We can't just add a method to
+;;; SPECIALIZER-CLASS, or at least not with confidence, as that
+;;; function is used elsewhere in PCL.  `STANDARD' here is used in the
+;;; sense of `comes with PCL' rather than `blessed by the
+;;; authorities'.  -- CSR, 2007-05-10
+(defmethod standard-specializer-p ((specializer class)) t)
+(defmethod standard-specializer-p ((specializer eql-specializer)) t)
+(defmethod standard-specializer-p ((specializer class-eq-specializer)) t)
+(defmethod standard-specializer-p ((specializer class-prototype-specializer))
+  t)
+(defmethod standard-specializer-p ((specializer specializer)) nil)
+
+(defun specializer-class-or-nil (specializer)
+  (and (standard-specializer-p specializer)
+       (specializer-class specializer)))
+
 (defun error-need-at-least-n-args (function n)
   (error 'simple-program-error
          :format-control "~@<The function ~2I~_~S ~I~_requires ~
@@ -947,14 +965,12 @@
          (nkeys (arg-info-nkeys arg-info))
          (metatypes (arg-info-metatypes arg-info))
          (wrappers (unless (eq nkeys 1) (make-list nkeys)))
-         (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
-         (default '(default)))
+         (precompute-p (gf-precompute-dfun-and-emf-p arg-info)))
     (flet ((add-class-list (classes)
              (when (or (null new-class) (memq new-class classes))
                (let ((%wrappers (get-wrappers-from-classes
                                  nkeys wrappers classes metatypes)))
-                 (when (and %wrappers
-                            (eq default (probe-cache cache %wrappers default)))
+                 (when (and %wrappers (not (probe-cache cache %wrappers)))
                    (let ((value (cond ((eq valuep t)
                                        (sdfun-for-caching generic-function
                                                           classes))
@@ -1337,11 +1353,12 @@
     (let* ((name (generic-function-name generic-function))
            (arg-info (gf-arg-info generic-function))
            (metatypes (arg-info-metatypes arg-info))
+           (nargs (length metatypes))
            (applyp (arg-info-applyp arg-info))
-           (fmc-arg-info (cons (length metatypes) applyp))
+           (fmc-arg-info (cons nargs applyp))
            (arglist (if function-p
-                        (make-dfun-lambda-list metatypes applyp)
-                        (make-fast-method-call-lambda-list metatypes applyp))))
+                        (make-dfun-lambda-list nargs applyp)
+                        (make-fast-method-call-lambda-list nargs applyp))))
       (multiple-value-bind (cfunction constants)
           (get-fun1 `(lambda
                       ,arglist
@@ -1349,7 +1366,7 @@
                           `((declare (ignore .pv-cell. .next-method-call.))))
                       (locally (declare #.*optimize-speed*)
                                (let ((emf ,net))
-                                 ,(make-emf-call metatypes applyp 'emf))))
+                                 ,(make-emf-call nargs applyp 'emf))))
                     #'net-test-converter
                     #'net-code-converter
                     (lambda (form)
@@ -1522,11 +1539,15 @@
       ((gf-precompute-dfun-and-emf-p arg-info)
        (multiple-value-bind (dfun cache info)
            (make-final-dfun-internal gf)
+         ;; FIXME: What does the next comment mean? Presumably it
+         ;; refers to the age-old implementation where cache vectors
+         ;; where cached resources? Also, the first thing UPDATE-DFUN
+         ;; does it SET-DFUN, so do we really need it here?
          (set-dfun gf dfun cache info) ; lest the cache be freed twice
          (update-dfun gf dfun cache info))))))
 \f
 (defmethod (setf class-name) (new-value class)
-  (let ((classoid (%wrapper-classoid (class-wrapper class))))
+  (let ((classoid (wrapper-classoid (class-wrapper class))))
     (if (and new-value (symbolp new-value))
         (setf (classoid-name classoid) new-value)
         (setf (classoid-name classoid) nil)))