X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=36fb2c036d5cf81616ccca1a4749f4269f436b69;hb=617d4fa1db5a4a11564e7c59bfb684c7eb25633d;hp=d3186a08f7203a7efc66f5f39a8254876855b854;hpb=11d63973b40deaab9c555bcdab8d5a742c814b48;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index d3186a0..36fb2c0 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -152,10 +152,9 @@
     (check-slot-name method slot-name)))
 
 (defmethod shared-initialize :after ((method standard-method) slot-names
-                                     &rest initargs &key)
-  (declare (ignore slot-names))
+                                     &rest initargs &key ((method-cell method-cell)))
+  (declare (ignore slot-names method-cell))
   (initialize-method-function initargs method))
-
 
 (defvar *the-class-generic-function*
   (find-class 'generic-function))
@@ -217,11 +216,8 @@
       (errorp (error "No generic function named ~S." name))
       (t nil))))
 
-(defun real-add-named-method (generic-function-name
-                              qualifiers
-                              specializers
-                              lambda-list
-                              &rest other-initargs)
+(defun real-add-named-method (generic-function-name qualifiers
+                              specializers lambda-list &rest other-initargs)
   (unless (and (fboundp generic-function-name)
                (typep (fdefinition generic-function-name) 'generic-function))
     (style-warn "implicitly creating new generic function ~S"
@@ -233,15 +229,15 @@
                generic-function-name
                :generic-function-class (class-of existing-gf))
               (ensure-generic-function generic-function-name)))
-         (specs (parse-specializers specializers))
-         (proto (method-prototype-for-gf generic-function-name))
-         (new (apply #'make-instance (class-of proto)
-                                     :qualifiers qualifiers
-                                     :specializers specs
-                                     :lambda-list lambda-list
-                                     other-initargs)))
-    (add-method generic-function new)
-    new))
+         (proto (method-prototype-for-gf generic-function-name)))
+    ;; FIXME: Destructive modification of &REST list.
+    (setf (getf (getf other-initargs 'plist) :name)
+          (make-method-spec generic-function qualifiers specializers))
+    (let ((new (apply #'make-instance (class-of proto)
+                      :qualifiers qualifiers :specializers specializers
+                      :lambda-list lambda-list other-initargs)))
+      (add-method generic-function new)
+      new)))
 
 (define-condition find-method-length-mismatch
     (reference-condition simple-error)
@@ -290,11 +286,14 @@
   ;; function, or an error is signaled."
   ;;
   ;; This error checking is done by REAL-GET-METHOD.
-  (real-get-method generic-function
-                   qualifiers
-                   (parse-specializers specializers)
-                   errorp
-                   t))
+  (real-get-method
+   generic-function qualifiers
+   ;; ANSI for FIND-METHOD seems to imply that in fact specializers
+   ;; should always be passed in parsed form instead of being parsed
+   ;; at this point.  Since there's no ANSI-blessed way of getting an
+   ;; EQL specializer, that seems unnecessarily painful, so we are
+   ;; nice to our users.  -- CSR, 2007-06-01
+   (parse-specializers generic-function specializers) errorp t))
 
 ;;; Compute various information about a generic-function's arglist by looking
 ;;; at the argument lists of the methods. The hair for trying not to use
@@ -450,107 +449,119 @@
                     (= a-nopt b-nopt)
                     (eq (or a-keyp a-restp)
                         (or b-keyp b-restp)))))))
