(make-effective-method-function-simple generic-function form)
;; We have some sort of `real' effective method. Go off and get a
;; compiled function for it. Most of the real hair here is done by
- ;; the GET-FUNCTION mechanism.
+ ;; the GET-FUN mechanism.
(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))
(method (car cm-args)))
(when method
(if (if (listp method)
- (eq (car method) ':early-method)
+ (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)
'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))
(defun make-effective-method-function-simple
(generic-function form &optional no-fmf-p)
- ;; The effective method is just a call to call-method. This opens up
+ ;; The effective method is just a call to CALL-METHOD. This opens up
;; the possibility of just using the method function of the method as
;; the effective method function.
;;
(null (cddr cm-args))))
(method (car cm-args))
(cm-args1 (cdr cm-args)))
- #'(lambda (method-alist wrappers)
- (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
- method-alist wrappers))))
+ (lambda (method-alist wrappers)
+ (make-effective-method-function-simple1 generic-function
+ method
+ cm-args1
+ fmf-p
+ method-alist
+ wrappers))))
(defun make-emf-from-method
(method cm-args &optional gf fmf-p method-alist wrappers)
gf (car next-methods)
(list* (cdr next-methods) (cdr cm-args))
fmf-p method-alist wrappers))
- (arg-info (method-function-get fmf ':arg-info)))
+ (arg-info (method-function-get fmf :arg-info)))
(make-fast-method-call :function fmf
:pv-cell pv-cell
:next-method-call next
(gf method cm-args fmf-p &optional method-alist wrappers)
(when method
(if (if (listp method)
- (eq (car method) ':early-method)
+ (eq (car method) :early-method)
(method-p method))
(make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
(if (and (consp method) (eq (car method) 'make-method))
(defun expand-effective-method-function (gf effective-method &optional env)
(declare (ignore env))
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info gf)
+ (get-generic-fun-info gf)
(declare (ignore nreq nkeys arg-info))
(let ((ll (make-fast-method-call-lambda-list metatypes applyp))
- ;; When there are no primary methods and a next-method call occurs
- ;; effective-method is (error "No mumble..") and the defined
- ;; args are not used giving a compiler warning.
- (error-p (eq (first effective-method) 'error)))
- `(lambda ,ll
- (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
- ,effective-method))))
+ (error-p (eq (first effective-method) '%no-primary-method))
+ (mc-args-p
+ (when (eq *boot-state* 'complete)
+ ;; Otherwise the METHOD-COMBINATION slot is not bound.
+ (let ((combin (generic-function-method-combination gf)))
+ (and (long-method-combination-p combin)
+ (long-method-combination-args-lambda-list combin))))))
+ (cond
+ (error-p
+ `(lambda (.pv-cell. .next-method-call. &rest .args.)
+ (declare (ignore .pv-cell. .next-method-call.))
+ (flet ((%no-primary-method (gf args)
+ (apply #'no-primary-method gf args)))
+ ,effective-method)))
+ (mc-args-p
+ (let* ((required
+ ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp
+ (let (req)
+ (dotimes (i (length metatypes) (nreverse req))
+ (push (dfun-arg-symbol i) req))))
+ (gf-args (if applyp
+ `(list* ,@required .dfun-rest-arg.)
+ `(list ,@required))))
+ `(lambda ,ll
+ (declare (ignore .pv-cell. .next-method-call.))
+ (let ((.gf-args. ,gf-args))
+ (declare (ignorable .gf-args.))
+ ,effective-method))))
+ (t
+ `(lambda ,ll
+ (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
+ ,effective-method))))))
(defun expand-emf-call-method (gf form metatypes applyp env)
(declare (ignore gf metatypes applyp env))
(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.)
(t
'.call-method.)))
((and (consp form) (eq (car form) 'call-method-list))
- (case (if (every #'(lambda (form)
- (eq 'fast-method-call
- (make-effective-method-function-type
- generic-function form
- method-alist-p wrappers-p)))
+ (case (if (every (lambda (form)
+ (eq 'fast-method-call
+ (make-effective-method-fun-type
+ generic-function form
+ method-alist-p wrappers-p)))
(cdr form))
'fast-method-call
- 't)
+ t)
(fast-method-call
'.fast-call-method-list.)
(t
(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
- generic-function form
- method-alist-p wrappers-p)))
+ (type (if (every (lambda (form)
+ (eq 'fast-method-call
+ (make-effective-method-fun-type
+ generic-function form
+ 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))))
generic-function form))))
((and (consp form) (eq (car form) 'call-method-list))
(list (cons '.meth-list.
- (mapcar #'(lambda (form)
- (make-effective-method-function-simple
- generic-function form))
+ (mapcar (lambda (form)
+ (make-effective-method-function-simple
+ generic-function form))
(cdr form)))))
(t
(default-constant-converter form))))
(defun make-effective-method-function-internal
(generic-function effective-method method-alist-p wrappers-p)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info generic-function)
+ (get-generic-fun-info generic-function)
(declare (ignore nkeys arg-info))
(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
generic-function effective-method)))
(multiple-value-bind (cfunction constants)
- (get-function1 effective-method-lambda
- #'(lambda (form)
- (memf-test-converter form generic-function
- method-alist-p wrappers-p))
- #'(lambda (form)
- (memf-code-converter form generic-function
- metatypes applyp
- method-alist-p wrappers-p))
- #'(lambda (form)
- (memf-constant-converter form generic-function)))
- #'(lambda (method-alist wrappers)
- (let* ((constants
- (mapcar #'(lambda (constant)
- (if (consp constant)
- (case (car constant)
- (.meth.
- (funcall (cdr constant)
- method-alist wrappers))
- (.meth-list.
- (mapcar #'(lambda (fn)
- (funcall fn
- method-alist
- wrappers))
- (cdr constant)))
- (t constant))
- constant))
- constants))
- (function (set-function-name
- (apply cfunction constants)
- `(combined-method ,name))))
- (make-fast-method-call :function function
- :arg-info arg-info)))))))
+ (get-fun1 effective-method-lambda
+ (lambda (form)
+ (memf-test-converter form generic-function
+ method-alist-p wrappers-p))
+ (lambda (form)
+ (memf-code-converter form generic-function
+ metatypes applyp
+ method-alist-p wrappers-p))
+ (lambda (form)
+ (memf-constant-converter form generic-function)))
+ (lambda (method-alist wrappers)
+ (let* ((constants
+ (mapcar (lambda (constant)
+ (if (consp constant)
+ (case (car constant)
+ (.meth.
+ (funcall (cdr constant)
+ method-alist wrappers))
+ (.meth-list.
+ (mapcar (lambda (fn)
+ (funcall fn
+ method-alist
+ wrappers))
+ (cdr constant)))
+ (t constant))
+ constant))
+ constants))
+ (function (set-fun-name
+ (apply cfunction constants)
+ `(combined-method ,name))))
+ (make-fast-method-call :function function
+ :arg-info arg-info)))))))
(defmacro call-method-list (&rest calls)
`(progn ,@calls))
(defun make-call-methods (methods)
`(call-method-list
- ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
+ ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
(defun standard-compute-effective-method (generic-function combin applicable-methods)
(declare (ignore combin))
(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)
around (reverse around))
(cond ((null primary)
- `(error "There is no primary method for the generic function ~S."
- ',generic-function))
+ `(%no-primary-method ',generic-function .args.))
((and (null before) (null after) (null around))
- ;; By returning a single call-method `form' here we enable an
- ;; important implementation-specific optimization.
+ ;; By returning a single call-method `form' here we enable
+ ;; an important implementation-specific optimization.
`(call-method ,(first primary) ,(rest primary)))
(t
(let ((main-effective-method
(if (or before after)
`(multiple-value-prog1
- (progn ,(make-call-methods before)
- (call-method ,(first primary)
- ,(rest primary)))
+ (progn
+ ,(make-call-methods before)
+ (call-method ,(first primary)
+ ,(rest primary)))
,(make-call-methods (reverse after)))
`(call-method ,(first primary) ,(rest primary)))))
(if around
(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