diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index 0cee6a4d5..ba654356f 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -26,18 +26,6 @@ ;;; it should be enough with a couple of different closures and hence ;;; the structural comparison is a loss of time. -;;; -;;; This function produces an effective method associated to the form -;;; (CALL-METHOD-FUNCTION method rest-methods) -;;; -(defun combine-method-functions (method rest-methods) - (declare (si::c-local)) - (setf method (effective-method-function method) - rest-methods (mapcar #'effective-method-function rest-methods)) - #'(lambda (&rest .combined-method-args.) - (let ((*next-methods* rest-methods)) - (apply method .combined-method-args.)))) - ;;; ;;; This is the core routine. It produces effective methods (i.e. ;;; functions) out of the forms generated by the method combinators. @@ -54,6 +42,8 @@ ;;; the forms in a null environment. This is the only form ;;; that may lead to consing of new bytecodes objects. Nested ;;; CALL-METHOD are handled via the global macro CALL-METHOD. +;;; 5) Ordinary forms are turned into lambda forms, much like +;;; what happens with the content of MAKE-METHOD. ;;; (defun effective-method-function (form) (if (atom form) @@ -65,7 +55,9 @@ (error "Malformed effective method form:~%~A" form))) (case (first form) (CALL-METHOD - (combine-method-functions (second form) (third form))) + (combine-method-functions + (effective-method-function (second form)) + (mapcar #'effective-method-function (third form)))) (MAKE-METHOD (setq form (second form)) (coerce `(lambda (&rest .combined-method-args.) ,form) @@ -74,15 +66,24 @@ (coerce `(lambda (&rest .combined-method-args.) ,form) 'function))))) +;;; +;;; This function is a combinator of effective methods. It creates a +;;; closure that invokes the first method while passing the information +;;; of the remaining methods. The resulting closure (or effective method) +;;; is the equivalent of (CALL-METHOD method rest-methods) +;;; +(defun combine-method-functions (method rest-methods) + (declare (si::c-local)) + #'(lambda (&rest .combined-method-args.) + (let ((*next-methods* rest-methods)) + (apply method .combined-method-args.)))) + (defmacro call-method (method rest-methods) (setq method (effective-method-function method) rest-methods (mapcar #'effective-method-function rest-methods)) `(let ((*next-methods* ,rest-methods)) (apply ,method .combined-method-args.))) -(defun make-method-call (method &optional next-methods) - `(CALL-METHOD ,method ,next-methods)) - (defun error-qualifier (m qualifier) (declare (si::c-local)) (error "Standard method combination allows only one qualifier ~ @@ -90,38 +91,37 @@ a method with ~S was found." m qualifier)) -#+nil (defun standard-main-effective-method (before primary after) - (setf before (mapcar #'effective-method-function before) - after (mapcar #'effective-method-function after) - primary (mapcar #'effective-method-function primary)) + (declare (si::c-local)) #'(lambda (&rest .combined-method-args.) (let ((*next-methods* nil)) (declare (special *next-methods*)) (dolist (i before) (apply i .combined-method-args.)) - (multiple-value-prog1 - (progn - (setf *next-methods* (rest primary)) - (apply (first primary) .combined-method-args.)) - (setf *next-methods* nil) - (dolist (i after) - (apply i .combined-method-args.)))))) + (setf *next-methods* (rest primary)) + (if after + (multiple-value-prog1 + (apply (first primary) .combined-method-args.) + (setf *next-methods* nil) + (dolist (i after) + (apply i .combined-method-args.))) + (apply (first primary) .combined-method-args.))))) (defun standard-compute-effective-method (gf methods) - (declare (ignore gf)) - (let*((before ()) - (primary ()) - (after ()) - (around ())) + (declare (si::c-local)) + (let* ((before ()) + (primary ()) + (after ()) + (around ())) (dolist (m methods) - (let ((qualifiers (method-qualifiers m))) - (cond ((null qualifiers) (push m primary)) + (let* ((qualifiers (method-qualifiers m)) + (f (method-function m))) + (cond ((null qualifiers) (push f primary)) ((rest qualifiers) (error-qualifier m qualifiers)) ((eq (setq qualifiers (first qualifiers)) :BEFORE) - (push m before)) - ((eq qualifiers :AFTER) (push m after)) - ((eq qualifiers :AROUND) (push m around)) + (push f before)) + ((eq qualifiers :AFTER) (push f after)) + ((eq qualifiers :AROUND) (push f around)) (t (error-qualifier m qualifiers))))) ;; When there are no primary methods, an error is to be signaled, ;; and we need not care about :AROUND, :AFTER or :BEFORE methods. @@ -129,27 +129,23 @@ (return-from standard-compute-effective-method #'(lambda (&rest args) (apply 'no-primary-method gf args)))) - (setq before (nreverse before) ;; most-specific-first order (ANSI 7.6.6.2) - after after ;; least-specific-first order (ANSI 7.6.6.2) - primary (nreverse primary) - around (nreverse around)) - (if (and (null before) - (null after)) - (if (null around) - ;; By returning a single call-method `form' here we enable - ;; an important implementation-specific optimization. - (combine-method-functions (first primary) (rest primary)) - (combine-method-functions (first around) - (append (rest around) primary))) - (let ((main (effective-method-function - `(PROGN ,@(mapcar #'make-method-call before) - (MULTIPLE-VALUE-PROG1 - (CALL-METHOD ,(first primary) ,(rest primary)) - ,@(mapcar #'make-method-call after)))))) - (if around - (combine-method-functions (first around) - (append (rest around) main)) - main))))) + ;; PRIMARY, BEFORE and AROUND are reversed because they have to + ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER + ;; may remain as it is because it is least-specific-order. + (setf primary (nreverse primary) + before (nreverse before)) + (if around + (let ((main (if (or before after) + (list + (standard-main-effective-method before primary after)) + primary))) + (setf around (nreverse around)) + (combine-method-functions (first around) + (nconc (rest around) main))) + (if (or before after) + (standard-main-effective-method before primary after) + (combine-method-functions (first primary) (rest primary)))) + )) ;; ---------------------------------------------------------------------- ;; DEFINE-METHOD-COMBINATION