[Sbcl-commits] master: Slightly better arglist for defmethod.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  0ed4db4a998679b83cdf7978b2c67470dec70b49 (commit)
      from  7b8eb24427562ae9e3ffe77e0a98899b9786e2b1 (commit)

- Log -----------------------------------------------------------------
commit 0ed4db4a998679b83cdf7978b2c67470dec70b49
Author: Stas Boukarev <sta...@gm...>
Date:   Wed Mar 13 12:29:26 2013 +0400

    Slightly better arglist for defmethod.
    
    (defmethod name &rest args) instead of just (defmethod &rest args).
---
 src/pcl/boot.lisp |    9 ++++-----
 src/pcl/env.lisp  |   29 +++++++++++++++--------------
 2 files changed, 19 insertions(+), 19 deletions(-)

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 7189a53..e470eb4 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -318,8 +318,8 @@ bootstrapping.
       ;; belong here!
       (aver (not morep)))))
 
-(defmacro defmethod (&rest args)
-  (multiple-value-bind (name qualifiers lambda-list body)
+(defmacro defmethod (name &rest args)
+  (multiple-value-bind (qualifiers lambda-list body)
       (parse-defmethod args)
     `(progn
       ;; KLUDGE: this double expansion is quite a monumental
@@ -2612,14 +2612,13 @@ bootstrapping.
 ;;; is really implemented.
 (defun parse-defmethod (cdr-of-form)
   (declare (list cdr-of-form))
-  (let ((name (pop cdr-of-form))
-        (qualifiers ())
+  (let ((qualifiers ())
         (spec-ll ()))
     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
               (push (pop cdr-of-form) qualifiers)
               (return (setq qualifiers (nreverse qualifiers)))))
     (setq spec-ll (pop cdr-of-form))
-    (values name qualifiers spec-ll cdr-of-form)))
+    (values qualifiers spec-ll cdr-of-form)))
 
 (defun parse-specializers (generic-function specializers)
   (declare (list specializers))
diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index 61ee08c..3182342 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -43,20 +43,21 @@
                                          (unparse-specializers
                                           (method-specializers method)))
                        (make-symbol (format nil "~S" method))))
-        (multiple-value-bind (gf-spec quals specls)
-            (parse-defmethod spec)
-          (and (setq gf (and (or errorp (fboundp gf-spec))
-                             (gdefinition gf-spec)))
-               (let ((nreq (compute-discriminating-function-arglist-info gf)))
-                 (setq specls (append (parse-specializers specls)
-                                      (make-list (- nreq (length specls))
-                                                 :initial-element
-                                                 *the-class-t*)))
-                 (and
-                   (setq method (get-method gf quals specls errorp))
-                   (setq name
-                         (make-method-spec
-                          gf-spec quals (unparse-specializers specls))))))))
+        (let ((gf-spec (car spec)))
+          (multiple-value-bind (quals specls)
+              (parse-defmethod (cdr spec))
+            (and (setq gf (and (or errorp (fboundp gf-spec))
+                               (gdefinition gf-spec)))
+                 (let ((nreq (compute-discriminating-function-arglist-info gf)))
+                   (setq specls (append (parse-specializers specls)
+                                        (make-list (- nreq (length specls))
+                                                   :initial-element
+                                                   *the-class-t*)))
+                   (and
+                    (setq method (get-method gf quals specls errorp))
+                    (setq name
+                          (make-method-spec
+                           gf-spec quals (unparse-specializers specls)))))))))
     (values gf method name)))
 
 ;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL