;; belong here!
(aver (not morep)))))
\f
-(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
;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or
;; unless they're fantastically unintrusive.
(let* ((method-name *method-name*)
+ (method-lambda-list *method-lambda-list*)
+ ;; Macroexpansion caused by code-walking may call make-method-lambda and
+ ;; end up with wrong values
+ (*method-name* nil)
+ (*method-lambda-list* nil)
(generic-function-name (when method-name (car method-name)))
- (specialized-lambda-list (or *method-lambda-list*
+ (specialized-lambda-list (or method-lambda-list
(ecase (car method-lambda)
(lambda (second method-lambda))
(named-lambda (third method-lambda)))))
(finalize-inheritance ,gf-class)))
(remf ,all-keys :generic-function-class)
(remf ,all-keys :environment)
- (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
- (unless (eq combin '.shes-not-there.)
- (setf (getf ,all-keys :method-combination)
- (find-method-combination (class-prototype ,gf-class)
- (car combin)
- (cdr combin)))))
+ (let ((combin (getf ,all-keys :method-combination)))
+ (etypecase combin
+ (cons
+ (setf (getf ,all-keys :method-combination)
+ (find-method-combination (class-prototype ,gf-class)
+ (car combin)
+ (cdr combin))))
+ ((or null method-combination))))
(let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
(unless (eq method-class '.shes-not-there.)
(setf (getf ,all-keys :method-class)
;;; 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))