diff options
| author | Joakim Verona | 2015-01-18 10:53:38 +0100 |
|---|---|---|
| committer | Joakim Verona | 2015-01-18 10:53:38 +0100 |
| commit | 54efd2ab176dd6cc33bb1e86a9c37908c26d0a46 (patch) | |
| tree | ae7dfc525e25275235b1d6de84cf067a751742e4 | |
| parent | 576960211cb54bc77dc6969591420bca89c59456 (diff) | |
| parent | 253d44bd27b7d90b614b6b968a3b125eeb0a48f2 (diff) | |
| download | emacs-54efd2ab176dd6cc33bb1e86a9c37908c26d0a46.tar.gz emacs-54efd2ab176dd6cc33bb1e86a9c37908c26d0a46.zip | |
merge master
32 files changed, 824 insertions, 516 deletions
diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog index 5057fb91f0b..2baa13cea8c 100644 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog | |||
| @@ -1,3 +1,7 @@ | |||
| 1 | 2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * eieio.texi (Slot Options): Document :protection as unsupported. | ||
| 4 | |||
| 1 | 2015-01-01 Michael Albinus <michael.albinus@gmx.de> | 5 | 2015-01-01 Michael Albinus <michael.albinus@gmx.de> |
| 2 | 6 | ||
| 3 | Sync with Tramp 2.2.11. | 7 | Sync with Tramp 2.2.11. |
| @@ -24,7 +28,7 @@ | |||
| 24 | 28 | ||
| 25 | 2014-12-18 Eric Abrahamsen <eric@ericabrahamsen.net> | 29 | 2014-12-18 Eric Abrahamsen <eric@ericabrahamsen.net> |
| 26 | 30 | ||
| 27 | * gnus.texi (Gnus Registry Setup): Explain pruning changes. Mention | 31 | * gnus.texi (Gnus Registry Setup): Explain pruning changes. Mention |
| 28 | gnus-registry-prune-factor. Explain sorting changes and | 32 | gnus-registry-prune-factor. Explain sorting changes and |
| 29 | gnus-registry-default-sort-function. Correct file extension. | 33 | gnus-registry-default-sort-function. Correct file extension. |
| 30 | 34 | ||
diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi index 954970dd527..3f42862f07a 100644 --- a/doc/misc/eieio.texi +++ b/doc/misc/eieio.texi | |||
| @@ -538,10 +538,15 @@ to quote the symbol. If you wanted to run a function on load, you | |||
| 538 | can output the code to do the construction of the value. | 538 | can output the code to do the construction of the value. |
| 539 | 539 | ||
| 540 | @item :protection | 540 | @item :protection |
| 541 | This is an old option that is not supported any more. | ||
| 542 | |||
| 541 | When using a slot referencing function such as @code{slot-value}, and | 543 | When using a slot referencing function such as @code{slot-value}, and |
| 542 | the value behind @var{slot} is private or protected, then the current | 544 | the value behind @var{slot} is private or protected, then the current |
| 543 | scope of operation must be within a method of the calling object. | 545 | scope of operation must be within a method of the calling object. |
| 544 | 546 | ||
| 547 | This protection is not enforced by the code any more, so it's only useful | ||
| 548 | as documentation. | ||
| 549 | |||
| 545 | Valid values are: | 550 | Valid values are: |
| 546 | 551 | ||
| 547 | @table @code | 552 | @table @code |
diff --git a/etc/ChangeLog b/etc/ChangeLog index 681858e5977..7b64dfb9153 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog | |||
| @@ -1,3 +1,7 @@ | |||
| 1 | 2015-01-16 Artur Malabarba <bruce.connor.am@gmail.com> | ||
| 2 | |||
| 3 | * NEWS: Document installing packages from directories. | ||
| 4 | |||
| 1 | 2015-01-15 Eli Zaretskii <eliz@gnu.org> | 5 | 2015-01-15 Eli Zaretskii <eliz@gnu.org> |
| 2 | 6 | ||
| 3 | * NEWS: Mention 'set-binary-mode'. | 7 | * NEWS: Mention 'set-binary-mode'. |
| @@ -56,6 +56,10 @@ so if you want to use it, you can always take a copy from an older Emacs. | |||
| 56 | 56 | ||
| 57 | * Changes in Emacs 25.1 | 57 | * Changes in Emacs 25.1 |
| 58 | 58 | ||
| 59 | ** `package-install-from-buffer' and `package-install-file' work on directories. | ||
| 60 | This follows the same rules as installing from a .tar file, except the | ||
| 61 | -pkg file is optional. | ||
| 62 | |||
| 59 | ** New function `custom-prompt-customize-unsaved-options' checks for | 63 | ** New function `custom-prompt-customize-unsaved-options' checks for |
| 60 | unsaved customizations and prompts user to customize (if found). | 64 | unsaved customizations and prompts user to customize (if found). |
| 61 | 65 | ||
| @@ -198,6 +202,7 @@ the old behavior -- *shell* buffer displays in current window -- use | |||
| 198 | 202 | ||
| 199 | 203 | ||
| 200 | ** EIEIO | 204 | ** EIEIO |
| 205 | *** The `:protection' slot option is not obeyed any more. | ||
| 201 | *** The <class>-list-p and <class>-child-p functions are declared obsolete. | 206 | *** The <class>-list-p and <class>-child-p functions are declared obsolete. |
| 202 | *** The <class> variables are declared obsolete. | 207 | *** The <class> variables are declared obsolete. |
| 203 | *** The <initarg> variables are declared obsolete. | 208 | *** The <initarg> variables are declared obsolete. |
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 57aaea0f4ce..680adc71d0a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,149 @@ | |||
| 1 | 2015-01-18 Leo Liu <sdl.web@gmail.com> | ||
| 2 | |||
| 3 | * emacs-lisp/cl-extra.el (cl-subseq): Use seq-subseq and fix | ||
| 4 | multiple evaluation. (Bug#19519) | ||
| 5 | |||
| 6 | * emacs-lisp/seq.el (seq-subseq): Throw bad bounding indices | ||
| 7 | error. (Bug#19434) | ||
| 8 | |||
| 9 | 2015-01-18 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 10 | |||
| 11 | * emacs-lisp/cl-macs.el (cl-defstruct): Minor optimization when include | ||
| 12 | or print is nil. | ||
| 13 | (cl-struct-type-p): New function. | ||
| 14 | |||
| 15 | * emacs-lisp/cl-generic.el: Add support for cl-next-method-p. | ||
| 16 | (cl-defmethod): Add edebug spec. | ||
| 17 | (cl--generic-build-combined-method): Fix call to | ||
| 18 | cl-no-applicable-method. | ||
| 19 | (cl--generic-nnm-sample, cl--generic-cnm-sample): New constant. | ||
| 20 | (cl--generic-isnot-nnm-p): New function. | ||
| 21 | (cl--generic-lambda): Use it to add support for cl-next-method-p. | ||
| 22 | (cl-no-next-method, cl-no-applicable-method): Simplify arg list. | ||
| 23 | (cl-next-method-p): New function. | ||
| 24 | |||
| 25 | 2015-01-17 Ulrich Müller <ulm@gentoo.org> | ||
| 26 | |||
| 27 | * version.el (emacs-repository-get-version): Update docstring. | ||
| 28 | |||
| 29 | 2015-01-17 Ivan Shmakov <ivan@siamics.net> | ||
| 30 | |||
| 31 | * url/url-cookie.el (url-cookie-write-file): Let-bind print-length | ||
| 32 | and print-level to nil to avoid writing a garbled list. (Bug#16805) | ||
| 33 | |||
| 34 | * files.el (find-file-other-window, find-file-other-frame): | ||
| 35 | Use mapc instead of mapcar. (Bug#18175) | ||
| 36 | |||
| 37 | * files.el (dir-locals-collect-variables): Use default-directory | ||
| 38 | in place of the file name while working on non-file buffers, just | ||
| 39 | like hack-dir-local-variables already does. (Bug#19140) | ||
| 40 | |||
| 41 | * textmodes/enriched.el (enriched-encode): | ||
| 42 | Use inhibit-point-motion-hooks in addition to inhibit-read-only. | ||
| 43 | (Bug#18246) | ||
| 44 | |||
| 45 | * desktop.el (desktop-read): Do not call desktop-clear when no | ||
| 46 | desktop file is found. (Bug#18371) | ||
| 47 | |||
| 48 | * misearch.el (multi-isearch-unload-function): New function. | ||
| 49 | (misearch-unload-function): New alias. (Bug#19566) | ||
| 50 | |||
| 51 | 2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 52 | |||
| 53 | * emacs-lisp/eieio-core.el (eieio--class-constructor): Rename from | ||
| 54 | class-constructor, and make it an alias for `identity'. | ||
| 55 | Update all callers. | ||
| 56 | |||
| 57 | * emacs-lisp/eieio.el (eieio-constructor): Handle obsolete object name | ||
| 58 | argument here (bug#19620)... | ||
| 59 | (defclass): ...instead of in the constructor here. | ||
| 60 | |||
| 61 | 2015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de> | ||
| 62 | |||
| 63 | * emacs-lisp/package.el (package-archive-priorities): | ||
| 64 | Specify correct type. | ||
| 65 | |||
| 66 | 2015-01-17 Ulrich Müller <ulm@gentoo.org> | ||
| 67 | |||
| 68 | * version.el (emacs-bzr-version-dirstate, emacs-bzr-version-bzr): | ||
| 69 | Remove. | ||
| 70 | (emacs-repository-get-version): Discard the Bazaar case. | ||
| 71 | * vc/vc-bzr.el (vc-bzr-version-dirstate): Rename from | ||
| 72 | emacs-bzr-version-dirstate and move from version.el to here. | ||
| 73 | (vc-bzr-working-revision): Use it. | ||
| 74 | |||
| 75 | 2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 76 | |||
| 77 | * emacs-lisp/eieio-generic.el (call-next-method): Don't bother checking | ||
| 78 | eieio--scoped-class any more. | ||
| 79 | |||
| 80 | * emacs-lisp/eieio-core.el (eieio--scoped-class-stack): Remove var. | ||
| 81 | (eieio--scoped-class): Remove function. | ||
| 82 | (eieio--with-scoped-class): Remove macro. Replace uses with `progn'. | ||
| 83 | (eieio--slot-name-index): Don't check the :protection anymore. | ||
| 84 | (eieio-initializing-object): Remove var. | ||
| 85 | (eieio-set-defaults): Don't let-bind eieio-initializing-object. | ||
| 86 | |||
| 87 | 2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 88 | |||
| 89 | Improve handling of doc-strings and describe-function for cl-generic. | ||
| 90 | |||
| 91 | * help-mode.el (help-function-def): Add optional arg `type'. | ||
| 92 | |||
| 93 | * help-fns.el (find-lisp-object-file-name): Accept any `type' as long | ||
| 94 | as it's a symbol. | ||
| 95 | (help-fns-short-filename): New function. | ||
| 96 | (describe-function-1): Use it. Use autoload-do-load. | ||
| 97 | |||
| 98 | * emacs-lisp/find-func.el: Use lexical-binding. | ||
| 99 | (find-function-regexp): Don't rule out `defgeneric'. | ||
| 100 | (find-function-regexp-alist): Document new possibility of including | ||
| 101 | a function instead of a regexp. | ||
| 102 | (find-function-search-for-symbol): Implement that new possibility. | ||
| 103 | (find-function-library): Don't assume that `function' is a symbol. | ||
| 104 | (find-function-do-it): Remove unused var `orig-buf'. | ||
| 105 | |||
| 106 | * emacs-lisp/eieio-generic.el (eieio--defalias): Move from eieio-core. | ||
| 107 | (eieio--defgeneric-init-form): Don't throw away a previous docstring. | ||
| 108 | (eieio--method-optimize-primary): Don't mess with the docstring. | ||
| 109 | (defgeneric): Keep the `args' in the docstring. | ||
| 110 | (defmethod): Don't use the method's docstring for the generic | ||
| 111 | function's docstring. | ||
| 112 | |||
| 113 | * emacs-lisp/eieio-core.el (eieio--defalias): Move to eieio-generic.el. | ||
| 114 | (eieio-defclass-autoload): Don't record the superclasses any more. | ||
| 115 | (eieio-defclass-internal): Reuse the old class object if it was just an | ||
| 116 | autoload stub. | ||
| 117 | (eieio--class-precedence-list): Load the class if it's autoloaded. | ||
| 118 | |||
| 119 | * emacs-lisp/cl-generic.el (cl-generic-ensure-function): It's OK to | ||
| 120 | override an autoload. | ||
| 121 | (cl-generic-current-method-specializers): Replace dyn-bind variable | ||
| 122 | with a lexically-scoped macro. | ||
| 123 | (cl--generic-lambda): Update accordingly. | ||
| 124 | (cl-generic-define-method): Record manually in the load-history with | ||
| 125 | type `cl-defmethod'. | ||
| 126 | (cl--generic-get-dispatcher): Minor optimization. | ||
| 127 | (cl--generic-search-method): New function. | ||
| 128 | (find-function-regexp-alist): Add entry for `cl-defmethod' type. | ||
| 129 | (cl--generic-search-method): Add hyperlinks for methods. Merge the | ||
| 130 | specializers and the function's arguments. | ||
| 131 | |||
| 132 | 2015-01-16 Artur Malabarba <bruce.connor.am@gmail.com> | ||
| 133 | |||
| 134 | * emacs-lisp/package.el (package--read-pkg-desc): | ||
| 135 | New function. Read a `define-package' form in current buffer. Return | ||
| 136 | the pkg-desc, with desc-kind set to KIND. | ||
| 137 | (package-dir-info): New function. Find package information for a | ||
| 138 | directory. The return result is a `package-desc'. | ||
| 139 | (package-install-from-buffer): Install packages from dired buffer. | ||
| 140 | (package-install-file): Install packages from directory. | ||
| 141 | (package-desc-suffix) | ||
| 142 | (package-install-from-archive) | ||
| 143 | * emacs-lisp/package-x.el (package-upload-buffer-internal): | ||
| 144 | Ensure all remaining instances of `package-desc-kind' handle the 'dir | ||
| 145 | value. | ||
| 146 | |||
| 1 | 2015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de> | 147 | 2015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de> |
| 2 | 148 | ||
| 3 | * emacs-lisp/package.el: Provide repository priorities. | 149 | * emacs-lisp/package.el: Provide repository priorities. |
| @@ -38,6 +184,13 @@ | |||
| 38 | 184 | ||
| 39 | 2015-01-15 Stefan Monnier <monnier@iro.umontreal.ca> | 185 | 2015-01-15 Stefan Monnier <monnier@iro.umontreal.ca> |
| 40 | 186 | ||
| 187 | * emacs-lisp/cl-macs.el (cl--labels-magic): New constant. | ||
| 188 | (cl--labels-convert): Use it to ask the macro what is its replacement | ||
| 189 | in the #'f case. | ||
| 190 | |||
| 191 | * emacs-lisp/cl-generic.el (cl--generic-build-combined-method): | ||
| 192 | Return the value of the primary rather than the after method. | ||
| 193 | |||
| 41 | * emacs-lisp/eieio-core.el: Provide support for cl-generic. | 194 | * emacs-lisp/eieio-core.el: Provide support for cl-generic. |
| 42 | (eieio--generic-tagcode): New function. | 195 | (eieio--generic-tagcode): New function. |
| 43 | (cl-generic-tagcode-function): Use it. | 196 | (cl-generic-tagcode-function): Use it. |
diff --git a/lisp/desktop.el b/lisp/desktop.el index 3845f940d02..c355d7f080f 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el | |||
| @@ -1191,7 +1191,6 @@ Using it may cause conflicts. Use it anyway? " owner))))) | |||
| 1191 | (desktop-auto-save-enable) | 1191 | (desktop-auto-save-enable) |
| 1192 | t)) | 1192 | t)) |
| 1193 | ;; No desktop file found. | 1193 | ;; No desktop file found. |
| 1194 | (desktop-clear) | ||
| 1195 | (let ((default-directory desktop-dirname)) | 1194 | (let ((default-directory desktop-dirname)) |
| 1196 | (run-hooks 'desktop-no-desktop-file-hook)) | 1195 | (run-hooks 'desktop-no-desktop-file-hook)) |
| 1197 | (message "No desktop file.") | 1196 | (message "No desktop file.") |
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 2f8a5a62f28..afc2adbee6d 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el | |||
| @@ -38,6 +38,7 @@ | |||
| 38 | ;;; Code: | 38 | ;;; Code: |
| 39 | 39 | ||
| 40 | (require 'cl-lib) | 40 | (require 'cl-lib) |
| 41 | (require 'seq) | ||
| 41 | 42 | ||
| 42 | ;;; Type coercion. | 43 | ;;; Type coercion. |
| 43 | 44 | ||
| @@ -521,28 +522,10 @@ If END is omitted, it defaults to the length of the sequence. | |||
| 521 | If START or END is negative, it counts from the end." | 522 | If START or END is negative, it counts from the end." |
| 522 | (declare (gv-setter | 523 | (declare (gv-setter |
| 523 | (lambda (new) | 524 | (lambda (new) |
| 524 | `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) | 525 | (macroexp-let2 nil new new |
| 525 | ,new)))) | 526 | `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end) |
| 526 | (if (stringp seq) (substring seq start end) | 527 | ,new))))) |
| 527 | (let (len) | 528 | (seq-subseq seq start end)) |
| 528 | (and end (< end 0) (setq end (+ end (setq len (length seq))))) | ||
| 529 | (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) | ||
| 530 | (cond ((listp seq) | ||
| 531 | (if (> start 0) (setq seq (nthcdr start seq))) | ||
| 532 | (if end | ||
| 533 | (let ((res nil)) | ||
| 534 | (while (>= (setq end (1- end)) start) | ||
| 535 | (push (pop seq) res)) | ||
| 536 | (nreverse res)) | ||
| 537 | (copy-sequence seq))) | ||
| 538 | (t | ||
| 539 | (or end (setq end (or len (length seq)))) | ||
| 540 | (let ((res (make-vector (max (- end start) 0) nil)) | ||
| 541 | (i 0)) | ||
| 542 | (while (< start end) | ||
| 543 | (aset res i (aref seq start)) | ||
| 544 | (setq i (1+ i) start (1+ start))) | ||
| 545 | res)))))) | ||
| 546 | 529 | ||
| 547 | ;;;###autoload | 530 | ;;;###autoload |
| 548 | (defun cl-concatenate (type &rest seqs) | 531 | (defun cl-concatenate (type &rest seqs) |
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 41a419a3c4a..819e2e92888 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el | |||
| @@ -26,8 +26,7 @@ | |||
| 26 | ;; The main entry points are: `cl-defgeneric' and `cl-defmethod'. | 26 | ;; The main entry points are: `cl-defgeneric' and `cl-defmethod'. |
| 27 | 27 | ||
| 28 | ;; Missing elements: | 28 | ;; Missing elements: |
| 29 | ;; - We don't support next-method-p, make-method, call-method, | 29 | ;; - We don't support make-method, call-method, define-method-combination. |
| 30 | ;; define-method-combination. | ||
| 31 | ;; - Method and generic function objects: CLOS defines methods as objects | 30 | ;; - Method and generic function objects: CLOS defines methods as objects |
| 32 | ;; (same for generic functions), whereas we don't offer such an abstraction. | 31 | ;; (same for generic functions), whereas we don't offer such an abstraction. |
| 33 | ;; - `no-next-method' should receive the "calling method" object, but since we | 32 | ;; - `no-next-method' should receive the "calling method" object, but since we |
| @@ -107,6 +106,7 @@ They should be sorted from most specific to least specific.") | |||
| 107 | (symbolp (symbol-function name))) | 106 | (symbolp (symbol-function name))) |
| 108 | (setq name (symbol-function name))) | 107 | (setq name (symbol-function name))) |
| 109 | (unless (or (not (fboundp name)) | 108 | (unless (or (not (fboundp name)) |
| 109 | (autoloadp (symbol-function name)) | ||
| 110 | (and (functionp name) generic)) | 110 | (and (functionp name) generic)) |
| 111 | (error "%s is already defined as something else than a generic function" | 111 | (error "%s is already defined as something else than a generic function" |
| 112 | origname)) | 112 | origname)) |
| @@ -132,7 +132,7 @@ They should be sorted from most specific to least specific.") | |||
| 132 | "Create a generic function NAME. | 132 | "Create a generic function NAME. |
| 133 | DOC-STRING is the base documentation for this class. A generic | 133 | DOC-STRING is the base documentation for this class. A generic |
| 134 | function has no body, as its purpose is to decide which method body | 134 | function has no body, as its purpose is to decide which method body |
| 135 | is appropriate to use. Specific methods are defined with `defmethod'. | 135 | is appropriate to use. Specific methods are defined with `cl-defmethod'. |
| 136 | With this implementation the ARGS are currently ignored. | 136 | With this implementation the ARGS are currently ignored. |
| 137 | OPTIONS-AND-METHODS is currently only used to specify the docstring, | 137 | OPTIONS-AND-METHODS is currently only used to specify the docstring, |
| 138 | via (:documentation DOCSTRING)." | 138 | via (:documentation DOCSTRING)." |
| @@ -153,7 +153,7 @@ via (:documentation DOCSTRING)." | |||
| 153 | code)) | 153 | code)) |
| 154 | (defalias ',name | 154 | (defalias ',name |
| 155 | (cl-generic-define ',name ',args ',options-and-methods) | 155 | (cl-generic-define ',name ',args ',options-and-methods) |
| 156 | ,doc)))) | 156 | ,(help-add-fundoc-usage doc args))))) |
| 157 | 157 | ||
| 158 | (defun cl--generic-mandatory-args (args) | 158 | (defun cl--generic-mandatory-args (args) |
| 159 | (let ((res ())) | 159 | (let ((res ())) |
| @@ -176,15 +176,10 @@ via (:documentation DOCSTRING)." | |||
| 176 | (setf (cl--generic-method-table generic) nil) | 176 | (setf (cl--generic-method-table generic) nil) |
| 177 | (cl--generic-make-function generic))) | 177 | (cl--generic-make-function generic))) |
| 178 | 178 | ||
| 179 | (defvar cl-generic-current-method-specializers nil | 179 | (defmacro cl-generic-current-method-specializers () |
| 180 | ;; This is let-bound during macro-expansion of method bodies, so that those | 180 | "List of (VAR . TYPE) where TYPE is var's specializer. |
| 181 | ;; bodies can be optimized knowing that the specializers have matched. | 181 | This macro can only be used within the lexical scope of a cl-generic method." |
| 182 | ;; FIXME: This presumes the formal arguments aren't modified via `setq' and | 182 | (error "cl-generic-current-method-specializers used outside of a method")) |
| 183 | ;; aren't shadowed either ;-( | ||
| 184 | ;; FIXME: This might leak outside the scope of the method if, during | ||
| 185 | ;; macroexpansion of the method, something causes some other macroexpansion | ||
| 186 | ;; (e.g. an autoload). | ||
| 187 | "List of (VAR . TYPE) where TYPE is var's specializer.") | ||
| 188 | 183 | ||
| 189 | (eval-and-compile ;Needed while compiling the cl-defmethod calls below! | 184 | (eval-and-compile ;Needed while compiling the cl-defmethod calls below! |
| 190 | (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. | 185 | (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. |
| @@ -199,46 +194,54 @@ via (:documentation DOCSTRING)." | |||
| 199 | (defun cl--generic-lambda (args body with-cnm) | 194 | (defun cl--generic-lambda (args body with-cnm) |
| 200 | "Make the lambda expression for a method with ARGS and BODY." | 195 | "Make the lambda expression for a method with ARGS and BODY." |
| 201 | (let ((plain-args ()) | 196 | (let ((plain-args ()) |
| 202 | (cl-generic-current-method-specializers nil) | 197 | (specializers nil) |
| 203 | (doc-string (if (stringp (car-safe body)) (pop body))) | 198 | (doc-string (if (stringp (car-safe body)) (pop body))) |
| 204 | (mandatory t)) | 199 | (mandatory t)) |
| 205 | (dolist (arg args) | 200 | (dolist (arg args) |
| 206 | (push (pcase arg | 201 | (push (pcase arg |
| 207 | ((or '&optional '&rest '&key) (setq mandatory nil) arg) | 202 | ((or '&optional '&rest '&key) (setq mandatory nil) arg) |
| 208 | ((and `(,name . ,type) (guard mandatory)) | 203 | ((and `(,name . ,type) (guard mandatory)) |
| 209 | (push (cons name (car type)) | 204 | (push (cons name (car type)) specializers) |
| 210 | cl-generic-current-method-specializers) | ||
| 211 | name) | 205 | name) |
| 212 | (_ arg)) | 206 | (_ arg)) |
| 213 | plain-args)) | 207 | plain-args)) |
| 214 | (setq plain-args (nreverse plain-args)) | 208 | (setq plain-args (nreverse plain-args)) |
| 215 | (let ((fun `(cl-function (lambda ,plain-args | 209 | (let ((fun `(cl-function (lambda ,plain-args |
| 216 | ,@(if doc-string (list doc-string)) | 210 | ,@(if doc-string (list doc-string)) |
| 217 | ,@body)))) | 211 | ,@body))) |
| 212 | (macroenv (cons `(cl-generic-current-method-specializers | ||
| 213 | . ,(lambda () specializers)) | ||
| 214 | macroexpand-all-environment))) | ||
| 218 | (if (not with-cnm) | 215 | (if (not with-cnm) |
| 219 | (cons nil fun) | 216 | (cons nil (macroexpand-all fun macroenv)) |
| 220 | ;; First macroexpand away the cl-function stuff (e.g. &key and | 217 | ;; First macroexpand away the cl-function stuff (e.g. &key and |
| 221 | ;; destructuring args, `declare' and whatnot). | 218 | ;; destructuring args, `declare' and whatnot). |
| 222 | (pcase (macroexpand fun macroexpand-all-environment) | 219 | (pcase (macroexpand fun macroenv) |
| 223 | (`#'(lambda ,args . ,body) | 220 | (`#'(lambda ,args . ,body) |
| 224 | (require 'cl-lib) ;Needed to expand `cl-flet'. | 221 | (require 'cl-lib) ;Needed to expand `cl-flet'. |
| 225 | (let* ((doc-string (and doc-string (stringp (car body)) | 222 | (let* ((doc-string (and doc-string (stringp (car body)) |
| 226 | (pop body))) | 223 | (pop body))) |
| 227 | (cnm (make-symbol "cl--cnm")) | 224 | (cnm (make-symbol "cl--cnm")) |
| 225 | (nmp (make-symbol "cl--nmp")) | ||
| 228 | (nbody (macroexpand-all | 226 | (nbody (macroexpand-all |
| 229 | `(cl-flet ((cl-call-next-method ,cnm)) | 227 | `(cl-flet ((cl-call-next-method ,cnm) |
| 228 | (cl-next-method-p ,nmp)) | ||
| 230 | ,@body) | 229 | ,@body) |
| 231 | macroexpand-all-environment)) | 230 | macroenv)) |
| 232 | ;; FIXME: Rather than `grep' after the fact, the | 231 | ;; FIXME: Rather than `grep' after the fact, the |
| 233 | ;; macroexpansion should directly set some flag when cnm | 232 | ;; macroexpansion should directly set some flag when cnm |
| 234 | ;; is used. | 233 | ;; is used. |
| 235 | ;; FIXME: Also, optimize the case where call-next-method is | 234 | ;; FIXME: Also, optimize the case where call-next-method is |
| 236 | ;; only called with explicit arguments. | 235 | ;; only called with explicit arguments. |
| 237 | (uses-cnm (cl--generic-fgrep (list cnm) nbody))) | 236 | (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) |
| 238 | (cons (not (not uses-cnm)) | 237 | (cons (not (not uses-cnm)) |
| 239 | `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) | 238 | `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) |
| 240 | ,@(if doc-string (list doc-string)) | 239 | ,@(if doc-string (list doc-string)) |
| 241 | ,nbody)))) | 240 | ,(if (not (memq nmp uses-cnm)) |
| 241 | nbody | ||
| 242 | `(let ((,nmp (lambda () | ||
| 243 | (cl--generic-isnot-nnm-p ,cnm)))) | ||
| 244 | ,nbody)))))) | ||
| 242 | (f (error "Unexpected macroexpansion result: %S" f)))))))) | 245 | (f (error "Unexpected macroexpansion result: %S" f)))))))) |
| 243 | 246 | ||
| 244 | 247 | ||
| @@ -263,7 +266,15 @@ Other than a type, TYPE can also be of the form `(eql VAL)' in | |||
| 263 | which case this method will be invoked when the argument is `eql' to VAL. | 266 | which case this method will be invoked when the argument is `eql' to VAL. |
| 264 | 267 | ||
| 265 | \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" | 268 | \(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" |
| 266 | (declare (doc-string 3) (indent 2)) | 269 | (declare (doc-string 3) (indent 2) |
| 270 | (debug | ||
| 271 | (&define ; this means we are defining something | ||
| 272 | [&or name ("setf" :name setf name)] | ||
| 273 | ;; ^^ This is the methods symbol | ||
| 274 | [ &optional keywordp ] ; this is key :before etc | ||
| 275 | list ; arguments | ||
| 276 | [ &optional stringp ] ; documentation string | ||
| 277 | def-body))) ; part to be debugged | ||
| 267 | (let ((qualifiers nil)) | 278 | (let ((qualifiers nil)) |
| 268 | (while (keywordp args) | 279 | (while (keywordp args) |
| 269 | (push args qualifiers) | 280 | (push args qualifiers) |
| @@ -309,8 +320,13 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 309 | (setf (cl--generic-method-table generic) | 320 | (setf (cl--generic-method-table generic) |
| 310 | (cons `(,key ,uses-cnm . ,function) mt))) | 321 | (cons `(,key ,uses-cnm . ,function) mt))) |
| 311 | ;; For aliases, cl--generic-name gives us the actual name. | 322 | ;; For aliases, cl--generic-name gives us the actual name. |
| 312 | (defalias (cl--generic-name generic) | 323 | (let ((gfun (cl--generic-make-function generic)) |
| 313 | (cl--generic-make-function generic)))) | 324 | ;; Prevent `defalias' from recording this as the definition site of |
| 325 | ;; the generic function. | ||
| 326 | current-load-list) | ||
| 327 | (defalias (cl--generic-name generic) gfun)) | ||
| 328 | (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) | ||
| 329 | current-load-list :test #'equal))) | ||
| 314 | 330 | ||
| 315 | (defmacro cl--generic-with-memoization (place &rest code) | 331 | (defmacro cl--generic-with-memoization (place &rest code) |
| 316 | (declare (indent 1) (debug t)) | 332 | (declare (indent 1) (debug t)) |
| @@ -327,6 +343,14 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 327 | (cl--generic-with-memoization | 343 | (cl--generic-with-memoization |
| 328 | (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers) | 344 | (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers) |
| 329 | (let ((lexical-binding t) | 345 | (let ((lexical-binding t) |
| 346 | (tag-exp `(or ,@(mapcar #'cdr | ||
| 347 | ;; Minor optimization: since this tag-exp is | ||
| 348 | ;; only used to lookup the method-cache, it | ||
| 349 | ;; doesn't matter if the default value is some | ||
| 350 | ;; constant or nil. | ||
| 351 | (if (macroexp-const-p (car (last tagcodes))) | ||
| 352 | (butlast tagcodes) | ||
| 353 | tagcodes)))) | ||
| 330 | (extraargs ())) | 354 | (extraargs ())) |
| 331 | (dotimes (_ dispatch-arg) | 355 | (dotimes (_ dispatch-arg) |
| 332 | (push (make-symbol "arg") extraargs)) | 356 | (push (make-symbol "arg") extraargs)) |
| @@ -335,7 +359,7 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 335 | (let ((method-cache (make-hash-table :test #'eql))) | 359 | (let ((method-cache (make-hash-table :test #'eql))) |
| 336 | (lambda (,@extraargs arg &rest args) | 360 | (lambda (,@extraargs arg &rest args) |
| 337 | (apply (cl--generic-with-memoization | 361 | (apply (cl--generic-with-memoization |
| 338 | (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache) | 362 | (gethash ,tag-exp method-cache) |
| 339 | (cl--generic-cache-miss | 363 | (cl--generic-cache-miss |
| 340 | generic ',dispatch-arg dispatches-left | 364 | generic ',dispatch-arg dispatches-left |
| 341 | (list ,@(mapcar #'cdr tagcodes)))) | 365 | (list ,@(mapcar #'cdr tagcodes)))) |
| @@ -391,7 +415,8 @@ for all those different tags in the method-cache.") | |||
| 391 | cl--generic-combined-method-memoization) | 415 | cl--generic-combined-method-memoization) |
| 392 | (cond | 416 | (cond |
| 393 | ((null mets-by-qual) (lambda (&rest args) | 417 | ((null mets-by-qual) (lambda (&rest args) |
| 394 | (cl-no-applicable-method generic-name args))) | 418 | (apply #'cl-no-applicable-method |
| 419 | generic-name args))) | ||
| 395 | (t | 420 | (t |
| 396 | (let* ((fun (lambda (&rest args) | 421 | (let* ((fun (lambda (&rest args) |
| 397 | ;; FIXME: CLOS passes as second arg the "calling method". | 422 | ;; FIXME: CLOS passes as second arg the "calling method". |
| @@ -411,11 +436,44 @@ for all those different tags in the method-cache.") | |||
| 411 | (setq fun (lambda (&rest args) | 436 | (setq fun (lambda (&rest args) |
| 412 | (dolist (bf before) | 437 | (dolist (bf before) |
| 413 | (apply bf args)) | 438 | (apply bf args)) |
| 414 | (apply next args) | 439 | (prog1 |
| 415 | (dolist (af after) | 440 | (apply next args) |
| 416 | (apply af args)))))) | 441 | (dolist (af after) |
| 442 | (apply af args))))))) | ||
| 417 | (cl--generic-nest fun (alist-get :around mets-by-qual)))))))) | 443 | (cl--generic-nest fun (alist-get :around mets-by-qual)))))))) |
| 418 | 444 | ||
| 445 | (defconst cl--generic-nnm-sample | ||
| 446 | (cl--generic-build-combined-method nil '(((specializer . :qualifier))))) | ||
| 447 | (defconst cl--generic-cnm-sample | ||
| 448 | (funcall (cl--generic-build-combined-method | ||
| 449 | nil `(((specializer . :primary) t . ,#'identity))))) | ||
| 450 | |||
| 451 | (defun cl--generic-isnot-nnm-p (cnm) | ||
| 452 | "Return non-nil if CNM is the function that calls `cl-no-next-method'." | ||
| 453 | ;; ¡Big Gross Ugly Hack! | ||
| 454 | ;; `next-method-p' just sucks, we should let it die. But EIEIO did support | ||
| 455 | ;; it, and some packages use it, so we need to support it. | ||
| 456 | (catch 'found | ||
| 457 | (cl-assert (function-equal cnm cl--generic-cnm-sample)) | ||
| 458 | (if (byte-code-function-p cnm) | ||
| 459 | (let ((cnm-constants (aref cnm 2)) | ||
| 460 | (sample-constants (aref cl--generic-cnm-sample 2))) | ||
| 461 | (dotimes (i (length sample-constants)) | ||
| 462 | (when (function-equal (aref sample-constants i) | ||
| 463 | cl--generic-nnm-sample) | ||
| 464 | (throw 'found | ||
| 465 | (not (function-equal (aref cnm-constants i) | ||
| 466 | cl--generic-nnm-sample)))))) | ||
| 467 | (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) | ||
| 468 | (let ((cnm-env (cadr cnm))) | ||
| 469 | (dolist (vb (cadr cl--generic-cnm-sample)) | ||
| 470 | (when (function-equal (cdr vb) cl--generic-nnm-sample) | ||
| 471 | (throw 'found | ||
| 472 | (not (function-equal (cdar cnm-env) | ||
| 473 | cl--generic-nnm-sample)))) | ||
| 474 | (setq cnm-env (cdr cnm-env))))) | ||
| 475 | (error "Haven't found no-next-method-sample in cnm-sample"))) | ||
| 476 | |||
| 419 | (defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) | 477 | (defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags) |
| 420 | (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) | 478 | (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags))) |
| 421 | (methods '())) | 479 | (methods '())) |
| @@ -440,12 +498,12 @@ for all those different tags in the method-cache.") | |||
| 440 | 498 | ||
| 441 | (cl-defgeneric cl-no-next-method (generic method &rest args) | 499 | (cl-defgeneric cl-no-next-method (generic method &rest args) |
| 442 | "Function called when `cl-call-next-method' finds no next method.") | 500 | "Function called when `cl-call-next-method' finds no next method.") |
| 443 | (cl-defmethod cl-no-next-method ((generic t) method &rest args) | 501 | (cl-defmethod cl-no-next-method (generic method &rest args) |
| 444 | (signal 'cl-no-next-method `(,generic ,method ,@args))) | 502 | (signal 'cl-no-next-method `(,generic ,method ,@args))) |
| 445 | 503 | ||
| 446 | (cl-defgeneric cl-no-applicable-method (generic &rest args) | 504 | (cl-defgeneric cl-no-applicable-method (generic &rest args) |
| 447 | "Function called when a method call finds no applicable method.") | 505 | "Function called when a method call finds no applicable method.") |
| 448 | (cl-defmethod cl-no-applicable-method ((generic t) &rest args) | 506 | (cl-defmethod cl-no-applicable-method (generic &rest args) |
| 449 | (signal 'cl-no-applicable-method `(,generic ,@args))) | 507 | (signal 'cl-no-applicable-method `(,generic ,@args))) |
| 450 | 508 | ||
| 451 | (defun cl-call-next-method (&rest _args) | 509 | (defun cl-call-next-method (&rest _args) |
| @@ -453,33 +511,71 @@ for all those different tags in the method-cache.") | |||
| 453 | Can only be used from within the lexical body of a primary or around method." | 511 | Can only be used from within the lexical body of a primary or around method." |
| 454 | (error "cl-call-next-method only allowed inside primary and around methods")) | 512 | (error "cl-call-next-method only allowed inside primary and around methods")) |
| 455 | 513 | ||
| 514 | (defun cl-next-method-p () | ||
| 515 | "Return non-nil if there is a next method. | ||
| 516 | Can only be used from within the lexical body of a primary or around method." | ||
| 517 | (declare (obsolete "make sure there's always a next method, or catch `cl-no-next-method' instead" "25.1")) | ||
| 518 | (error "cl-next-method-p only allowed inside primary and around methods")) | ||
| 519 | |||
| 456 | ;;; Add support for describe-function | 520 | ;;; Add support for describe-function |
| 457 | 521 | ||
| 458 | (add-hook 'help-fns-describe-function-functions 'cl--generic-describe) | 522 | (defun cl--generic-search-method (met-name) |
| 523 | (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+" | ||
| 524 | (regexp-quote (format "%s\\_>" (car met-name)))))) | ||
| 525 | (or | ||
| 526 | (re-search-forward | ||
| 527 | (concat base-re "[^&\"\n]*" | ||
| 528 | (mapconcat (lambda (specializer) | ||
| 529 | (regexp-quote | ||
| 530 | (format "%S" (if (consp specializer) | ||
| 531 | (nth 1 specializer) specializer)))) | ||
| 532 | (remq t (cdr met-name)) | ||
| 533 | "[ \t\n]*)[^&\"\n]*")) | ||
| 534 | nil t) | ||
| 535 | (re-search-forward base-re nil t)))) | ||
| 536 | |||
| 537 | |||
| 538 | (with-eval-after-load 'find-func | ||
| 539 | (defvar find-function-regexp-alist) | ||
| 540 | (add-to-list 'find-function-regexp-alist | ||
| 541 | `(cl-defmethod . ,#'cl--generic-search-method))) | ||
| 542 | |||
| 543 | (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) | ||
| 459 | (defun cl--generic-describe (function) | 544 | (defun cl--generic-describe (function) |
| 460 | ;; FIXME: Fix up the main "in `<file>'" hyperlink, and add such hyperlinks | ||
| 461 | ;; for each method. | ||
| 462 | (let ((generic (if (symbolp function) (cl--generic function)))) | 545 | (let ((generic (if (symbolp function) (cl--generic function)))) |
| 463 | (when generic | 546 | (when generic |
| 547 | (require 'help-mode) ;Needed for `help-function-def' button! | ||
| 464 | (save-excursion | 548 | (save-excursion |
| 465 | (insert "\n\nThis is a generic function.\n\n") | 549 | (insert "\n\nThis is a generic function.\n\n") |
| 466 | (insert (propertize "Implementations:\n\n" 'face 'bold)) | 550 | (insert (propertize "Implementations:\n\n" 'face 'bold)) |
| 467 | ;; Loop over fanciful generics | 551 | ;; Loop over fanciful generics |
| 468 | (pcase-dolist (`((,type . ,qualifier) . ,method) | 552 | (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method) |
| 469 | (cl--generic-method-table generic)) | 553 | (cl--generic-method-table generic)) |
| 470 | (insert "`") | 554 | (let* ((args (help-function-arglist method 'names)) |
| 471 | (if (symbolp type) | 555 | (docstring (documentation method)) |
| 472 | ;; FIXME: Add support for cl-structs in help-variable. | 556 | (doconly (if docstring |
| 473 | (help-insert-xref-button (symbol-name type) | 557 | (let ((split (help-split-fundoc docstring nil))) |
| 474 | 'help-variable type) | 558 | (if split (cdr split) docstring)))) |
| 475 | (insert (format "%S" type))) | 559 | (combined-args ())) |
| 476 | (insert (format "' %S %S\n" | 560 | (if uses-cnm (setq args (cdr args))) |
| 477 | (car qualifier) | 561 | (dolist (specializer specializers) |
| 478 | (let ((args (help-function-arglist method))) | 562 | (let ((arg (if (eq '&rest (car args)) |
| 479 | ;; Drop cl--generic-next arg if present. | 563 | (intern (format "arg%d" (length combined-args))) |
| 480 | (if (memq (car qualifier) '(:after :before)) | 564 | (pop args)))) |
| 481 | args (cdr args))))) | 565 | (push (if (eq specializer t) arg (list arg specializer)) |
| 482 | (insert (or (documentation method) "Undocumented") "\n\n")))))) | 566 | combined-args))) |
| 567 | (setq combined-args (append (nreverse combined-args) args)) | ||
| 568 | ;; FIXME: Add hyperlinks for the types as well. | ||
| 569 | (insert (format "%S %S" qualifier combined-args)) | ||
| 570 | (let* ((met-name (cons function specializers)) | ||
| 571 | (file (find-lisp-object-file-name met-name 'cl-defmethod))) | ||
| 572 | (when file | ||
| 573 | (insert " in `") | ||
| 574 | (help-insert-xref-button (help-fns-short-filename file) | ||
| 575 | 'help-function-def met-name file | ||
| 576 | 'cl-defmethod) | ||
| 577 | (insert "'.\n"))) | ||
| 578 | (insert "\n" (or doconly "Undocumented") "\n\n"))))))) | ||
| 483 | 579 | ||
| 484 | ;;; Support for (eql <val>) specializers. | 580 | ;;; Support for (eql <val>) specializers. |
| 485 | 581 | ||
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 0070599af6f..38f15b89b0e 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el | |||
| @@ -1807,6 +1807,8 @@ a `let' form, except that the list of symbols can be computed at run-time." | |||
| 1807 | (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) | 1807 | (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) |
| 1808 | (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun)))))))) | 1808 | (eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun)))))))) |
| 1809 | 1809 | ||
| 1810 | (defconst cl--labels-magic (make-symbol "cl--labels-magic")) | ||
| 1811 | |||
| 1810 | (defvar cl--labels-convert-cache nil) | 1812 | (defvar cl--labels-convert-cache nil) |
| 1811 | 1813 | ||
| 1812 | (defun cl--labels-convert (f) | 1814 | (defun cl--labels-convert (f) |
| @@ -1818,10 +1820,12 @@ a `let' form, except that the list of symbols can be computed at run-time." | |||
| 1818 | ;; being expanded even though we don't receive it. | 1820 | ;; being expanded even though we don't receive it. |
| 1819 | ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) | 1821 | ((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache)) |
| 1820 | (t | 1822 | (t |
| 1821 | (let ((found (assq f macroexpand-all-environment))) | 1823 | (let* ((found (assq f macroexpand-all-environment)) |
| 1822 | (if (and found (ignore-errors | 1824 | (replacement (and found |
| 1823 | (eq (cadr (cl-caddr found)) 'cl-labels-args))) | 1825 | (ignore-errors |
| 1824 | (cadr (cl-caddr (cl-cadddr found))) | 1826 | (funcall (cdr found) cl--labels-magic))))) |
| 1827 | (if (and replacement (eq cl--labels-magic (car replacement))) | ||
| 1828 | (nth 1 replacement) | ||
| 1825 | (let ((res `(function ,f))) | 1829 | (let ((res `(function ,f))) |
| 1826 | (setq cl--labels-convert-cache (cons f res)) | 1830 | (setq cl--labels-convert-cache (cons f res)) |
| 1827 | res)))))) | 1831 | res)))))) |
| @@ -1850,17 +1854,18 @@ for (FUNC (lambda ARGLIST BODY)). | |||
| 1850 | `(cl-function (lambda . ,args-and-body)))) | 1854 | `(cl-function (lambda . ,args-and-body)))) |
| 1851 | binds)) | 1855 | binds)) |
| 1852 | (push (cons (car binding) | 1856 | (push (cons (car binding) |
| 1853 | (lambda (&rest cl-labels-args) | 1857 | (lambda (&rest args) |
| 1854 | (cl-list* 'funcall var cl-labels-args))) | 1858 | (if (eq (car args) cl--labels-magic) |
| 1859 | (list cl--labels-magic var) | ||
| 1860 | `(funcall ,var ,@args)))) | ||
| 1855 | newenv))) | 1861 | newenv))) |
| 1856 | ;; FIXME: Eliminate those functions which aren't referenced. | 1862 | ;; FIXME: Eliminate those functions which aren't referenced. |
| 1857 | `(let ,(nreverse binds) | 1863 | (macroexp-let* (nreverse binds) |
| 1858 | ,@(macroexp-unprogn | 1864 | (macroexpand-all |
| 1859 | (macroexpand-all | 1865 | `(progn ,@body) |
| 1860 | `(progn ,@body) | 1866 | ;; Don't override lexical-let's macro-expander. |
| 1861 | ;; Don't override lexical-let's macro-expander. | 1867 | (if (assq 'function newenv) newenv |
| 1862 | (if (assq 'function newenv) newenv | 1868 | (cons (cons 'function #'cl--labels-convert) newenv)))))) |
| 1863 | (cons (cons 'function #'cl--labels-convert) newenv))))))) | ||
| 1864 | 1869 | ||
| 1865 | ;;;###autoload | 1870 | ;;;###autoload |
| 1866 | (defmacro cl-flet* (bindings &rest body) | 1871 | (defmacro cl-flet* (bindings &rest body) |
| @@ -1887,8 +1892,10 @@ in closures will only work if `lexical-binding' is in use. | |||
| 1887 | (let ((var (make-symbol (format "--cl-%s--" (car binding))))) | 1892 | (let ((var (make-symbol (format "--cl-%s--" (car binding))))) |
| 1888 | (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) | 1893 | (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) |
| 1889 | (push (cons (car binding) | 1894 | (push (cons (car binding) |
| 1890 | (lambda (&rest cl-labels-args) | 1895 | (lambda (&rest args) |
| 1891 | (cl-list* 'funcall var cl-labels-args))) | 1896 | (if (eq (car args) cl--labels-magic) |
| 1897 | (list cl--labels-magic var) | ||
| 1898 | (cl-list* 'funcall var args)))) | ||
| 1892 | newenv))) | 1899 | newenv))) |
| 1893 | (macroexpand-all `(letrec ,(nreverse binds) ,@body) | 1900 | (macroexpand-all `(letrec ,(nreverse binds) ,@body) |
| 1894 | ;; Don't override lexical-let's macro-expander. | 1901 | ;; Don't override lexical-let's macro-expander. |
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index bfa922bade6..a82e887fa0c 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el | |||
| @@ -34,19 +34,6 @@ | |||
| 34 | (require 'cl-lib) | 34 | (require 'cl-lib) |
| 35 | (require 'pcase) | 35 | (require 'pcase) |
| 36 | 36 | ||
| 37 | (put 'eieio--defalias 'byte-hunk-handler | ||
| 38 | #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) | ||
| 39 | (defun eieio--defalias (name body) | ||
| 40 | "Like `defalias', but with less side-effects. | ||
| 41 | More specifically, it has no side-effects at all when the new function | ||
| 42 | definition is the same (`eq') as the old one." | ||
| 43 | (while (and (fboundp name) (symbolp (symbol-function name))) | ||
| 44 | ;; Follow aliases, so methods applied to obsolete aliases still work. | ||
| 45 | (setq name (symbol-function name))) | ||
| 46 | (unless (and (fboundp name) | ||
| 47 | (eq (symbol-function name) body)) | ||
| 48 | (defalias name body))) | ||
| 49 | |||
| 50 | ;;; | 37 | ;;; |
| 51 | ;; A few functions that are better in the official EIEIO src, but | 38 | ;; A few functions that are better in the official EIEIO src, but |
| 52 | ;; used from the core. | 39 | ;; used from the core. |
| @@ -75,9 +62,6 @@ default setting for optimization purposes.") | |||
| 75 | (defvar eieio-optimize-primary-methods-flag t | 62 | (defvar eieio-optimize-primary-methods-flag t |
| 76 | "Non-nil means to optimize the method dispatch on primary methods.") | 63 | "Non-nil means to optimize the method dispatch on primary methods.") |
| 77 | 64 | ||
| 78 | (defvar eieio-initializing-object nil | ||
| 79 | "Set to non-nil while initializing an object.") | ||
| 80 | |||
| 81 | (defvar eieio-backward-compatibility t | 65 | (defvar eieio-backward-compatibility t |
| 82 | "If nil, drop support for some behaviors of older versions of EIEIO. | 66 | "If nil, drop support for some behaviors of older versions of EIEIO. |
| 83 | Currently under control of this var: | 67 | Currently under control of this var: |
| @@ -95,29 +79,6 @@ Currently under control of this var: | |||
| 95 | ;; while it is being built itself. | 79 | ;; while it is being built itself. |
| 96 | (defvar eieio-default-superclass nil) | 80 | (defvar eieio-default-superclass nil) |
| 97 | 81 | ||
| 98 | ;;; | ||
| 99 | ;; Class currently in scope. | ||
| 100 | ;; | ||
| 101 | ;; When invoking methods, the running method needs to know which class | ||
| 102 | ;; is currently in scope. Generally this is the class of the method | ||
| 103 | ;; being called, but 'call-next-method' needs to query this state, | ||
| 104 | ;; and change it to be then next super class up. | ||
| 105 | ;; | ||
| 106 | ;; Thus, the scoped class is a stack that needs to be managed. | ||
| 107 | |||
| 108 | (defvar eieio--scoped-class-stack nil | ||
| 109 | "A stack of the classes currently in scope during method invocation.") | ||
| 110 | |||
| 111 | (defun eieio--scoped-class () | ||
| 112 | "Return the class object currently in scope, or nil." | ||
| 113 | (car-safe eieio--scoped-class-stack)) | ||
| 114 | |||
| 115 | (defmacro eieio--with-scoped-class (class &rest forms) | ||
| 116 | "Set CLASS as the currently scoped class while executing FORMS." | ||
| 117 | (declare (indent 1)) | ||
| 118 | `(let ((eieio--scoped-class-stack (cons ,class eieio--scoped-class-stack))) | ||
| 119 | ,@forms)) | ||
| 120 | |||
| 121 | (progn | 82 | (progn |
| 122 | ;; Arrange for field access not to bother checking if the access is indeed | 83 | ;; Arrange for field access not to bother checking if the access is indeed |
| 123 | ;; made to an eieio--class object. | 84 | ;; made to an eieio--class object. |
| @@ -248,10 +209,8 @@ CLASS is a symbol." ;FIXME: Is it a vector or a symbol? | |||
| 248 | (format "#<class %s>" (symbol-name class))) | 209 | (format "#<class %s>" (symbol-name class))) |
| 249 | (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") | 210 | (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") |
| 250 | 211 | ||
| 251 | (defmacro class-constructor (class) | 212 | (defalias 'eieio--class-constructor #'identity |
| 252 | "Return the symbol representing the constructor of CLASS." | 213 | "Return the symbol representing the constructor of CLASS.") |
| 253 | (declare (debug t)) | ||
| 254 | `(eieio--class-symbol (eieio--class-v ,class))) | ||
| 255 | 214 | ||
| 256 | (defmacro eieio--class-option-assoc (list option) | 215 | (defmacro eieio--class-option-assoc (list option) |
| 257 | "Return from LIST the found OPTION, or nil if it doesn't exist." | 216 | "Return from LIST the found OPTION, or nil if it doesn't exist." |
| @@ -292,7 +251,7 @@ Abstract classes cannot be instantiated." | |||
| 292 | 251 | ||
| 293 | ;; We autoload this because it's used in `make-autoload'. | 252 | ;; We autoload this because it's used in `make-autoload'. |
| 294 | ;;;###autoload | 253 | ;;;###autoload |
| 295 | (defun eieio-defclass-autoload (cname superclasses filename doc) | 254 | (defun eieio-defclass-autoload (cname _superclasses filename doc) |
| 296 | "Create autoload symbols for the EIEIO class CNAME. | 255 | "Create autoload symbols for the EIEIO class CNAME. |
| 297 | SUPERCLASSES are the superclasses that CNAME inherits from. | 256 | SUPERCLASSES are the superclasses that CNAME inherits from. |
| 298 | DOC is the docstring for CNAME. | 257 | DOC is the docstring for CNAME. |
| @@ -301,58 +260,35 @@ SUPERCLASSES as children. | |||
| 301 | It creates an autoload function for CNAME's constructor." | 260 | It creates an autoload function for CNAME's constructor." |
| 302 | ;; Assume we've already debugged inputs. | 261 | ;; Assume we've already debugged inputs. |
| 303 | 262 | ||
| 263 | ;; We used to store the list of superclasses in the `parent' slot (as a list | ||
| 264 | ;; of class names). But now this slot holds a list of class objects, and | ||
| 265 | ;; those parents may not exist yet, so the corresponding class objects may | ||
| 266 | ;; simply not exist yet. So instead we just don't store the list of parents | ||
| 267 | ;; here in eieio-defclass-autoload at all, since it seems that they're just | ||
| 268 | ;; not needed before the class is actually loaded. | ||
| 304 | (let* ((oldc (when (class-p cname) (eieio--class-v cname))) | 269 | (let* ((oldc (when (class-p cname) (eieio--class-v cname))) |
| 305 | (newc (eieio--class-make cname)) | 270 | (newc (eieio--class-make cname)) |
| 306 | ) | 271 | ) |
| 307 | (if oldc | 272 | (if oldc |
| 308 | nil ;; Do nothing if we already have this class. | 273 | nil ;; Do nothing if we already have this class. |
| 309 | 274 | ||
| 310 | (let ((clear-parent nil)) | 275 | ;; turn this into a usable self-pointing symbol |
| 311 | ;; No parents? | 276 | (when eieio-backward-compatibility |
| 312 | (when (not superclasses) | 277 | (set cname cname) |
| 313 | (setq superclasses '(eieio-default-superclass) | 278 | (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) |
| 314 | clear-parent t) | ||
| 315 | ) | ||
| 316 | |||
| 317 | ;; Hook our new class into the existing structures so we can | ||
| 318 | ;; autoload it later. | ||
| 319 | (dolist (SC superclasses) | ||
| 320 | 279 | ||
| 280 | ;; Store the new class vector definition into the symbol. We need to | ||
| 281 | ;; do this first so that we can call defmethod for the accessor. | ||
| 282 | ;; The vector will be updated by the following while loop and will not | ||
| 283 | ;; need to be stored a second time. | ||
| 284 | (setf (eieio--class-v cname) newc) | ||
| 321 | 285 | ||
| 322 | ;; TODO - If we create an autoload that is in the map, that | 286 | ;; Create an autoload on top of our constructor function. |
| 323 | ;; map needs to be cleared! | 287 | (autoload cname filename doc nil nil) |
| 324 | 288 | (autoload (intern (format "%s-p" cname)) filename "" nil nil) | |
| 325 | 289 | (when eieio-backward-compatibility | |
| 326 | ;; Save the child in the parent. | 290 | (autoload (intern (format "%s-child-p" cname)) filename "" nil nil) |
| 327 | (cl-pushnew cname (if (class-p SC) | 291 | (autoload (intern (format "%s-list-p" cname)) filename "" nil nil))))) |
| 328 | (eieio--class-children (eieio--class-v SC)) | ||
| 329 | ;; Parent doesn't exist yet. | ||
| 330 | (gethash SC eieio-defclass-autoload-map))) | ||
| 331 | |||
| 332 | ;; Save parent in child. | ||
| 333 | (push (eieio--class-v SC) (eieio--class-parent newc))) | ||
| 334 | |||
| 335 | ;; turn this into a usable self-pointing symbol | ||
| 336 | (when eieio-backward-compatibility | ||
| 337 | (set cname cname) | ||
| 338 | (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) | ||
| 339 | |||
| 340 | ;; Store the new class vector definition into the symbol. We need to | ||
| 341 | ;; do this first so that we can call defmethod for the accessor. | ||
| 342 | ;; The vector will be updated by the following while loop and will not | ||
| 343 | ;; need to be stored a second time. | ||
| 344 | (setf (eieio--class-v cname) newc) | ||
| 345 | |||
| 346 | ;; Clear the parent | ||
| 347 | (if clear-parent (setf (eieio--class-parent newc) nil)) | ||
| 348 | |||
| 349 | ;; Create an autoload on top of our constructor function. | ||
| 350 | (autoload cname filename doc nil nil) | ||
| 351 | (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil nil) | ||
| 352 | (autoload (intern (concat (symbol-name cname) "-child-p")) filename "" nil nil) | ||
| 353 | (autoload (intern (concat (symbol-name cname) "-list-p")) filename "" nil nil) | ||
| 354 | |||
| 355 | )))) | ||
| 356 | 292 | ||
| 357 | (defsubst eieio-class-un-autoload (cname) | 293 | (defsubst eieio-class-un-autoload (cname) |
| 358 | "If class CNAME is in an autoload state, load its file." | 294 | "If class CNAME is in an autoload state, load its file." |
| @@ -378,8 +314,13 @@ See `defclass' for more information." | |||
| 378 | (setq eieio-hook nil) | 314 | (setq eieio-hook nil) |
| 379 | 315 | ||
| 380 | (let* ((pname superclasses) | 316 | (let* ((pname superclasses) |
| 381 | (newc (eieio--class-make cname)) | ||
| 382 | (oldc (when (class-p cname) (eieio--class-v cname))) | 317 | (oldc (when (class-p cname) (eieio--class-v cname))) |
| 318 | (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) | ||
| 319 | ;; The oldc class is a stub setup by eieio-defclass-autoload. | ||
| 320 | ;; Reuse it instead of creating a new one, so that existing | ||
| 321 | ;; references are still valid. | ||
| 322 | oldc | ||
| 323 | (eieio--class-make cname))) | ||
| 383 | (groups nil) ;; list of groups id'd from slots | 324 | (groups nil) ;; list of groups id'd from slots |
| 384 | (clearparent nil)) | 325 | (clearparent nil)) |
| 385 | 326 | ||
| @@ -1060,27 +1001,26 @@ Fills in the default value in CLASS' in SLOT with VALUE." | |||
| 1060 | (setq class (eieio--class-object class)) | 1001 | (setq class (eieio--class-object class)) |
| 1061 | (eieio--check-type eieio--class-p class) | 1002 | (eieio--check-type eieio--class-p class) |
| 1062 | (eieio--check-type symbolp slot) | 1003 | (eieio--check-type symbolp slot) |
| 1063 | (eieio--with-scoped-class class | 1004 | (let* ((c (eieio--slot-name-index class nil slot))) |
| 1064 | (let* ((c (eieio--slot-name-index class nil slot))) | 1005 | (if (not c) |
| 1065 | (if (not c) | 1006 | ;; It might be missing because it is a :class allocated slot. |
| 1066 | ;; It might be missing because it is a :class allocated slot. | 1007 | ;; Let's check that info out. |
| 1067 | ;; Let's check that info out. | 1008 | (if (setq c (eieio--class-slot-name-index class slot)) |
| 1068 | (if (setq c (eieio--class-slot-name-index class slot)) | 1009 | (progn |
| 1069 | (progn | 1010 | ;; Oref that slot. |
| 1070 | ;; Oref that slot. | 1011 | (eieio--validate-class-slot-value class c value slot) |
| 1071 | (eieio--validate-class-slot-value class c value slot) | 1012 | (aset (eieio--class-class-allocation-values class) c |
| 1072 | (aset (eieio--class-class-allocation-values class) c | 1013 | value)) |
| 1073 | value)) | 1014 | (signal 'invalid-slot-name (list (eieio--class-symbol class) slot))) |
| 1074 | (signal 'invalid-slot-name (list (eieio--class-symbol class) slot))) | 1015 | (eieio--validate-slot-value class c value slot) |
| 1075 | (eieio--validate-slot-value class c value slot) | 1016 | ;; Set this into the storage for defaults. |
| 1076 | ;; Set this into the storage for defaults. | 1017 | (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) |
| 1077 | (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) | 1018 | (eieio--class-public-d class)) |
| 1078 | (eieio--class-public-d class)) | 1019 | value) |
| 1079 | value) | 1020 | ;; Take the value, and put it into our cache object. |
| 1080 | ;; Take the value, and put it into our cache object. | 1021 | (eieio-oset (eieio--class-default-object-cache class) |
| 1081 | (eieio-oset (eieio--class-default-object-cache class) | 1022 | slot value) |
| 1082 | slot value) | 1023 | ))) |
| 1083 | )))) | ||
| 1084 | 1024 | ||
| 1085 | 1025 | ||
| 1086 | ;;; EIEIO internal search functions | 1026 | ;;; EIEIO internal search functions |
| @@ -1111,27 +1051,7 @@ reverse-lookup that name, and recurse with the associated slot value." | |||
| 1111 | (let* ((fsym (gethash slot (eieio--class-symbol-hashtable class))) | 1051 | (let* ((fsym (gethash slot (eieio--class-symbol-hashtable class))) |
| 1112 | (fsi (car fsym))) | 1052 | (fsi (car fsym))) |
| 1113 | (if (integerp fsi) | 1053 | (if (integerp fsi) |
| 1114 | (cond | 1054 | (+ (eval-when-compile eieio--object-num-slots) fsi) |
| 1115 | ((not (cdr fsym)) | ||
| 1116 | (+ (eval-when-compile eieio--object-num-slots) fsi)) | ||
| 1117 | ((and (eq (cdr fsym) 'protected) | ||
| 1118 | (eieio--scoped-class) | ||
| 1119 | (or (child-of-class-p class (eieio--scoped-class)) | ||
| 1120 | (and (eieio-object-p obj) | ||
| 1121 | ;; AFAICT, for all callers, if `obj' is not a class, | ||
| 1122 | ;; then its class is `class'. | ||
| 1123 | ;;(child-of-class-p class (eieio--object-class-object obj)) | ||
| 1124 | (progn | ||
| 1125 | (cl-assert (eq class (eieio--object-class-object obj))) | ||
| 1126 | t)))) | ||
| 1127 | (+ (eval-when-compile eieio--object-num-slots) fsi)) | ||
| 1128 | ((and (eq (cdr fsym) 'private) | ||
| 1129 | (or (and (eieio--scoped-class) | ||
| 1130 | (eieio--slot-originating-class-p | ||
| 1131 | (eieio--scoped-class) slot)) | ||
| 1132 | eieio-initializing-object)) | ||
| 1133 | (+ (eval-when-compile eieio--object-num-slots) fsi)) | ||
| 1134 | (t nil)) | ||
| 1135 | (let ((fn (eieio--initarg-to-attribute class slot))) | 1055 | (let ((fn (eieio--initarg-to-attribute class slot))) |
| 1136 | (if fn (eieio--slot-name-index class obj fn) nil))))) | 1056 | (if fn (eieio--slot-name-index class obj fn) nil))))) |
| 1137 | 1057 | ||
| @@ -1159,14 +1079,12 @@ reverse-lookup that name, and recurse with the associated slot value." | |||
| 1159 | If SET-ALL is non-nil, then when a default is nil, that value is | 1079 | If SET-ALL is non-nil, then when a default is nil, that value is |
| 1160 | reset. If SET-ALL is nil, the slots are only reset if the default is | 1080 | reset. If SET-ALL is nil, the slots are only reset if the default is |
| 1161 | not nil." | 1081 | not nil." |
| 1162 | (eieio--with-scoped-class (eieio--object-class-object obj) | 1082 | (let ((pub (eieio--class-public-a (eieio--object-class-object obj)))) |
| 1163 | (let ((eieio-initializing-object t) | 1083 | (while pub |
| 1164 | (pub (eieio--class-public-a (eieio--object-class-object obj)))) | 1084 | (let ((df (eieio-oref-default obj (car pub)))) |
| 1165 | (while pub | 1085 | (if (or df set-all) |
| 1166 | (let ((df (eieio-oref-default obj (car pub)))) | 1086 | (eieio-oset obj (car pub) df))) |
| 1167 | (if (or df set-all) | 1087 | (setq pub (cdr pub))))) |
| 1168 | (eieio-oset obj (car pub) df))) | ||
| 1169 | (setq pub (cdr pub)))))) | ||
| 1170 | 1088 | ||
| 1171 | (defun eieio--initarg-to-attribute (class initarg) | 1089 | (defun eieio--initarg-to-attribute (class initarg) |
| 1172 | "For CLASS, convert INITARG to the actual attribute name. | 1090 | "For CLASS, convert INITARG to the actual attribute name. |
| @@ -1284,6 +1202,8 @@ The order, in which the parents are returned depends on the | |||
| 1284 | method invocation orders of the involved classes." | 1202 | method invocation orders of the involved classes." |
| 1285 | (if (or (null class) (eq class eieio-default-superclass)) | 1203 | (if (or (null class) (eq class eieio-default-superclass)) |
| 1286 | nil | 1204 | nil |
| 1205 | (unless (eieio--class-default-object-cache class) | ||
| 1206 | (eieio-class-un-autoload (eieio--class-symbol class))) | ||
| 1287 | (cl-case (eieio--class-method-invocation-order class) | 1207 | (cl-case (eieio--class-method-invocation-order class) |
| 1288 | (:depth-first | 1208 | (:depth-first |
| 1289 | (eieio--class-precedence-dfs class)) | 1209 | (eieio--class-precedence-dfs class)) |
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index d0eaaf24d2b..8ab74ae3352 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el | |||
| @@ -184,7 +184,7 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 184 | (if (not (widget-get widget :value)) | 184 | (if (not (widget-get widget :value)) |
| 185 | (widget-put widget | 185 | (widget-put widget |
| 186 | :value (cond ((widget-get widget :objecttype) | 186 | :value (cond ((widget-get widget :objecttype) |
| 187 | (funcall (class-constructor | 187 | (funcall (eieio--class-constructor |
| 188 | (widget-get widget :objecttype)) | 188 | (widget-get widget :objecttype)) |
| 189 | "Custom-new")) | 189 | "Custom-new")) |
| 190 | ((widget-get widget :objectcreatefcn) | 190 | ((widget-get widget :objectcreatefcn) |
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 43d9a03932a..ab8d41e4ac4 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el | |||
| @@ -88,7 +88,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 88 | "Name: ") | 88 | "Name: ") |
| 89 | (let* ((cl (eieio-object-class obj)) | 89 | (let* ((cl (eieio-object-class obj)) |
| 90 | (cv (eieio--class-v cl))) | 90 | (cv (eieio--class-v cl))) |
| 91 | (data-debug-insert-thing (class-constructor cl) | 91 | (data-debug-insert-thing (eieio--class-constructor cl) |
| 92 | prefix | 92 | prefix |
| 93 | "Class: ") | 93 | "Class: ") |
| 94 | ;; Loop over all the public slots | 94 | ;; Loop over all the public slots |
diff --git a/lisp/emacs-lisp/eieio-generic.el b/lisp/emacs-lisp/eieio-generic.el index 0e90074660e..27a58493905 100644 --- a/lisp/emacs-lisp/eieio-generic.el +++ b/lisp/emacs-lisp/eieio-generic.el | |||
| @@ -33,6 +33,19 @@ | |||
| 33 | (require 'eieio-core) | 33 | (require 'eieio-core) |
| 34 | (declare-function child-of-class-p "eieio") | 34 | (declare-function child-of-class-p "eieio") |
| 35 | 35 | ||
| 36 | (put 'eieio--defalias 'byte-hunk-handler | ||
| 37 | #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) | ||
| 38 | (defun eieio--defalias (name body) | ||
| 39 | "Like `defalias', but with less side-effects. | ||
| 40 | More specifically, it has no side-effects at all when the new function | ||
| 41 | definition is the same (`eq') as the old one." | ||
| 42 | (while (and (fboundp name) (symbolp (symbol-function name))) | ||
| 43 | ;; Follow aliases, so methods applied to obsolete aliases still work. | ||
| 44 | (setq name (symbol-function name))) | ||
| 45 | (unless (and (fboundp name) | ||
| 46 | (eq (symbol-function name) body)) | ||
| 47 | (defalias name body))) | ||
| 48 | |||
| 36 | (defconst eieio--method-static 0 "Index into :static tag on a method.") | 49 | (defconst eieio--method-static 0 "Index into :static tag on a method.") |
| 37 | (defconst eieio--method-before 1 "Index into :before tag on a method.") | 50 | (defconst eieio--method-before 1 "Index into :before tag on a method.") |
| 38 | (defconst eieio--method-primary 2 "Index into :primary tag on a method.") | 51 | (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." | |||
| 101 | ;; Make sure the method tables are installed. | 114 | ;; Make sure the method tables are installed. |
| 102 | (eieio--mt-install method) | 115 | (eieio--mt-install method) |
| 103 | ;; Construct the actual body of this function. | 116 | ;; Construct the actual body of this function. |
| 104 | (put method 'function-documentation doc-string) | 117 | (if doc-string (put method 'function-documentation doc-string)) |
| 105 | (eieio--defgeneric-form method)) | 118 | (eieio--defgeneric-form method)) |
| 106 | ((generic-p method) (symbol-function method)) ;Leave it as-is. | 119 | ((generic-p method) (symbol-function method)) ;Leave it as-is. |
| 107 | (t (error "You cannot create a generic/method over an existing symbol: %s" | 120 | (t (error "You cannot create a generic/method over an existing symbol: %s" |
| @@ -161,8 +174,7 @@ IMPL is the symbol holding the method implementation." | |||
| 161 | (eieio--generic-call-key eieio--method-primary) | 174 | (eieio--generic-call-key eieio--method-primary) |
| 162 | (eieio--generic-call-arglst local-args) | 175 | (eieio--generic-call-arglst local-args) |
| 163 | ) | 176 | ) |
| 164 | (eieio--with-scoped-class (eieio--class-v class) | 177 | (apply impl local-args)))))) |
| 165 | (apply impl local-args))))))) | ||
| 166 | 178 | ||
| 167 | (defun eieio-unbind-method-implementations (method) | 179 | (defun eieio-unbind-method-implementations (method) |
| 168 | "Make the generic method METHOD have no implementations. | 180 | "Make the generic method METHOD have no implementations. |
| @@ -177,20 +189,18 @@ but remove reference to all implementations of METHOD." | |||
| 177 | ;; | 189 | ;; |
| 178 | ;; If this method, after this setup, only has primary methods, then | 190 | ;; If this method, after this setup, only has primary methods, then |
| 179 | ;; we can setup the generic that way. | 191 | ;; we can setup the generic that way. |
| 180 | (let ((doc-string (documentation method 'raw))) | 192 | ;; Use `defalias' so as to interact properly with nadvice.el. |
| 181 | (put method 'function-documentation doc-string) | 193 | (defalias method |
| 182 | ;; Use `defalias' so as to interact properly with nadvice.el. | 194 | (if (eieio--generic-primary-only-p method) |
| 183 | (defalias method | 195 | ;; If there is only one primary method, then we can go one more |
| 184 | (if (eieio--generic-primary-only-p method) | 196 | ;; optimization step. |
| 185 | ;; If there is only one primary method, then we can go one more | 197 | (if (eieio--generic-primary-only-one-p method) |
| 186 | ;; optimization step. | 198 | (let* ((M (get method 'eieio-method-tree)) |
| 187 | (if (eieio--generic-primary-only-one-p method) | 199 | (entry (car (aref M eieio--method-primary)))) |
| 188 | (let* ((M (get method 'eieio-method-tree)) | 200 | (eieio--defgeneric-form-primary-only-one |
| 189 | (entry (car (aref M eieio--method-primary)))) | 201 | method (car entry) (cdr entry))) |
| 190 | (eieio--defgeneric-form-primary-only-one | 202 | (eieio--defgeneric-form-primary-only method)) |
| 191 | method (car entry) (cdr entry))) | 203 | (eieio--defgeneric-form method))))) |
| 192 | (eieio--defgeneric-form-primary-only method)) | ||
| 193 | (eieio--defgeneric-form method)))))) | ||
| 194 | 204 | ||
| 195 | (defun eieio--defmethod (method kind argclass code) | 205 | (defun eieio--defmethod (method kind argclass code) |
| 196 | "Work part of the `defmethod' macro defining METHOD with ARGS." | 206 | "Work part of the `defmethod' macro defining METHOD with ARGS." |
| @@ -276,11 +286,9 @@ This should only be called from a generic function." | |||
| 276 | ) | 286 | ) |
| 277 | ;; Now create a list in reverse order of all the calls we have | 287 | ;; Now create a list in reverse order of all the calls we have |
| 278 | ;; make in order to successfully do this right. Rules: | 288 | ;; make in order to successfully do this right. Rules: |
| 279 | ;; 1) Only call generics if scoped-class is not defined | 289 | ;; 1) Only call static if this is a static method. |
| 280 | ;; This prevents multiple calls in the case of recursion | 290 | ;; 2) Only call specifics if the definition allows for them. |
| 281 | ;; 2) Only call static if this is a static method. | 291 | ;; 3) Call in order based on :before, :primary, and :after |
| 282 | ;; 3) Only call specifics if the definition allows for them. | ||
| 283 | ;; 4) Call in order based on :before, :primary, and :after | ||
| 284 | (when (eieio-object-p firstarg) | 292 | (when (eieio-object-p firstarg) |
| 285 | ;; Non-static calls do all this stuff. | 293 | ;; Non-static calls do all this stuff. |
| 286 | 294 | ||
| @@ -346,22 +354,21 @@ This should only be called from a generic function." | |||
| 346 | (let ((rval nil) (lastval nil) (found nil)) | 354 | (let ((rval nil) (lastval nil) (found nil)) |
| 347 | (while lambdas | 355 | (while lambdas |
| 348 | (if (car lambdas) | 356 | (if (car lambdas) |
| 349 | (eieio--with-scoped-class (cdr (car lambdas)) | 357 | (let* ((eieio--generic-call-key (car keys)) |
| 350 | (let* ((eieio--generic-call-key (car keys)) | 358 | (has-return-val |
| 351 | (has-return-val | 359 | (or (= eieio--generic-call-key eieio--method-primary) |
| 352 | (or (= eieio--generic-call-key eieio--method-primary) | 360 | (= eieio--generic-call-key eieio--method-static))) |
| 353 | (= eieio--generic-call-key eieio--method-static))) | 361 | (eieio--generic-call-next-method-list |
| 354 | (eieio--generic-call-next-method-list | 362 | ;; Use the cdr, as the first element is the fcn |
| 355 | ;; Use the cdr, as the first element is the fcn | 363 | ;; we are calling right now. |
| 356 | ;; we are calling right now. | 364 | (when has-return-val (cdr primarymethodlist))) |
| 357 | (when has-return-val (cdr primarymethodlist))) | 365 | ) |
| 358 | ) | 366 | (setq found t) |
| 359 | (setq found t) | 367 | ;;(setq rval (apply (car (car lambdas)) newargs)) |
| 360 | ;;(setq rval (apply (car (car lambdas)) newargs)) | 368 | (setq lastval (apply (car (car lambdas)) newargs)) |
| 361 | (setq lastval (apply (car (car lambdas)) newargs)) | 369 | (when has-return-val |
| 362 | (when has-return-val | 370 | (setq rval lastval)) |
| 363 | (setq rval lastval)) | 371 | )) |
| 364 | ))) | ||
| 365 | (setq lambdas (cdr lambdas) | 372 | (setq lambdas (cdr lambdas) |
| 366 | keys (cdr keys))) | 373 | keys (cdr keys))) |
| 367 | (if (not found) | 374 | (if (not found) |
| @@ -414,33 +421,32 @@ for this common case to improve performance." | |||
| 414 | 421 | ||
| 415 | ;; Now loop through all occurrences forms which we must execute | 422 | ;; Now loop through all occurrences forms which we must execute |
| 416 | ;; (which are happily sorted now) and execute them all! | 423 | ;; (which are happily sorted now) and execute them all! |
| 417 | (eieio--with-scoped-class (cdr lambdas) | 424 | (let* ((rval nil) (lastval nil) |
| 418 | (let* ((rval nil) (lastval nil) | 425 | (eieio--generic-call-key eieio--method-primary) |
| 419 | (eieio--generic-call-key eieio--method-primary) | 426 | ;; Use the cdr, as the first element is the fcn |
| 420 | ;; Use the cdr, as the first element is the fcn | 427 | ;; we are calling right now. |
| 421 | ;; we are calling right now. | 428 | (eieio--generic-call-next-method-list (cdr primarymethodlist)) |
| 422 | (eieio--generic-call-next-method-list (cdr primarymethodlist)) | 429 | ) |
| 423 | ) | ||
| 424 | 430 | ||
| 425 | (if (or (not lambdas) (not (car lambdas))) | 431 | (if (or (not lambdas) (not (car lambdas))) |
| 426 | 432 | ||
| 427 | ;; No methods found for this impl... | 433 | ;; No methods found for this impl... |
| 428 | (if (eieio-object-p (car args)) | 434 | (if (eieio-object-p (car args)) |
| 429 | (setq rval (apply #'no-applicable-method | 435 | (setq rval (apply #'no-applicable-method |
| 430 | (car args) method args)) | 436 | (car args) method args)) |
| 431 | (signal | 437 | (signal |
| 432 | 'no-method-definition | 438 | 'no-method-definition |
| 433 | (list method args))) | 439 | (list method args))) |
| 434 | 440 | ||
| 435 | ;; Do the regular implementation here. | 441 | ;; Do the regular implementation here. |
| 436 | 442 | ||
| 437 | (run-hook-with-args 'eieio-pre-method-execution-functions | 443 | (run-hook-with-args 'eieio-pre-method-execution-functions |
| 438 | lambdas) | 444 | lambdas) |
| 439 | 445 | ||
| 440 | (setq lastval (apply (car lambdas) newargs)) | 446 | (setq lastval (apply (car lambdas) newargs)) |
| 441 | (setq rval lastval)) | 447 | (setq rval lastval)) |
| 442 | 448 | ||
| 443 | rval)))) | 449 | rval))) |
| 444 | 450 | ||
| 445 | (defun eieio--mt-method-list (method key class) | 451 | (defun eieio--mt-method-list (method key class) |
| 446 | "Return an alist list of methods lambdas. | 452 | "Return an alist list of methods lambdas. |
| @@ -627,7 +633,7 @@ is memorized for faster future use." | |||
| 627 | 633 | ||
| 628 | ;;; CLOS methods and generics | 634 | ;;; CLOS methods and generics |
| 629 | ;; | 635 | ;; |
| 630 | (defmacro defgeneric (method _args &optional doc-string) | 636 | (defmacro defgeneric (method args &optional doc-string) |
| 631 | "Create a generic function METHOD. | 637 | "Create a generic function METHOD. |
| 632 | DOC-STRING is the base documentation for this class. A generic | 638 | DOC-STRING is the base documentation for this class. A generic |
| 633 | function has no body, as its purpose is to decide which method body | 639 | function has no body, as its purpose is to decide which method body |
| @@ -637,7 +643,9 @@ currently ignored. You can use `defgeneric' to apply specialized | |||
| 637 | top level documentation to a method." | 643 | top level documentation to a method." |
| 638 | (declare (doc-string 3)) | 644 | (declare (doc-string 3)) |
| 639 | `(eieio--defalias ',method | 645 | `(eieio--defalias ',method |
| 640 | (eieio--defgeneric-init-form ',method ,doc-string))) | 646 | (eieio--defgeneric-init-form |
| 647 | ',method | ||
| 648 | ,(if doc-string (help-add-fundoc-usage doc-string args))))) | ||
| 641 | 649 | ||
| 642 | (defmacro defmethod (method &rest args) | 650 | (defmacro defmethod (method &rest args) |
| 643 | "Create a new METHOD through `defgeneric' with ARGS. | 651 | "Create a new METHOD through `defgeneric' with ARGS. |
| @@ -684,9 +692,7 @@ Summary: | |||
| 684 | (code `(lambda ,fargs ,@(cdr args)))) | 692 | (code `(lambda ,fargs ,@(cdr args)))) |
| 685 | `(progn | 693 | `(progn |
| 686 | ;; Make sure there is a generic and the byte-compiler sees it. | 694 | ;; Make sure there is a generic and the byte-compiler sees it. |
| 687 | (defgeneric ,method ,args | 695 | (defgeneric ,method ,args) |
| 688 | ,(or (documentation code) | ||
| 689 | (format "Generically created method `%s'." method))) | ||
| 690 | (eieio--defmethod ',method ',key ',class #',code)))) | 696 | (eieio--defmethod ',method ',key ',class #',code)))) |
| 691 | 697 | ||
| 692 | 698 | ||
| @@ -710,8 +716,6 @@ If REPLACEMENT-ARGS is non-nil, then use them instead of | |||
| 710 | arguments passed in at the top level. | 716 | arguments passed in at the top level. |
| 711 | 717 | ||
| 712 | Use `next-method-p' to find out if there is a next method to call." | 718 | Use `next-method-p' to find out if there is a next method to call." |
| 713 | (if (not (eieio--scoped-class)) | ||
| 714 | (error "`call-next-method' not called within a class specific method")) | ||
| 715 | (if (and (/= eieio--generic-call-key eieio--method-primary) | 719 | (if (and (/= eieio--generic-call-key eieio--method-primary) |
| 716 | (/= eieio--generic-call-key eieio--method-static)) | 720 | (/= eieio--generic-call-key eieio--method-static)) |
| 717 | (error "Cannot `call-next-method' except in :primary or :static methods") | 721 | (error "Cannot `call-next-method' except in :primary or :static methods") |
| @@ -726,8 +730,7 @@ Use `next-method-p' to find out if there is a next method to call." | |||
| 726 | (eieio--generic-call-arglst newargs) | 730 | (eieio--generic-call-arglst newargs) |
| 727 | (fcn (car next)) | 731 | (fcn (car next)) |
| 728 | ) | 732 | ) |
| 729 | (eieio--with-scoped-class (cdr next) | 733 | (apply fcn newargs)) ))) |
| 730 | (apply fcn newargs)) )))) | ||
| 731 | 734 | ||
| 732 | (defgeneric no-applicable-method (object method &rest args) | 735 | (defgeneric no-applicable-method (object method &rest args) |
| 733 | "Called if there are no implementations for OBJECT in METHOD.") | 736 | "Called if there are no implementations for OBJECT in METHOD.") |
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 419a78be469..c5597b83170 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el | |||
| @@ -36,12 +36,12 @@ | |||
| 36 | ;; Retrieved from: | 36 | ;; Retrieved from: |
| 37 | ;; http://192.220.96.201/dylan/linearization-oopsla96.html | 37 | ;; http://192.220.96.201/dylan/linearization-oopsla96.html |
| 38 | 38 | ||
| 39 | ;; There is funny stuff going on with typep and deftype. This | ||
| 40 | ;; is the only way I seem to be able to make this stuff load properly. | ||
| 41 | |||
| 42 | ;; @TODO - fix :initform to be a form, not a quoted value | 39 | ;; @TODO - fix :initform to be a form, not a quoted value |
| 43 | ;; @TODO - Prefix non-clos functions with `eieio-'. | 40 | ;; @TODO - Prefix non-clos functions with `eieio-'. |
| 44 | 41 | ||
| 42 | ;; TODO: better integrate CL's defstructs and classes. E.g. make it possible | ||
| 43 | ;; to create a new class that inherits from a struct. | ||
| 44 | |||
| 45 | ;;; Code: | 45 | ;;; Code: |
| 46 | 46 | ||
| 47 | (defvar eieio-version "1.4" | 47 | (defvar eieio-version "1.4" |
| @@ -76,8 +76,6 @@ being the slots residing in that class definition. Supported tags are: | |||
| 76 | - A string documenting use of this slot. | 76 | - A string documenting use of this slot. |
| 77 | 77 | ||
| 78 | The following are extensions on CLOS: | 78 | The following are extensions on CLOS: |
| 79 | :protection - Specify protection for this slot. | ||
| 80 | Defaults to `:public'. Also use `:protected', or `:private'. | ||
| 81 | :custom - When customizing an object, the custom :type. Public only. | 79 | :custom - When customizing an object, the custom :type. Public only. |
| 82 | :label - A text string label used for a slot when customizing. | 80 | :label - A text string label used for a slot when customizing. |
| 83 | :group - Name of a customization group this slot belongs in. | 81 | :group - Name of a customization group this slot belongs in. |
| @@ -278,12 +276,6 @@ and reference them using the function `class-option'." | |||
| 278 | `(defun ,name (&rest slots) | 276 | `(defun ,name (&rest slots) |
| 279 | ,(format "Create a new object with name NAME of class type %S." | 277 | ,(format "Create a new object with name NAME of class type %S." |
| 280 | name) | 278 | name) |
| 281 | (if (and slots | ||
| 282 | (let ((x (car slots))) | ||
| 283 | (or (stringp x) (null x)))) | ||
| 284 | (funcall (if eieio-backward-compatibility #'ignore #'message) | ||
| 285 | "Obsolete name %S passed to %S constructor" | ||
| 286 | (pop slots) ',name)) | ||
| 287 | (apply #'eieio-constructor ',name slots)))))) | 279 | (apply #'eieio-constructor ',name slots)))))) |
| 288 | 280 | ||
| 289 | 281 | ||
| @@ -309,7 +301,7 @@ In EIEIO, the class' constructor requires a name for use when printing. | |||
| 309 | `make-instance' in CLOS doesn't use names the way Emacs does, so the | 301 | `make-instance' in CLOS doesn't use names the way Emacs does, so the |
| 310 | class is used as the name slot instead when INITARGS doesn't start with | 302 | class is used as the name slot instead when INITARGS doesn't start with |
| 311 | a string." | 303 | a string." |
| 312 | (apply (class-constructor class) initargs)) | 304 | (apply (eieio--class-constructor class) initargs)) |
| 313 | 305 | ||
| 314 | 306 | ||
| 315 | ;;; Get/Set slots in an object. | 307 | ;;; Get/Set slots in an object. |
| @@ -658,7 +650,14 @@ SLOTS are the initialization slots used by `shared-initialize'. | |||
| 658 | This static method is called when an object is constructed. | 650 | This static method is called when an object is constructed. |
| 659 | It allocates the vector used to represent an EIEIO object, and then | 651 | It allocates the vector used to represent an EIEIO object, and then |
| 660 | calls `shared-initialize' on that object." | 652 | calls `shared-initialize' on that object." |
| 661 | (let* ((new-object (copy-sequence (eieio--class-default-object-cache (eieio--class-v class))))) | 653 | (let* ((new-object (copy-sequence (eieio--class-default-object-cache |
| 654 | (eieio--class-v class))))) | ||
| 655 | (if (and slots | ||
| 656 | (let ((x (car slots))) | ||
| 657 | (or (stringp x) (null x)))) | ||
| 658 | (funcall (if eieio-backward-compatibility #'ignore #'message) | ||
| 659 | "Obsolete name %S passed to %S constructor" | ||
| 660 | (pop slots) class)) | ||
| 662 | ;; Call the initialize method on the new object with the slots | 661 | ;; Call the initialize method on the new object with the slots |
| 663 | ;; that were passed down to us. | 662 | ;; that were passed down to us. |
| 664 | (initialize-instance new-object slots) | 663 | (initialize-instance new-object slots) |
| @@ -672,14 +671,13 @@ Called from the constructor routine.") | |||
| 672 | (defmethod shared-initialize ((obj eieio-default-superclass) slots) | 671 | (defmethod shared-initialize ((obj eieio-default-superclass) slots) |
| 673 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. | 672 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. |
| 674 | Called from the constructor routine." | 673 | Called from the constructor routine." |
| 675 | (eieio--with-scoped-class (eieio--object-class-object obj) | 674 | (while slots |
| 676 | (while slots | 675 | (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj) |
| 677 | (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj) | 676 | (car slots)))) |
| 678 | (car slots)))) | 677 | (if (not rn) |
| 679 | (if (not rn) | 678 | (slot-missing obj (car slots) 'oset (car (cdr slots))) |
| 680 | (slot-missing obj (car slots) 'oset (car (cdr slots))) | 679 | (eieio-oset obj rn (car (cdr slots))))) |
| 681 | (eieio-oset obj rn (car (cdr slots))))) | 680 | (setq slots (cdr (cdr slots))))) |
| 682 | (setq slots (cdr (cdr slots)))))) | ||
| 683 | 681 | ||
| 684 | (defgeneric initialize-instance (this &optional slots) | 682 | (defgeneric initialize-instance (this &optional slots) |
| 685 | "Construct the new object THIS based on SLOTS.") | 683 | "Construct the new object THIS based on SLOTS.") |
| @@ -823,7 +821,7 @@ this object." | |||
| 823 | ;; Each slot's slot is writen using its :writer. | 821 | ;; Each slot's slot is writen using its :writer. |
| 824 | (princ (make-string (* eieio-print-depth 2) ? )) | 822 | (princ (make-string (* eieio-print-depth 2) ? )) |
| 825 | (princ "(") | 823 | (princ "(") |
| 826 | (princ (symbol-name (class-constructor (eieio-object-class this)))) | 824 | (princ (symbol-name (eieio--class-constructor (eieio-object-class this)))) |
| 827 | (princ " ") | 825 | (princ " ") |
| 828 | (prin1 (eieio-object-name-string this)) | 826 | (prin1 (eieio-object-name-string this)) |
| 829 | (princ "\n") | 827 | (princ "\n") |
| @@ -926,7 +924,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to | |||
| 926 | 924 | ||
| 927 | ;;; Start of automatically extracted autoloads. | 925 | ;;; Start of automatically extracted autoloads. |
| 928 | 926 | ||
| 929 | ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "9a908efef1720439feb6323c1dd01770") | 927 | ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "6baa78cfc590cc0422e12b7eb55abf24") |
| 930 | ;;; Generated autoloads from eieio-custom.el | 928 | ;;; Generated autoloads from eieio-custom.el |
| 931 | 929 | ||
| 932 | (autoload 'customize-object "eieio-custom" "\ | 930 | (autoload 'customize-object "eieio-custom" "\ |
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index cc7b06c35b1..6c9c798bc16 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; find-func.el --- find the definition of the Emacs Lisp function near point | 1 | ;;; find-func.el --- find the definition of the Emacs Lisp function near point -*- lexical-binding:t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -59,7 +59,7 @@ | |||
| 59 | (concat | 59 | (concat |
| 60 | "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ | 60 | "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ |
| 61 | ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ | 61 | ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ |
| 62 | foo\\|[^icfgv]\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ | 62 | foo\\|\\(?:[^icfv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ |
| 63 | menu-bar-make-toggle\\)" | 63 | menu-bar-make-toggle\\)" |
| 64 | find-function-space-re | 64 | find-function-space-re |
| 65 | "\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)") | 65 | "\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)") |
| @@ -106,7 +106,10 @@ Please send improvements and fixes to the maintainer." | |||
| 106 | (defface . find-face-regexp)) | 106 | (defface . find-face-regexp)) |
| 107 | "Alist mapping definition types into regexp variables. | 107 | "Alist mapping definition types into regexp variables. |
| 108 | Each regexp variable's value should actually be a format string | 108 | Each regexp variable's value should actually be a format string |
| 109 | to be used to substitute the desired symbol name into the regexp.") | 109 | to be used to substitute the desired symbol name into the regexp. |
| 110 | Instead of regexp variable, types can be mapped to functions as well, | ||
| 111 | in which case the function is called with one argument (the object | ||
| 112 | we're looking for) and it should search for it.") | ||
| 110 | (put 'find-function-regexp-alist 'risky-local-variable t) | 113 | (put 'find-function-regexp-alist 'risky-local-variable t) |
| 111 | 114 | ||
| 112 | (defcustom find-function-source-path nil | 115 | (defcustom find-function-source-path nil |
| @@ -282,30 +285,33 @@ The search is done in the source for library LIBRARY." | |||
| 282 | (let* ((filename (find-library-name library)) | 285 | (let* ((filename (find-library-name library)) |
| 283 | (regexp-symbol (cdr (assq type find-function-regexp-alist)))) | 286 | (regexp-symbol (cdr (assq type find-function-regexp-alist)))) |
| 284 | (with-current-buffer (find-file-noselect filename) | 287 | (with-current-buffer (find-file-noselect filename) |
| 285 | (let ((regexp (format (symbol-value regexp-symbol) | 288 | (let ((regexp (if (functionp regexp-symbol) regexp-symbol |
| 286 | ;; Entry for ` (backquote) macro in loaddefs.el, | 289 | (format (symbol-value regexp-symbol) |
| 287 | ;; (defalias (quote \`)..., has a \ but | 290 | ;; Entry for ` (backquote) macro in loaddefs.el, |
| 288 | ;; (symbol-name symbol) doesn't. Add an | 291 | ;; (defalias (quote \`)..., has a \ but |
| 289 | ;; optional \ to catch this. | 292 | ;; (symbol-name symbol) doesn't. Add an |
| 290 | (concat "\\\\?" | 293 | ;; optional \ to catch this. |
| 291 | (regexp-quote (symbol-name symbol))))) | 294 | (concat "\\\\?" |
| 295 | (regexp-quote (symbol-name symbol)))))) | ||
| 292 | (case-fold-search)) | 296 | (case-fold-search)) |
| 293 | (with-syntax-table emacs-lisp-mode-syntax-table | 297 | (with-syntax-table emacs-lisp-mode-syntax-table |
| 294 | (goto-char (point-min)) | 298 | (goto-char (point-min)) |
| 295 | (if (or (re-search-forward regexp nil t) | 299 | (if (if (functionp regexp) |
| 296 | ;; `regexp' matches definitions using known forms like | 300 | (funcall regexp symbol) |
| 297 | ;; `defun', or `defvar'. But some functions/variables | 301 | (or (re-search-forward regexp nil t) |
| 298 | ;; are defined using special macros (or functions), so | 302 | ;; `regexp' matches definitions using known forms like |
| 299 | ;; if `regexp' can't find the definition, we look for | 303 | ;; `defun', or `defvar'. But some functions/variables |
| 300 | ;; something of the form "(SOMETHING <symbol> ...)". | 304 | ;; are defined using special macros (or functions), so |
| 301 | ;; This fails to distinguish function definitions from | 305 | ;; if `regexp' can't find the definition, we look for |
| 302 | ;; variable declarations (or even uses thereof), but is | 306 | ;; something of the form "(SOMETHING <symbol> ...)". |
| 303 | ;; a good pragmatic fallback. | 307 | ;; This fails to distinguish function definitions from |
| 304 | (re-search-forward | 308 | ;; variable declarations (or even uses thereof), but is |
| 305 | (concat "^([^ ]+" find-function-space-re "['(]?" | 309 | ;; a good pragmatic fallback. |
| 306 | (regexp-quote (symbol-name symbol)) | 310 | (re-search-forward |
| 307 | "\\_>") | 311 | (concat "^([^ ]+" find-function-space-re "['(]?" |
| 308 | nil t)) | 312 | (regexp-quote (symbol-name symbol)) |
| 313 | "\\_>") | ||
| 314 | nil t))) | ||
| 309 | (progn | 315 | (progn |
| 310 | (beginning-of-line) | 316 | (beginning-of-line) |
| 311 | (cons (current-buffer) (point))) | 317 | (cons (current-buffer) (point))) |
| @@ -324,18 +330,19 @@ signal an error. | |||
| 324 | 330 | ||
| 325 | If VERBOSE is non-nil, and FUNCTION is an alias, display a | 331 | If VERBOSE is non-nil, and FUNCTION is an alias, display a |
| 326 | message about the whole chain of aliases." | 332 | message about the whole chain of aliases." |
| 327 | (let ((def (symbol-function (find-function-advised-original function))) | 333 | (let ((def (if (symbolp function) |
| 334 | (symbol-function (find-function-advised-original function)))) | ||
| 328 | aliases) | 335 | aliases) |
| 329 | ;; FIXME for completeness, it might be nice to print something like: | 336 | ;; FIXME for completeness, it might be nice to print something like: |
| 330 | ;; foo (which is advised), which is an alias for bar (which is advised). | 337 | ;; foo (which is advised), which is an alias for bar (which is advised). |
| 331 | (while (symbolp def) | 338 | (while (and def (symbolp def)) |
| 332 | (or (eq def function) | 339 | (or (eq def function) |
| 333 | (not verbose) | 340 | (not verbose) |
| 334 | (if aliases | 341 | (setq aliases (if aliases |
| 335 | (setq aliases (concat aliases | 342 | (concat aliases |
| 336 | (format ", which is an alias for `%s'" | 343 | (format ", which is an alias for `%s'" |
| 337 | (symbol-name def)))) | 344 | (symbol-name def))) |
| 338 | (setq aliases (format "`%s' is an alias for `%s'" | 345 | (format "`%s' is an alias for `%s'" |
| 339 | function (symbol-name def))))) | 346 | function (symbol-name def))))) |
| 340 | (setq function (symbol-function (find-function-advised-original function)) | 347 | (setq function (symbol-function (find-function-advised-original function)) |
| 341 | def (symbol-function (find-function-advised-original function)))) | 348 | def (symbol-function (find-function-advised-original function)))) |
| @@ -408,7 +415,6 @@ See also `find-function-after-hook'. | |||
| 408 | 415 | ||
| 409 | Set mark before moving, if the buffer already existed." | 416 | Set mark before moving, if the buffer already existed." |
| 410 | (let* ((orig-point (point)) | 417 | (let* ((orig-point (point)) |
| 411 | (orig-buf (window-buffer)) | ||
| 412 | (orig-buffers (buffer-list)) | 418 | (orig-buffers (buffer-list)) |
| 413 | (buffer-point (save-excursion | 419 | (buffer-point (save-excursion |
| 414 | (find-definition-noselect symbol type))) | 420 | (find-definition-noselect symbol type))) |
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index f2bcdad1720..e0945d47a45 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el | |||
| @@ -207,6 +207,10 @@ if it exists." | |||
| 207 | (pkg-version (package-version-join split-version)) | 207 | (pkg-version (package-version-join split-version)) |
| 208 | (pkg-buffer (current-buffer))) | 208 | (pkg-buffer (current-buffer))) |
| 209 | 209 | ||
| 210 | ;; `package-upload-file' will error if given a directory, | ||
| 211 | ;; but we check it here as well just in case. | ||
| 212 | (when (eq 'dir file-type) | ||
| 213 | (user-error "Can't upload directory, tar it instead")) | ||
| 210 | ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or | 214 | ;; Get archive-contents from ARCHIVE-URL if it's non-nil, or |
| 211 | ;; from `package-archive-upload-base' otherwise. | 215 | ;; from `package-archive-upload-base' otherwise. |
| 212 | (let ((contents (or (package--archive-contents-from-url archive-url) | 216 | (let ((contents (or (package--archive-contents-from-url archive-url) |
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5336271b65b..4be3b584a72 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el | |||
| @@ -239,7 +239,8 @@ selected. When higher versions are available from archives with | |||
| 239 | lower priorities, the user has to select those manually. | 239 | lower priorities, the user has to select those manually. |
| 240 | 240 | ||
| 241 | Archives not in this list have the priority 0." | 241 | Archives not in this list have the priority 0." |
| 242 | :type 'integer | 242 | :type '(alist :key-type (string :tag "Archive name") |
| 243 | :value-type (integer :tag "Priority (default is 0)")) | ||
| 243 | :risky t | 244 | :risky t |
| 244 | :group 'package | 245 | :group 'package |
| 245 | :version "25.1") | 246 | :version "25.1") |
| @@ -413,6 +414,7 @@ Slots: | |||
| 413 | (pcase (package-desc-kind pkg-desc) | 414 | (pcase (package-desc-kind pkg-desc) |
| 414 | (`single ".el") | 415 | (`single ".el") |
| 415 | (`tar ".tar") | 416 | (`tar ".tar") |
| 417 | (`dir "") | ||
| 416 | (kind (error "Unknown package kind: %s" kind)))) | 418 | (kind (error "Unknown package kind: %s" kind)))) |
| 417 | 419 | ||
| 418 | (defun package-desc--keywords (pkg-desc) | 420 | (defun package-desc--keywords (pkg-desc) |
| @@ -800,6 +802,20 @@ untar into a directory named DIR; otherwise, signal an error." | |||
| 800 | (dirname (package-desc-full-name pkg-desc)) | 802 | (dirname (package-desc-full-name pkg-desc)) |
| 801 | (pkg-dir (expand-file-name dirname package-user-dir))) | 803 | (pkg-dir (expand-file-name dirname package-user-dir))) |
| 802 | (pcase (package-desc-kind pkg-desc) | 804 | (pcase (package-desc-kind pkg-desc) |
| 805 | (`dir | ||
| 806 | (make-directory pkg-dir t) | ||
| 807 | (let ((file-list | ||
| 808 | (directory-files | ||
| 809 | default-directory 'full "\\`[^.].*\\.el\\'" 'nosort))) | ||
| 810 | (dolist (source-file file-list) | ||
| 811 | (let ((target-el-file | ||
| 812 | (expand-file-name (file-name-nondirectory source-file) pkg-dir))) | ||
| 813 | (copy-file source-file target-el-file t))) | ||
| 814 | ;; Now that the files have been installed, this package is | ||
| 815 | ;; indistinguishable from a `tar' or a `single'. Let's make | ||
| 816 | ;; things simple by ensuring we're one of them. | ||
| 817 | (setf (package-desc-kind pkg-desc) | ||
| 818 | (if (> (length file-list) 1) 'tar 'single)))) | ||
| 803 | (`tar | 819 | (`tar |
| 804 | (make-directory package-user-dir t) | 820 | (make-directory package-user-dir t) |
| 805 | ;; FIXME: should we delete PKG-DIR if it exists? | 821 | ;; FIXME: should we delete PKG-DIR if it exists? |
| @@ -925,6 +941,9 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." | |||
| 925 | 941 | ||
| 926 | (defun package-install-from-archive (pkg-desc) | 942 | (defun package-install-from-archive (pkg-desc) |
| 927 | "Download and install a tar package." | 943 | "Download and install a tar package." |
| 944 | ;; This won't happen, unless the archive is doing something wrong. | ||
| 945 | (when (eq (package-desc-kind pkg-desc) 'dir) | ||
| 946 | (error "Can't install directory package from archive")) | ||
| 928 | (let* ((location (package-archive-base pkg-desc)) | 947 | (let* ((location (package-archive-base pkg-desc)) |
| 929 | (file (concat (package-desc-full-name pkg-desc) | 948 | (file (concat (package-desc-full-name pkg-desc) |
| 930 | (package-desc-suffix pkg-desc))) | 949 | (package-desc-suffix pkg-desc))) |
| @@ -1277,30 +1296,69 @@ The return result is a `package-desc'." | |||
| 1277 | (unless tar-desc | 1296 | (unless tar-desc |
| 1278 | (error "No package descriptor file found")) | 1297 | (error "No package descriptor file found")) |
| 1279 | (with-current-buffer (tar--extract tar-desc) | 1298 | (with-current-buffer (tar--extract tar-desc) |
| 1280 | (goto-char (point-min)) | ||
| 1281 | (unwind-protect | 1299 | (unwind-protect |
| 1282 | (let* ((pkg-def-parsed (read (current-buffer))) | 1300 | (package--read-pkg-desc 'tar) |
| 1283 | (pkg-desc | ||
| 1284 | (if (not (eq (car pkg-def-parsed) 'define-package)) | ||
| 1285 | (error "Can't find define-package in %s" | ||
| 1286 | (tar-header-name tar-desc)) | ||
| 1287 | (apply #'package-desc-from-define | ||
| 1288 | (append (cdr pkg-def-parsed)))))) | ||
| 1289 | (setf (package-desc-kind pkg-desc) 'tar) | ||
| 1290 | pkg-desc) | ||
| 1291 | (kill-buffer (current-buffer)))))) | 1301 | (kill-buffer (current-buffer)))))) |
| 1292 | 1302 | ||
| 1303 | (defun package-dir-info () | ||
| 1304 | "Find package information for a directory. | ||
| 1305 | The return result is a `package-desc'." | ||
| 1306 | (cl-assert (derived-mode-p 'dired-mode)) | ||
| 1307 | (let* ((desc-file (package--description-file default-directory))) | ||
| 1308 | (if (file-readable-p desc-file) | ||
| 1309 | (with-temp-buffer | ||
| 1310 | (insert-file-contents desc-file) | ||
| 1311 | (package--read-pkg-desc 'dir)) | ||
| 1312 | (let ((files (directory-files default-directory t "\\.el\\'" t)) | ||
| 1313 | info) | ||
| 1314 | (while files | ||
| 1315 | (with-temp-buffer | ||
| 1316 | (insert-file-contents (pop files)) | ||
| 1317 | (if (setq info (ignore-errors (package-buffer-info))) | ||
| 1318 | (setq files nil) | ||
| 1319 | (setf (package-desc-kind info) 'dir)))))))) | ||
| 1320 | |||
| 1321 | (defun package--read-pkg-desc (kind) | ||
| 1322 | "Read a `define-package' form in current buffer. | ||
| 1323 | Return the pkg-desc, with desc-kind set to KIND." | ||
| 1324 | (goto-char (point-min)) | ||
| 1325 | (unwind-protect | ||
| 1326 | (let* ((pkg-def-parsed (read (current-buffer))) | ||
| 1327 | (pkg-desc | ||
| 1328 | (if (not (eq (car pkg-def-parsed) 'define-package)) | ||
| 1329 | (error "Can't find define-package in %s" | ||
| 1330 | (tar-header-name tar-desc)) | ||
| 1331 | (apply #'package-desc-from-define | ||
| 1332 | (append (cdr pkg-def-parsed)))))) | ||
| 1333 | (setf (package-desc-kind pkg-desc) kind) | ||
| 1334 | pkg-desc))) | ||
| 1335 | |||
| 1293 | 1336 | ||
| 1294 | ;;;###autoload | 1337 | ;;;###autoload |
| 1295 | (defun package-install-from-buffer () | 1338 | (defun package-install-from-buffer () |
| 1296 | "Install a package from the current buffer. | 1339 | "Install a package from the current buffer. |
| 1297 | The current buffer is assumed to be a single .el or .tar file that follows the | 1340 | The current buffer is assumed to be a single .el or .tar file or |
| 1298 | packaging guidelines; see info node `(elisp)Packaging'. | 1341 | a directory. These must follow the packaging guidelines (see |
| 1342 | info node `(elisp)Packaging'). | ||
| 1343 | |||
| 1344 | Specially, if current buffer is a directory, the -pkg.el | ||
| 1345 | description file is not mandatory, in which case the information | ||
| 1346 | is derived from the main .el file in the directory. | ||
| 1347 | |||
| 1299 | Downloads and installs required packages as needed." | 1348 | Downloads and installs required packages as needed." |
| 1300 | (interactive) | 1349 | (interactive) |
| 1301 | (let ((pkg-desc (if (derived-mode-p 'tar-mode) | 1350 | (let ((pkg-desc |
| 1302 | (package-tar-file-info) | 1351 | (cond |
| 1303 | (package-buffer-info)))) | 1352 | ((derived-mode-p 'dired-mode) |
| 1353 | ;; This is the only way a package-desc object with a `dir' | ||
| 1354 | ;; desc-kind can be created. Such packages can't be | ||
| 1355 | ;; uploaded or installed from archives, they can only be | ||
| 1356 | ;; installed from local buffers or directories. | ||
| 1357 | (package-dir-info)) | ||
| 1358 | ((derived-mode-p 'tar-mode) | ||
| 1359 | (package-tar-file-info)) | ||
| 1360 | (t | ||
| 1361 | (package-buffer-info))))) | ||
| 1304 | ;; Download and install the dependencies. | 1362 | ;; Download and install the dependencies. |
| 1305 | (let* ((requires (package-desc-reqs pkg-desc)) | 1363 | (let* ((requires (package-desc-reqs pkg-desc)) |
| 1306 | (transaction (package-compute-transaction nil requires))) | 1364 | (transaction (package-compute-transaction nil requires))) |
| @@ -1315,8 +1373,12 @@ Downloads and installs required packages as needed." | |||
| 1315 | The file can either be a tar file or an Emacs Lisp file." | 1373 | The file can either be a tar file or an Emacs Lisp file." |
| 1316 | (interactive "fPackage file name: ") | 1374 | (interactive "fPackage file name: ") |
| 1317 | (with-temp-buffer | 1375 | (with-temp-buffer |
| 1318 | (insert-file-contents-literally file) | 1376 | (if (file-directory-p file) |
| 1319 | (when (string-match "\\.tar\\'" file) (tar-mode)) | 1377 | (progn |
| 1378 | (setq default-directory file) | ||
| 1379 | (dired-mode)) | ||
| 1380 | (insert-file-contents-literally file) | ||
| 1381 | (when (string-match "\\.tar\\'" file) (tar-mode))) | ||
| 1320 | (package-install-from-buffer))) | 1382 | (package-install-from-buffer))) |
| 1321 | 1383 | ||
| 1322 | (defun package-delete (pkg-desc) | 1384 | (defun package-delete (pkg-desc) |
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index f6740c7d7f5..b28153b7f81 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el | |||
| @@ -197,14 +197,18 @@ If END is omitted, it defaults to the length of the sequence. | |||
| 197 | If START or END is negative, it counts from the end." | 197 | If START or END is negative, it counts from the end." |
| 198 | (cond ((or (stringp seq) (vectorp seq)) (substring seq start end)) | 198 | (cond ((or (stringp seq) (vectorp seq)) (substring seq start end)) |
| 199 | ((listp seq) | 199 | ((listp seq) |
| 200 | (let (len) | 200 | (let (len (errtext (format "Bad bounding indices: %s, %s" start end))) |
| 201 | (and end (< end 0) (setq end (+ end (setq len (seq-length seq))))) | 201 | (and end (< end 0) (setq end (+ end (setq len (seq-length seq))))) |
| 202 | (if (< start 0) (setq start (+ start (or len (setq len (seq-length seq)))))) | 202 | (if (< start 0) (setq start (+ start (or len (setq len (seq-length seq)))))) |
| 203 | (if (> start 0) (setq seq (nthcdr start seq))) | 203 | (when (> start 0) |
| 204 | (setq seq (nthcdr (1- start) seq)) | ||
| 205 | (or seq (error "%s" errtext)) | ||
| 206 | (setq seq (cdr seq))) | ||
| 204 | (if end | 207 | (if end |
| 205 | (let ((res nil)) | 208 | (let ((res nil)) |
| 206 | (while (>= (setq end (1- end)) start) | 209 | (while (and (>= (setq end (1- end)) start) seq) |
| 207 | (push (pop seq) res)) | 210 | (push (pop seq) res)) |
| 211 | (or (= (1+ end) start) (error "%s" errtext)) | ||
| 208 | (nreverse res)) | 212 | (nreverse res)) |
| 209 | (seq-copy seq)))) | 213 | (seq-copy seq)))) |
| 210 | (t (error "Unsupported sequence: %s" seq)))) | 214 | (t (error "Unsupported sequence: %s" seq)))) |
diff --git a/lisp/files.el b/lisp/files.el index f8318d8a34d..e9632edacef 100644 --- a/lisp/files.el +++ b/lisp/files.el | |||
| @@ -1489,8 +1489,9 @@ expand wildcards (if any) and visit multiple files." | |||
| 1489 | (if (listp value) | 1489 | (if (listp value) |
| 1490 | (progn | 1490 | (progn |
| 1491 | (setq value (nreverse value)) | 1491 | (setq value (nreverse value)) |
| 1492 | (cons (switch-to-buffer-other-window (car value)) | 1492 | (switch-to-buffer-other-window (car value)) |
| 1493 | (mapcar 'switch-to-buffer (cdr value)))) | 1493 | (mapc 'switch-to-buffer (cdr value)) |
| 1494 | value) | ||
| 1494 | (switch-to-buffer-other-window value)))) | 1495 | (switch-to-buffer-other-window value)))) |
| 1495 | 1496 | ||
| 1496 | (defun find-file-other-frame (filename &optional wildcards) | 1497 | (defun find-file-other-frame (filename &optional wildcards) |
| @@ -1512,8 +1513,9 @@ expand wildcards (if any) and visit multiple files." | |||
| 1512 | (if (listp value) | 1513 | (if (listp value) |
| 1513 | (progn | 1514 | (progn |
| 1514 | (setq value (nreverse value)) | 1515 | (setq value (nreverse value)) |
| 1515 | (cons (switch-to-buffer-other-frame (car value)) | 1516 | (switch-to-buffer-other-frame (car value)) |
| 1516 | (mapcar 'switch-to-buffer (cdr value)))) | 1517 | (mapc 'switch-to-buffer (cdr value)) |
| 1518 | value) | ||
| 1517 | (switch-to-buffer-other-frame value)))) | 1519 | (switch-to-buffer-other-frame value)))) |
| 1518 | 1520 | ||
| 1519 | (defun find-file-existing (filename) | 1521 | (defun find-file-existing (filename) |
| @@ -3600,7 +3602,9 @@ Returns the new list." | |||
| 3600 | "Collect entries from CLASS-VARIABLES into VARIABLES. | 3602 | "Collect entries from CLASS-VARIABLES into VARIABLES. |
| 3601 | ROOT is the root directory of the project. | 3603 | ROOT is the root directory of the project. |
| 3602 | Return the new variables list." | 3604 | Return the new variables list." |
| 3603 | (let* ((file-name (buffer-file-name)) | 3605 | (let* ((file-name (or (buffer-file-name) |
| 3606 | ;; Handle non-file buffers, too. | ||
| 3607 | (expand-file-name default-directory))) | ||
| 3604 | (sub-file-name (if file-name | 3608 | (sub-file-name (if file-name |
| 3605 | ;; FIXME: Why not use file-relative-name? | 3609 | ;; FIXME: Why not use file-relative-name? |
| 3606 | (substring file-name (length root))))) | 3610 | (substring file-name (length root))))) |
diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 10c040a246c..c0d63935035 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; | |||
| 183 | alternatively, it can be a function definition. | 183 | alternatively, it can be a function definition. |
| 184 | If TYPE is `defvar', search for a variable definition. | 184 | If TYPE is `defvar', search for a variable definition. |
| 185 | If TYPE is `defface', search for a face definition. | 185 | If TYPE is `defface', search for a face definition. |
| 186 | If TYPE is the value returned by `symbol-function' for a function symbol, | 186 | If TYPE is not a symbol, search for a function definition. |
| 187 | search for a function definition. | ||
| 188 | 187 | ||
| 189 | The return value is the absolute name of a readable file where OBJECT is | 188 | The return value is the absolute name of a readable file where OBJECT is |
| 190 | defined. If several such files exist, preference is given to a file | 189 | defined. If several such files exist, preference is given to a file |
| @@ -194,9 +193,10 @@ suitable file is found, return nil." | |||
| 194 | (let* ((autoloaded (autoloadp type)) | 193 | (let* ((autoloaded (autoloadp type)) |
| 195 | (file-name (or (and autoloaded (nth 1 type)) | 194 | (file-name (or (and autoloaded (nth 1 type)) |
| 196 | (symbol-file | 195 | (symbol-file |
| 197 | object (if (memq type (list 'defvar 'defface)) | 196 | ;; FIXME: Why do we have this weird "If TYPE is the |
| 198 | type | 197 | ;; value returned by `symbol-function' for a function |
| 199 | 'defun))))) | 198 | ;; symbol" exception? |
| 199 | object (or (if (symbolp type) type) 'defun))))) | ||
| 200 | (cond | 200 | (cond |
| 201 | (autoloaded | 201 | (autoloaded |
| 202 | ;; An autoloaded function: Locate the file since `symbol-function' | 202 | ;; An autoloaded function: Locate the file since `symbol-function' |
| @@ -452,6 +452,18 @@ FILE is the file where FUNCTION was probably defined." | |||
| 452 | (t ".")) | 452 | (t ".")) |
| 453 | "\n"))))) | 453 | "\n"))))) |
| 454 | 454 | ||
| 455 | (defun help-fns-short-filename (filename) | ||
| 456 | (let* ((abbrev (abbreviate-file-name filename)) | ||
| 457 | (short abbrev)) | ||
| 458 | (dolist (dir load-path) | ||
| 459 | (let ((rel (file-relative-name filename dir))) | ||
| 460 | (if (< (length rel) (length short)) | ||
| 461 | (setq short rel))) | ||
| 462 | (let ((rel (file-relative-name abbrev dir))) | ||
| 463 | (if (< (length rel) (length short)) | ||
| 464 | (setq short rel)))) | ||
| 465 | short)) | ||
| 466 | |||
| 455 | ;;;###autoload | 467 | ;;;###autoload |
| 456 | (defun describe-function-1 (function) | 468 | (defun describe-function-1 (function) |
| 457 | (let* ((advised (and (symbolp function) | 469 | (let* ((advised (and (symbolp function) |
| @@ -543,7 +555,7 @@ FILE is the file where FUNCTION was probably defined." | |||
| 543 | ;; but that's completely wrong when the user used load-file. | 555 | ;; but that's completely wrong when the user used load-file. |
| 544 | (princ (if (eq file-name 'C-source) | 556 | (princ (if (eq file-name 'C-source) |
| 545 | "C source code" | 557 | "C source code" |
| 546 | (file-name-nondirectory file-name))) | 558 | (help-fns-short-filename file-name))) |
| 547 | (princ "'") | 559 | (princ "'") |
| 548 | ;; Make a hyperlink to the library. | 560 | ;; Make a hyperlink to the library. |
| 549 | (with-current-buffer standard-output | 561 | (with-current-buffer standard-output |
| @@ -564,7 +576,7 @@ FILE is the file where FUNCTION was probably defined." | |||
| 564 | help-enable-auto-load | 576 | help-enable-auto-load |
| 565 | (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" | 577 | (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" |
| 566 | doc-raw) | 578 | doc-raw) |
| 567 | (load (cadr real-def) t)) | 579 | (autoload-do-load real-def)) |
| 568 | (substitute-command-keys doc-raw)))) | 580 | (substitute-command-keys doc-raw)))) |
| 569 | 581 | ||
| 570 | (help-fns--key-bindings function) | 582 | (help-fns--key-bindings function) |
diff --git a/lisp/help-mode.el b/lisp/help-mode.el index dd2030706b2..c62ddc3dcd0 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el | |||
| @@ -191,7 +191,7 @@ The format is (FUNCTION ARGS...).") | |||
| 191 | 191 | ||
| 192 | (define-button-type 'help-function-def | 192 | (define-button-type 'help-function-def |
| 193 | :supertype 'help-xref | 193 | :supertype 'help-xref |
| 194 | 'help-function (lambda (fun file) | 194 | 'help-function (lambda (fun file &optional type) |
| 195 | (require 'find-func) | 195 | (require 'find-func) |
| 196 | (when (eq file 'C-source) | 196 | (when (eq file 'C-source) |
| 197 | (setq file | 197 | (setq file |
| @@ -199,7 +199,7 @@ The format is (FUNCTION ARGS...).") | |||
| 199 | ;; Don't use find-function-noselect because it follows | 199 | ;; Don't use find-function-noselect because it follows |
| 200 | ;; aliases (which fails for built-in functions). | 200 | ;; aliases (which fails for built-in functions). |
| 201 | (let ((location | 201 | (let ((location |
| 202 | (find-function-search-for-symbol fun nil file))) | 202 | (find-function-search-for-symbol fun type file))) |
| 203 | (pop-to-buffer (car location)) | 203 | (pop-to-buffer (car location)) |
| 204 | (if (cdr location) | 204 | (if (cdr location) |
| 205 | (goto-char (cdr location)) | 205 | (goto-char (cdr location)) |
diff --git a/lisp/misearch.el b/lisp/misearch.el index 6daae243fbb..dcc819564fb 100644 --- a/lisp/misearch.el +++ b/lisp/misearch.el | |||
| @@ -377,6 +377,25 @@ whose file names match the specified wildcard." | |||
| 377 | (goto-char (if isearch-forward (point-min) (point-max))) | 377 | (goto-char (if isearch-forward (point-min) (point-max))) |
| 378 | (isearch-forward-regexp nil t))) | 378 | (isearch-forward-regexp nil t))) |
| 379 | 379 | ||
| 380 | (defun multi-isearch-unload-function () | ||
| 381 | "Remove autoloaded variables from `unload-function-defs-list'. | ||
| 382 | Also prevent the feature from being reloaded via `isearch-mode-hook'." | ||
| 383 | (remove-hook 'isearch-mode-hook 'multi-isearch-setup) | ||
| 384 | (let ((defs (list (car unload-function-defs-list))) | ||
| 385 | (auto '(multi-isearch-next-buffer-function | ||
| 386 | multi-isearch-next-buffer-current-function | ||
| 387 | multi-isearch-current-buffer | ||
| 388 | multi-isearch-buffer-list multi-isearch-file-list))) | ||
| 389 | (dolist (def (cdr unload-function-defs-list)) | ||
| 390 | (unless (and (symbolp def) | ||
| 391 | (memq def auto)) | ||
| 392 | (push def defs))) | ||
| 393 | (setq unload-function-defs-list (nreverse defs)) | ||
| 394 | ;; . | ||
| 395 | nil)) | ||
| 396 | |||
| 397 | (defalias 'misearch-unload-function 'multi-isearch-unload-function) | ||
| 398 | |||
| 380 | 399 | ||
| 381 | (provide 'multi-isearch) | 400 | (provide 'multi-isearch) |
| 382 | (provide 'misearch) | 401 | (provide 'misearch) |
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el index b9d45b3a32f..040a50e3099 100644 --- a/lisp/textmodes/enriched.el +++ b/lisp/textmodes/enriched.el | |||
| @@ -314,7 +314,8 @@ the region, and the START and END of each region." | |||
| 314 | ;;;###autoload | 314 | ;;;###autoload |
| 315 | (defun enriched-encode (from to orig-buf) | 315 | (defun enriched-encode (from to orig-buf) |
| 316 | (if enriched-verbose (message "Enriched: encoding document...")) | 316 | (if enriched-verbose (message "Enriched: encoding document...")) |
| 317 | (let ((inhibit-read-only t)) | 317 | (let ((inhibit-read-only t) |
| 318 | (inhibit-point-motion-hooks t)) | ||
| 318 | (save-restriction | 319 | (save-restriction |
| 319 | (narrow-to-region from to) | 320 | (narrow-to-region from to) |
| 320 | (delete-to-left-margin) | 321 | (delete-to-left-margin) |
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index ccb2606c528..a7b3d16d46d 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el | |||
| @@ -104,9 +104,10 @@ telling Microsoft that." | |||
| 104 | (insert ";; Emacs-W3 HTTP cookies file\n" | 104 | (insert ";; Emacs-W3 HTTP cookies file\n" |
| 105 | ";; Automatically generated file!!! DO NOT EDIT!!!\n\n" | 105 | ";; Automatically generated file!!! DO NOT EDIT!!!\n\n" |
| 106 | "(setq url-cookie-storage\n '") | 106 | "(setq url-cookie-storage\n '") |
| 107 | (pp url-cookie-storage (current-buffer)) | 107 | (let ((print-length nil) (print-level nil)) |
| 108 | (insert ")\n(setq url-cookie-secure-storage\n '") | 108 | (pp url-cookie-storage (current-buffer)) |
| 109 | (pp url-cookie-secure-storage (current-buffer)) | 109 | (insert ")\n(setq url-cookie-secure-storage\n '") |
| 110 | (pp url-cookie-secure-storage (current-buffer))) | ||
| 110 | (insert ")\n") | 111 | (insert ")\n") |
| 111 | (insert "\n;; Local Variables:\n" | 112 | (insert "\n;; Local Variables:\n" |
| 112 | ";; version-control: never\n" | 113 | ";; version-control: never\n" |
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index 163df1fdb5e..96d6d1da48c 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el | |||
| @@ -493,6 +493,19 @@ in the branch repository (or whose status not be determined)." | |||
| 493 | (add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t) | 493 | (add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t) |
| 494 | (message "There are unresolved conflicts in this file"))) | 494 | (message "There are unresolved conflicts in this file"))) |
| 495 | 495 | ||
| 496 | (defun vc-bzr-version-dirstate (dir) | ||
| 497 | "Try to return as a string the bzr revision ID of directory DIR. | ||
| 498 | This uses the dirstate file's parent revision entry. | ||
| 499 | Returns nil if unable to find this information." | ||
| 500 | (let ((file (expand-file-name ".bzr/checkout/dirstate" dir))) | ||
| 501 | (when (file-readable-p file) | ||
| 502 | (with-temp-buffer | ||
| 503 | (insert-file-contents file) | ||
| 504 | (and (looking-at "#bazaar dirstate flat format 3") | ||
| 505 | (forward-line 3) | ||
| 506 | (looking-at "[0-9]+\0\\([^\0\n]+\\)\0") | ||
| 507 | (match-string 1)))))) | ||
| 508 | |||
| 496 | (defun vc-bzr-working-revision (file) | 509 | (defun vc-bzr-working-revision (file) |
| 497 | (let* ((rootdir (vc-bzr-root file)) | 510 | (let* ((rootdir (vc-bzr-root file)) |
| 498 | (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file | 511 | (branch-format-file (expand-file-name vc-bzr-admin-branch-format-file |
| @@ -538,8 +551,8 @@ in the branch repository (or whose status not be determined)." | |||
| 538 | ;; files exist. | 551 | ;; files exist. |
| 539 | (and (file-exists-p branch-format-file) | 552 | (and (file-exists-p branch-format-file) |
| 540 | (file-exists-p lastrev-file) | 553 | (file-exists-p lastrev-file) |
| 541 | (equal (emacs-bzr-version-dirstate l-c-parent-dir) | 554 | (equal (vc-bzr-version-dirstate l-c-parent-dir) |
| 542 | (emacs-bzr-version-dirstate rootdir)))))) | 555 | (vc-bzr-version-dirstate rootdir)))))) |
| 543 | t))) | 556 | t))) |
| 544 | (with-temp-buffer | 557 | (with-temp-buffer |
| 545 | (insert-file-contents branch-format-file) | 558 | (insert-file-contents branch-format-file) |
diff --git a/lisp/version.el b/lisp/version.el index 75763b3f682..1837cbf0a85 100644 --- a/lisp/version.el +++ b/lisp/version.el | |||
| @@ -93,41 +93,6 @@ or if we could not determine the revision.") | |||
| 93 | (define-obsolete-variable-alias 'emacs-bzr-version | 93 | (define-obsolete-variable-alias 'emacs-bzr-version |
| 94 | 'emacs-repository-version "24.4") | 94 | 'emacs-repository-version "24.4") |
| 95 | 95 | ||
| 96 | (defun emacs-bzr-version-dirstate (dir) | ||
| 97 | "Try to return as a string the bzr revision ID of directory DIR. | ||
| 98 | This uses the dirstate file's parent revision entry. | ||
| 99 | Returns nil if unable to find this information." | ||
| 100 | (let ((file (expand-file-name ".bzr/checkout/dirstate" dir))) | ||
| 101 | (when (file-readable-p file) | ||
| 102 | (with-temp-buffer | ||
| 103 | (insert-file-contents file) | ||
| 104 | (and (looking-at "#bazaar dirstate flat format 3") | ||
| 105 | (forward-line 3) | ||
| 106 | (looking-at "[0-9]+\0\\([^\0\n]+\\)\0") | ||
| 107 | (match-string 1)))))) | ||
| 108 | |||
| 109 | (defun emacs-bzr-version-bzr (dir) | ||
| 110 | "Ask bzr itself for the version information for directory DIR." | ||
| 111 | ;; Comments on `bzr version-info': | ||
| 112 | ;; i) Unknown files also cause clean != 1. | ||
| 113 | ;; ii) It can be slow, contacting the upstream repo to get the | ||
| 114 | ;; branch nick if one is not set locally, even with a custom | ||
| 115 | ;; template that is not asking for the nick (as used here). You'd | ||
| 116 | ;; think the latter part would be trivial to fix: | ||
| 117 | ;; https://bugs.launchpad.net/bzr/+bug/882541/comments/3 | ||
| 118 | ;; https://bugs.launchpad.net/bzr/+bug/629150 | ||
| 119 | ;; You can set the nick locally with `bzr nick ...', which speeds | ||
| 120 | ;; things up enormously. `bzr revno' does not have this issue, but | ||
| 121 | ;; has no way to print the revision_id AFAICS. | ||
| 122 | (message "Waiting for bzr...") | ||
| 123 | (with-temp-buffer | ||
| 124 | (if (zerop | ||
| 125 | (call-process "bzr" nil '(t nil) nil "version-info" | ||
| 126 | "--custom" | ||
| 127 | "--template={revno} {revision_id} (clean = {clean})" | ||
| 128 | dir)) | ||
| 129 | (buffer-string)))) | ||
| 130 | |||
| 131 | (define-obsolete-function-alias 'emacs-bzr-get-version | 96 | (define-obsolete-function-alias 'emacs-bzr-get-version |
| 132 | 'emacs-repository-get-version "24.4") | 97 | 'emacs-repository-get-version "24.4") |
| 133 | 98 | ||
| @@ -140,48 +105,10 @@ this reports on the current state of the sources, which may not | |||
| 140 | correspond to the running Emacs. | 105 | correspond to the running Emacs. |
| 141 | 106 | ||
| 142 | Optional argument DIR is a directory to use instead of | 107 | Optional argument DIR is a directory to use instead of |
| 143 | `source-directory'. Optional argument EXTERNAL non-nil means to | 108 | `source-directory'. Optional argument EXTERNAL is ignored and is |
| 144 | maybe ask the VCS itself, if the sources appear to be under | 109 | retained for compatibility." |
| 145 | version control. If `force', always ask. the VCS. Otherwise | ||
| 146 | only ask the VCS if we cannot find any information ourselves." | ||
| 147 | (or dir (setq dir source-directory)) | 110 | (or dir (setq dir source-directory)) |
| 148 | (cond ((file-directory-p (expand-file-name ".bzr/branch" dir)) | 111 | (cond ((file-directory-p (expand-file-name ".git" dir)) |
| 149 | (if (eq external 'force) | ||
| 150 | (emacs-bzr-version-bzr dir) | ||
| 151 | (let (file loc rev) | ||
| 152 | (cond ((file-readable-p | ||
| 153 | (setq file (expand-file-name | ||
| 154 | ".bzr/branch/last-revision" dir))) | ||
| 155 | (with-temp-buffer | ||
| 156 | (insert-file-contents file) | ||
| 157 | (goto-char (point-max)) | ||
| 158 | (if (looking-back "\n") | ||
| 159 | (delete-char -1)) | ||
| 160 | (buffer-string))) | ||
| 161 | ;; OK, no last-revision. Is it a lightweight checkout? | ||
| 162 | ((file-readable-p | ||
| 163 | (setq file (expand-file-name ".bzr/branch/location" dir))) | ||
| 164 | (setq rev (emacs-bzr-version-dirstate dir)) | ||
| 165 | ;; If parent branch is local, try looking there for the rev. | ||
| 166 | ;; Note: there is no guarantee that the parent branch's rev | ||
| 167 | ;; corresponds to this branch. This branch could have | ||
| 168 | ;; been made with a specific -r revno argument, or the | ||
| 169 | ;; parent could have been updated since this branch was | ||
| 170 | ;; created. | ||
| 171 | ;; To try and detect this, we check the dirstate revids | ||
| 172 | ;; to see if they match. | ||
| 173 | (if (and (setq loc (with-temp-buffer | ||
| 174 | (insert-file-contents file) | ||
| 175 | (if (looking-at "file://\\(.*\\)") | ||
| 176 | (match-string 1)))) | ||
| 177 | (equal rev (emacs-bzr-version-dirstate loc))) | ||
| 178 | (emacs-repository-get-version loc) | ||
| 179 | ;; If parent does not match, the best we can do without | ||
| 180 | ;; calling external commands is to use the dirstate rev. | ||
| 181 | rev)) | ||
| 182 | (external | ||
| 183 | (emacs-bzr-version-bzr dir)))))) | ||
| 184 | ((file-directory-p (expand-file-name ".git" dir)) | ||
| 185 | (message "Waiting for git...") | 112 | (message "Waiting for git...") |
| 186 | (with-temp-buffer | 113 | (with-temp-buffer |
| 187 | (let ((default-directory (file-name-as-directory dir))) | 114 | (let ((default-directory (file-name-as-directory dir))) |
diff --git a/test/ChangeLog b/test/ChangeLog index 8ed02ee341b..15baf866f37 100644 --- a/test/ChangeLog +++ b/test/ChangeLog | |||
| @@ -1,3 +1,34 @@ | |||
| 1 | 2015-01-18 Leo Liu <sdl.web@gmail.com> | ||
| 2 | |||
| 3 | * automated/seq-tests.el (test-seq-subseq): Add more tests. | ||
| 4 | (Bug#19434) | ||
| 5 | |||
| 6 | 2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 7 | |||
| 8 | * automated/eieio-tests.el | ||
| 9 | (eieio-test-37-obsolete-name-in-constructor): New test. | ||
| 10 | |||
| 11 | 2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 12 | |||
| 13 | * automated/eieio-tests.el (eieio-test-25-slot-tests) | ||
| 14 | (eieio-test-26-default-inheritance, eieio-test-28-slot-protection) | ||
| 15 | (eieio-test-30-slot-attribute-override) | ||
| 16 | (eieio-test-31-slot-attribute-override-class-allocation): Don't check | ||
| 17 | that we enforce :protection since we don't any more. | ||
| 18 | |||
| 19 | * automated/eieio-test-methodinvoke.el (eieio-test-method-store): | ||
| 20 | Use an explicit arg instead of eieio--scoped-class. Update all callers. | ||
| 21 | |||
| 22 | 2015-01-17 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 23 | |||
| 24 | * automated/eieio-test-methodinvoke.el (eieio-test-cl-generic-1): | ||
| 25 | Reset eieio-test--1. | ||
| 26 | |||
| 27 | * automated/cl-generic-tests.el (cl-generic-test-8-after/before): | ||
| 28 | Rename from cl-generic-test-7-after/before. | ||
| 29 | (cl--generic-test-advice): New function. | ||
| 30 | (cl-generic-test-9-advice): New test. | ||
| 31 | |||
| 1 | 2015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de> | 32 | 2015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de> |
| 2 | 33 | ||
| 3 | * automated/package-test.el (package-test-install-prioritized): | 34 | * 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 17bce6a3157..46397fb7f51 100644 --- a/test/automated/cl-generic-tests.el +++ b/test/automated/cl-generic-tests.el | |||
| @@ -129,5 +129,31 @@ | |||
| 129 | (cons "x&y-int" (cl-call-next-method))) | 129 | (cons "x&y-int" (cl-call-next-method))) |
| 130 | (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) | 130 | (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) |
| 131 | 131 | ||
| 132 | (ert-deftest cl-generic-test-8-after/before () | ||
| 133 | (let ((log ())) | ||
| 134 | (cl-defgeneric cl--generic-1 (x y)) | ||
| 135 | (cl-defmethod cl--generic-1 ((_x t) y) (cons y log)) | ||
| 136 | (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) | ||
| 137 | (cons "quatre" (cl-call-next-method))) | ||
| 138 | (cl-defmethod cl--generic-1 :after (x _y) | ||
| 139 | (push (list :after x) log)) | ||
| 140 | (cl-defmethod cl--generic-1 :before (x _y) | ||
| 141 | (push (list :before x) log)) | ||
| 142 | (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4)))) | ||
| 143 | (should (equal log '((:after 4) (:before 4)))))) | ||
| 144 | |||
| 145 | (defun cl--generic-test-advice (&rest args) (cons "advice" (apply args))) | ||
| 146 | |||
| 147 | (ert-deftest cl-generic-test-9-advice () | ||
| 148 | (cl-defgeneric cl--generic-1 (x y) "My doc.") | ||
| 149 | (cl-defmethod cl--generic-1 (x y) (list x y)) | ||
| 150 | (advice-add 'cl--generic-1 :around #'cl--generic-test-advice) | ||
| 151 | (should (equal (cl--generic-1 4 5) '("advice" 4 5))) | ||
| 152 | (cl-defmethod cl--generic-1 ((_x integer) _y) | ||
| 153 | (cons "integer" (cl-call-next-method))) | ||
| 154 | (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5))) | ||
| 155 | (advice-remove 'cl--generic-1 #'cl--generic-test-advice) | ||
| 156 | (should (equal (cl--generic-1 4 5) '("integer" 4 5)))) | ||
| 157 | |||
| 132 | (provide 'cl-generic-tests) | 158 | (provide 'cl-generic-tests) |
| 133 | ;;; cl-generic-tests.el ends here | 159 | ;;; cl-generic-tests.el ends here |
diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el index bbfb8d1f1da..c83391b1cc5 100644 --- a/test/automated/cl-lib-tests.el +++ b/test/automated/cl-lib-tests.el | |||
| @@ -245,4 +245,7 @@ | |||
| 245 | (ert-deftest cl-loop-destructuring-with () | 245 | (ert-deftest cl-loop-destructuring-with () |
| 246 | (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) | 246 | (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) |
| 247 | 247 | ||
| 248 | (ert-deftest cl-flet-test () | ||
| 249 | (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) | ||
| 250 | |||
| 248 | ;;; cl-lib.el ends here | 251 | ;;; cl-lib.el ends here |
diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el index 6362fc5a8d9..b6d60b85815 100644 --- a/test/automated/eieio-test-methodinvoke.el +++ b/test/automated/eieio-test-methodinvoke.el | |||
| @@ -58,11 +58,9 @@ | |||
| 58 | (defvar eieio-test-method-order-list nil | 58 | (defvar eieio-test-method-order-list nil |
| 59 | "List of symbols stored during method invocation.") | 59 | "List of symbols stored during method invocation.") |
| 60 | 60 | ||
| 61 | (defun eieio-test-method-store (keysym) | 61 | (defun eieio-test-method-store (&rest args) |
| 62 | "Store current invocation class symbol in the invocation order list." | 62 | "Store current invocation class symbol in the invocation order list." |
| 63 | ;; FIXME: Don't depend on `eieio--scoped-class'! | 63 | (push args eieio-test-method-order-list)) |
| 64 | (let* ((c (list keysym (eieio--class-symbol (eieio--scoped-class))))) | ||
| 65 | (push c eieio-test-method-order-list))) | ||
| 66 | 64 | ||
| 67 | (defun eieio-test-match (rightanswer) | 65 | (defun eieio-test-match (rightanswer) |
| 68 | "Do a test match." | 66 | "Do a test match." |
| @@ -86,36 +84,36 @@ | |||
| 86 | (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) | 84 | (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) |
| 87 | 85 | ||
| 88 | (defmethod eitest-F :BEFORE ((p eitest-B-base1)) | 86 | (defmethod eitest-F :BEFORE ((p eitest-B-base1)) |
| 89 | (eieio-test-method-store :BEFORE)) | 87 | (eieio-test-method-store :BEFORE 'eitest-B-base1)) |
| 90 | 88 | ||
| 91 | (defmethod eitest-F :BEFORE ((p eitest-B-base2)) | 89 | (defmethod eitest-F :BEFORE ((p eitest-B-base2)) |
| 92 | (eieio-test-method-store :BEFORE)) | 90 | (eieio-test-method-store :BEFORE 'eitest-B-base2)) |
| 93 | 91 | ||
| 94 | (defmethod eitest-F :BEFORE ((p eitest-B)) | 92 | (defmethod eitest-F :BEFORE ((p eitest-B)) |
| 95 | (eieio-test-method-store :BEFORE)) | 93 | (eieio-test-method-store :BEFORE 'eitest-B)) |
| 96 | 94 | ||
| 97 | (defmethod eitest-F ((p eitest-B)) | 95 | (defmethod eitest-F ((p eitest-B)) |
| 98 | (eieio-test-method-store :PRIMARY) | 96 | (eieio-test-method-store :PRIMARY 'eitest-B) |
| 99 | (call-next-method)) | 97 | (call-next-method)) |
| 100 | 98 | ||
| 101 | (defmethod eitest-F ((p eitest-B-base1)) | 99 | (defmethod eitest-F ((p eitest-B-base1)) |
| 102 | (eieio-test-method-store :PRIMARY) | 100 | (eieio-test-method-store :PRIMARY 'eitest-B-base1) |
| 103 | (call-next-method)) | 101 | (call-next-method)) |
| 104 | 102 | ||
| 105 | (defmethod eitest-F ((p eitest-B-base2)) | 103 | (defmethod eitest-F ((p eitest-B-base2)) |
| 106 | (eieio-test-method-store :PRIMARY) | 104 | (eieio-test-method-store :PRIMARY 'eitest-B-base2) |
| 107 | (when (next-method-p) | 105 | (when (next-method-p) |
| 108 | (call-next-method)) | 106 | (call-next-method)) |
| 109 | ) | 107 | ) |
| 110 | 108 | ||
| 111 | (defmethod eitest-F :AFTER ((p eitest-B-base1)) | 109 | (defmethod eitest-F :AFTER ((p eitest-B-base1)) |
| 112 | (eieio-test-method-store :AFTER)) | 110 | (eieio-test-method-store :AFTER 'eitest-B-base1)) |
| 113 | 111 | ||
| 114 | (defmethod eitest-F :AFTER ((p eitest-B-base2)) | 112 | (defmethod eitest-F :AFTER ((p eitest-B-base2)) |
| 115 | (eieio-test-method-store :AFTER)) | 113 | (eieio-test-method-store :AFTER 'eitest-B-base2)) |
| 116 | 114 | ||
| 117 | (defmethod eitest-F :AFTER ((p eitest-B)) | 115 | (defmethod eitest-F :AFTER ((p eitest-B)) |
| 118 | (eieio-test-method-store :AFTER)) | 116 | (eieio-test-method-store :AFTER 'eitest-B)) |
| 119 | 117 | ||
| 120 | (ert-deftest eieio-test-method-order-list-3 () | 118 | (ert-deftest eieio-test-method-order-list-3 () |
| 121 | (let ((eieio-test-method-order-list nil) | 119 | (let ((eieio-test-method-order-list nil) |
| @@ -150,15 +148,15 @@ | |||
| 150 | ;;; Return value from :PRIMARY | 148 | ;;; Return value from :PRIMARY |
| 151 | ;; | 149 | ;; |
| 152 | (defmethod eitest-I :BEFORE ((a eitest-A)) | 150 | (defmethod eitest-I :BEFORE ((a eitest-A)) |
| 153 | (eieio-test-method-store :BEFORE) | 151 | (eieio-test-method-store :BEFORE 'eitest-A) |
| 154 | ":before") | 152 | ":before") |
| 155 | 153 | ||
| 156 | (defmethod eitest-I :PRIMARY ((a eitest-A)) | 154 | (defmethod eitest-I :PRIMARY ((a eitest-A)) |
| 157 | (eieio-test-method-store :PRIMARY) | 155 | (eieio-test-method-store :PRIMARY 'eitest-A) |
| 158 | ":primary") | 156 | ":primary") |
| 159 | 157 | ||
| 160 | (defmethod eitest-I :AFTER ((a eitest-A)) | 158 | (defmethod eitest-I :AFTER ((a eitest-A)) |
| 161 | (eieio-test-method-store :AFTER) | 159 | (eieio-test-method-store :AFTER 'eitest-A) |
| 162 | ":after") | 160 | ":after") |
| 163 | 161 | ||
| 164 | (ert-deftest eieio-test-method-order-list-5 () | 162 | (ert-deftest eieio-test-method-order-list-5 () |
| @@ -177,17 +175,17 @@ | |||
| 177 | 175 | ||
| 178 | ;; Just use the obsolete name once, to make sure it also works. | 176 | ;; Just use the obsolete name once, to make sure it also works. |
| 179 | (defmethod constructor :STATIC ((p C-base1) &rest args) | 177 | (defmethod constructor :STATIC ((p C-base1) &rest args) |
| 180 | (eieio-test-method-store :STATIC) | 178 | (eieio-test-method-store :STATIC 'C-base1) |
| 181 | (if (next-method-p) (call-next-method)) | 179 | (if (next-method-p) (call-next-method)) |
| 182 | ) | 180 | ) |
| 183 | 181 | ||
| 184 | (defmethod eieio-constructor :STATIC ((p C-base2) &rest args) | 182 | (defmethod eieio-constructor :STATIC ((p C-base2) &rest args) |
| 185 | (eieio-test-method-store :STATIC) | 183 | (eieio-test-method-store :STATIC 'C-base2) |
| 186 | (if (next-method-p) (call-next-method)) | 184 | (if (next-method-p) (call-next-method)) |
| 187 | ) | 185 | ) |
| 188 | 186 | ||
| 189 | (defmethod eieio-constructor :STATIC ((p C) &rest args) | 187 | (defmethod eieio-constructor :STATIC ((p C) &rest args) |
| 190 | (eieio-test-method-store :STATIC) | 188 | (eieio-test-method-store :STATIC 'C) |
| 191 | (call-next-method) | 189 | (call-next-method) |
| 192 | ) | 190 | ) |
| 193 | 191 | ||
| @@ -214,24 +212,24 @@ | |||
| 214 | 212 | ||
| 215 | (defmethod eitest-F ((p D)) | 213 | (defmethod eitest-F ((p D)) |
| 216 | "D" | 214 | "D" |
| 217 | (eieio-test-method-store :PRIMARY) | 215 | (eieio-test-method-store :PRIMARY 'D) |
| 218 | (call-next-method)) | 216 | (call-next-method)) |
| 219 | 217 | ||
| 220 | (defmethod eitest-F ((p D-base0)) | 218 | (defmethod eitest-F ((p D-base0)) |
| 221 | "D-base0" | 219 | "D-base0" |
| 222 | (eieio-test-method-store :PRIMARY) | 220 | (eieio-test-method-store :PRIMARY 'D-base0) |
| 223 | ;; This should have no next | 221 | ;; This should have no next |
| 224 | ;; (when (next-method-p) (call-next-method)) | 222 | ;; (when (next-method-p) (call-next-method)) |
| 225 | ) | 223 | ) |
| 226 | 224 | ||
| 227 | (defmethod eitest-F ((p D-base1)) | 225 | (defmethod eitest-F ((p D-base1)) |
| 228 | "D-base1" | 226 | "D-base1" |
| 229 | (eieio-test-method-store :PRIMARY) | 227 | (eieio-test-method-store :PRIMARY 'D-base1) |
| 230 | (call-next-method)) | 228 | (call-next-method)) |
| 231 | 229 | ||
| 232 | (defmethod eitest-F ((p D-base2)) | 230 | (defmethod eitest-F ((p D-base2)) |
| 233 | "D-base2" | 231 | "D-base2" |
| 234 | (eieio-test-method-store :PRIMARY) | 232 | (eieio-test-method-store :PRIMARY 'D-base2) |
| 235 | (when (next-method-p) | 233 | (when (next-method-p) |
| 236 | (call-next-method)) | 234 | (call-next-method)) |
| 237 | ) | 235 | ) |
| @@ -256,21 +254,21 @@ | |||
| 256 | (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) | 254 | (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) |
| 257 | 255 | ||
| 258 | (defmethod eitest-F ((p E)) | 256 | (defmethod eitest-F ((p E)) |
| 259 | (eieio-test-method-store :PRIMARY) | 257 | (eieio-test-method-store :PRIMARY 'E) |
| 260 | (call-next-method)) | 258 | (call-next-method)) |
| 261 | 259 | ||
| 262 | (defmethod eitest-F ((p E-base0)) | 260 | (defmethod eitest-F ((p E-base0)) |
| 263 | (eieio-test-method-store :PRIMARY) | 261 | (eieio-test-method-store :PRIMARY 'E-base0) |
| 264 | ;; This should have no next | 262 | ;; This should have no next |
| 265 | ;; (when (next-method-p) (call-next-method)) | 263 | ;; (when (next-method-p) (call-next-method)) |
| 266 | ) | 264 | ) |
| 267 | 265 | ||
| 268 | (defmethod eitest-F ((p E-base1)) | 266 | (defmethod eitest-F ((p E-base1)) |
| 269 | (eieio-test-method-store :PRIMARY) | 267 | (eieio-test-method-store :PRIMARY 'E-base1) |
| 270 | (call-next-method)) | 268 | (call-next-method)) |
| 271 | 269 | ||
| 272 | (defmethod eitest-F ((p E-base2)) | 270 | (defmethod eitest-F ((p E-base2)) |
| 273 | (eieio-test-method-store :PRIMARY) | 271 | (eieio-test-method-store :PRIMARY 'E-base2) |
| 274 | (when (next-method-p) | 272 | (when (next-method-p) |
| 275 | (call-next-method)) | 273 | (call-next-method)) |
| 276 | ) | 274 | ) |
| @@ -384,6 +382,7 @@ | |||
| 384 | (cl-defgeneric eieio-test--1 (x y)) | 382 | (cl-defgeneric eieio-test--1 (x y)) |
| 385 | 383 | ||
| 386 | (ert-deftest eieio-test-cl-generic-1 () | 384 | (ert-deftest eieio-test-cl-generic-1 () |
| 385 | (cl-defgeneric eieio-test--1 (x y)) | ||
| 387 | (cl-defmethod eieio-test--1 (x y) (list x y)) | 386 | (cl-defmethod eieio-test--1 (x y) (list x y)) |
| 388 | (cl-defmethod eieio-test--1 ((_x CNM-0) y) | 387 | (cl-defmethod eieio-test--1 ((_x CNM-0) y) |
| 389 | (cons "CNM-0" (cl-call-next-method 7 y))) | 388 | (cons "CNM-0" (cl-call-next-method 7 y))) |
diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el index 0b1ff1fd93b..e0120b4b5b8 100644 --- a/test/automated/eieio-tests.el +++ b/test/automated/eieio-tests.el | |||
| @@ -563,7 +563,7 @@ METHOD is the method that was attempting to be called." | |||
| 563 | (should (eq (oref eitest-t1 slot-1) 'moose)) | 563 | (should (eq (oref eitest-t1 slot-1) 'moose)) |
| 564 | (should (eq (oref eitest-t1 :moose) 'moose)) | 564 | (should (eq (oref eitest-t1 :moose) 'moose)) |
| 565 | ;; Don't pass reference of private slot | 565 | ;; Don't pass reference of private slot |
| 566 | (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) | 566 | ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) |
| 567 | ;; Check private slot accessor | 567 | ;; Check private slot accessor |
| 568 | (should (string= (get-slot-2 eitest-t1) "penguin")) | 568 | (should (string= (get-slot-2 eitest-t1) "penguin")) |
| 569 | ;; Pass string instead of symbol | 569 | ;; Pass string instead of symbol |
| @@ -583,7 +583,7 @@ METHOD is the method that was attempting to be called." | |||
| 583 | (should (eq (oref eitest-t2 slot-1) 'moose)) | 583 | (should (eq (oref eitest-t2 slot-1) 'moose)) |
| 584 | (should (eq (oref eitest-t2 :moose) 'moose)) | 584 | (should (eq (oref eitest-t2 :moose) 'moose)) |
| 585 | (should (string= (get-slot-2 eitest-t2) "linux")) | 585 | (should (string= (get-slot-2 eitest-t2) "linux")) |
| 586 | (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) | 586 | ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) |
| 587 | (should (string= (get-slot-2 eitest-t2) "linux")) | 587 | (should (string= (get-slot-2 eitest-t2) "linux")) |
| 588 | (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type)) | 588 | (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type)) |
| 589 | 589 | ||
| @@ -654,20 +654,23 @@ Do not override for `prot-2'." | |||
| 654 | ;; Access public slots | 654 | ;; Access public slots |
| 655 | (oref eitest-p1 slot-1) | 655 | (oref eitest-p1 slot-1) |
| 656 | (oref eitest-p2 slot-1) | 656 | (oref eitest-p2 slot-1) |
| 657 | ;; Accessing protected slot out of context must fail | 657 | ;; Accessing protected slot out of context used to fail, but we dropped this |
| 658 | (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name) | 658 | ;; feature, since it was underused and noone noticed that the check was |
| 659 | ;; incorrect (much too loose). | ||
| 660 | ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name) | ||
| 659 | ;; Access protected slot in method | 661 | ;; Access protected slot in method |
| 660 | (prot1-slot-2 eitest-p1) | 662 | (prot1-slot-2 eitest-p1) |
| 661 | ;; Protected slot in subclass method | 663 | ;; Protected slot in subclass method |
| 662 | (prot1-slot-2 eitest-p2) | 664 | (prot1-slot-2 eitest-p2) |
| 663 | ;; Protected slot from parent class method | 665 | ;; Protected slot from parent class method |
| 664 | (prot0-slot-2 eitest-p1) | 666 | (prot0-slot-2 eitest-p1) |
| 665 | ;; Accessing private slot out of context must fail | 667 | ;; Accessing private slot out of context used to fail, but we dropped this |
| 666 | (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name) | 668 | ;; feature, since it was not used. |
| 669 | ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name) | ||
| 667 | ;; Access private slot in method | 670 | ;; Access private slot in method |
| 668 | (prot1-slot-3 eitest-p1) | 671 | (prot1-slot-3 eitest-p1) |
| 669 | ;; Access private slot in subclass method must fail | 672 | ;; Access private slot in subclass method must fail |
| 670 | (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name) | 673 | ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name) |
| 671 | ;; Access private slot by same class | 674 | ;; Access private slot by same class |
| 672 | (prot1-slot-3-only eitest-p1) | 675 | (prot1-slot-3-only eitest-p1) |
| 673 | ;; Access private slot by subclass in sameclass method | 676 | ;; Access private slot by subclass in sameclass method |
| @@ -729,12 +732,13 @@ Subclasses to override slot attributes.") | |||
| 729 | 732 | ||
| 730 | (ert-deftest eieio-test-30-slot-attribute-override () | 733 | (ert-deftest eieio-test-30-slot-attribute-override () |
| 731 | ;; Subclass should not override :protection slot attribute | 734 | ;; Subclass should not override :protection slot attribute |
| 732 | (should-error | 735 | ;;PROTECTION is gone. |
| 733 | (eval | 736 | ;;(should-error |
| 734 | '(defclass slotattr-fail (slotattr-base) | 737 | ;; (eval |
| 735 | ((protection :protection :public) | 738 | ;; '(defclass slotattr-fail (slotattr-base) |
| 736 | ) | 739 | ;; ((protection :protection :public) |
| 737 | "This class should throw an error."))) | 740 | ;; ) |
| 741 | ;; "This class should throw an error."))) | ||
| 738 | 742 | ||
| 739 | ;; Subclass should not override :type slot attribute | 743 | ;; Subclass should not override :type slot attribute |
| 740 | (should-error | 744 | (should-error |
| @@ -782,12 +786,13 @@ Subclasses to override slot attributes.") | |||
| 782 | 786 | ||
| 783 | (ert-deftest eieio-test-31-slot-attribute-override-class-allocation () | 787 | (ert-deftest eieio-test-31-slot-attribute-override-class-allocation () |
| 784 | ;; Same as test-30, but with class allocation | 788 | ;; Same as test-30, but with class allocation |
| 785 | (should-error | 789 | ;;PROTECTION is gone. |
| 786 | (eval | 790 | ;;(should-error |
| 787 | '(defclass slotattr-fail (slotattr-class-base) | 791 | ;; (eval |
| 788 | ((protection :protection :public) | 792 | ;; '(defclass slotattr-fail (slotattr-class-base) |
| 789 | ) | 793 | ;; ((protection :protection :public) |
| 790 | "This class should throw an error."))) | 794 | ;; ) |
| 795 | ;; "This class should throw an error."))) | ||
| 791 | (should-error | 796 | (should-error |
| 792 | (eval | 797 | (eval |
| 793 | '(defclass slotattr-fail (slotattr-class-base) | 798 | '(defclass slotattr-fail (slotattr-class-base) |
| @@ -887,6 +892,15 @@ Subclasses to override slot attributes.") | |||
| 887 | (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) | 892 | (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) |
| 888 | (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) | 893 | (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) |
| 889 | 894 | ||
| 895 | (defclass eieio--testing () | ||
| 896 | ()) | ||
| 897 | |||
| 898 | (defmethod constructor :static ((_x eieio--testing) newname &rest _args) | ||
| 899 | (list newname 2)) | ||
| 900 | |||
| 901 | (ert-deftest eieio-test-37-obsolete-name-in-constructor () | ||
| 902 | (should (equal (eieio--testing "toto") '("toto" 2)))) | ||
| 903 | |||
| 890 | (provide 'eieio-tests) | 904 | (provide 'eieio-tests) |
| 891 | 905 | ||
| 892 | ;;; eieio-tests.el ends here | 906 | ;;; eieio-tests.el ends here |
diff --git a/test/automated/seq-tests.el b/test/automated/seq-tests.el index 9fcda7f7c9d..23989799306 100644 --- a/test/automated/seq-tests.el +++ b/test/automated/seq-tests.el | |||
| @@ -182,7 +182,12 @@ Evaluate BODY for each created sequence. | |||
| 182 | (should (same-contents-p (seq-subseq seq 1 -1) '(3 4)))) | 182 | (should (same-contents-p (seq-subseq seq 1 -1) '(3 4)))) |
| 183 | (should (vectorp (seq-subseq [2 3 4 5] 2))) | 183 | (should (vectorp (seq-subseq [2 3 4 5] 2))) |
| 184 | (should (stringp (seq-subseq "foo" 2 3))) | 184 | (should (stringp (seq-subseq "foo" 2 3))) |
| 185 | (should (listp (seq-subseq '(2 3 4 4) 2 3)))) | 185 | (should (listp (seq-subseq '(2 3 4 4) 2 3))) |
| 186 | (should-error (seq-subseq '(1 2 3) 4)) | ||
| 187 | (should-not (seq-subseq '(1 2 3) 3)) | ||
| 188 | (should (seq-subseq '(1 2 3) -3)) | ||
| 189 | (should-error (seq-subseq '(1 2 3) 1 4)) | ||
| 190 | (should (seq-subseq '(1 2 3) 1 3))) | ||
| 186 | 191 | ||
| 187 | (ert-deftest test-seq-concatenate () | 192 | (ert-deftest test-seq-concatenate () |
| 188 | (with-test-sequences (seq '(2 4 6)) | 193 | (with-test-sequences (seq '(2 4 6)) |