',type ',operator ',identity-with-one-arg ',documentation)))
(defun load-short-defcombin (type operator ioa doc)
- (let* ((truename *load-truename*)
+ (let* ((pathname *load-pathname*)
(specializers
(list (find-class 'generic-function)
(intern-eql-specializer type)
(short-combine-methods
type options operator ioa new-method doc))
args))
- :definition-source `((define-method-combination ,type) ,truename)))
+ :definition-source `((define-method-combination ,type) ,pathname)))
(when old-method
(remove-method #'find-method-combination old-method))
- (add-method #'find-method-combination new-method)))
+ (add-method #'find-method-combination new-method)
+ type))
(defun short-combine-methods (type options operator ioa method doc)
(cond ((null options) (setq options '(:most-specific-first)))
:documentation doc))
args))
:definition-source `((define-method-combination ,type)
- ,*load-truename*))))
+ ,*load-pathname*))))
(setf (gethash type *long-method-combination-functions*) function)
(when old-method (remove-method #'find-method-combination old-method))
- (add-method #'find-method-combination new-method)))
+ (add-method #'find-method-combination new-method)
+ type))
(defmethod compute-effective-method ((generic-function generic-function)
(combin long-method-combination)
(defun make-long-method-combination-function
(type ll method-group-specifiers args-option gf-var body)
- ;;(declare (values documentation function))
(declare (ignore type))
- (multiple-value-bind (documentation declarations real-body)
- (extract-declarations body)
+ (multiple-value-bind (real-body declarations documentation)
+ ;; (Note that PARSE-BODY ignores its second arg ENVIRONMENT.)
+ (parse-body body nil)
(let ((wrapped-body
(wrap-method-group-specifier-bindings method-group-specifiers
(push name names)
(push specializer-cache specializer-caches)
(push `((or ,@tests)
- (if (equal ,specializer-cache .specializers.)
- (return-from .long-method-combination-function.
- '(error "More than one method of type ~S ~
+ (if (and (equal ,specializer-cache .specializers.)
+ (not (null .specializers.)))
+ (return-from .long-method-combination-function.
+ '(error "More than one method of type ~S ~
with the same specializers."
- ',name))
- (setq ,specializer-cache .specializers.))
- (push .method. ,name))
- cond-clauses)
+ ',name))
+ (setq ,specializer-cache .specializers.))
+ (push .method. ,name))
+ cond-clauses)
(when required
(push `(when (null ,name)
(return-from .long-method-combination-function.
(dolist (.method. .applicable-methods.)
(let ((.qualifiers. (method-qualifiers .method.))
(.specializers. (method-specializers .method.)))
- (progn .qualifiers. .specializers.)
+ (declare (ignorable .qualifiers. .specializers.))
(cond ,@(nreverse cond-clauses))))
,@(nreverse required-checks)
,@(nreverse order-cleanups)