mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
ba76af0b22
Prompted by a report by Daniel Kochmański: rework the keyword argument checking in effective methods. The checking needs to be inserted by the caller of compute-effective-method; it should be orthogonal to the effective method computation. The fact that SBCL elides the checking in the dispatch function, instead relying on the effective method function to perform the check, is an implementation detail, and the presence of the local pseudo-macro in the standard effective method causes problems to particular custom uses of the MOP, for example the very simple implementation of COMPUTE-DISCRIMINATING-FUNCTION in the new test file. As a (very welcome) side effect, this fixes the fact that we apparently did not perform keyword applicability checking if there were applicable auxiliary methods on the generic function.
664 lines
31 KiB
Common Lisp
664 lines
31 KiB
Common Lisp
;;;; This software is part of the SBCL system. See the README file for
|
||
;;;; more information.
|
||
|
||
;;;; This software is derived from software originally released by Xerox
|
||
;;;; Corporation. Copyright and release statements follow. Later modifications
|
||
;;;; to the software are in the public domain and are provided with
|
||
;;;; absolutely no warranty. See the COPYING and CREDITS files for more
|
||
;;;; information.
|
||
|
||
;;;; copyright information from original PCL sources:
|
||
;;;;
|
||
;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
|
||
;;;; All rights reserved.
|
||
;;;;
|
||
;;;; Use and copying of this software and preparation of derivative works based
|
||
;;;; upon this software are permitted. Any distribution of this software or
|
||
;;;; derivative works must comply with all applicable United States export
|
||
;;;; control laws.
|
||
;;;;
|
||
;;;; This software is made available AS IS, and Xerox Corporation makes no
|
||
;;;; warranty about the software, its performance or its conformity to any
|
||
;;;; specification.
|
||
|
||
(in-package "SB-PCL")
|
||
|
||
(defun get-method-function (method &optional method-alist wrappers)
|
||
(let ((fn (cadr (assoc method method-alist))))
|
||
(if fn
|
||
(values fn nil nil nil)
|
||
(multiple-value-bind (mf fmf)
|
||
(if (listp method)
|
||
(early-method-function method)
|
||
(values nil (safe-method-fast-function method)))
|
||
(let* ((pv-table (and fmf (method-plist-value method :pv-table))))
|
||
(if (and fmf (or (null pv-table) wrappers))
|
||
(let* ((pv-wrappers (when pv-table
|
||
(pv-wrappers-from-all-wrappers
|
||
pv-table wrappers)))
|
||
(pv (when (and pv-table pv-wrappers)
|
||
(pv-table-lookup pv-table pv-wrappers))))
|
||
(values mf t fmf pv))
|
||
(values
|
||
(or mf (if (listp method)
|
||
(bug "early method with no method-function")
|
||
(method-function method)))
|
||
t nil nil)))))))
|
||
|
||
(defun make-effective-method-function (generic-function form &optional
|
||
method-alist wrappers)
|
||
(funcall (make-effective-method-function1 generic-function form
|
||
(not (null method-alist))
|
||
(not (null wrappers)))
|
||
method-alist wrappers))
|
||
|
||
(defun make-effective-method-function1 (generic-function form
|
||
method-alist-p wrappers-p)
|
||
(if (and (listp form)
|
||
(eq (car form) 'call-method)
|
||
(not (gf-requires-emf-keyword-checks generic-function)))
|
||
(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-FUN mechanism.
|
||
(make-effective-method-function-internal 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)
|
||
(method-p method))
|
||
(if method-alist-p
|
||
t
|
||
(multiple-value-bind (mf fmf)
|
||
(if (listp method)
|
||
(early-method-function method)
|
||
(values nil (safe-method-fast-function method)))
|
||
(declare (ignore mf))
|
||
(let* ((pv-table (and fmf (method-plist-value method :pv-table))))
|
||
(if (and fmf (or (null pv-table) wrappers-p))
|
||
'fast-method-call
|
||
'method-call))))
|
||
(if (and (consp method) (eq (car method) 'make-method))
|
||
(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 possibility of just using the method function of the method as
|
||
;; the effective method function.
|
||
;;
|
||
;; But we have to be careful. If that method function will ask for
|
||
;; the next methods we have to provide them. We do not look to see
|
||
;; if there are next methods, we look at whether the method function
|
||
;; asks about them. If it does, we must tell it whether there are
|
||
;; or aren't to prevent the leaky next methods bug.
|
||
(let* ((cm-args (cdr form))
|
||
(fmf-p (and (null no-fmf-p)
|
||
(or (not (eq **boot-state** 'complete))
|
||
(gf-fast-method-function-p generic-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))))
|
||
|
||
;;; methods-tracing TODO:
|
||
;;;
|
||
;;; 2. tracing method calls for non-fast-method-function calls
|
||
;;; - [DONE] the calls themselves
|
||
;;; - calls to the METHOD-FUNCTION of methods with fast functions
|
||
;;; (e.g. from something implementing CALL-NEXT-METHOD; handle this with
|
||
;;; some more smarts in %METHOD-FUNCTION objects?)
|
||
;;; - calls to the METHOD-FUNCTION of methods without fast functions
|
||
;;; (TRACE :METHODS T /could/ modify the METHOD-FUNCTION slot)
|
||
;;; 4. tracing particular methods
|
||
;;; - need an interface.
|
||
;;; * (trace (method foo :around (t)))? [ how to trace the method and not
|
||
;;; the generic function as a whole?]
|
||
;;; * (trace :methods '((:around (t))) foo)? [probably not, interacts
|
||
;;; poorly with TRACE arg handling]
|
||
;;; 5. supporting non-munged arguments as an option
|
||
|
||
(defun method-trace-name (gf method)
|
||
;; KLUDGE: we abuse NIL as second argument to mean that this is a
|
||
;; combined method (i.e. something resulting from MAKE-METHOD in a
|
||
;; method combination, rather than CALL-METHOD on a method object).
|
||
(if method
|
||
`(method ,(generic-function-name gf)
|
||
,@(method-qualifiers method)
|
||
,(unparse-specializers gf (method-specializers method)))
|
||
`(combined-method ,(generic-function-name gf))))
|
||
|
||
(defun maybe-trace-method (gf method fun fmf-p)
|
||
(let ((m-name (when (plusp (hash-table-count sb-debug::*traced-funs*))
|
||
;; KLUDGE: testing if *TRACE-FUNS* has anything anything to
|
||
;; avoid calling METHOD-TRACE-NAME during PCL bootstrapping
|
||
;; when the generic-function type is not yet defined.)
|
||
(method-trace-name gf method))))
|
||
(when m-name
|
||
(sb-debug::retrace-local-funs m-name))
|
||
(let ((info (when m-name
|
||
(or (gethash m-name sb-debug::*traced-funs*)
|
||
(let ((gf-info (gethash (or (generic-function-name gf) gf)
|
||
sb-debug::*traced-funs*)))
|
||
(when (and gf-info (sb-debug::trace-info-methods gf-info))
|
||
(let ((copy (copy-structure gf-info)))
|
||
(setf (sb-debug::trace-info-what copy) m-name)
|
||
copy)))))))
|
||
(if info
|
||
(lambda (&rest args)
|
||
(apply #'sb-debug::trace-method-call info fun fmf-p args))
|
||
fun))))
|
||
|
||
(defun make-emf-from-method
|
||
(gf method cm-args fmf-p &optional method-alist wrappers)
|
||
;; Avoid style-warning about compiler-macro being unavailable.
|
||
(declare (notinline make-instance))
|
||
(multiple-value-bind (mf real-mf-p fmf pv)
|
||
(get-method-function method method-alist wrappers)
|
||
(if fmf
|
||
(let* ((next-methods (car cm-args))
|
||
(next (make-effective-method-function-simple1
|
||
gf (car next-methods)
|
||
(list* (cdr next-methods) (cdr cm-args))
|
||
fmf-p method-alist wrappers))
|
||
(arg-info (method-plist-value method :arg-info))
|
||
(default (cons nil nil))
|
||
(value (method-plist-value method :constant-value default))
|
||
(fun (maybe-trace-method gf method fmf t)))
|
||
(if (eq value default)
|
||
(make-fast-method-call
|
||
:function fun :pv pv :next-method-call next :arg-info arg-info)
|
||
(make-constant-fast-method-call
|
||
:function fun :pv pv :next-method-call next
|
||
:arg-info arg-info :value value)))
|
||
(if real-mf-p
|
||
(flet ((frob-cm-arg (arg)
|
||
(if (if (listp arg)
|
||
(eq (car arg) :early-method)
|
||
(method-p arg))
|
||
arg
|
||
(if (and (consp arg) (eq (car arg) 'make-method))
|
||
(let ((emf (make-effective-method-function
|
||
gf (cadr arg) method-alist wrappers)))
|
||
(etypecase emf
|
||
(method-call
|
||
(make-instance 'standard-method
|
||
:specializers nil ; XXX
|
||
:qualifiers nil ; XXX
|
||
:function (method-call-function emf)))
|
||
(fast-method-call
|
||
(let* ((fmf (fast-method-call-function emf))
|
||
(fun (method-function-from-fast-method-call emf))
|
||
(mf (%make-method-function fmf)))
|
||
(setf (%funcallable-instance-fun mf) fun)
|
||
(make-instance 'standard-method
|
||
:specializers nil ; XXX
|
||
:qualifiers nil
|
||
:function mf)))))
|
||
arg))))
|
||
(let* ((default (cons nil nil))
|
||
(value
|
||
(method-plist-value method :constant-value default))
|
||
;; FIXME: this is wrong. Very wrong. It assumes
|
||
;; that the only place that can have make-method
|
||
;; calls is in the list structure of the second
|
||
;; argument to CALL-METHOD, but AMOP says that
|
||
;; CALL-METHOD can be more complicated if
|
||
;; COMPUTE-EFFECTIVE-METHOD (and presumably
|
||
;; MAKE-METHOD-LAMBDA) is adjusted to match.
|
||
;;
|
||
;; On the other hand, it's a start, because
|
||
;; without this calls to MAKE-METHOD in method
|
||
;; combination where one of the methods is of a
|
||
;; user-defined class don't work at all. -- CSR,
|
||
;; 2006-08-05
|
||
(args (cons (mapcar #'frob-cm-arg (car cm-args))
|
||
(cdr cm-args)))
|
||
(fun (maybe-trace-method gf method mf nil)))
|
||
(if (eq value default)
|
||
(make-method-call :function fun :call-method-args args)
|
||
(make-constant-method-call
|
||
:function fun :value value :call-method-args args))))
|
||
mf))))
|
||
|
||
(defun make-effective-method-function-simple1
|
||
(gf method cm-args fmf-p &optional method-alist wrappers)
|
||
(when method
|
||
(if (if (listp method)
|
||
(eq (car method) :early-method)
|
||
(method-p method))
|
||
(make-emf-from-method gf method cm-args fmf-p method-alist wrappers)
|
||
(if (and (consp method) (eq (car method) 'make-method))
|
||
(make-effective-method-function gf
|
||
(cadr method)
|
||
method-alist wrappers)
|
||
method))))
|
||
|
||
(defvar *global-effective-method-gensyms* ())
|
||
(defvar *rebound-effective-method-gensyms*)
|
||
|
||
(defun get-effective-method-gensym ()
|
||
(or (pop *rebound-effective-method-gensyms*)
|
||
(let ((new (pcl-format-symbol "EFFECTIVE-METHOD-GENSYM-~D"
|
||
(length *global-effective-method-gensyms*))))
|
||
(setq *global-effective-method-gensyms*
|
||
(append *global-effective-method-gensyms* (list new)))
|
||
new)))
|
||
|
||
(let ((*rebound-effective-method-gensyms* ()))
|
||
(dotimes-fixnum (i 10) (get-effective-method-gensym)))
|
||
|
||
(defun expand-effective-method-function (gf effective-method &optional env)
|
||
(declare (ignore env))
|
||
(declare (muffle-conditions code-deletion-note))
|
||
(multiple-value-bind (nreq applyp)
|
||
(get-generic-fun-info gf)
|
||
(let ((ll (make-fast-method-call-lambda-list nreq applyp))
|
||
(error-p (or (eq (first effective-method) '%no-primary-method)
|
||
(eq (first effective-method) '%invalid-qualifiers)))
|
||
(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)))))
|
||
(name `(emf ,(generic-function-name gf))))
|
||
(cond
|
||
(error-p
|
||
`(named-lambda ,name (.pv. .next-method-call. &rest .args.)
|
||
(declare (ignore .pv. .next-method-call.))
|
||
(declare (ignorable .args.))
|
||
(flet ((%no-primary-method (gf args)
|
||
(call-no-primary-method gf args))
|
||
(%invalid-qualifiers (gf combin method)
|
||
(invalid-qualifiers gf combin method)))
|
||
(declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
|
||
,effective-method)))
|
||
(mc-args-p
|
||
(let* ((required (make-dfun-required-args nreq))
|
||
(gf-args (if applyp
|
||
`(list* ,@required
|
||
(sb-c::%listify-rest-args
|
||
.dfun-more-context.
|
||
(the (and unsigned-byte fixnum)
|
||
.dfun-more-count.)))
|
||
`(list ,@required))))
|
||
`(named-lambda ,name ,ll
|
||
(declare (ignore .pv. .next-method-call.))
|
||
(let ((.gf-args. ,gf-args))
|
||
(declare (ignorable .gf-args.))
|
||
,effective-method))))
|
||
(t
|
||
`(named-lambda ,name ,ll
|
||
(declare (ignore ,@(if error-p ll '(.pv. .next-method-call.))))
|
||
,effective-method))))))
|
||
|
||
(defun expand-emf-call-method (gf form metatypes applyp env)
|
||
(declare (ignore gf metatypes applyp env))
|
||
`(call-method ,(cdr form)))
|
||
|
||
(defmacro call-method (&rest args)
|
||
(declare (ignore args))
|
||
;; the PROGN is here to defend against premature macroexpansion by
|
||
;; RESTART-CASE.
|
||
`(progn (error "~S outside of a effective method form" 'call-method)))
|
||
|
||
(defun make-effective-method-list-fun-type
|
||
(generic-function form method-alist-p wrappers-p)
|
||
(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))
|
||
|
||
(defun memf-test-converter (form generic-function method-alist-p wrappers-p)
|
||
(case (and (consp form) (car form))
|
||
(call-method
|
||
(case (make-effective-method-fun-type
|
||
generic-function form method-alist-p wrappers-p)
|
||
(fast-method-call '.fast-call-method.)
|
||
(t '.call-method.)))
|
||
(call-method-list
|
||
(case (make-effective-method-list-fun-type
|
||
generic-function form method-alist-p wrappers-p)
|
||
(fast-method-call '.fast-call-method-list.)
|
||
(t '.call-method-list.)))
|
||
(t (default-test-converter form))))
|
||
|
||
;;; CMUCL comment (2003-10-15):
|
||
;;;
|
||
;;; This function is called via the GET-FUNCTION mechanism on forms
|
||
;;; of an emf lambda. First value returned replaces FORM in the emf
|
||
;;; lambda. Second value is a list of variable names that become
|
||
;;; closure variables.
|
||
(defun memf-code-converter
|
||
(form generic-function metatypes applyp method-alist-p wrappers-p)
|
||
(case (and (consp form) (car form))
|
||
(call-method
|
||
(let ((gensym (get-effective-method-gensym)))
|
||
(values (make-emf-call
|
||
(length metatypes) applyp gensym
|
||
(make-effective-method-fun-type
|
||
generic-function form method-alist-p wrappers-p))
|
||
(list gensym))))
|
||
(call-method-list
|
||
(let ((gensym (get-effective-method-gensym))
|
||
(type (make-effective-method-list-fun-type
|
||
generic-function form method-alist-p wrappers-p)))
|
||
(values `(dolist (emf ,gensym nil)
|
||
,(make-emf-call (length metatypes) applyp 'emf type))
|
||
(list gensym))))
|
||
(t
|
||
(default-code-converter form))))
|
||
|
||
(defun memf-constant-converter (form generic-function)
|
||
(case (and (consp form) (car form))
|
||
(call-method
|
||
(list (cons '.meth.
|
||
(make-effective-method-function-simple
|
||
generic-function form))))
|
||
(call-method-list
|
||
(list (cons '.meth-list.
|
||
(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-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)
|
||
(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-fun 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)
|
||
(flet ((compute-constant (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))
|
||
(case constant
|
||
(t constant)))))
|
||
(let ((fun (apply cfunction
|
||
(mapcar #'compute-constant constants))))
|
||
(set-fun-name fun `(combined-method ,name))
|
||
(make-fast-method-call :function (maybe-trace-method generic-function nil fun t)
|
||
: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)))
|
||
|
||
(defun gf-requires-emf-keyword-checks (generic-function)
|
||
(member '&key (gf-lambda-list generic-function)))
|
||
|
||
(defconstant-eqx +standard-method-combination-qualifiers+
|
||
'(:around :before :after) #'equal)
|
||
|
||
(defun standard-method-combination-qualifier-p (qualifier)
|
||
(member qualifier +standard-method-combination-qualifiers+))
|
||
|
||
(defun standard-compute-effective-method
|
||
(generic-function combin applicable-methods)
|
||
(collect ((before) (primary) (after) (around))
|
||
(flet ((invalid (gf combin m) (invalid-qualifiers gf combin m)))
|
||
(dolist (m applicable-methods)
|
||
(let ((qualifiers (if (listp m)
|
||
(early-method-qualifiers m)
|
||
(safe-method-qualifiers m))))
|
||
(cond
|
||
((null qualifiers) (primary m))
|
||
((cdr qualifiers) (invalid generic-function combin m))
|
||
((eq (car qualifiers) :around) (around m))
|
||
((eq (car qualifiers) :before) (before m))
|
||
((eq (car qualifiers) :after) (after m))
|
||
(t (invalid generic-function combin m))))))
|
||
(cond ((null (primary))
|
||
`(%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; that
|
||
;; is, we can use the fast method function directly as the
|
||
;; effective method function.
|
||
;;
|
||
;; However, the requirement by ANSI (CLHS 7.6.5) on generic
|
||
;; function argument checking inhibits this, as we don't
|
||
;; perform this checking in fast-method-functions given
|
||
;; that they are not solely used for effective method
|
||
;; functions, but also in combination, when they should not
|
||
;; perform argument checks. We still return the bare
|
||
;; CALL-METHOD, but the caller is responsible for ensuring
|
||
;; that keyword applicability is checked if this is a fast
|
||
;; method function used in an effective method. (See
|
||
;; WRAP-WITH-APPLICABLE-KEYWORD-CHECK below).
|
||
`(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))))
|
||
,(make-call-methods (reverse (after))))
|
||
`(call-method ,(first (primary)) ,(rest (primary))))))
|
||
(if (around)
|
||
`(call-method ,(first (around))
|
||
(,@(rest (around))
|
||
(make-method ,main-effective-method)))
|
||
main-effective-method))))))
|
||
|
||
(defun short-method-combination-qualifiers (type-name)
|
||
(list type-name :around))
|
||
|
||
(defun short-method-combination-qualifier-p (type-name qualifier)
|
||
(or (eq qualifier type-name) (eq qualifier :around)))
|
||
|
||
(defun short-compute-effective-method
|
||
(generic-function combin applicable-methods)
|
||
(let ((type-name (method-combination-type-name combin))
|
||
(operator (short-combination-operator combin))
|
||
(ioa (short-combination-identity-with-one-argument combin))
|
||
(order (car (method-combination-options combin)))
|
||
(around ())
|
||
(primary ()))
|
||
(flet ((invalid (gf combin m)
|
||
(return-from short-compute-effective-method
|
||
`(%invalid-qualifiers ',gf ',combin ',m))))
|
||
(dolist (m applicable-methods)
|
||
(let ((qualifiers (method-qualifiers m)))
|
||
(cond ((null qualifiers) (invalid generic-function combin m))
|
||
((cdr qualifiers) (invalid generic-function combin m))
|
||
((eq (car qualifiers) :around)
|
||
(push m around))
|
||
((eq (car qualifiers) type-name)
|
||
(push m primary))
|
||
(t (invalid generic-function combin m))))))
|
||
(setq around (nreverse around))
|
||
(ecase order
|
||
(:most-specific-last) ; nothing to be done, already in correct order
|
||
(:most-specific-first
|
||
(setq primary (nreverse primary))))
|
||
(let ((main-method
|
||
(if (and (null (cdr primary))
|
||
(not (null ioa)))
|
||
`(call-method ,(car primary) ())
|
||
`(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
|
||
primary)))))
|
||
(cond ((null primary)
|
||
;; As of sbcl-0.8.0.80 we don't seem to need to do
|
||
;; anything messy like
|
||
;; `(APPLY (FUNCTION (IF AROUND
|
||
;; 'NO-PRIMARY-METHOD
|
||
;; 'NO-APPLICABLE-METHOD)
|
||
;; ',GENERIC-FUNCTION
|
||
;; .ARGS.)
|
||
;; here because (for reasons I don't understand at the
|
||
;; moment -- WHN) control will never reach here if there
|
||
;; are no applicable methods, but instead end up
|
||
;; in NO-APPLICABLE-METHODS first.
|
||
;;
|
||
;; FIXME: The way that we arrange for .ARGS. to be bound
|
||
;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
|
||
;; recognizing any form whose operator is %NO-PRIMARY-METHOD
|
||
;; as magical, and carefully surrounding it with a
|
||
;; LAMBDA form which binds .ARGS. But...
|
||
;; 1. That seems fragile, because the magicalness of
|
||
;; %NO-PRIMARY-METHOD forms is scattered around
|
||
;; the system. So it could easily be broken by
|
||
;; locally-plausible maintenance changes like,
|
||
;; e.g., using the APPLY expression above.
|
||
;; 2. That seems buggy w.r.t. to MOPpish tricks in
|
||
;; user code, e.g.
|
||
;; (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...)
|
||
;; `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*)))
|
||
`(%no-primary-method ',generic-function .args.))
|
||
((null around) main-method)
|
||
(t
|
||
`(call-method ,(car around)
|
||
(,@(cdr around) (make-method ,main-method))))))))
|
||
|
||
;;; helper code for checking keywords in generic function calls.
|
||
(defun compute-applicable-keywords (gf methods)
|
||
(let ((any-keyp nil))
|
||
(flet ((analyze (lambda-list)
|
||
(multiple-value-bind (llks nreq nopt keys)
|
||
(analyze-lambda-list lambda-list)
|
||
(declare (ignore nreq))
|
||
(when (ll-kwds-keyp llks)
|
||
(setq any-keyp t))
|
||
(values nopt (ll-kwds-allowp llks) keys))))
|
||
(multiple-value-bind (nopt allowp keys)
|
||
(analyze (generic-function-lambda-list gf))
|
||
(dolist (method methods)
|
||
(let ((ll (if (consp method)
|
||
(early-method-lambda-list method)
|
||
(method-lambda-list method))))
|
||
(multiple-value-bind (n allowp method-keys)
|
||
(analyze ll)
|
||
(declare (ignore n))
|
||
(when allowp
|
||
(return-from compute-applicable-keywords (values t nopt)))
|
||
(setq keys (union method-keys keys)))))
|
||
(aver any-keyp)
|
||
(values (if allowp t keys) nopt)))))
|
||
|
||
(defun check-applicable-keywords (start valid-keys more-context more-count)
|
||
(let ((allow-other-keys-seen nil)
|
||
(allow-other-keys nil)
|
||
(i start))
|
||
(declare (type index i more-count)
|
||
(optimize speed))
|
||
(flet ((current-value ()
|
||
(sb-c::%more-arg more-context i)))
|
||
(declare (inline current-value))
|
||
(collect ((invalid))
|
||
(loop
|
||
(when (>= i more-count)
|
||
(when (and (invalid) (not allow-other-keys))
|
||
(%program-error "~@<invalid keyword argument~P: ~
|
||
~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
|
||
(length (invalid)) (invalid) valid-keys))
|
||
(return))
|
||
(let ((key (current-value)))
|
||
(incf i)
|
||
(cond
|
||
((not (symbolp key))
|
||
(%program-error "~@<keyword argument not a symbol: ~S.~@:>"
|
||
key))
|
||
((= i more-count)
|
||
(sb-c::%odd-key-args-error))
|
||
((eq key :allow-other-keys)
|
||
;; only the leftmost :ALLOW-OTHER-KEYS has any effect
|
||
(unless allow-other-keys-seen
|
||
(setq allow-other-keys-seen t
|
||
allow-other-keys (current-value))))
|
||
((eq t valid-keys))
|
||
((not (memq key valid-keys)) (invalid key))))
|
||
(incf i))))))
|
||
|
||
(defun wrap-with-applicable-keyword-check (effective valid-keys keyargs-start)
|
||
(setf effective
|
||
`(let ((.valid-keys. ',valid-keys)
|
||
(.keyargs-start. ',keyargs-start))
|
||
(check-applicable-keywords
|
||
.keyargs-start. .valid-keys. .dfun-more-context. .dfun-more-count.)
|
||
,effective)))
|
||
|
||
;;;; 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.
|
||
|
||
(defun compute-effective-method (generic-function combin applicable-methods)
|
||
(standard-compute-effective-method generic-function
|
||
combin
|
||
applicable-methods))
|
||
|
||
(defun invalid-method-error (method format-control &rest format-arguments)
|
||
(let ((sb-debug:*stack-top-hint* (find-caller-frame)))
|
||
(error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
|
||
method
|
||
format-control
|
||
format-arguments)))
|
||
|
||
(defun method-combination-error (format-control &rest format-arguments)
|
||
(let ((sb-debug:*stack-top-hint* (find-caller-frame)))
|
||
(error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
|
||
format-control
|
||
format-arguments)))
|