X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fcombin.lisp;h=76746897f06ba462d4f69171bef52c20ba8897fe;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=925be9798c5a62edb80ee9e0eeaae45a3d0929e4;hpb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;p=sbcl.git diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 925be97..7674689 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -64,8 +64,10 @@ (make-effective-method-function-internal generic-function form method-alist-p wrappers-p))) -(defun make-effective-method-function-type (generic-function form - method-alist-p wrappers-p) +(defun make-effective-method-fun-type (generic-function + form + method-alist-p + wrappers-p) (if (and (listp form) (eq (car form) 'call-method)) (let* ((cm-args (cdr form)) @@ -86,7 +88,7 @@ 'fast-method-call 'method-call)))) (if (and (consp method) (eq (car method) 'make-method)) - (make-effective-method-function-type + (make-effective-method-fun-type generic-function (cadr method) method-alist-p wrappers-p) (type-of method))))) 'fast-method-call)) @@ -186,7 +188,7 @@ (defun memf-test-converter (form generic-function method-alist-p wrappers-p) (cond ((and (consp form) (eq (car form) 'call-method)) - (case (make-effective-method-function-type + (case (make-effective-method-fun-type generic-function form method-alist-p wrappers-p) (fast-method-call '.fast-call-method.) @@ -195,7 +197,7 @@ ((and (consp form) (eq (car form) 'call-method-list)) (case (if (every #'(lambda (form) (eq 'fast-method-call - (make-effective-method-function-type + (make-effective-method-fun-type generic-function form method-alist-p wrappers-p))) (cdr form)) @@ -213,14 +215,14 @@ (cond ((and (consp form) (eq (car form) 'call-method)) (let ((gensym (get-effective-method-gensym))) (values (make-emf-call metatypes applyp gensym - (make-effective-method-function-type + (make-effective-method-fun-type generic-function form method-alist-p wrappers-p)) (list gensym)))) ((and (consp form) (eq (car form) 'call-method-list)) (let ((gensym (get-effective-method-gensym)) (type (if (every #'(lambda (form) (eq 'fast-method-call - (make-effective-method-function-type + (make-effective-method-fun-type generic-function form method-alist-p wrappers-p))) (cdr form)) @@ -287,7 +289,7 @@ (t constant)) constant)) constants)) - (function (set-function-name + (function (set-fun-name (apply cfunction constants) `(combined-method ,name)))) (make-fast-method-call :function function @@ -306,15 +308,30 @@ (primary ()) (after ()) (around ())) - (dolist (m applicable-methods) - (let ((qualifiers (if (listp m) - (early-method-qualifiers m) - (method-qualifiers m)))) - (cond ((member ':before qualifiers) (push m before)) - ((member ':after qualifiers) (push m after)) - ((member ':around qualifiers) (push m around)) - (t - (push m primary))))) + (flet ((lose (method why) + (invalid-method-error + method + "The method ~S ~A.~%~ + Standard method combination requires all methods to have one~%~ + of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~ + have no qualifier at all." + method why))) + (dolist (m applicable-methods) + (let ((qualifiers (if (listp m) + (early-method-qualifiers m) + (method-qualifiers m)))) + (cond + ((null qualifiers) (push m primary)) + ((cdr qualifiers) + (lose m "has more than one qualifier")) + ((eq (car qualifiers) :around) + (push m around)) + ((eq (car qualifiers) :before) + (push m before)) + ((eq (car qualifiers) :after) + (push m after)) + (t + (lose m "has an illegal qualifier")))))) (setq before (reverse before) after (reverse after) primary (reverse primary) @@ -341,10 +358,11 @@ (make-method ,main-effective-method))) main-effective-method)))))) -;;;; the STANDARD method combination type. This is coded by hand (rather than -;;;; with define-method-combination) for bootstrapping and efficiency reasons. -;;;; Note that the definition of the find-method-combination-method appears in -;;;; the file defcombin.lisp. This is because EQL methods can't appear in the +;;;; the STANDARD method combination type. This is coded by hand +;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping +;;;; and efficiency reasons. Note that the definition of the +;;;; FIND-METHOD-COMBINATION-METHOD appears in the file +;;;; defcombin.lisp. This is because EQL methods can't appear in the ;;;; bootstrap. ;;;; ;;;; The DEFCLASS for the METHOD-COMBINATION and @@ -357,52 +375,13 @@ combin applicable-methods)) -;;; FIXME: As of sbcl-0.6.10, the bindings of *INVALID-METHOD-ERROR* -;;; and *METHOD-COMBINATION-ERROR* are never changed, even within the -;;; dynamic scope of method combination functions. -(defvar *invalid-method-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) -(defvar *method-combination-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) +(defun invalid-method-error (method format-control &rest format-arguments) + (error "~@" + method + format-control + format-arguments)) -;(defmethod compute-effective-method :around ;issue with magic -; ((generic-function generic-function) ;generic functions -; (method-combination method-combination) -; applicable-methods) -; (declare (ignore applicable-methods)) -; (flet ((real-invalid-method-error (method format-string &rest args) -; (declare (ignore method)) -; (apply #'error format-string args)) -; (real-method-combination-error (format-string &rest args) -; (apply #'error format-string args))) -; (let ((*invalid-method-error* #'real-invalid-method-error) -; (*method-combination-error* #'real-method-combination-error)) -; (call-next-method)))) - -(defun invalid-method-error (&rest args) - (apply *invalid-method-error* args)) - -(defun method-combination-error (&rest args) - (apply *method-combination-error* args)) - -;This definition now appears in defcombin.lisp. -; -;(defmethod find-method-combination ((generic-function generic-function) -; (type (eql 'standard)) -; options) -; (when options -; (method-combination-error -; "The method combination type STANDARD accepts no options.")) -; *standard-method-combination*) +(defun method-combination-error (format-control &rest format-arguments) + (error "~@" + format-control + format-arguments))