[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 4cdde91: * lisp/emacs-lisp/cl-generic.el: Add a met
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] master 4cdde91: * lisp/emacs-lisp/cl-generic.el: Add a method-combination hook. |
|
Date: |
Mon, 26 Jan 2015 14:05:13 +0000 |
branch: master
commit 4cdde9196fb4fafb00b0c51b908fd605274147bd
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
* 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.
---
lisp/ChangeLog | 22 ++++
lisp/emacs-lisp/cl-generic.el | 205 ++++++++++++++++++++----------------
lisp/emacs-lisp/eieio-compat.el | 6 +-
lisp/emacs-lisp/eieio-datadebug.el | 16 ---
test/ChangeLog | 5 +
test/automated/cl-generic-tests.el | 8 ++
6 files changed, 155 insertions(+), 107 deletions(-)
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 8af0ec4..0bdf4e2 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,25 @@
+2015-01-26 Stefan Monnier <address@hidden>
+
+ * 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 <address@hidden>
* net/shr.el (shr-make-table-1): Fix colspan typo.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 02a4351..4245959 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -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'."
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index c2dabf7..30bb5ce 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -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)
diff --git a/lisp/emacs-lisp/eieio-datadebug.el
b/lisp/emacs-lisp/eieio-datadebug.el
index 6534bd0..119f7cc 100644
--- a/lisp/emacs-lisp/eieio-datadebug.el
+++ b/lisp/emacs-lisp/eieio-datadebug.el
@@ -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
diff --git a/test/ChangeLog b/test/ChangeLog
index d8cd367..9a31da4 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,8 @@
+2015-01-26 Stefan Monnier <address@hidden>
+
+ * automated/cl-generic-tests.el (cl-generic-test-11-next-method-p):
+ New test.
+
2015-01-25 Paul Eggert <address@hidden>
* indent/shell.sh (bar): Use '[ $# -eq 0 ]', not '[ $# == 0 ]'.
diff --git a/test/automated/cl-generic-tests.el
b/test/automated/cl-generic-tests.el
index bc9a1ec..5b3a9fd 100644
--- a/test/automated/cl-generic-tests.el
+++ b/test/automated/cl-generic-tests.el
@@ -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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 4cdde91: * lisp/emacs-lisp/cl-generic.el: Add a method-combination hook.,
Stefan Monnier <=