',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)))
(let ((type (method-combination-type combin))
(operator (short-combination-operator combin))
(ioa (short-combination-identity-with-one-argument combin))
+ (order (car (method-combination-options combin)))
(around ())
(primary ()))
(dolist (m applicable-methods)
(push m primary))
(t
(lose m "has an illegal qualifier"))))))
- (setq around (nreverse around)
- primary (nreverse primary))
+ (setq around (nreverse around))
+ (ecase order
+ (:most-specific-last) ; nothing to be done, already in correct order
+ (:most-specific-first
+ (setq primary (nreverse primary))))
(let ((main-method
(if (and (null (cdr primary))
(not (null ioa)))
(declare (ignore nms cm-args))
(apply
(lambda (generic-function type options)
- (declare (ignore generic-function options))
+ (declare (ignore generic-function))
(make-instance 'long-method-combination
:type type
+ :options options
: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)