0.8.20.6:

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

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index e312ba9..060f4a0 100644 (file)
--- a/src/pcl/defcombin.lisp
+++ b/src/pcl/defcombin.lisp
@@ -25,10 +25,13 @@
 \f
 (defmacro define-method-combination (&whole form &rest args)
   (declare (ignore args))
 \f
 (defmacro define-method-combination (&whole form &rest args)
   (declare (ignore args))

-  (if (and (cddr form)
-          (listp (caddr form)))
-      (expand-long-defcombin form)
-      (expand-short-defcombin form)))
+  `(progn
+     (with-single-package-locked-error
+        (:symbol ',(second form) "defining ~A as a method combination"))
+     ,(if (and (cddr form)
+              (listp (caddr form)))
+         (expand-long-defcombin form)
+         (expand-short-defcombin form))))

 \f
 ;;;; standard method combination
 
 \f
 ;;;; standard method combination
 

@@ -99,6 +102,7 @@
     (when old-method
       (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)
     (when old-method
       (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)

+    (setf (random-documentation type 'method-combination) doc)

     type))
 
 (defun short-combine-methods (type options operator ioa method doc)
     type))
 
 (defun short-combine-methods (type options operator ioa method doc)

@@ -128,27 +132,20 @@
        (order (car (method-combination-options combin)))
        (around ())
        (primary ()))
        (order (car (method-combination-options combin)))
        (around ())
        (primary ()))

-    (dolist (m applicable-methods)
-      (let ((qualifiers (method-qualifiers m)))
-       (flet ((lose (method why)
-                (invalid-method-error
-                  method
-                  "The method ~S ~A.~%~
-                   The method combination type ~S was defined with the~%~
-                   short form of DEFINE-METHOD-COMBINATION and so requires~%~
-                   all methods have either the single qualifier ~S or the~%~
-                   single qualifier :AROUND."
-                  method why type type)))
-         (cond ((null qualifiers)
-                (lose m "has no qualifiers"))
-               ((cdr qualifiers)
-                (lose m "has more than one qualifier"))
+    (flet ((invalid (gf combin m)
+            (if *in-precompute-effective-methods-p*
+                (return-from compute-effective-method
+                  `(%invalid-qualifiers ',gf ',combin ',m))
+                (invalid-qualifiers gf combin m))))
+      (dolist (m applicable-methods)
+       (let ((qualifiers (method-qualifiers m)))
+         (cond ((null qualifiers) (invalid generic-function combin m))
+               ((cdr qualifiers) (invalid generic-function combin m))

                ((eq (car qualifiers) :around)
                 (push m around))
                ((eq (car qualifiers) type)
                 (push m primary))
                ((eq (car qualifiers) :around)
                 (push m around))
                ((eq (car qualifiers) type)
                 (push m primary))

-               (t
-                (lose m "has an illegal qualifier"))))))
+               (t (invalid generic-function combin m))))))

     (setq around (nreverse around))
     (ecase order
       (:most-specific-last) ; nothing to be done, already in correct order
     (setq around (nreverse around))
     (ecase order
       (:most-specific-last) ; nothing to be done, already in correct order

@@ -161,12 +158,57 @@
                `(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
                                      primary)))))
       (cond ((null primary)
                `(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
                                      primary)))))
       (cond ((null primary)

-            `(error "No ~S methods for the generic function ~S."
-                    ',type ',generic-function))
+            ;; As of sbcl-0.8.0.80 we don't seem to need to need
+            ;; to do anything messy like
+            ;;        `(APPLY (FUNCTION (IF AROUND
+            ;;                              'NO-PRIMARY-METHOD
+            ;;                              'NO-APPLICABLE-METHOD)
+            ;;                           ',GENERIC-FUNCTION
+            ;;                           .ARGS.)
+            ;; here because (for reasons I don't understand at the
+            ;; moment -- WHN) control will never reach here if there
+            ;; are no applicable methods, but instead end up
+            ;; in NO-APPLICABLE-METHODS first.
+            ;;
+            ;; FIXME: The way that we arrange for .ARGS. to be bound 
+            ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
+            ;; recognizing any form whose operator is %NO-PRIMARY-METHOD
+            ;; as magical, and carefully surrounding it with a
+            ;; LAMBDA form which binds .ARGS. But...
+            ;;   1. That seems fragile, because the magicalness of
+            ;;      %NO-PRIMARY-METHOD forms is scattered around
+            ;;      the system. So it could easily be broken by
+            ;;      locally-plausible maintenance changes like,
+            ;;      e.g., using the APPLY expression above.
+            ;;   2. That seems buggy w.r.t. to MOPpish tricks in
+            ;;      user code, e.g.
+            ;;         (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...)
+            ;;           `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*)))
+             `(%no-primary-method ',generic-function .args.))

            ((null around) main-method)
            (t
             `(call-method ,(car around)
                           (,@(cdr around) (make-method ,main-method))))))))
            ((null around) main-method)
            (t
             `(call-method ,(car around)
                           (,@(cdr around) (make-method ,main-method))))))))

+
+(defmethod invalid-qualifiers ((gf generic-function)
+                              (combin short-method-combination)
+                              method)
+  (let ((qualifiers (method-qualifiers method))
+       (type (method-combination-type combin)))
+    (let ((why (cond
+                ((null qualifiers) "has no qualifiers")
+                ((cdr qualifiers) "has too many qualifiers")
+                (t (aver (and (neq (car qualifiers) type)
+                              (neq (car qualifiers) :around)))
+                   "has an invalid qualifier"))))
+      (invalid-method-error
+       method
+       "The method ~S on ~S ~A.~%~
+       The method combination type ~S was defined with the~%~
+       short form of DEFINE-METHOD-COMBINATION and so requires~%~
+       all methods have either the single qualifier ~S or the~%~
+       single qualifier :AROUND."
+       method gf why type type))))

 \f
 ;;;; long method combinations
 
 \f
 ;;;; long method combinations
 

@@ -218,6 +260,7 @@
     (setf (gethash type *long-method-combination-functions*) function)
     (when old-method (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)
     (setf (gethash type *long-method-combination-functions*) function)
     (when old-method (remove-method #'find-method-combination old-method))
     (add-method #'find-method-combination new-method)

+    (setf (random-documentation type 'method-combination) doc)

     type))
 
 (defmethod compute-effective-method ((generic-function generic-function)
     type))
 
 (defmethod compute-effective-method ((generic-function generic-function)

@@ -233,9 +276,7 @@
        (type ll method-group-specifiers args-option gf-var body)
   (declare (ignore type))
   (multiple-value-bind (real-body declarations documentation)
        (type ll method-group-specifiers args-option gf-var body)
   (declare (ignore type))
   (multiple-value-bind (real-body declarations documentation)

-      ;; (Note that PARSE-BODY ignores its second arg ENVIRONMENT.)
-      (parse-body body nil)
-
+      (parse-body body)

     (let ((wrapped-body
            (wrap-method-group-specifier-bindings method-group-specifiers
                                                  declarations
     (let ((wrapped-body
            (wrap-method-group-specifier-bindings method-group-specifiers
                                                  declarations

@@ -260,6 +301,12 @@
 
 ;; parse-method-group-specifiers parse the method-group-specifiers
 
 
 ;; parse-method-group-specifiers parse the method-group-specifiers
 

+(define-condition long-method-combination-error 
+    (reference-condition simple-error)
+  ()
+  (:default-initargs 
+      :references (list '(:ansi-cl :macro define-method-combination))))
+

 (defun wrap-method-group-specifier-bindings
        (method-group-specifiers declarations real-body)
   (let (names
 (defun wrap-method-group-specifier-bindings
        (method-group-specifiers declarations real-body)
   (let (names

@@ -278,16 +325,19 @@
                    (if (and (equal ,specializer-cache .specializers.)
                             (not (null .specializers.)))
                        (return-from .long-method-combination-function.
                    (if (and (equal ,specializer-cache .specializers.)
                             (not (null .specializers.)))
                        (return-from .long-method-combination-function.

-                         '(error "More than one method of type ~S ~
-                                     with the same specializers."
-                                  ',name))
+                         '(error 'long-method-combination-error
+                           :format-control "More than one method of type ~S ~
+                                            with the same specializers."
+                           :format-arguments (list ',name)))

                        (setq ,specializer-cache .specializers.))
                    (push .method. ,name))
                  cond-clauses)
            (when required
              (push `(when (null ,name)
                         (return-from .long-method-combination-function.
                        (setq ,specializer-cache .specializers.))
                    (push .method. ,name))
                  cond-clauses)
            (when required
              (push `(when (null ,name)
                         (return-from .long-method-combination-function.

-                          '(error "No ~S methods." ',name)))
+                          '(error 'long-method-combination-error
+                            :format-control "No ~S methods." 
+                            :format-arguments (list ',name))))

                      required-checks))
            (loop (unless (and (constantp order)
                               (neq order (setq order (eval order))))
                      required-checks))
            (loop (unless (and (constantp order)
                               (neq order (setq order (eval order))))

@@ -371,12 +421,21 @@
 ;;;
 ;;; At compute-effective-method time, the symbols in the :arguments
 ;;; option are bound to the symbols in the intercept lambda list.
 ;;;
 ;;; At compute-effective-method time, the symbols in the :arguments
 ;;; option are bound to the symbols in the intercept lambda list.

+;;;
+;;; FIXME: in here we have not one but two mini-copies of a weird
+;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST.

 (defun deal-with-args-option (wrapped-body args-lambda-list)
   (let ((intercept-rebindings
         (let (rebindings)
           (dolist (arg args-lambda-list (nreverse rebindings))
             (unless (member arg lambda-list-keywords)
 (defun deal-with-args-option (wrapped-body args-lambda-list)
   (let ((intercept-rebindings
         (let (rebindings)
           (dolist (arg args-lambda-list (nreverse rebindings))
             (unless (member arg lambda-list-keywords)

-              (push `(,arg ',arg) rebindings)))))
+              (typecase arg
+                (symbol (push `(,arg ',arg) rebindings))
+                (cons
+                 (unless (symbolp (car arg))
+                   (error "invalid lambda-list specifier: ~S." arg))
+                 (push `(,(car arg) ',(car arg)) rebindings))
+                (t (error "invalid lambda-list-specifier: ~S." arg)))))))

        (nreq 0)
        (nopt 0)
        (whole nil))
        (nreq 0)
        (nopt 0)
        (whole nil))

@@ -473,3 +532,4 @@
            (return (nconc (frob required nr nreq)
                           (frob optional no nopt)
                           values)))))
            (return (nconc (frob required nr nreq)
                           (frob optional no nopt)
                           values)))))

+