From 0ed4db4a998679b83cdf7978b2c67470dec70b49 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Wed, 13 Mar 2013 12:29:26 +0400 Subject: [PATCH] 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 -- 1.7.10.4