+2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ 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 <bruce.connor.am@gmail.com>
* emacs-lisp/package.el (package--read-pkg-desc): New
(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))
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 ()))
(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.
(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))
(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.
(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))
(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))
(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))))
;;; 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.
(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.
;; 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.
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."
(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))
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))
(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.")
;; 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"
;;
;; 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."
;;; 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
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.
(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))))
-;;; 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.
(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-\\|$\\|\(\\|\)\\)")
(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
(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)))
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))))
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)))
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
(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'
(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)
;; 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
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)
(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
;; 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))
+2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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 <contact@jorgenschaefer.de>
* automated/package-test.el (package-test-install-prioritized):
(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))
(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
(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)))
projects / emacs.git / commitdiff