\f
;;;; standard method combination
-;;; The STANDARD method combination type is implemented directly by the class
-;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does
-;;; standard method combination directly and is defined by hand in the file
-;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this
-;;; file for bootstrapping reasons.
-;;;
-;;; A commented out copy of this definition appears in combin.lisp.
-;;; If you change this definition here, be sure to change it there
-;;; also.
+;;; The STANDARD method combination type is implemented directly by
+;;; the class STANDARD-METHOD-COMBINATION. The method on
+;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly
+;;; and is defined by hand in the file combin.lisp. The method for
+;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping
+;;; reasons.
(defmethod find-method-combination ((generic-function generic-function)
(type (eql 'standard))
options)
:qualifiers ()
:specializers specializers
:lambda-list '(generic-function type options)
- :function #'(lambda(args nms &rest cm-args)
- (declare (ignore nms cm-args))
- (apply
- #'(lambda (gf type options)
- (declare (ignore gf))
- (do-short-method-combination
- type options operator ioa new-method doc))
- args))
+ :function (lambda (args nms &rest cm-args)
+ (declare (ignore nms cm-args))
+ (apply
+ (lambda (gf type options)
+ (declare (ignore gf))
+ (short-combine-methods
+ type options operator ioa new-method doc))
+ args))
:definition-source `((define-method-combination ,type) ,truename)))
(when old-method
(remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)))
-(defun do-short-method-combination (type options operator ioa method doc)
+(defun short-combine-methods (type options operator ioa method doc)
(cond ((null options) (setq options '(:most-specific-first)))
((equal options '(:most-specific-first)))
((equal options '(:most-specific-last)))
(t
(method-combination-error
- "Illegal options to a short method combination type.~%~
- The method combination type ~S accepts one option which~%~
- must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
- type)))
+ "Illegal options to a short method combination type.~%~
+ The method combination type ~S accepts one option which~%~
+ must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
+ type)))
(make-instance 'short-method-combination
:type type
:options options
(if (and (null (cdr primary))
(not (null ioa)))
`(call-method ,(car primary) ())
- `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
+ `(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
primary)))))
(cond ((null primary)
`(error "No ~S methods for the generic function ~S."
(lambda-list (caddr form))
(method-group-specifiers (cadddr form))
(body (cddddr form))
- (arguments-option ())
+ (args-option ())
(gf-var nil))
(when (and (consp (car body)) (eq (caar body) :arguments))
- (setq arguments-option (cdr (pop body))))
+ (setq args-option (cdr (pop body))))
(when (and (consp (car body)) (eq (caar body) :generic-function))
(setq gf-var (cadr (pop body))))
(multiple-value-bind (documentation function)
(make-long-method-combination-function
- type lambda-list method-group-specifiers arguments-option gf-var
+ type lambda-list method-group-specifiers args-option gf-var
body)
`(load-long-defcombin ',type ',documentation #',function))))
:qualifiers ()
:specializers specializers
:lambda-list '(generic-function type options)
- :function #'(lambda (args nms &rest cm-args)
- (declare (ignore nms cm-args))
- (apply
- #'(lambda (generic-function type options)
- (declare (ignore generic-function options))
- (make-instance 'long-method-combination
- :type type
- :documentation doc))
- args))
- :definition-source `((define-method-combination ,type)
+ :function (lambda (args nms &rest cm-args)
+ (declare (ignore nms cm-args))
+ (apply
+ (lambda (generic-function type options)
+ (declare (ignore generic-function options))
+ (make-instance 'long-method-combination
+ :type type
+ :documentation doc))
+ args))
+ :definition-source `((define-method-combination ,type)
,*load-truename*))))
(setf (gethash type *long-method-combination-functions*) function)
(when old-method (remove-method #'find-method-combination old-method))
applicable-methods))
(defun make-long-method-combination-function
- (type ll method-group-specifiers arguments-option gf-var body)
+ (type ll method-group-specifiers args-option gf-var body)
;;(declare (values documentation function))
(declare (ignore type))
(multiple-value-bind (documentation declarations real-body)
(when gf-var
(push `(,gf-var .generic-function.) (cadr wrapped-body)))
- (when arguments-option
- (setq wrapped-body (deal-with-arguments-option wrapped-body
- arguments-option)))
+ (when args-option
+ (setq wrapped-body (deal-with-args-option wrapped-body args-option)))
(when ll
(setq wrapped-body
(defun wrap-method-group-specifier-bindings
(method-group-specifiers declarations real-body)
- (with-gathering ((names (collecting))
- (specializer-caches (collecting))
- (cond-clauses (collecting))
- (required-checks (collecting))
- (order-cleanups (collecting)))
+ (let (names
+ specializer-caches
+ cond-clauses
+ required-checks
+ order-cleanups)
(dolist (method-group-specifier method-group-specifiers)
(multiple-value-bind (name tests description order required)
(parse-method-group-specifier method-group-specifier)
(declare (ignore description))
(let ((specializer-cache (gensym)))
- (gather name names)
- (gather specializer-cache specializer-caches)
- (gather `((or ,@tests)
+ (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 ~
(push .method. ,name))
cond-clauses)
(when required
- (gather `(when (null ,name)
+ (push `(when (null ,name)
(return-from .long-method-combination-function.
'(error "No ~S methods." ',name)))
required-checks))
(loop (unless (and (constantp order)
(neq order (setq order (eval order))))
(return t)))
- (gather (cond ((eq order :most-specific-first)
+ (push (cond ((eq order :most-specific-first)
`(setq ,name (nreverse ,name)))
((eq order :most-specific-last) ())
(t
(setq ,name (nreverse ,name)))
(:most-specific-last))))
order-cleanups))))
- `(let (,@names ,@specializer-caches)
+ `(let (,@(nreverse names) ,@(nreverse specializer-caches))
,@declarations
(dolist (.method. .applicable-methods.)
(let ((.qualifiers. (method-qualifiers .method.))
(.specializers. (method-specializers .method.)))
(progn .qualifiers. .specializers.)
- (cond ,@cond-clauses)))
- ,@required-checks
- ,@order-cleanups
+ (cond ,@(nreverse cond-clauses))))
+ ,@(nreverse required-checks)
+ ,@(nreverse order-cleanups)
,@real-body)))
(defun parse-method-group-specifier (method-group-specifier)
(let* ((name (pop method-group-specifier))
(patterns ())
(tests
- (gathering1 (collecting)
+ (let (collect)
(block collect-tests
(loop
(if (or (null method-group-specifier)
(return-from collect-tests t)
(let ((pattern (pop method-group-specifier)))
(push pattern patterns)
- (gather1 (parse-qualifier-pattern name pattern)))))))))
+ (push (parse-qualifier-pattern name pattern)
+ collect)))))
+ (nreverse collect))))
(values name
tests
(getf method-group-specifier :description
;;;
;;; At compute-effective-method time, the symbols in the :arguments
;;; option are bound to the symbols in the intercept lambda list.
-(defun deal-with-arguments-option (wrapped-body arguments-option)
+(defun deal-with-args-option (wrapped-body args-option)
(let* ((intercept-lambda-list
- (gathering1 (collecting)
- (dolist (arg arguments-option)
+ (let (collect)
+ (dolist (arg args-option)
(if (memq arg lambda-list-keywords)
- (gather1 arg)
- (gather1 (gensym))))))
+ (push arg collect)
+ (push (gensym) collect)))
+ (nreverse collect)))
(intercept-rebindings
- (gathering1 (collecting)
- (iterate ((arg (list-elements arguments-option))
- (int (list-elements intercept-lambda-list)))
- (unless (memq arg lambda-list-keywords)
- (gather1 `(,arg ',int)))))))
-
+ (loop for arg in args-option
+ for int in intercept-lambda-list
+ unless (memq arg lambda-list-keywords)
+ collect `(,arg ',int))))
(setf (cadr wrapped-body)
(append intercept-rebindings (cadr wrapped-body)))
projects / sbcl.git / blobdiff