X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=dacd5209aa812624c941f4e55ae3ced218bf5247;hb=550e5afc7ad95ff1e1bbfe932bf8dd81b0c4dce6;hp=dac7e10c8dc90ba68d0471da27d228cf1482f584;hpb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index dac7e10..dacd520 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -87,20 +87,20 @@ :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))) @@ -124,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) @@ -147,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." @@ -174,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)))) @@ -200,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)) @@ -225,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) @@ -238,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 @@ -257,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 ~ @@ -279,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 @@ -295,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) @@ -311,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) @@ -320,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 @@ -363,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)))