-      (let* ((name (generic-function-name generic-function))
-             (qualifiers (method-qualifiers method))
-             (specializers (method-specializers method))
-             (existing (get-method generic-function
-                                   qualifiers
-                                   specializers
-                                   nil)))
-
-        ;; If there is already a method like this one then we must get
-        ;; rid of it before proceeding.  Note that we call the generic
-        ;; function REMOVE-METHOD to remove it rather than doing it in
-        ;; some internal way.
-        (when (and existing (similar-lambda-lists-p existing method))
-          (remove-method generic-function existing))
-
-        ;; KLUDGE: We have a special case here, as we disallow
-        ;; specializations of the NEW-VALUE argument to (SETF
-        ;; SLOT-VALUE-USING-CLASS).  GET-ACCESSOR-METHOD-FUNCTION is
-        ;; the optimizing function here: it precomputes the effective
-        ;; method, assuming that there is no dispatch to be done on
-        ;; the new-value argument.
-        (when (and (eq generic-function #'(setf slot-value-using-class))
-                   (not (eq *the-class-t* (first specializers))))
-          (error 'new-value-specialization
-                 :method method))
-
-        (setf (method-generic-function method) generic-function)
-        (pushnew method (generic-function-methods generic-function))
-        (dolist (specializer specializers)
-          (add-direct-method specializer method))
-
-        ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
-        ;; detecting attempts to add methods with incongruent lambda
-        ;; lists.  However, according to Gerd Moellmann on cmucl-imp,
-        ;; it also depends on the new method already having been added
-        ;; to the generic function.  Therefore, we need to remove it
-        ;; again on error:
-        (let ((remove-again-p t))
-          (unwind-protect
-               (progn
-                 (set-arg-info generic-function :new-method method)
-                 (setq remove-again-p nil))
-            (when remove-again-p
-              (remove-method generic-function method))))
-
-        ;; KLUDGE II: ANSI saith that it is not an error to add a
-        ;; method with invalid qualifiers to a generic function of the
-        ;; wrong kind; it's only an error at generic function
-        ;; invocation time; I dunno what the rationale was, and it
-        ;; sucks.  Nevertheless, it's probably a programmer error, so
-        ;; let's warn anyway. -- CSR, 2003-08-20
-        (let ((mc (generic-function-method-combination generic-functioN)))
-          (cond
-            ((eq mc *standard-method-combination*)
-             (when (and qualifiers
-                        (or (cdr qualifiers)
-                            (not (memq (car qualifiers)
-                                       '(:around :before :after)))))
-               (warn "~@<Invalid qualifiers for standard method combination ~
-                      in method ~S:~2I~_~S.~@:>"
-                     method qualifiers)))
-            ((short-method-combination-p mc)
-             (let ((mc-name (method-combination-type-name mc)))
-               (when (or (null qualifiers)
-                         (cdr qualifiers)
-                         (and (neq (car qualifiers) :around)
-                              (neq (car qualifiers) mc-name)))
-                 (warn "~@<Invalid qualifiers for ~S method combination ~
-                        in method ~S:~2I~_~S.~@:>"
-                       mc-name method qualifiers))))))
-
-        (unless skip-dfun-update-p
-          (update-ctors 'add-method
-                        :generic-function generic-function
-                        :method method)
-          (update-dfun generic-function))
-        (map-dependents generic-function
-                        (lambda (dep)
-                          (update-dependent generic-function
-                                            dep 'add-method method)))
-        generic-function)))
+    (let ((lock (gf-lock generic-function)))
+      ;; HANDLER-CASE takes care of releasing the lock and enabling
+      ;; interrupts before going forth with the error.
+      (handler-case
+          ;; System lock because interrupts need to be disabled as
+          ;; well: it would be bad to unwind and leave the gf in an
+          ;; inconsistent state.
+          (sb-thread::with-recursive-system-spinlock (lock)
+            (let* ((qualifiers (method-qualifiers method))
+                   (specializers (method-specializers method))
+                   (existing (get-method generic-function
+                                         qualifiers
+                                         specializers
+                                         nil)))
+
+              ;; If there is already a method like this one then we must get
+              ;; rid of it before proceeding.  Note that we call the generic
+              ;; function REMOVE-METHOD to remove it rather than doing it in
+              ;; some internal way.
+              (when (and existing (similar-lambda-lists-p existing method))
+                (remove-method generic-function existing))
+
+              ;; KLUDGE: We have a special case here, as we disallow
+              ;; specializations of the NEW-VALUE argument to (SETF
+              ;; SLOT-VALUE-USING-CLASS).  GET-ACCESSOR-METHOD-FUNCTION is
+              ;; the optimizing function here: it precomputes the effective
+              ;; method, assuming that there is no dispatch to be done on
+              ;; the new-value argument.
+              (when (and (eq generic-function #'(setf slot-value-using-class))
+                         (not (eq *the-class-t* (first specializers))))
+                (error 'new-value-specialization :method  method))
+
+              (setf (method-generic-function method) generic-function)
+              (pushnew method (generic-function-methods generic-function))
+              (dolist (specializer specializers)
+                (add-direct-method specializer method))
+
+              ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
+              ;; detecting attempts to add methods with incongruent lambda
+              ;; lists.  However, according to Gerd Moellmann on cmucl-imp,
+              ;; it also depends on the new method already having been added
+              ;; to the generic function.  Therefore, we need to remove it
+              ;; again on error:
+              (let ((remove-again-p t))
+                (unwind-protect
+                     (progn
+                       (set-arg-info generic-function :new-method method)
+                       (setq remove-again-p nil))
+                  (when remove-again-p
+                    (remove-method generic-function method))))
+
+              ;; KLUDGE II: ANSI saith that it is not an error to add a
+              ;; method with invalid qualifiers to a generic function of the
+              ;; wrong kind; it's only an error at generic function
+              ;; invocation time; I dunno what the rationale was, and it
+              ;; sucks.  Nevertheless, it's probably a programmer error, so
+              ;; let's warn anyway. -- CSR, 2003-08-20
+              (let ((mc (generic-function-method-combination generic-functioN)))
+                (cond
+                  ((eq mc *standard-method-combination*)
+                   (when (and qualifiers
+                              (or (cdr qualifiers)
+                                  (not (memq (car qualifiers)
+                                             '(:around :before :after)))))
+                     (warn "~@<Invalid qualifiers for standard method ~
+                            combination in method ~S:~2I~_~S.~@:>"
+                           method qualifiers)))
+                  ((short-method-combination-p mc)
+                   (let ((mc-name (method-combination-type-name mc)))
+                     (when (or (null qualifiers)
+                               (cdr qualifiers)
+                               (and (neq (car qualifiers) :around)
+                                    (neq (car qualifiers) mc-name)))
+                       (warn "~@<Invalid qualifiers for ~S method combination ~
+                              in method ~S:~2I~_~S.~@:>"
+                             mc-name method qualifiers))))))
+
+              (unless skip-dfun-update-p
+                (update-ctors 'add-method
+                              :generic-function generic-function
+                              :method method)
+                (update-dfun generic-function))
+              (map-dependents generic-function
+                              (lambda (dep)
+                                (update-dependent generic-function
+                                                  dep 'add-method method)))))
+        (serious-condition (c)
+          (error c)))))
+  generic-function)
 
 (defun real-remove-method (generic-function method)
   (when (eq generic-function (method-generic-function method))
-    (let* ((name (generic-function-name generic-function))
-           (specializers (method-specializers method))
-           (methods (generic-function-methods generic-function))
-           (new-methods (remove method methods)))
-      (setf (method-generic-function method) nil)
-      (setf (generic-function-methods generic-function) new-methods)
-      (dolist (specializer (method-specializers method))
-        (remove-direct-method specializer method))
-      (set-arg-info generic-function)
-      (update-ctors 'remove-method
-                    :generic-function generic-function
-                    :method method)
-      (update-dfun generic-function)
-      (map-dependents generic-function
-                      (lambda (dep)
-                        (update-dependent generic-function
-                                          dep 'remove-method method)))))
+    (let ((lock (gf-lock generic-function)))
+      ;; System lock because interrupts need to be disabled as well:
+      ;; it would be bad to unwind and leave the gf in an inconsistent
+      ;; state.
+      (sb-thread::with-recursive-system-spinlock (lock)
+        (let* ((specializers (method-specializers method))
+               (methods (generic-function-methods generic-function))
+               (new-methods (remove method methods)))
+          (setf (method-generic-function method) nil
+                (generic-function-methods generic-function) new-methods)
+          (dolist (specializer (method-specializers method))
+            (remove-direct-method specializer method))
+          (set-arg-info generic-function)
+          (update-ctors 'remove-method
+                        :generic-function generic-function
+                        :method method)
+          (update-dfun generic-function)
+          (map-dependents generic-function
+                          (lambda (dep)
+                            (update-dependent generic-function
+                                              dep 'remove-method method)))))))
   generic-function)
 
 (defun compute-applicable-methods-function (generic-function arguments)
@@ -610,7 +621,7 @@
    ))
 
 (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 +640,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 +976,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))
@@ -1523,7 +1550,6 @@
       ((gf-precompute-dfun-and-emf-p arg-info)
        (multiple-value-bind (dfun cache info)
            (make-final-dfun-internal gf)
-         (set-dfun gf dfun cache info) ; lest the cache be freed twice
          (update-dfun gf dfun cache info))))))
 
 (defmethod (setf class-name) (new-value class)