* lisp/emacs-lisp/cl-generic.el: Add a method-combination hook.
(cl-generic-method-combination-function): New var. (cl--generic-lambda): Remove `with-cnm' arg. (cl-defmethod): Change accordingly. (cl-generic-define-method): Don't check qualifiers validity. Preserve all qualifiers in `method-table'. (cl-generic-call-method): New function. (cl--generic-nest): Remove (morph into cl-generic-call-method). (cl--generic-build-combined-method): Adjust to new format of method-table and use cl-generic-method-combination-function. (cl--generic-standard-method-combination): New function, extracted from cl--generic-build-combined-method. (cl--generic-cnm-sample): Adjust to new format of method-table. * lisp/emacs-lisp/eieio-compat.el (eieio--defmethod): Use () qualifiers instead of :primary. * lisp/emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke): Remove obsolete function. * test/automated/cl-generic-tests.el (cl-generic-test-11-next-method-p): New test.
This commit is contained in:
Stefan Monnier
parent
242354a23a
commit
4cdde9196f
6 changed files with 155 additions and 107 deletions
|
|
@ -1,3 +1,25 @@
|
|||
2015-01-26 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/cl-generic.el: Add a method-combination hook.
|
||||
(cl-generic-method-combination-function): New var.
|
||||
(cl--generic-lambda): Remove `with-cnm' arg.
|
||||
(cl-defmethod): Change accordingly.
|
||||
(cl-generic-define-method): Don't check qualifiers validity.
|
||||
Preserve all qualifiers in `method-table'.
|
||||
(cl-generic-call-method): New function.
|
||||
(cl--generic-nest): Remove (morph into cl-generic-call-method).
|
||||
(cl--generic-build-combined-method): Adjust to new format of method-table
|
||||
and use cl-generic-method-combination-function.
|
||||
(cl--generic-standard-method-combination): New function, extracted from
|
||||
cl--generic-build-combined-method.
|
||||
(cl--generic-cnm-sample): Adjust to new format of method-table.
|
||||
|
||||
* emacs-lisp/eieio-compat.el (eieio--defmethod): Use () qualifiers
|
||||
instead of :primary.
|
||||
|
||||
* emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke):
|
||||
Remove obsolete function.
|
||||
|
||||
2015-01-26 Lars Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* net/shr.el (shr-make-table-1): Fix colspan typo.
|
||||
|
|
|
|||
|
|
@ -30,7 +30,9 @@
|
|||
;; CLOS's define-method-combination is IMO overly complicated, and it suffers
|
||||
;; from a significant problem: the method-combination code returns a sexp
|
||||
;; that needs to be `eval'uated or compiled. IOW it requires run-time
|
||||
;; code generation.
|
||||
;; code generation. Given how rarely method-combinations are used,
|
||||
;; I just provided a cl-generic-method-combination-function, which
|
||||
;; people can use if they are really desperate for such functionality.
|
||||
;; - Method and generic function objects: CLOS defines methods as objects
|
||||
;; (same for generic functions), whereas we don't offer such an abstraction.
|
||||
;; - `no-next-method' should receive the "calling method" object, but since we
|
||||
|
|
@ -115,10 +117,10 @@ They should be sorted from most specific to least specific.")
|
|||
;; The most important dispatch is last in the list (and the least is first).
|
||||
(dispatches nil :type (list-of (cons natnum (list-of tagcode))))
|
||||
;; `method-table' is a list of
|
||||
;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
|
||||
;; ((SPECIALIZERS . QUALIFIERS) USES-CNM . FUNCTION), where
|
||||
;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
|
||||
;; (and hence expects an extra argument holding the next-method).
|
||||
(method-table nil :type (list-of (cons (cons (list-of type) keyword)
|
||||
(method-table nil :type (list-of (cons (cons (list-of type) (list-of atom))
|
||||
(cons boolean function)))))
|
||||
|
||||
(defmacro cl--generic (name)
|
||||
|
|
@ -232,7 +234,7 @@ This macro can only be used within the lexical scope of a cl-generic method."
|
|||
(and (memq sexp vars) (not (memq sexp res)) (push sexp res))
|
||||
res))
|
||||
|
||||
(defun cl--generic-lambda (args body with-cnm)
|
||||
(defun cl--generic-lambda (args body)
|
||||
"Make the lambda expression for a method with ARGS and BODY."
|
||||
(let ((plain-args ())
|
||||
(specializers nil)
|
||||
|
|
@ -255,36 +257,34 @@ This macro can only be used within the lexical scope of a cl-generic method."
|
|||
. ,(lambda () specializers))
|
||||
macroexpand-all-environment)))
|
||||
(require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'.
|
||||
(if (not with-cnm)
|
||||
(cons nil (macroexpand-all fun macroenv))
|
||||
;; First macroexpand away the cl-function stuff (e.g. &key and
|
||||
;; destructuring args, `declare' and whatnot).
|
||||
(pcase (macroexpand fun macroenv)
|
||||
(`#'(lambda ,args . ,body)
|
||||
(let* ((doc-string (and doc-string (stringp (car body)) (cdr body)
|
||||
(pop body)))
|
||||
(cnm (make-symbol "cl--cnm"))
|
||||
(nmp (make-symbol "cl--nmp"))
|
||||
(nbody (macroexpand-all
|
||||
`(cl-flet ((cl-call-next-method ,cnm)
|
||||
(cl-next-method-p ,nmp))
|
||||
,@body)
|
||||
macroenv))
|
||||
;; FIXME: Rather than `grep' after the fact, the
|
||||
;; macroexpansion should directly set some flag when cnm
|
||||
;; is used.
|
||||
;; FIXME: Also, optimize the case where call-next-method is
|
||||
;; only called with explicit arguments.
|
||||
(uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
|
||||
(cons (not (not uses-cnm))
|
||||
`#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
|
||||
,@(if doc-string (list doc-string))
|
||||
,(if (not (memq nmp uses-cnm))
|
||||
nbody
|
||||
`(let ((,nmp (lambda ()
|
||||
(cl--generic-isnot-nnm-p ,cnm))))
|
||||
,nbody))))))
|
||||
(f (error "Unexpected macroexpansion result: %S" f))))))))
|
||||
;; First macroexpand away the cl-function stuff (e.g. &key and
|
||||
;; destructuring args, `declare' and whatnot).
|
||||
(pcase (macroexpand fun macroenv)
|
||||
(`#'(lambda ,args . ,body)
|
||||
(let* ((doc-string (and doc-string (stringp (car body)) (cdr body)
|
||||
(pop body)))
|
||||
(cnm (make-symbol "cl--cnm"))
|
||||
(nmp (make-symbol "cl--nmp"))
|
||||
(nbody (macroexpand-all
|
||||
`(cl-flet ((cl-call-next-method ,cnm)
|
||||
(cl-next-method-p ,nmp))
|
||||
,@body)
|
||||
macroenv))
|
||||
;; FIXME: Rather than `grep' after the fact, the
|
||||
;; macroexpansion should directly set some flag when cnm
|
||||
;; is used.
|
||||
;; FIXME: Also, optimize the case where call-next-method is
|
||||
;; only called with explicit arguments.
|
||||
(uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
|
||||
(cons (not (not uses-cnm))
|
||||
`#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
|
||||
,@(if doc-string (list doc-string))
|
||||
,(if (not (memq nmp uses-cnm))
|
||||
nbody
|
||||
`(let ((,nmp (lambda ()
|
||||
(cl--generic-isnot-nnm-p ,cnm))))
|
||||
,nbody))))))
|
||||
(f (error "Unexpected macroexpansion result: %S" f)))))))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
|
|
@ -324,8 +324,7 @@ which case this method will be invoked when the argument is `eql' to VAL.
|
|||
(while (not (listp args))
|
||||
(push args qualifiers)
|
||||
(setq args (pop body)))
|
||||
(pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
|
||||
(`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
|
||||
(pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body)))
|
||||
`(progn
|
||||
,(when setfizer
|
||||
(setq name (car setfizer))
|
||||
|
|
@ -347,15 +346,11 @@ which case this method will be invoked when the argument is `eql' to VAL.
|
|||
|
||||
;;;###autoload
|
||||
(defun cl-generic-define-method (name qualifiers args uses-cnm function)
|
||||
(when (> (length qualifiers) 1)
|
||||
(error "We only support a single qualifier per method: %S" qualifiers))
|
||||
(unless (memq (car qualifiers) '(nil :primary :around :after :before))
|
||||
(error "Unsupported qualifier in: %S" qualifiers))
|
||||
(let* ((generic (cl-generic-ensure-function name))
|
||||
(mandatory (cl--generic-mandatory-args args))
|
||||
(specializers
|
||||
(mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
|
||||
(key (cons specializers (or (car qualifiers) ':primary)))
|
||||
(key (cons specializers qualifiers))
|
||||
(mt (cl--generic-method-table generic))
|
||||
(me (assoc key mt))
|
||||
(dispatches (cl--generic-dispatches generic))
|
||||
|
|
@ -438,22 +433,19 @@ which case this method will be invoked when the argument is `eql' to VAL.
|
|||
(cdr dispatch) (car dispatch))))
|
||||
(funcall dispatcher generic dispatches)))))
|
||||
|
||||
(defun cl--generic-nest (fun methods)
|
||||
(pcase-dolist (`(,uses-cnm . ,method) methods)
|
||||
(setq fun
|
||||
(if (not uses-cnm) method
|
||||
(let ((next fun))
|
||||
(lambda (&rest args)
|
||||
(apply method
|
||||
;; FIXME: This sucks: passing just `next' would
|
||||
;; be a lot more efficient than the lambda+apply
|
||||
;; quasi-η, but we need this to implement the
|
||||
;; "if call-next-method is called with no
|
||||
;; arguments, then use the previous arguments".
|
||||
(lambda (&rest cnm-args)
|
||||
(apply next (or cnm-args args)))
|
||||
args))))))
|
||||
fun)
|
||||
(defvar cl-generic-method-combination-function
|
||||
#'cl--generic-standard-method-combination
|
||||
"Function to build the effective method.
|
||||
Called with 2 arguments: NAME and METHOD-ALIST.
|
||||
It should return an effective method, i.e. a function that expects the same
|
||||
arguments as the methods, and calls those methods in some appropriate order.
|
||||
NAME is the name (a symbol) of the corresponding generic function.
|
||||
METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where
|
||||
QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected
|
||||
methods for that qualifier list.
|
||||
The METHODS lists are sorted from most generic first to most specific last.
|
||||
The function can use `cl-generic-call-method' to create functions that call those
|
||||
methods.")
|
||||
|
||||
(defvar cl--generic-combined-method-memoization
|
||||
(make-hash-table :test #'equal :weakness 'value)
|
||||
|
|
@ -462,6 +454,22 @@ This is particularly useful when many different tags select the same set
|
|||
of methods, since this table then allows us to share a single combined-method
|
||||
for all those different tags in the method-cache.")
|
||||
|
||||
(defun cl--generic-build-combined-method (generic-name methods)
|
||||
(cl--generic-with-memoization
|
||||
(gethash (cons generic-name methods)
|
||||
cl--generic-combined-method-memoization)
|
||||
(let ((mets-by-qual ()))
|
||||
(dolist (qm methods)
|
||||
(let* ((qualifiers (cdar qm))
|
||||
(x (assoc qualifiers mets-by-qual)))
|
||||
;; FIXME: sadly, alist-get only uses `assq' and we need `assoc'.
|
||||
;;(push (cdr qm) (alist-get qualifiers mets-by-qual)))
|
||||
(if x
|
||||
(push (cdr qm) (cdr x))
|
||||
(push (list qualifiers (cdr qm)) mets-by-qual))))
|
||||
(funcall cl-generic-method-combination-function
|
||||
generic-name mets-by-qual))))
|
||||
|
||||
(defun cl--generic-no-next-method-function (generic)
|
||||
(lambda (&rest args)
|
||||
;; FIXME: CLOS passes as second arg the "calling method".
|
||||
|
|
@ -474,42 +482,61 @@ for all those different tags in the method-cache.")
|
|||
;; it anyway. So we pass nil for now.
|
||||
(apply #'cl-no-next-method generic nil args)))
|
||||
|
||||
(defun cl--generic-build-combined-method (generic-name methods)
|
||||
(let ((mets-by-qual ()))
|
||||
(dolist (qm methods)
|
||||
(push (cdr qm) (alist-get (cdar qm) mets-by-qual)))
|
||||
(cl--generic-with-memoization
|
||||
(gethash (cons generic-name mets-by-qual)
|
||||
cl--generic-combined-method-memoization)
|
||||
(cond
|
||||
((null mets-by-qual)
|
||||
(lambda (&rest args)
|
||||
(apply #'cl-no-applicable-method generic-name args)))
|
||||
((null (alist-get :primary mets-by-qual))
|
||||
(lambda (&rest args)
|
||||
(apply #'cl-no-primary-method generic-name args)))
|
||||
(t
|
||||
(let* ((fun (cl--generic-no-next-method-function generic-name))
|
||||
;; We use `cdr' to drop the `uses-cnm' annotations.
|
||||
(before
|
||||
(mapcar #'cdr (reverse (alist-get :before mets-by-qual))))
|
||||
(after (mapcar #'cdr (alist-get :after mets-by-qual))))
|
||||
(setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual)))
|
||||
(when (or after before)
|
||||
(let ((next fun))
|
||||
(setq fun (lambda (&rest args)
|
||||
(dolist (bf before)
|
||||
(apply bf args))
|
||||
(prog1
|
||||
(apply next args)
|
||||
(dolist (af after)
|
||||
(apply af args)))))))
|
||||
(cl--generic-nest fun (alist-get :around mets-by-qual))))))))
|
||||
(defun cl-generic-call-method (generic-name method &optional fun)
|
||||
"Return a function that calls METHOD.
|
||||
FUN is the function that should be called when METHOD calls
|
||||
`call-next-method'."
|
||||
(pcase method
|
||||
(`(nil . ,method) method)
|
||||
(`(,_uses-cnm . ,method)
|
||||
(let ((next (or fun (cl--generic-no-next-method-function generic-name))))
|
||||
(lambda (&rest args)
|
||||
(apply method
|
||||
;; FIXME: This sucks: passing just `next' would
|
||||
;; be a lot more efficient than the lambda+apply
|
||||
;; quasi-η, but we need this to implement the
|
||||
;; "if call-next-method is called with no
|
||||
;; arguments, then use the previous arguments".
|
||||
(lambda (&rest cnm-args)
|
||||
(apply next (or cnm-args args)))
|
||||
args))))))
|
||||
|
||||
(defun cl--generic-standard-method-combination (generic-name mets-by-qual)
|
||||
(dolist (x mets-by-qual)
|
||||
(unless (member (car x) '(() (:after) (:before) (:around)))
|
||||
(error "Unsupported qualifiers in function %S: %S" generic-name (car x))))
|
||||
(cond
|
||||
((null mets-by-qual)
|
||||
(lambda (&rest args)
|
||||
(apply #'cl-no-applicable-method generic-name args)))
|
||||
((null (alist-get nil mets-by-qual))
|
||||
(lambda (&rest args)
|
||||
(apply #'cl-no-primary-method generic-name args)))
|
||||
(t
|
||||
(let* ((fun nil)
|
||||
(ab-call (lambda (m) (cl-generic-call-method generic-name m)))
|
||||
(before
|
||||
(mapcar ab-call (reverse (cdr (assoc '(:before) mets-by-qual)))))
|
||||
(after (mapcar ab-call (cdr (assoc '(:after) mets-by-qual)))))
|
||||
(dolist (method (cdr (assoc nil mets-by-qual)))
|
||||
(setq fun (cl-generic-call-method generic-name method fun)))
|
||||
(when (or after before)
|
||||
(let ((next fun))
|
||||
(setq fun (lambda (&rest args)
|
||||
(dolist (bf before)
|
||||
(apply bf args))
|
||||
(prog1
|
||||
(apply next args)
|
||||
(dolist (af after)
|
||||
(apply af args)))))))
|
||||
(dolist (method (cdr (assoc '(:around) mets-by-qual)))
|
||||
(setq fun (cl-generic-call-method generic-name method fun)))
|
||||
fun))))
|
||||
|
||||
(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function 'dummy))
|
||||
(defconst cl--generic-cnm-sample
|
||||
(funcall (cl--generic-build-combined-method
|
||||
nil `(((specializer . :primary) t . ,#'identity)))))
|
||||
nil `(((specializer . nil) t . ,#'identity)))))
|
||||
|
||||
(defun cl--generic-isnot-nnm-p (cnm)
|
||||
"Return non-nil if CNM is the function that calls `cl-no-next-method'."
|
||||
|
|
|
|||
|
|
@ -181,7 +181,8 @@ Summary:
|
|||
(lambda (generic arg &rest args) (apply code arg generic args)))
|
||||
(_ code))))
|
||||
(cl-generic-define-method
|
||||
method (if kind (list kind)) specializers uses-cnm
|
||||
method (unless (memq kind '(nil :primary)) (list kind))
|
||||
specializers uses-cnm
|
||||
(if uses-cnm
|
||||
(let* ((docstring (documentation code 'raw))
|
||||
(args (help-function-arglist code 'preserve-names))
|
||||
|
|
@ -201,10 +202,11 @@ Summary:
|
|||
;; applicable but only of the before/after kind. So if we add a :before
|
||||
;; or :after, make sure there's a matching dummy primary.
|
||||
(when (and (memq kind '(:before :after))
|
||||
;; FIXME: Use `cl-find-method'?
|
||||
(not (assoc (cons (mapcar (lambda (arg)
|
||||
(if (consp arg) (nth 1 arg) t))
|
||||
specializers)
|
||||
:primary)
|
||||
nil)
|
||||
(cl--generic-method-table (cl--generic method)))))
|
||||
(cl-generic-define-method method () specializers t
|
||||
(lambda (cnm &rest args)
|
||||
|
|
|
|||
|
|
@ -129,22 +129,6 @@ PREBUTTONTEXT is some text between PREFIX and the object button."
|
|||
(data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
|
||||
(data-debug-insert-object-slots obj "]"))
|
||||
|
||||
;;; DEBUG FUNCTIONS
|
||||
;;
|
||||
(defun eieio-debug-methodinvoke (method class)
|
||||
"Show the method invocation order for METHOD with CLASS object."
|
||||
(interactive "aMethod: \nXClass Expression: ")
|
||||
(let* ((eieio-pre-method-execution-functions
|
||||
(lambda (l) (throw 'moose l) ))
|
||||
(data
|
||||
(catch 'moose (eieio--generic-call
|
||||
method (list class))))
|
||||
(_buf (data-debug-new-buffer "*Method Invocation*"))
|
||||
(data2 (mapcar (lambda (sym)
|
||||
(symbol-function (car sym)))
|
||||
data)))
|
||||
(data-debug-insert-thing data2 ">" "")))
|
||||
|
||||
(provide 'eieio-datadebug)
|
||||
|
||||
;;; eieio-datadebug.el ends here
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2015-01-26 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/cl-generic-tests.el (cl-generic-test-11-next-method-p):
|
||||
New test.
|
||||
|
||||
2015-01-25 Paul Eggert <eggert@cs.ucla.edu>
|
||||
|
||||
* indent/shell.sh (bar): Use '[ $# -eq 0 ]', not '[ $# == 0 ]'.
|
||||
|
|
|
|||
|
|
@ -171,5 +171,13 @@
|
|||
(should (equal (cl--generic-1 'a 'b) '(a b)))
|
||||
(should (equal (cl--generic-1 1 2) '("integer" 2 1))))
|
||||
|
||||
(ert-deftest cl-generic-test-11-next-method-p ()
|
||||
(cl-defgeneric cl--generic-1 (x y))
|
||||
(cl-defmethod cl--generic-1 ((x t) y)
|
||||
(list x y (cl-next-method-p)))
|
||||
(cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
|
||||
(cl-list* "quatre" (cl-next-method-p) (cl-call-next-method)))
|
||||
(should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil))))
|
||||
|
||||
(provide 'cl-generic-tests)
|
||||
;;; cl-generic-tests.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue