0.8.0.2:

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

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 1c600ff..5be842e 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -60,19 +60,21 @@
       (make-effective-method-function-simple generic-function form)
       ;; We have some sort of `real' effective method. Go off and get a
       ;; compiled function for it. Most of the real hair here is done by
       (make-effective-method-function-simple generic-function form)
       ;; We have some sort of `real' effective method. Go off and get a
       ;; compiled function for it. Most of the real hair here is done by

-      ;; the GET-FUNCTION mechanism.
+      ;; the GET-FUN mechanism.

       (make-effective-method-function-internal generic-function form
                                               method-alist-p wrappers-p)))
 
       (make-effective-method-function-internal generic-function form
                                               method-alist-p wrappers-p)))
 

-(defun make-effective-method-function-type (generic-function form
-                                           method-alist-p wrappers-p)
+(defun make-effective-method-fun-type (generic-function
+                                      form
+                                      method-alist-p
+                                      wrappers-p)

   (if (and (listp form)
           (eq (car form) 'call-method))
       (let* ((cm-args (cdr form))
             (method (car cm-args)))
        (when method
          (if (if (listp method)
   (if (and (listp form)
           (eq (car form) 'call-method))
       (let* ((cm-args (cdr form))
             (method (car cm-args)))
        (when method
          (if (if (listp method)

-                 (eq (car method) ':early-method)
+                 (eq (car method) :early-method)

                  (method-p method))
              (if method-alist-p
                  t
                  (method-p method))
              (if method-alist-p
                  t

@@ -86,14 +88,14 @@
                          'fast-method-call
                          'method-call))))
              (if (and (consp method) (eq (car method) 'make-method))
                          'fast-method-call
                          'method-call))))
              (if (and (consp method) (eq (car method) 'make-method))

-                 (make-effective-method-function-type
+                 (make-effective-method-fun-type

                   generic-function (cadr method) method-alist-p wrappers-p)
                  (type-of method)))))
       'fast-method-call))
 
 (defun make-effective-method-function-simple
     (generic-function form &optional no-fmf-p)
                   generic-function (cadr method) method-alist-p wrappers-p)
                  (type-of method)))))
       'fast-method-call))
 
 (defun make-effective-method-function-simple
     (generic-function form &optional no-fmf-p)

-  ;; The effective method is just a call to call-method. This opens up
+  ;; The effective method is just a call to CALL-METHOD. This opens up

   ;; the possibility of just using the method function of the method as
   ;; the effective method function.
   ;;
   ;; the possibility of just using the method function of the method as
   ;; the effective method function.
   ;;

@@ -109,9 +111,13 @@
                     (null (cddr cm-args))))
         (method (car cm-args))
         (cm-args1 (cdr cm-args)))
                     (null (cddr cm-args))))
         (method (car cm-args))
         (cm-args1 (cdr cm-args)))

-    #'(lambda (method-alist wrappers)
-       (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
-                                               method-alist wrappers))))
+    (lambda (method-alist wrappers)
+      (make-effective-method-function-simple1 generic-function
+                                             method
+                                             cm-args1
+                                             fmf-p
+                                             method-alist
+                                             wrappers))))

 
 (defun make-emf-from-method
     (method cm-args &optional gf fmf-p method-alist wrappers)
 
 (defun make-emf-from-method
     (method cm-args &optional gf fmf-p method-alist wrappers)

@@ -123,7 +129,7 @@
                      gf (car next-methods)
                      (list* (cdr next-methods) (cdr cm-args))
                      fmf-p method-alist wrappers))
                      gf (car next-methods)
                      (list* (cdr next-methods) (cdr cm-args))
                      fmf-p method-alist wrappers))

-              (arg-info (method-function-get fmf ':arg-info)))
+              (arg-info (method-function-get fmf :arg-info)))

          (make-fast-method-call :function fmf
                                 :pv-cell pv-cell
                                 :next-method-call next
          (make-fast-method-call :function fmf
                                 :pv-cell pv-cell
                                 :next-method-call next

@@ -137,7 +143,7 @@
     (gf method cm-args fmf-p &optional method-alist wrappers)
   (when method
     (if (if (listp method)
     (gf method cm-args fmf-p &optional method-alist wrappers)
   (when method
     (if (if (listp method)

-           (eq (car method) ':early-method)
+           (eq (car method) :early-method)

            (method-p method))
        (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
        (if (and (consp method) (eq (car method) 'make-method))
            (method-p method))
        (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
        (if (and (consp method) (eq (car method) 'make-method))

@@ -165,16 +171,41 @@
 (defun expand-effective-method-function (gf effective-method &optional env)
   (declare (ignore env))
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
 (defun expand-effective-method-function (gf effective-method &optional env)
   (declare (ignore env))
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)

-      (get-generic-function-info gf)
+      (get-generic-fun-info gf)

     (declare (ignore nreq nkeys arg-info))
     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
     (declare (ignore nreq nkeys arg-info))
     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))

-         ;; When there are no primary methods and a next-method call occurs
-         ;; effective-method is (error "No mumble..") and the defined
-         ;; args are not used giving a compiler warning.
-         (error-p (eq (first effective-method) 'error)))
-      `(lambda ,ll
-        (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
-        ,effective-method))))
+         (error-p (eq (first effective-method) '%no-primary-method))
+         (mc-args-p
+          (when (eq *boot-state* 'complete)
+            ;; Otherwise the METHOD-COMBINATION slot is not bound.
+            (let ((combin (generic-function-method-combination gf)))
+              (and (long-method-combination-p combin)
+                   (long-method-combination-args-lambda-list combin))))))
+      (cond
+       (error-p
+        `(lambda (.pv-cell. .next-method-call. &rest .args.)
+          (declare (ignore .pv-cell. .next-method-call.))
+          (flet ((%no-primary-method (gf args)
+                   (apply #'no-primary-method gf args)))
+            ,effective-method)))
+       (mc-args-p
+        (let* ((required
+                ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp
+                (let (req)
+                  (dotimes (i (length metatypes) (nreverse req))
+                    (push (dfun-arg-symbol i) req))))
+               (gf-args (if applyp
+                            `(list* ,@required .dfun-rest-arg.)
+                            `(list ,@required))))
+          `(lambda ,ll
+            (declare (ignore .pv-cell. .next-method-call.))
+            (let ((.gf-args. ,gf-args))
+              (declare (ignorable .gf-args.))
+              ,effective-method))))
+       (t
+        `(lambda ,ll
+          (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
+          ,effective-method))))))

 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))
 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))

@@ -186,18 +217,18 @@
 
 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
   (cond ((and (consp form) (eq (car form) 'call-method))
 
 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
   (cond ((and (consp form) (eq (car form) 'call-method))

-        (case (make-effective-method-function-type
+        (case (make-effective-method-fun-type

                generic-function form method-alist-p wrappers-p)
           (fast-method-call
            '.fast-call-method.)
           (t
            '.call-method.)))
        ((and (consp form) (eq (car form) 'call-method-list))
                generic-function form method-alist-p wrappers-p)
           (fast-method-call
            '.fast-call-method.)
           (t
            '.call-method.)))
        ((and (consp form) (eq (car form) 'call-method-list))

-        (case (if (every #'(lambda (form)
-                             (eq 'fast-method-call
-                                 (make-effective-method-function-type
-                                  generic-function form
-                                  method-alist-p wrappers-p)))
+        (case (if (every (lambda (form)
+                           (eq 'fast-method-call
+                               (make-effective-method-fun-type
+                                generic-function form
+                                method-alist-p wrappers-p)))

                          (cdr form))
                   'fast-method-call
                   t)
                          (cdr form))
                   'fast-method-call
                   t)

@@ -213,16 +244,16 @@
   (cond ((and (consp form) (eq (car form) 'call-method))
         (let ((gensym (get-effective-method-gensym)))
           (values (make-emf-call metatypes applyp gensym
   (cond ((and (consp form) (eq (car form) 'call-method))
         (let ((gensym (get-effective-method-gensym)))
           (values (make-emf-call metatypes applyp gensym

-                                 (make-effective-method-function-type
+                                 (make-effective-method-fun-type

                                   generic-function form method-alist-p wrappers-p))
                   (list gensym))))
        ((and (consp form) (eq (car form) 'call-method-list))
         (let ((gensym (get-effective-method-gensym))
                                   generic-function form method-alist-p wrappers-p))
                   (list gensym))))
        ((and (consp form) (eq (car form) 'call-method-list))
         (let ((gensym (get-effective-method-gensym))

-              (type (if (every #'(lambda (form)
-                                   (eq 'fast-method-call
-                                       (make-effective-method-function-type
-                                        generic-function form
-                                        method-alist-p wrappers-p)))
+              (type (if (every (lambda (form)
+                                 (eq 'fast-method-call
+                                     (make-effective-method-fun-type
+                                      generic-function form
+                                      method-alist-p wrappers-p)))

                                (cdr form))
                         'fast-method-call
                         t)))
                                (cdr form))
                         'fast-method-call
                         t)))

@@ -239,9 +270,9 @@
                      generic-function form))))
        ((and (consp form) (eq (car form) 'call-method-list))
         (list (cons '.meth-list.
                      generic-function form))))
        ((and (consp form) (eq (car form) 'call-method-list))
         (list (cons '.meth-list.

-                    (mapcar #'(lambda (form)
-                                (make-effective-method-function-simple
-                                 generic-function form))
+                    (mapcar (lambda (form)
+                              (make-effective-method-function-simple
+                               generic-function form))

                             (cdr form)))))
        (t
         (default-constant-converter form))))
                             (cdr form)))))
        (t
         (default-constant-converter form))))

@@ -249,7 +280,7 @@
 (defun make-effective-method-function-internal
     (generic-function effective-method method-alist-p wrappers-p)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
 (defun make-effective-method-function-internal
     (generic-function effective-method method-alist-p wrappers-p)
   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)

-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)

     (declare (ignore nkeys arg-info))
     (let* ((*rebound-effective-method-gensyms*
            *global-effective-method-gensyms*)
     (declare (ignore nkeys arg-info))
     (let* ((*rebound-effective-method-gensyms*
            *global-effective-method-gensyms*)

@@ -260,45 +291,45 @@
           (effective-method-lambda (expand-effective-method-function
                                     generic-function effective-method)))
       (multiple-value-bind (cfunction constants)
           (effective-method-lambda (expand-effective-method-function
                                     generic-function effective-method)))
       (multiple-value-bind (cfunction constants)

-         (get-function1 effective-method-lambda
-                        #'(lambda (form)
-                            (memf-test-converter form generic-function
-                                                 method-alist-p wrappers-p))
-                        #'(lambda (form)
-                            (memf-code-converter form generic-function
-                                                 metatypes applyp
-                                                 method-alist-p wrappers-p))
-                        #'(lambda (form)
-                            (memf-constant-converter form generic-function)))
-       #'(lambda (method-alist wrappers)
-           (let* ((constants
-                   (mapcar #'(lambda (constant)
-                               (if (consp constant)
-                                   (case (car constant)
-                                     (.meth.
-                                      (funcall (cdr constant)
-                                               method-alist wrappers))
-                                     (.meth-list.
-                                      (mapcar #'(lambda (fn)
-                                                  (funcall fn
-                                                           method-alist
-                                                           wrappers))
-                                              (cdr constant)))
-                                     (t constant))
-                                   constant))
-                           constants))
-                  (function (set-function-name
-                             (apply cfunction constants)
-                             `(combined-method ,name))))
-             (make-fast-method-call :function function
-                                    :arg-info arg-info)))))))
+         (get-fun1 effective-method-lambda
+                   (lambda (form)
+                     (memf-test-converter form generic-function
+                                          method-alist-p wrappers-p))
+                   (lambda (form)
+                     (memf-code-converter form generic-function
+                                          metatypes applyp
+                                          method-alist-p wrappers-p))
+                   (lambda (form)
+                     (memf-constant-converter form generic-function)))
+       (lambda (method-alist wrappers)
+         (let* ((constants
+                 (mapcar (lambda (constant)
+                           (if (consp constant)
+                               (case (car constant)
+                                 (.meth.
+                                  (funcall (cdr constant)
+                                           method-alist wrappers))
+                                 (.meth-list.
+                                  (mapcar (lambda (fn)
+                                            (funcall fn
+                                                     method-alist
+                                                     wrappers))
+                                          (cdr constant)))
+                                 (t constant))
+                               constant))
+                         constants))
+                (function (set-fun-name
+                           (apply cfunction constants)
+                           `(combined-method ,name))))
+           (make-fast-method-call :function function
+                                  :arg-info arg-info)))))))

 
 (defmacro call-method-list (&rest calls)
   `(progn ,@calls))
 
 (defun make-call-methods (methods)
   `(call-method-list
 
 (defmacro call-method-list (&rest calls)
   `(progn ,@calls))
 
 (defun make-call-methods (methods)
   `(call-method-list

-    ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
+    ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))

 
 (defun standard-compute-effective-method (generic-function combin applicable-methods)
   (declare (ignore combin))
 
 (defun standard-compute-effective-method (generic-function combin applicable-methods)
   (declare (ignore combin))

@@ -306,33 +337,48 @@
        (primary ())
        (after ())
        (around ()))
        (primary ())
        (after ())
        (around ()))

-    (dolist (m applicable-methods)
-      (let ((qualifiers (if (listp m)
-                           (early-method-qualifiers m)
-                           (method-qualifiers m))))
-       (cond ((member ':before qualifiers)  (push m before))
-             ((member ':after  qualifiers)  (push m after))
-             ((member ':around  qualifiers) (push m around))
-             (t
-              (push m primary)))))
+    (flet ((lose (method why)
+             (invalid-method-error
+              method
+              "The method ~S ~A.~%~
+               Standard method combination requires all methods to have one~%~
+               of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
+               have no qualifier at all."
+              method why)))
+      (dolist (m applicable-methods)
+        (let ((qualifiers (if (listp m)
+                            (early-method-qualifiers m)
+                            (method-qualifiers m))))
+          (cond
+            ((null qualifiers) (push m primary))
+            ((cdr qualifiers)
+              (lose m "has more than one qualifier"))
+            ((eq (car qualifiers) :around)
+              (push m around))
+            ((eq (car qualifiers) :before)
+              (push m before))
+            ((eq (car qualifiers) :after)
+              (push m after))
+            (t
+              (lose m "has an illegal qualifier"))))))

     (setq before  (reverse before)
          after   (reverse after)
          primary (reverse primary)
          around  (reverse around))
     (cond ((null primary)
     (setq before  (reverse before)
          after   (reverse after)
          primary (reverse primary)
          around  (reverse around))
     (cond ((null primary)

-          `(error "There is no primary method for the generic function ~S."
-                  ',generic-function))
+          `(%no-primary-method ',generic-function .args.))

          ((and (null before) (null after) (null around))
          ((and (null before) (null after) (null around))

-          ;; By returning a single call-method `form' here we enable an
-          ;; important implementation-specific optimization.
+          ;; By returning a single call-method `form' here we enable
+          ;; an important implementation-specific optimization.

           `(call-method ,(first primary) ,(rest primary)))
          (t
           (let ((main-effective-method
                   (if (or before after)
                       `(multiple-value-prog1
           `(call-method ,(first primary) ,(rest primary)))
          (t
           (let ((main-effective-method
                   (if (or before after)
                       `(multiple-value-prog1

-                         (progn ,(make-call-methods before)
-                                (call-method ,(first primary)
-                                             ,(rest primary)))
+                         (progn
+                           ,(make-call-methods before)
+                           (call-method ,(first primary)
+                                        ,(rest primary)))

                          ,(make-call-methods (reverse after)))
                       `(call-method ,(first primary) ,(rest primary)))))
             (if around
                          ,(make-call-methods (reverse after)))
                       `(call-method ,(first primary) ,(rest primary)))))
             (if around

@@ -359,7 +405,7 @@
                                     applicable-methods))
 
 (defun invalid-method-error (method format-control &rest format-arguments)
                                     applicable-methods))
 
 (defun invalid-method-error (method format-control &rest format-arguments)

-  (error "~@<invalid method error for ~2I_~S ~I~_method: ~2I~_~?~:>"
+  (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"

         method
         format-control
         format-arguments))
         method
         format-control
         format-arguments))