aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJoakim Verona2015-01-18 10:53:38 +0100
committerJoakim Verona2015-01-18 10:53:38 +0100
commit54efd2ab176dd6cc33bb1e86a9c37908c26d0a46 (patch)
treeae7dfc525e25275235b1d6de84cf067a751742e4
parent576960211cb54bc77dc6969591420bca89c59456 (diff)
parent253d44bd27b7d90b614b6b968a3b125eeb0a48f2 (diff)
downloademacs-54efd2ab176dd6cc33bb1e86a9c37908c26d0a46.tar.gz
emacs-54efd2ab176dd6cc33bb1e86a9c37908c26d0a46.zip
merge master
-rw-r--r--doc/misc/ChangeLog6
-rw-r--r--doc/misc/eieio.texi5
-rw-r--r--etc/ChangeLog4
-rw-r--r--etc/NEWS5
-rw-r--r--lisp/ChangeLog153
-rw-r--r--lisp/desktop.el1
-rw-r--r--lisp/emacs-lisp/cl-extra.el27
-rw-r--r--lisp/emacs-lisp/cl-generic.el196
-rw-r--r--lisp/emacs-lisp/cl-macs.el37
-rw-r--r--lisp/emacs-lisp/eieio-core.el198
-rw-r--r--lisp/emacs-lisp/eieio-custom.el2
-rw-r--r--lisp/emacs-lisp/eieio-datadebug.el2
-rw-r--r--lisp/emacs-lisp/eieio-generic.el139
-rw-r--r--lisp/emacs-lisp/eieio.el44
-rw-r--r--lisp/emacs-lisp/find-func.el68
-rw-r--r--lisp/emacs-lisp/package-x.el4
-rw-r--r--lisp/emacs-lisp/package.el98
-rw-r--r--lisp/emacs-lisp/seq.el10
-rw-r--r--lisp/files.el14
-rw-r--r--lisp/help-fns.el26
-rw-r--r--lisp/help-mode.el4
-rw-r--r--lisp/misearch.el19
-rw-r--r--lisp/textmodes/enriched.el3
-rw-r--r--lisp/url/url-cookie.el7
-rw-r--r--lisp/vc/vc-bzr.el17
-rw-r--r--lisp/version.el79
-rw-r--r--test/ChangeLog31
-rw-r--r--test/automated/cl-generic-tests.el26
-rw-r--r--test/automated/cl-lib-tests.el3
-rw-r--r--test/automated/eieio-test-methodinvoke.el53
-rw-r--r--test/automated/eieio-tests.el52
-rw-r--r--test/automated/seq-tests.el7
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 @@
12015-01-17 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * eieio.texi (Slot Options): Document :protection as unsupported.
4
12015-01-01 Michael Albinus <michael.albinus@gmx.de> 52015-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
252014-12-18 Eric Abrahamsen <eric@ericabrahamsen.net> 292014-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
538can output the code to do the construction of the value. 538can output the code to do the construction of the value.
539 539
540@item :protection 540@item :protection
541This is an old option that is not supported any more.
542
541When using a slot referencing function such as @code{slot-value}, and 543When using a slot referencing function such as @code{slot-value}, and
542the value behind @var{slot} is private or protected, then the current 544the value behind @var{slot} is private or protected, then the current
543scope of operation must be within a method of the calling object. 545scope of operation must be within a method of the calling object.
544 546
547This protection is not enforced by the code any more, so it's only useful
548as documentation.
549
545Valid values are: 550Valid 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 @@
12015-01-16 Artur Malabarba <bruce.connor.am@gmail.com>
2
3 * NEWS: Document installing packages from directories.
4
12015-01-15 Eli Zaretskii <eliz@gnu.org> 52015-01-15 Eli Zaretskii <eliz@gnu.org>
2 6
3 * NEWS: Mention 'set-binary-mode'. 7 * NEWS: Mention 'set-binary-mode'.
diff --git a/etc/NEWS b/etc/NEWS
index 0bfd3fd2a2d..be283bbc1c3 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -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.
60This 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
60unsaved customizations and prompts user to customize (if found). 64unsaved 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 @@
12015-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
92015-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
252015-01-17 Ulrich Müller <ulm@gentoo.org>
26
27 * version.el (emacs-repository-get-version): Update docstring.
28
292015-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
512015-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
612015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de>
62
63 * emacs-lisp/package.el (package-archive-priorities):
64 Specify correct type.
65
662015-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
752015-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
872015-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
1322015-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
12015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de> 1472015-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
392015-01-15 Stefan Monnier <monnier@iro.umontreal.ca> 1852015-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.
521If START or END is negative, it counts from the end." 522If 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.
133DOC-STRING is the base documentation for this class. A generic 133DOC-STRING is the base documentation for this class. A generic
134function has no body, as its purpose is to decide which method body 134function has no body, as its purpose is to decide which method body
135is appropriate to use. Specific methods are defined with `defmethod'. 135is appropriate to use. Specific methods are defined with `cl-defmethod'.
136With this implementation the ARGS are currently ignored. 136With this implementation the ARGS are currently ignored.
137OPTIONS-AND-METHODS is currently only used to specify the docstring, 137OPTIONS-AND-METHODS is currently only used to specify the docstring,
138via (:documentation DOCSTRING)." 138via (: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. 181This 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
263which case this method will be invoked when the argument is `eql' to VAL. 266which 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.")
453Can only be used from within the lexical body of a primary or around method." 511Can 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.
516Can 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.
41More specifically, it has no side-effects at all when the new function
42definition 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.
83Currently under control of this var: 67Currently 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.
297SUPERCLASSES are the superclasses that CNAME inherits from. 256SUPERCLASSES are the superclasses that CNAME inherits from.
298DOC is the docstring for CNAME. 257DOC is the docstring for CNAME.
@@ -301,58 +260,35 @@ SUPERCLASSES as children.
301It creates an autoload function for CNAME's constructor." 260It 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."
1159If SET-ALL is non-nil, then when a default is nil, that value is 1079If SET-ALL is non-nil, then when a default is nil, that value is
1160reset. If SET-ALL is nil, the slots are only reset if the default is 1080reset. If SET-ALL is nil, the slots are only reset if the default is
1161not nil." 1081not 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
1284method invocation orders of the involved classes." 1202method 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.
40More specifically, it has no side-effects at all when the new function
41definition 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.
632DOC-STRING is the base documentation for this class. A generic 638DOC-STRING is the base documentation for this class. A generic
633function has no body, as its purpose is to decide which method body 639function 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
637top level documentation to a method." 643top 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
710arguments passed in at the top level. 716arguments passed in at the top level.
711 717
712Use `next-method-p' to find out if there is a next method to call." 718Use `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
78The following are extensions on CLOS: 78The 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
310class is used as the name slot instead when INITARGS doesn't start with 302class is used as the name slot instead when INITARGS doesn't start with
311a string." 303a 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'.
658This static method is called when an object is constructed. 650This static method is called when an object is constructed.
659It allocates the vector used to represent an EIEIO object, and then 651It allocates the vector used to represent an EIEIO object, and then
660calls `shared-initialize' on that object." 652calls `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.
674Called from the constructor routine." 673Called 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\\|\
61ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ 61ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\
62foo\\|[^icfgv]\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ 62foo\\|\\(?:[^icfv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
63menu-bar-make-toggle\\)" 63menu-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.
108Each regexp variable's value should actually be a format string 108Each regexp variable's value should actually be a format string
109to be used to substitute the desired symbol name into the regexp.") 109to be used to substitute the desired symbol name into the regexp.
110Instead of regexp variable, types can be mapped to functions as well,
111in which case the function is called with one argument (the object
112we'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
325If VERBOSE is non-nil, and FUNCTION is an alias, display a 331If VERBOSE is non-nil, and FUNCTION is an alias, display a
326message about the whole chain of aliases." 332message 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
409Set mark before moving, if the buffer already existed." 416Set 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
239lower priorities, the user has to select those manually. 239lower priorities, the user has to select those manually.
240 240
241Archives not in this list have the priority 0." 241Archives 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.
1305The 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.
1323Return 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.
1297The current buffer is assumed to be a single .el or .tar file that follows the 1340The current buffer is assumed to be a single .el or .tar file or
1298packaging guidelines; see info node `(elisp)Packaging'. 1341a directory. These must follow the packaging guidelines (see
1342info node `(elisp)Packaging').
1343
1344Specially, if current buffer is a directory, the -pkg.el
1345description file is not mandatory, in which case the information
1346is derived from the main .el file in the directory.
1347
1299Downloads and installs required packages as needed." 1348Downloads 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."
1315The file can either be a tar file or an Emacs Lisp file." 1373The 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.
197If START or END is negative, it counts from the end." 197If 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.
3601ROOT is the root directory of the project. 3603ROOT is the root directory of the project.
3602Return the new variables list." 3604Return 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.
184If TYPE is `defvar', search for a variable definition. 184If TYPE is `defvar', search for a variable definition.
185If TYPE is `defface', search for a face definition. 185If TYPE is `defface', search for a face definition.
186If TYPE is the value returned by `symbol-function' for a function symbol, 186If TYPE is not a symbol, search for a function definition.
187 search for a function definition.
188 187
189The return value is the absolute name of a readable file where OBJECT is 188The return value is the absolute name of a readable file where OBJECT is
190defined. If several such files exist, preference is given to a file 189defined. 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'.
382Also 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.
498This uses the dirstate file's parent revision entry.
499Returns 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.
98This uses the dirstate file's parent revision entry.
99Returns 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
140correspond to the running Emacs. 105correspond to the running Emacs.
141 106
142Optional argument DIR is a directory to use instead of 107Optional 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
144maybe ask the VCS itself, if the sources appear to be under 109retained for compatibility."
145version control. If `force', always ask. the VCS. Otherwise
146only 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 @@
12015-01-18 Leo Liu <sdl.web@gmail.com>
2
3 * automated/seq-tests.el (test-seq-subseq): Add more tests.
4 (Bug#19434)
5
62015-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
112015-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
222015-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
12015-01-16 Jorgen Schaefer <contact@jorgenschaefer.de> 322015-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))