[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 24b7f77: Improve handling of doc-strings and descri
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] master 24b7f77: Improve handling of doc-strings and describe-function for cl-generic |
|
Date: |
Sat, 17 Jan 2015 03:52:22 +0000 |
branch: master
commit 24b7f77581c7eefe484db6cbbd661c04460c66aa
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
Improve handling of doc-strings and describe-function for cl-generic
* lisp/help-fns.el (find-lisp-object-file-name): Accept any `type' as long
as it's a symbol.
(help-fns-short-filename): New function.
(describe-function-1): Use it. Use autoload-do-load.
* lisp/help-mode.el (help-function-def): Add optional arg `type'.
* lisp/emacs-lisp/cl-generic.el (cl-generic-ensure-function): It's OK to
override an autoload.
(cl-generic-current-method-specializers): Replace dyn-bind variable
with a lexically-scoped macro.
(cl--generic-lambda): Update accordingly.
(cl-generic-define-method): Record manually in the load-history with
type `cl-defmethod'.
(cl--generic-get-dispatcher): Minor optimization.
(cl--generic-search-method): New function.
(find-function-regexp-alist): Add entry for `cl-defmethod' type.
(cl--generic-search-method): Add hyperlinks for methods. Merge the
specializers and the function's arguments.
* lisp/emacs-lisp/eieio-core.el (eieio--defalias): Move to eieio-generic.el.
(eieio-defclass-autoload): Don't record the superclasses any more.
(eieio-defclass-internal): Reuse the old class object if it was just an
autoload stub.
(eieio--class-precedence-list): Load the class if it's autoloaded.
* lisp/emacs-lisp/eieio-generic.el (eieio--defalias): Move from eieio-core.
(eieio--defgeneric-init-form): Don't throw away a previous docstring.
(eieio--method-optimize-primary): Don't mess with the docstring.
(defgeneric): Keep the `args' in the docstring.
(defmethod): Don't use the method's docstring for the generic
function's docstring.
* lisp/emacs-lisp/find-func.el: Use lexical-binding.
(find-function-regexp): Don't rule out `defgeneric'.
(find-function-regexp-alist): Document new possibility of including
a function instead of a regexp.
(find-function-search-for-symbol): Implement that new possibility.
(find-function-library): Don't assume that `function' is a symbol.
(find-function-do-it): Remove unused var `orig-buf'.
* test/automated/cl-generic-tests.el (cl-generic-test-8-after/before):
Rename from cl-generic-test-7-after/before.
(cl--generic-test-advice): New function.
(cl-generic-test-9-advice): New test.
* test/automated/eieio-test-methodinvoke.el (eieio-test-cl-generic-1): Reset
eieio-test--1.
---
lisp/ChangeLog | 45 +++++++++++
lisp/emacs-lisp/cl-generic.el | 117 ++++++++++++++++++++---------
lisp/emacs-lisp/eieio-core.el | 89 ++++++++---------------
lisp/emacs-lisp/eieio-generic.el | 51 ++++++++-----
lisp/emacs-lisp/find-func.el | 68 +++++++++--------
lisp/help-fns.el | 26 +++++--
lisp/help-mode.el | 4 +-
test/ChangeLog | 10 +++
test/automated/cl-generic-tests.el | 15 ++++-
test/automated/eieio-test-methodinvoke.el | 1 +
10 files changed, 269 insertions(+), 157 deletions(-)
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index f78714b..01de483 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,48 @@
+2015-01-17 Stefan Monnier <address@hidden>
+
+ Improve handling of doc-strings and describe-function for cl-generic.
+
+ * help-mode.el (help-function-def): Add optional arg `type'.
+
+ * help-fns.el (find-lisp-object-file-name): Accept any `type' as long
+ as it's a symbol.
+ (help-fns-short-filename): New function.
+ (describe-function-1): Use it. Use autoload-do-load.
+
+ * emacs-lisp/find-func.el: Use lexical-binding.
+ (find-function-regexp): Don't rule out `defgeneric'.
+ (find-function-regexp-alist): Document new possibility of including
+ a function instead of a regexp.
+ (find-function-search-for-symbol): Implement that new possibility.
+ (find-function-library): Don't assume that `function' is a symbol.
+ (find-function-do-it): Remove unused var `orig-buf'.
+
+ * emacs-lisp/eieio-generic.el (eieio--defalias): Move from eieio-core.
+ (eieio--defgeneric-init-form): Don't throw away a previous docstring.
+ (eieio--method-optimize-primary): Don't mess with the docstring.
+ (defgeneric): Keep the `args' in the docstring.
+ (defmethod): Don't use the method's docstring for the generic
+ function's docstring.
+
+ * emacs-lisp/eieio-core.el (eieio--defalias): Move to eieio-generic.el.
+ (eieio-defclass-autoload): Don't record the superclasses any more.
+ (eieio-defclass-internal): Reuse the old class object if it was just an
+ autoload stub.
+ (eieio--class-precedence-list): Load the class if it's autoloaded.
+
+ * emacs-lisp/cl-generic.el (cl-generic-ensure-function): It's OK to
+ override an autoload.
+ (cl-generic-current-method-specializers): Replace dyn-bind variable
+ with a lexically-scoped macro.
+ (cl--generic-lambda): Update accordingly.
+ (cl-generic-define-method): Record manually in the load-history with
+ type `cl-defmethod'.
+ (cl--generic-get-dispatcher): Minor optimization.
+ (cl--generic-search-method): New function.
+ (find-function-regexp-alist): Add entry for `cl-defmethod' type.
+ (cl--generic-search-method): Add hyperlinks for methods. Merge the
+ specializers and the function's arguments.
+
2015-01-16 Artur Malabarba <address@hidden>
* emacs-lisp/package.el (package--read-pkg-desc): New
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 21688be..ae0f129 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -107,6 +107,7 @@ They should be sorted from most specific to least
specific.")
(symbolp (symbol-function name)))
(setq name (symbol-function name)))
(unless (or (not (fboundp name))
+ (autoloadp (symbol-function name))
(and (functionp name) generic))
(error "%s is already defined as something else than a generic function"
origname))
@@ -153,7 +154,7 @@ via (:documentation DOCSTRING)."
code))
(defalias ',name
(cl-generic-define ',name ',args ',options-and-methods)
- ,doc))))
+ ,(help-add-fundoc-usage doc args)))))
(defun cl--generic-mandatory-args (args)
(let ((res ()))
@@ -176,15 +177,10 @@ via (:documentation DOCSTRING)."
(setf (cl--generic-method-table generic) nil)
(cl--generic-make-function generic)))
-(defvar cl-generic-current-method-specializers nil
- ;; This is let-bound during macro-expansion of method bodies, so that those
- ;; bodies can be optimized knowing that the specializers have matched.
- ;; FIXME: This presumes the formal arguments aren't modified via `setq' and
- ;; aren't shadowed either ;-(
- ;; FIXME: This might leak outside the scope of the method if, during
- ;; macroexpansion of the method, something causes some other macroexpansion
- ;; (e.g. an autoload).
- "List of (VAR . TYPE) where TYPE is var's specializer.")
+(defmacro cl-generic-current-method-specializers ()
+ "List of (VAR . TYPE) where TYPE is var's specializer.
+This macro can only be used within the lexical scope of a cl-generic method."
+ (error "cl-generic-current-method-specializers used outside of a method"))
(eval-and-compile ;Needed while compiling the cl-defmethod calls below!
(defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
@@ -199,27 +195,29 @@ via (:documentation DOCSTRING)."
(defun cl--generic-lambda (args body with-cnm)
"Make the lambda expression for a method with ARGS and BODY."
(let ((plain-args ())
- (cl-generic-current-method-specializers nil)
+ (specializers nil)
(doc-string (if (stringp (car-safe body)) (pop body)))
(mandatory t))
(dolist (arg args)
(push (pcase arg
((or '&optional '&rest '&key) (setq mandatory nil) arg)
((and `(,name . ,type) (guard mandatory))
- (push (cons name (car type))
- cl-generic-current-method-specializers)
+ (push (cons name (car type)) specializers)
name)
(_ arg))
plain-args))
(setq plain-args (nreverse plain-args))
(let ((fun `(cl-function (lambda ,plain-args
,@(if doc-string (list doc-string))
- ,@body))))
+ ,@body)))
+ (macroenv (cons `(cl-generic-current-method-specializers
+ . ,(lambda () specializers))
+ macroexpand-all-environment)))
(if (not with-cnm)
- (cons nil fun)
+ (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 macroexpand-all-environment)
+ (pcase (macroexpand fun macroenv)
(`#'(lambda ,args . ,body)
(require 'cl-lib) ;Needed to expand `cl-flet'.
(let* ((doc-string (and doc-string (stringp (car body))
@@ -228,7 +226,7 @@ via (:documentation DOCSTRING)."
(nbody (macroexpand-all
`(cl-flet ((cl-call-next-method ,cnm))
,@body)
- macroexpand-all-environment))
+ macroenv))
;; FIXME: Rather than `grep' after the fact, the
;; macroexpansion should directly set some flag when cnm
;; is used.
@@ -309,8 +307,13 @@ which case this method will be invoked when the argument
is `eql' to VAL.
(setf (cl--generic-method-table generic)
(cons `(,key ,uses-cnm . ,function) mt)))
;; For aliases, cl--generic-name gives us the actual name.
- (defalias (cl--generic-name generic)
- (cl--generic-make-function generic))))
+ (let ((gfun (cl--generic-make-function generic))
+ ;; Prevent `defalias' from recording this as the definition site of
+ ;; the generic function.
+ current-load-list)
+ (defalias (cl--generic-name generic) gfun))
+ (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
+ current-load-list :test #'equal)))
(defmacro cl--generic-with-memoization (place &rest code)
(declare (indent 1) (debug t))
@@ -327,6 +330,14 @@ which case this method will be invoked when the argument
is `eql' to VAL.
(cl--generic-with-memoization
(gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers)
(let ((lexical-binding t)
+ (tag-exp `(or ,@(mapcar #'cdr
+ ;; Minor optimization: since this tag-exp is
+ ;; only used to lookup the method-cache, it
+ ;; doesn't matter if the default value is some
+ ;; constant or nil.
+ (if (macroexp-const-p (car (last tagcodes)))
+ (butlast tagcodes)
+ tagcodes))))
(extraargs ()))
(dotimes (_ dispatch-arg)
(push (make-symbol "arg") extraargs))
@@ -335,7 +346,7 @@ which case this method will be invoked when the argument is
`eql' to VAL.
(let ((method-cache (make-hash-table :test #'eql)))
(lambda (,@extraargs arg &rest args)
(apply (cl--generic-with-memoization
- (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache)
+ (gethash ,tag-exp method-cache)
(cl--generic-cache-miss
generic ',dispatch-arg dispatches-left
(list ,@(mapcar #'cdr tagcodes))))
@@ -456,31 +467,63 @@ Can only be used from within the lexical body of a
primary or around method."
;;; Add support for describe-function
-(add-hook 'help-fns-describe-function-functions 'cl--generic-describe)
+(defun cl--generic-search-method (met-name)
+ (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
+ (regexp-quote (format "%s\\_>" (car met-name))))))
+ (or
+ (re-search-forward
+ (concat base-re "[^&\"\n]*"
+ (mapconcat (lambda (specializer)
+ (regexp-quote
+ (format "%S" (if (consp specializer)
+ (nth 1 specializer)
specializer))))
+ (remq t (cdr met-name))
+ "[ \t\n]*)[^&\"\n]*"))
+ nil t)
+ (re-search-forward base-re nil t))))
+
+
+(with-eval-after-load 'find-func
+ (defvar find-function-regexp-alist)
+ (add-to-list 'find-function-regexp-alist
+ `(cl-defmethod . ,#'cl--generic-search-method)))
+
+(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
(defun cl--generic-describe (function)
- ;; FIXME: Fix up the main "in `<file>'" hyperlink, and add such hyperlinks
- ;; for each method.
(let ((generic (if (symbolp function) (cl--generic function))))
(when generic
+ (require 'help-mode) ;Needed for `help-function-def' button!
(save-excursion
(insert "\n\nThis is a generic function.\n\n")
(insert (propertize "Implementations:\n\n" 'face 'bold))
;; Loop over fanciful generics
- (pcase-dolist (`((,type . ,qualifier) . ,method)
+ (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method)
(cl--generic-method-table generic))
- (insert "`")
- (if (symbolp type)
- ;; FIXME: Add support for cl-structs in help-variable.
- (help-insert-xref-button (symbol-name type)
- 'help-variable type)
- (insert (format "%S" type)))
- (insert (format "' %S %S\n"
- (car qualifier)
- (let ((args (help-function-arglist method)))
- ;; Drop cl--generic-next arg if present.
- (if (memq (car qualifier) '(:after :before))
- args (cdr args)))))
- (insert (or (documentation method) "Undocumented") "\n\n"))))))
+ (let* ((args (help-function-arglist method 'names))
+ (docstring (documentation method))
+ (doconly (if docstring
+ (let ((split (help-split-fundoc docstring nil)))
+ (if split (cdr split) docstring))))
+ (combined-args ()))
+ (if uses-cnm (setq args (cdr args)))
+ (dolist (specializer specializers)
+ (let ((arg (if (eq '&rest (car args))
+ (intern (format "arg%d" (length combined-args)))
+ (pop args))))
+ (push (if (eq specializer t) arg (list arg specializer))
+ combined-args)))
+ (setq combined-args (append (nreverse combined-args) args))
+ ;; FIXME: Add hyperlinks for the types as well.
+ (insert (format "%S %S" qualifier combined-args))
+ (let* ((met-name (cons function specializers))
+ (file (find-lisp-object-file-name met-name 'cl-defmethod)))
+ (when file
+ (insert " in `")
+ (help-insert-xref-button (help-fns-short-filename file)
+ 'help-function-def met-name file
+ 'cl-defmethod)
+ (insert "'.\n")))
+ (insert "\n" (or doconly "Undocumented") "\n\n")))))))
;;; Support for (eql <val>) specializers.
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index bfa922b..e526a41 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -34,19 +34,6 @@
(require 'cl-lib)
(require 'pcase)
-(put 'eieio--defalias 'byte-hunk-handler
- #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
-(defun eieio--defalias (name body)
- "Like `defalias', but with less side-effects.
-More specifically, it has no side-effects at all when the new function
-definition is the same (`eq') as the old one."
- (while (and (fboundp name) (symbolp (symbol-function name)))
- ;; Follow aliases, so methods applied to obsolete aliases still work.
- (setq name (symbol-function name)))
- (unless (and (fboundp name)
- (eq (symbol-function name) body))
- (defalias name body)))
-
;;;
;; A few functions that are better in the official EIEIO src, but
;; used from the core.
@@ -292,7 +279,7 @@ Abstract classes cannot be instantiated."
;; We autoload this because it's used in `make-autoload'.
;;;###autoload
-(defun eieio-defclass-autoload (cname superclasses filename doc)
+(defun eieio-defclass-autoload (cname _superclasses filename doc)
"Create autoload symbols for the EIEIO class CNAME.
SUPERCLASSES are the superclasses that CNAME inherits from.
DOC is the docstring for CNAME.
@@ -301,58 +288,35 @@ SUPERCLASSES as children.
It creates an autoload function for CNAME's constructor."
;; Assume we've already debugged inputs.
+ ;; We used to store the list of superclasses in the `parent' slot (as a list
+ ;; of class names). But now this slot holds a list of class objects, and
+ ;; those parents may not exist yet, so the corresponding class objects may
+ ;; simply not exist yet. So instead we just don't store the list of parents
+ ;; here in eieio-defclass-autoload at all, since it seems that they're just
+ ;; not needed before the class is actually loaded.
(let* ((oldc (when (class-p cname) (eieio--class-v cname)))
(newc (eieio--class-make cname))
)
(if oldc
nil ;; Do nothing if we already have this class.
- (let ((clear-parent nil))
- ;; No parents?
- (when (not superclasses)
- (setq superclasses '(eieio-default-superclass)
- clear-parent t)
- )
-
- ;; Hook our new class into the existing structures so we can
- ;; autoload it later.
- (dolist (SC superclasses)
-
-
- ;; TODO - If we create an autoload that is in the map, that
- ;; map needs to be cleared!
-
-
- ;; Save the child in the parent.
- (cl-pushnew cname (if (class-p SC)
- (eieio--class-children (eieio--class-v SC))
- ;; Parent doesn't exist yet.
- (gethash SC eieio-defclass-autoload-map)))
+ ;; turn this into a usable self-pointing symbol
+ (when eieio-backward-compatibility
+ (set cname cname)
+ (make-obsolete-variable cname (format "use '%s instead" cname) "25.1"))
- ;; Save parent in child.
- (push (eieio--class-v SC) (eieio--class-parent newc)))
+ ;; Store the new class vector definition into the symbol. We need to
+ ;; do this first so that we can call defmethod for the accessor.
+ ;; The vector will be updated by the following while loop and will not
+ ;; need to be stored a second time.
+ (setf (eieio--class-v cname) newc)
- ;; turn this into a usable self-pointing symbol
- (when eieio-backward-compatibility
- (set cname cname)
- (make-obsolete-variable cname (format "use '%s instead" cname)
"25.1"))
-
- ;; Store the new class vector definition into the symbol. We need to
- ;; do this first so that we can call defmethod for the accessor.
- ;; The vector will be updated by the following while loop and will not
- ;; need to be stored a second time.
- (setf (eieio--class-v cname) newc)
-
- ;; Clear the parent
- (if clear-parent (setf (eieio--class-parent newc) nil))
-
- ;; Create an autoload on top of our constructor function.
- (autoload cname filename doc nil nil)
- (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil
nil)
- (autoload (intern (concat (symbol-name cname) "-child-p")) filename ""
nil nil)
- (autoload (intern (concat (symbol-name cname) "-list-p")) filename ""
nil nil)
-
- ))))
+ ;; Create an autoload on top of our constructor function.
+ (autoload cname filename doc nil nil)
+ (autoload (intern (format "%s-p" cname)) filename "" nil nil)
+ (when eieio-backward-compatibility
+ (autoload (intern (format "%s-child-p" cname)) filename "" nil nil)
+ (autoload (intern (format "%s-list-p" cname)) filename "" nil nil)))))
(defsubst eieio-class-un-autoload (cname)
"If class CNAME is in an autoload state, load its file."
@@ -378,8 +342,13 @@ See `defclass' for more information."
(setq eieio-hook nil)
(let* ((pname superclasses)
- (newc (eieio--class-make cname))
(oldc (when (class-p cname) (eieio--class-v cname)))
+ (newc (if (and oldc (not (eieio--class-default-object-cache oldc)))
+ ;; The oldc class is a stub setup by
eieio-defclass-autoload.
+ ;; Reuse it instead of creating a new one, so that existing
+ ;; references are still valid.
+ oldc
+ (eieio--class-make cname)))
(groups nil) ;; list of groups id'd from slots
(clearparent nil))
@@ -1284,6 +1253,8 @@ The order, in which the parents are returned depends on
the
method invocation orders of the involved classes."
(if (or (null class) (eq class eieio-default-superclass))
nil
+ (unless (eieio--class-default-object-cache class)
+ (eieio-class-un-autoload (eieio--class-symbol class)))
(cl-case (eieio--class-method-invocation-order class)
(:depth-first
(eieio--class-precedence-dfs class))
diff --git a/lisp/emacs-lisp/eieio-generic.el b/lisp/emacs-lisp/eieio-generic.el
index 0e90074..4045c03 100644
--- a/lisp/emacs-lisp/eieio-generic.el
+++ b/lisp/emacs-lisp/eieio-generic.el
@@ -33,6 +33,19 @@
(require 'eieio-core)
(declare-function child-of-class-p "eieio")
+(put 'eieio--defalias 'byte-hunk-handler
+ #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
+(defun eieio--defalias (name body)
+ "Like `defalias', but with less side-effects.
+More specifically, it has no side-effects at all when the new function
+definition is the same (`eq') as the old one."
+ (while (and (fboundp name) (symbolp (symbol-function name)))
+ ;; Follow aliases, so methods applied to obsolete aliases still work.
+ (setq name (symbol-function name)))
+ (unless (and (fboundp name)
+ (eq (symbol-function name) body))
+ (defalias name body)))
+
(defconst eieio--method-static 0 "Index into :static tag on a method.")
(defconst eieio--method-before 1 "Index into :before tag on a method.")
(defconst eieio--method-primary 2 "Index into :primary tag on a method.")
@@ -101,7 +114,7 @@ Methods with only primary implementations are executed in
an optimized way."
;; Make sure the method tables are installed.
(eieio--mt-install method)
;; Construct the actual body of this function.
- (put method 'function-documentation doc-string)
+ (if doc-string (put method 'function-documentation doc-string))
(eieio--defgeneric-form method))
((generic-p method) (symbol-function method)) ;Leave it as-is.
(t (error "You cannot create a generic/method over an existing symbol: %s"
@@ -177,20 +190,18 @@ but remove reference to all implementations of METHOD."
;;
;; If this method, after this setup, only has primary methods, then
;; we can setup the generic that way.
- (let ((doc-string (documentation method 'raw)))
- (put method 'function-documentation doc-string)
- ;; Use `defalias' so as to interact properly with nadvice.el.
- (defalias method
- (if (eieio--generic-primary-only-p method)
- ;; If there is only one primary method, then we can go one more
- ;; optimization step.
- (if (eieio--generic-primary-only-one-p method)
- (let* ((M (get method 'eieio-method-tree))
- (entry (car (aref M eieio--method-primary))))
- (eieio--defgeneric-form-primary-only-one
- method (car entry) (cdr entry)))
- (eieio--defgeneric-form-primary-only method))
- (eieio--defgeneric-form method))))))
+ ;; Use `defalias' so as to interact properly with nadvice.el.
+ (defalias method
+ (if (eieio--generic-primary-only-p method)
+ ;; If there is only one primary method, then we can go one more
+ ;; optimization step.
+ (if (eieio--generic-primary-only-one-p method)
+ (let* ((M (get method 'eieio-method-tree))
+ (entry (car (aref M eieio--method-primary))))
+ (eieio--defgeneric-form-primary-only-one
+ method (car entry) (cdr entry)))
+ (eieio--defgeneric-form-primary-only method))
+ (eieio--defgeneric-form method)))))
(defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS."
@@ -627,7 +638,7 @@ is memorized for faster future use."
;;; CLOS methods and generics
;;
-(defmacro defgeneric (method _args &optional doc-string)
+(defmacro defgeneric (method args &optional doc-string)
"Create a generic function METHOD.
DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body
@@ -637,7 +648,9 @@ currently ignored. You can use `defgeneric' to apply
specialized
top level documentation to a method."
(declare (doc-string 3))
`(eieio--defalias ',method
- (eieio--defgeneric-init-form ',method ,doc-string)))
+ (eieio--defgeneric-init-form
+ ',method
+ ,(if doc-string (help-add-fundoc-usage doc-string
args)))))
(defmacro defmethod (method &rest args)
"Create a new METHOD through `defgeneric' with ARGS.
@@ -684,9 +697,7 @@ Summary:
(code `(lambda ,fargs ,@(cdr args))))
`(progn
;; Make sure there is a generic and the byte-compiler sees it.
- (defgeneric ,method ,args
- ,(or (documentation code)
- (format "Generically created method `%s'." method)))
+ (defgeneric ,method ,args)
(eieio--defmethod ',method ',key ',class #',code))))
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index cc7b06c..6c9c798 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -1,4 +1,4 @@
-;;; find-func.el --- find the definition of the Emacs Lisp function near point
+;;; find-func.el --- find the definition of the Emacs Lisp function near point
-*- lexical-binding:t -*-
;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc.
@@ -59,7 +59,7 @@
(concat
"^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\
ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\
-foo\\|[^icfgv]\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
+foo\\|\\(?:[^icfv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
menu-bar-make-toggle\\)"
find-function-space-re
"\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)")
@@ -106,7 +106,10 @@ Please send improvements and fixes to the maintainer."
(defface . find-face-regexp))
"Alist mapping definition types into regexp variables.
Each regexp variable's value should actually be a format string
-to be used to substitute the desired symbol name into the regexp.")
+to be used to substitute the desired symbol name into the regexp.
+Instead of regexp variable, types can be mapped to functions as well,
+in which case the function is called with one argument (the object
+we're looking for) and it should search for it.")
(put 'find-function-regexp-alist 'risky-local-variable t)
(defcustom find-function-source-path nil
@@ -282,30 +285,33 @@ The search is done in the source for library LIBRARY."
(let* ((filename (find-library-name library))
(regexp-symbol (cdr (assq type find-function-regexp-alist))))
(with-current-buffer (find-file-noselect filename)
- (let ((regexp (format (symbol-value regexp-symbol)
- ;; Entry for ` (backquote) macro in loaddefs.el,
- ;; (defalias (quote \`)..., has a \ but
- ;; (symbol-name symbol) doesn't. Add an
- ;; optional \ to catch this.
- (concat "\\\\?"
- (regexp-quote (symbol-name symbol)))))
+ (let ((regexp (if (functionp regexp-symbol) regexp-symbol
+ (format (symbol-value regexp-symbol)
+ ;; Entry for ` (backquote) macro in
loaddefs.el,
+ ;; (defalias (quote \`)..., has a \ but
+ ;; (symbol-name symbol) doesn't. Add an
+ ;; optional \ to catch this.
+ (concat "\\\\?"
+ (regexp-quote (symbol-name symbol))))))
(case-fold-search))
(with-syntax-table emacs-lisp-mode-syntax-table
(goto-char (point-min))
- (if (or (re-search-forward regexp nil t)
- ;; `regexp' matches definitions using known forms like
- ;; `defun', or `defvar'. But some functions/variables
- ;; are defined using special macros (or functions), so
- ;; if `regexp' can't find the definition, we look for
- ;; something of the form "(SOMETHING <symbol> ...)".
- ;; This fails to distinguish function definitions from
- ;; variable declarations (or even uses thereof), but is
- ;; a good pragmatic fallback.
- (re-search-forward
- (concat "^([^ ]+" find-function-space-re "['(]?"
- (regexp-quote (symbol-name symbol))
- "\\_>")
- nil t))
+ (if (if (functionp regexp)
+ (funcall regexp symbol)
+ (or (re-search-forward regexp nil t)
+ ;; `regexp' matches definitions using known forms like
+ ;; `defun', or `defvar'. But some functions/variables
+ ;; are defined using special macros (or functions), so
+ ;; if `regexp' can't find the definition, we look for
+ ;; something of the form "(SOMETHING <symbol> ...)".
+ ;; This fails to distinguish function definitions from
+ ;; variable declarations (or even uses thereof), but is
+ ;; a good pragmatic fallback.
+ (re-search-forward
+ (concat "^([^ ]+" find-function-space-re "['(]?"
+ (regexp-quote (symbol-name symbol))
+ "\\_>")
+ nil t)))
(progn
(beginning-of-line)
(cons (current-buffer) (point)))
@@ -324,18 +330,19 @@ signal an error.
If VERBOSE is non-nil, and FUNCTION is an alias, display a
message about the whole chain of aliases."
- (let ((def (symbol-function (find-function-advised-original function)))
+ (let ((def (if (symbolp function)
+ (symbol-function (find-function-advised-original function))))
aliases)
;; FIXME for completeness, it might be nice to print something like:
;; foo (which is advised), which is an alias for bar (which is advised).
- (while (symbolp def)
+ (while (and def (symbolp def))
(or (eq def function)
(not verbose)
- (if aliases
- (setq aliases (concat aliases
+ (setq aliases (if aliases
+ (concat aliases
(format ", which is an alias for `%s'"
- (symbol-name def))))
- (setq aliases (format "`%s' is an alias for `%s'"
+ (symbol-name def)))
+ (format "`%s' is an alias for `%s'"
function (symbol-name def)))))
(setq function (symbol-function (find-function-advised-original
function))
def (symbol-function (find-function-advised-original function))))
@@ -408,7 +415,6 @@ See also `find-function-after-hook'.
Set mark before moving, if the buffer already existed."
(let* ((orig-point (point))
- (orig-buf (window-buffer))
(orig-buffers (buffer-list))
(buffer-point (save-excursion
(find-definition-noselect symbol type)))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 10c040a..c0d6393 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -183,8 +183,7 @@ OBJECT should be a symbol associated with a function,
variable, or face;
alternatively, it can be a function definition.
If TYPE is `defvar', search for a variable definition.
If TYPE is `defface', search for a face definition.
-If TYPE is the value returned by `symbol-function' for a function symbol,
- search for a function definition.
+If TYPE is not a symbol, search for a function definition.
The return value is the absolute name of a readable file where OBJECT is
defined. If several such files exist, preference is given to a file
@@ -194,9 +193,10 @@ suitable file is found, return nil."
(let* ((autoloaded (autoloadp type))
(file-name (or (and autoloaded (nth 1 type))
(symbol-file
- object (if (memq type (list 'defvar 'defface))
- type
- 'defun)))))
+ ;; FIXME: Why do we have this weird "If TYPE is the
+ ;; value returned by `symbol-function' for a function
+ ;; symbol" exception?
+ object (or (if (symbolp type) type) 'defun)))))
(cond
(autoloaded
;; An autoloaded function: Locate the file since `symbol-function'
@@ -452,6 +452,18 @@ FILE is the file where FUNCTION was probably defined."
(t "."))
"\n")))))
+(defun help-fns-short-filename (filename)
+ (let* ((abbrev (abbreviate-file-name filename))
+ (short abbrev))
+ (dolist (dir load-path)
+ (let ((rel (file-relative-name filename dir)))
+ (if (< (length rel) (length short))
+ (setq short rel)))
+ (let ((rel (file-relative-name abbrev dir)))
+ (if (< (length rel) (length short))
+ (setq short rel))))
+ short))
+
;;;###autoload
(defun describe-function-1 (function)
(let* ((advised (and (symbolp function)
@@ -543,7 +555,7 @@ FILE is the file where FUNCTION was probably defined."
;; but that's completely wrong when the user used load-file.
(princ (if (eq file-name 'C-source)
"C source code"
- (file-name-nondirectory file-name)))
+ (help-fns-short-filename file-name)))
(princ "'")
;; Make a hyperlink to the library.
(with-current-buffer standard-output
@@ -564,7 +576,7 @@ FILE is the file where FUNCTION was probably defined."
help-enable-auto-load
(string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]"
doc-raw)
- (load (cadr real-def) t))
+ (autoload-do-load real-def))
(substitute-command-keys doc-raw))))
(help-fns--key-bindings function)
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index dd20307..c62ddc3 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -191,7 +191,7 @@ The format is (FUNCTION ARGS...).")
(define-button-type 'help-function-def
:supertype 'help-xref
- 'help-function (lambda (fun file)
+ 'help-function (lambda (fun file &optional type)
(require 'find-func)
(when (eq file 'C-source)
(setq file
@@ -199,7 +199,7 @@ The format is (FUNCTION ARGS...).")
;; Don't use find-function-noselect because it follows
;; aliases (which fails for built-in functions).
(let ((location
- (find-function-search-for-symbol fun nil file)))
+ (find-function-search-for-symbol fun type file)))
(pop-to-buffer (car location))
(if (cdr location)
(goto-char (cdr location))
diff --git a/test/ChangeLog b/test/ChangeLog
index 8ed02ee..c40407f 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,13 @@
+2015-01-17 Stefan Monnier <address@hidden>
+
+ * automated/eieio-test-methodinvoke.el (eieio-test-cl-generic-1): Reset
+ eieio-test--1.
+
+ * automated/cl-generic-tests.el (cl-generic-test-8-after/before):
+ Rename from cl-generic-test-7-after/before.
+ (cl--generic-test-advice): New function.
+ (cl-generic-test-9-advice): New test.
+
2015-01-16 Jorgen Schaefer <address@hidden>
* automated/package-test.el (package-test-install-prioritized):
diff --git a/test/automated/cl-generic-tests.el
b/test/automated/cl-generic-tests.el
index 57b17b1..46397fb 100644
--- a/test/automated/cl-generic-tests.el
+++ b/test/automated/cl-generic-tests.el
@@ -129,7 +129,7 @@
(cons "x&y-int" (cl-call-next-method)))
(should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
-(ert-deftest cl-generic-test-7-after/before ()
+(ert-deftest cl-generic-test-8-after/before ()
(let ((log ()))
(cl-defgeneric cl--generic-1 (x y))
(cl-defmethod cl--generic-1 ((_x t) y) (cons y log))
@@ -142,5 +142,18 @@
(should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4))))
(should (equal log '((:after 4) (:before 4))))))
+(defun cl--generic-test-advice (&rest args) (cons "advice" (apply args)))
+
+(ert-deftest cl-generic-test-9-advice ()
+ (cl-defgeneric cl--generic-1 (x y) "My doc.")
+ (cl-defmethod cl--generic-1 (x y) (list x y))
+ (advice-add 'cl--generic-1 :around #'cl--generic-test-advice)
+ (should (equal (cl--generic-1 4 5) '("advice" 4 5)))
+ (cl-defmethod cl--generic-1 ((_x integer) _y)
+ (cons "integer" (cl-call-next-method)))
+ (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5)))
+ (advice-remove 'cl--generic-1 #'cl--generic-test-advice)
+ (should (equal (cl--generic-1 4 5) '("integer" 4 5))))
+
(provide 'cl-generic-tests)
;;; cl-generic-tests.el ends here
diff --git a/test/automated/eieio-test-methodinvoke.el
b/test/automated/eieio-test-methodinvoke.el
index 6362fc5..1c3d9c3 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -384,6 +384,7 @@
(cl-defgeneric eieio-test--1 (x y))
(ert-deftest eieio-test-cl-generic-1 ()
+ (cl-defgeneric eieio-test--1 (x y))
(cl-defmethod eieio-test--1 (x y) (list x y))
(cl-defmethod eieio-test--1 ((_x CNM-0) y)
(cons "CNM-0" (cl-call-next-method 7 y)))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 24b7f77: Improve handling of doc-strings and describe-function for cl-generic,
Stefan Monnier <=