X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=a28a1e4bfb41d654e1a3b2a6ed60c9137603d182;hb=7c07a6f965c51828d8f452b47e0620d8e6cf2959;hp=e61f22f85d13131ca0ebe32b1c68f6e8cf7eb424;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index e61f22f..a28a1e4 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -22,9 +22,6 @@ ;;;; specification. (in-package "SB-PCL") - -(sb-int:file-comment - "$Header$") (defun get-method-function (method &optional method-alist wrappers) (let ((fn (cadr (assoc method method-alist)))) @@ -78,7 +75,7 @@ (eq (car method) ':early-method) (method-p method)) (if method-alist-p - 't + t (multiple-value-bind (mf fmf) (if (listp method) (early-method-function method) @@ -203,7 +200,7 @@ method-alist-p wrappers-p))) (cdr form)) 'fast-method-call - 't) + t) (fast-method-call '.fast-call-method-list.) (t @@ -228,7 +225,7 @@ method-alist-p wrappers-p))) (cdr form)) 'fast-method-call - 't))) + t))) (values `(dolist (emf ,gensym nil) ,(make-emf-call metatypes applyp 'emf type)) (list gensym)))) @@ -257,7 +254,7 @@ (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) (name (if (early-gf-p generic-function) - (early-gf-name generic-function) + (!early-gf-name generic-function) (generic-function-name generic-function))) (arg-info (cons nreq applyp)) (effective-method-lambda (expand-effective-method-function @@ -309,15 +306,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) @@ -344,67 +356,30 @@ (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 STANDARD-METHOD-COMBINATION -;;;; classes has to appear here for this reason. This code must conform to -;;;; the code in the file defcombin.lisp, look there for more details. +;;;; The DEFCLASS for the METHOD-COMBINATION and +;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this +;;;; reason. This code must conform to the code in the file +;;;; defcombin.lisp, look there for more details. (defun compute-effective-method (generic-function combin applicable-methods) (standard-compute-effective-method generic-function combin applicable-methods)) -(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)."))) - -;(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) - (declare (arglist method format-string &rest format-arguments)) - (apply *invalid-method-error* args)) - -(defun method-combination-error (&rest args) - (declare (arglist format-string &rest format-arguments)) - (apply *method-combination-error* args)) +(defun invalid-method-error (method format-control &rest format-arguments) + (error "~@" + method + format-control + format-arguments)) -;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))