;; 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
applyp))
&body body
&environment env)
- (let* ((all-params (append args (when rest-arg (list rest-arg))))
- (rebindings (when (or setq-p call-next-method-p)
- (mapcar (lambda (x) (list x x)) all-params))))
+ (let* ((rebindings (when (or setq-p call-next-method-p)
+ (mapcar (lambda (x) (list x x)) parameters-setqd))))
(if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
`(locally
,@body)
(declare (optimize (sb-c:insert-step-conditions 0)))
(not (null ,next-method-call))))))
(let ,rebindings
- ,@(when rebindings `((declare (ignorable ,@all-params))))
,@body)))))
;;; CMUCL comment (Gerd Moellmann):
(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))