;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
(defun get-method-function (method &optional method-alist wrappers)
(let ((fn (cadr (assoc method method-alist))))
(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)
method-alist-p wrappers-p)))
(cdr form))
'fast-method-call
- 't)
+ t)
(fast-method-call
'.fast-call-method-list.)
(t
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))))
(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
(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)
(make-method ,main-effective-method)))
main-effective-method))))))
\f
-;;;; 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 "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
+ 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 "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
+ format-control
+ format-arguments))
projects / sbcl.git / blobdiff