X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=dacd5209aa812624c941f4e55ae3ced218bf5247;hb=550e5afc7ad95ff1e1bbfe932bf8dd81b0c4dce6;hp=ba355bebee13d6a11586ac5d4fcb0dc0a9d9dfca;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index ba355be..dacd520 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -32,15 +32,12 @@ ;;;; 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) @@ -90,29 +87,29 @@ :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 @@ -127,6 +124,7 @@ (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) @@ -150,13 +148,16 @@ (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))) `(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." @@ -177,15 +178,15 @@ (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)))) @@ -203,16 +204,16 @@ :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)) @@ -228,7 +229,7 @@ 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) @@ -241,9 +242,8 @@ (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 @@ -260,19 +260,19 @@ (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 ~ @@ -282,14 +282,14 @@ (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 @@ -298,15 +298,15 @@ (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) @@ -314,7 +314,7 @@ (let* ((name (pop method-group-specifier)) (patterns ()) (tests - (gathering1 (collecting) + (let (collect) (block collect-tests (loop (if (or (null method-group-specifier) @@ -323,7 +323,9 @@ (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 @@ -333,7 +335,7 @@ (defun parse-qualifier-pattern (name pattern) (cond ((eq pattern '()) `(null .qualifiers.)) - ((eq pattern '*) 't) + ((eq pattern '*) t) ((symbolp pattern) `(,pattern .qualifiers.)) ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) (t (error "In the method group specifier ~S,~%~ @@ -366,20 +368,19 @@ ;;; ;;; 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)))