X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=8c4bd49269975da702316e14953a8c51fbc3cf9d;hb=104ee7ee303efa16e415f5e75df635ac54dba733;hp=342f98f2f195fc94233773985956e179c441dc97;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 342f98f..8c4bd49 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) @@ -73,10 +70,8 @@ (getf (cddr whole) :identity-with-one-argument nil)) (operator (getf (cddr whole) :operator type))) - (make-top-level-form `(define-method-combination ,type) - '(:load-toplevel :execute) - `(load-short-defcombin - ',type ',operator ',identity-with-one-arg ',documentation)))) + `(load-short-defcombin + ',type ',operator ',identity-with-one-arg ',documentation))) (defun load-short-defcombin (type operator ioa doc) (let* ((truename *load-truename*) @@ -92,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 @@ -158,7 +153,7 @@ (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." @@ -179,19 +174,17 @@ (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) - (make-top-level-form `(define-method-combination ,type) - '(:load-toplevel :execute) - `(load-long-defcombin ',type ',documentation #',function))))) + `(load-long-defcombin ',type ',documentation #',function)))) (defvar *long-method-combination-functions* (make-hash-table :test 'eq)) @@ -207,16 +200,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)) @@ -232,7 +225,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) @@ -245,9 +238,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 @@ -264,19 +256,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 ~ @@ -286,14 +278,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 @@ -302,15 +294,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) @@ -318,7 +310,7 @@ (let* ((name (pop method-group-specifier)) (patterns ()) (tests - (gathering1 (collecting) + (let (collect) (block collect-tests (loop (if (or (null method-group-specifier) @@ -327,7 +319,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 @@ -337,7 +331,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,~%~ @@ -370,20 +364,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)))