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.
This commit is contained in:
Stefan Monnier
parent
a2cd6d90d2
commit
24b7f77581
10 changed files with 269 additions and 157 deletions
|
|
@ -1,3 +1,48 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
)
|
||||
;; 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"))
|
||||
|
||||
;; Hook our new class into the existing structures so we can
|
||||
;; autoload it later.
|
||||
(dolist (SC superclasses)
|
||||
;; 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)
|
||||
|
||||
|
||||
;; 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)))
|
||||
|
||||
;; Save parent in child.
|
||||
(push (eieio--class-v SC) (eieio--class-parent 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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,13 @@
|
|||
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):
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue