[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] xwidget 54efd2a: merge master
|
From: |
Joakim Verona |
|
Subject: |
[Emacs-diffs] xwidget 54efd2a: merge master |
|
Date: |
Sun, 18 Jan 2015 09:53:52 +0000 |
branch: xwidget
commit 54efd2ab176dd6cc33bb1e86a9c37908c26d0a46
Merge: 5769602 253d44b
Author: Joakim Verona <address@hidden>
Commit: Joakim Verona <address@hidden>
merge master
---
doc/misc/ChangeLog | 6 +-
doc/misc/eieio.texi | 5 +
etc/ChangeLog | 4 +
etc/NEWS | 5 +
lisp/ChangeLog | 153 ++++++++++++++++++++++
lisp/desktop.el | 1 -
lisp/emacs-lisp/cl-extra.el | 27 +---
lisp/emacs-lisp/cl-generic.el | 196 +++++++++++++++++++++-------
lisp/emacs-lisp/cl-macs.el | 37 +++--
lisp/emacs-lisp/eieio-core.el | 198 +++++++++--------------------
lisp/emacs-lisp/eieio-custom.el | 2 +-
lisp/emacs-lisp/eieio-datadebug.el | 2 +-
lisp/emacs-lisp/eieio-generic.el | 139 ++++++++++----------
lisp/emacs-lisp/eieio.el | 44 +++----
lisp/emacs-lisp/find-func.el | 68 ++++++-----
lisp/emacs-lisp/package-x.el | 4 +
lisp/emacs-lisp/package.el | 98 ++++++++++++---
lisp/emacs-lisp/seq.el | 10 +-
lisp/files.el | 14 ++-
lisp/help-fns.el | 26 +++-
lisp/help-mode.el | 4 +-
lisp/misearch.el | 19 +++
lisp/textmodes/enriched.el | 3 +-
lisp/url/url-cookie.el | 7 +-
lisp/vc/vc-bzr.el | 17 ++-
lisp/version.el | 79 +-----------
test/ChangeLog | 31 +++++
test/automated/cl-generic-tests.el | 26 ++++
test/automated/cl-lib-tests.el | 3 +
test/automated/eieio-test-methodinvoke.el | 53 ++++----
test/automated/eieio-tests.el | 52 +++++---
test/automated/seq-tests.el | 7 +-
32 files changed, 824 insertions(+), 516 deletions(-)
diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog
index 5057fb9..2baa13c 100644
--- a/doc/misc/ChangeLog
+++ b/doc/misc/ChangeLog
@@ -1,3 +1,7 @@
+2015-01-17 Stefan Monnier <address@hidden>
+
+ * eieio.texi (Slot Options): Document :protection as unsupported.
+
2015-01-01 Michael Albinus <address@hidden>
Sync with Tramp 2.2.11.
@@ -24,7 +28,7 @@
2014-12-18 Eric Abrahamsen <address@hidden>
- * gnus.texi (Gnus Registry Setup): Explain pruning changes. Mention
+ * gnus.texi (Gnus Registry Setup): Explain pruning changes. Mention
gnus-registry-prune-factor. Explain sorting changes and
gnus-registry-default-sort-function. Correct file extension.
diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi
index 954970d..3f42862 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
can output the code to do the construction of the value.
@item :protection
+This is an old option that is not supported any more.
+
When using a slot referencing function such as @code{slot-value}, and
the value behind @var{slot} is private or protected, then the current
scope of operation must be within a method of the calling object.
+This protection is not enforced by the code any more, so it's only useful
+as documentation.
+
Valid values are:
@table @code
diff --git a/etc/ChangeLog b/etc/ChangeLog
index 681858e..7b64dfb 100644
--- a/etc/ChangeLog
+++ b/etc/ChangeLog
@@ -1,3 +1,7 @@
+2015-01-16 Artur Malabarba <address@hidden>
+
+ * NEWS: Document installing packages from directories.
+
2015-01-15 Eli Zaretskii <address@hidden>
* NEWS: Mention 'set-binary-mode'.
diff --git a/etc/NEWS b/etc/NEWS
index 0bfd3fd..be283bb 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.
* Changes in Emacs 25.1
+** `package-install-from-buffer' and `package-install-file' work on
directories.
+This follows the same rules as installing from a .tar file, except the
+-pkg file is optional.
+
** New function `custom-prompt-customize-unsaved-options' checks for
unsaved customizations and prompts user to customize (if found).
@@ -198,6 +202,7 @@ the old behavior -- *shell* buffer displays in current
window -- use
** EIEIO
+*** The `:protection' slot option is not obeyed any more.
*** The <class>-list-p and <class>-child-p functions are declared obsolete.
*** The <class> variables are declared obsolete.
*** The <initarg> variables are declared obsolete.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 57aaea0..680adc7 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,149 @@
+2015-01-18 Leo Liu <address@hidden>
+
+ * emacs-lisp/cl-extra.el (cl-subseq): Use seq-subseq and fix
+ multiple evaluation. (Bug#19519)
+
+ * emacs-lisp/seq.el (seq-subseq): Throw bad bounding indices
+ error. (Bug#19434)
+
+2015-01-18 Stefan Monnier <address@hidden>
+
+ * emacs-lisp/cl-macs.el (cl-defstruct): Minor optimization when include
+ or print is nil.
+ (cl-struct-type-p): New function.
+
+ * emacs-lisp/cl-generic.el: Add support for cl-next-method-p.
+ (cl-defmethod): Add edebug spec.
+ (cl--generic-build-combined-method): Fix call to
+ cl-no-applicable-method.
+ (cl--generic-nnm-sample, cl--generic-cnm-sample): New constant.
+ (cl--generic-isnot-nnm-p): New function.
+ (cl--generic-lambda): Use it to add support for cl-next-method-p.
+ (cl-no-next-method, cl-no-applicable-method): Simplify arg list.
+ (cl-next-method-p): New function.
+
+2015-01-17 Ulrich Müller <address@hidden>
+
+ * version.el (emacs-repository-get-version): Update docstring.
+
+2015-01-17 Ivan Shmakov <address@hidden>
+
+ * url/url-cookie.el (url-cookie-write-file): Let-bind print-length
+ and print-level to nil to avoid writing a garbled list. (Bug#16805)
+
+ * files.el (find-file-other-window, find-file-other-frame):
+ Use mapc instead of mapcar. (Bug#18175)
+
+ * files.el (dir-locals-collect-variables): Use default-directory
+ in place of the file name while working on non-file buffers, just
+ like hack-dir-local-variables already does. (Bug#19140)
+
+ * textmodes/enriched.el (enriched-encode):
+ Use inhibit-point-motion-hooks in addition to inhibit-read-only.
+ (Bug#18246)
+
+ * desktop.el (desktop-read): Do not call desktop-clear when no
+ desktop file is found. (Bug#18371)
+
+ * misearch.el (multi-isearch-unload-function): New function.
+ (misearch-unload-function): New alias. (Bug#19566)
+
+2015-01-17 Stefan Monnier <address@hidden>
+
+ * emacs-lisp/eieio-core.el (eieio--class-constructor): Rename from
+ class-constructor, and make it an alias for `identity'.
+ Update all callers.
+
+ * emacs-lisp/eieio.el (eieio-constructor): Handle obsolete object name
+ argument here (bug#19620)...
+ (defclass): ...instead of in the constructor here.
+
+2015-01-16 Jorgen Schaefer <address@hidden>
+
+ * emacs-lisp/package.el (package-archive-priorities):
+ Specify correct type.
+
+2015-01-17 Ulrich Müller <address@hidden>
+
+ * version.el (emacs-bzr-version-dirstate, emacs-bzr-version-bzr):
+ Remove.
+ (emacs-repository-get-version): Discard the Bazaar case.
+ * vc/vc-bzr.el (vc-bzr-version-dirstate): Rename from
+ emacs-bzr-version-dirstate and move from version.el to here.
+ (vc-bzr-working-revision): Use it.
+
+2015-01-17 Stefan Monnier <address@hidden>
+
+ * emacs-lisp/eieio-generic.el (call-next-method): Don't bother checking
+ eieio--scoped-class any more.
+
+ * emacs-lisp/eieio-core.el (eieio--scoped-class-stack): Remove var.
+ (eieio--scoped-class): Remove function.
+ (eieio--with-scoped-class): Remove macro. Replace uses with `progn'.
+ (eieio--slot-name-index): Don't check the :protection anymore.
+ (eieio-initializing-object): Remove var.
+ (eieio-set-defaults): Don't let-bind eieio-initializing-object.
+
+2015-01-17 Stefan Monnier <address@hidden>
+
+ Improve handling of doc-strings and describe-function for cl-generic.
+
+ * help-mode.el (help-function-def): Add optional arg `type'.
+
+ * help-fns.el (find-lisp-object-file-name): Accept any `type' as long
+ as it's a symbol.
+ (help-fns-short-filename): New function.
+ (describe-function-1): Use it. Use autoload-do-load.
+
+ * emacs-lisp/find-func.el: Use lexical-binding.
+ (find-function-regexp): Don't rule out `defgeneric'.
+ (find-function-regexp-alist): Document new possibility of including
+ a function instead of a regexp.
+ (find-function-search-for-symbol): Implement that new possibility.
+ (find-function-library): Don't assume that `function' is a symbol.
+ (find-function-do-it): Remove unused var `orig-buf'.
+
+ * emacs-lisp/eieio-generic.el (eieio--defalias): Move from eieio-core.
+ (eieio--defgeneric-init-form): Don't throw away a previous docstring.
+ (eieio--method-optimize-primary): Don't mess with the docstring.
+ (defgeneric): Keep the `args' in the docstring.
+ (defmethod): Don't use the method's docstring for the generic
+ function's docstring.
+
+ * emacs-lisp/eieio-core.el (eieio--defalias): Move to eieio-generic.el.
+ (eieio-defclass-autoload): Don't record the superclasses any more.
+ (eieio-defclass-internal): Reuse the old class object if it was just an
+ autoload stub.
+ (eieio--class-precedence-list): Load the class if it's autoloaded.
+
+ * emacs-lisp/cl-generic.el (cl-generic-ensure-function): It's OK to
+ override an autoload.
+ (cl-generic-current-method-specializers): Replace dyn-bind variable
+ with a lexically-scoped macro.
+ (cl--generic-lambda): Update accordingly.
+ (cl-generic-define-method): Record manually in the load-history with
+ type `cl-defmethod'.
+ (cl--generic-get-dispatcher): Minor optimization.
+ (cl--generic-search-method): New function.
+ (find-function-regexp-alist): Add entry for `cl-defmethod' type.
+ (cl--generic-search-method): Add hyperlinks for methods. Merge the
+ specializers and the function's arguments.
+
+2015-01-16 Artur Malabarba <address@hidden>
+
+ * emacs-lisp/package.el (package--read-pkg-desc):
+ New function. Read a `define-package' form in current buffer. Return
+ the pkg-desc, with desc-kind set to KIND.
+ (package-dir-info): New function. Find package information for a
+ directory. The return result is a `package-desc'.
+ (package-install-from-buffer): Install packages from dired buffer.
+ (package-install-file): Install packages from directory.
+ (package-desc-suffix)
+ (package-install-from-archive)
+ * emacs-lisp/package-x.el (package-upload-buffer-internal):
+ Ensure all remaining instances of `package-desc-kind' handle the 'dir
+ value.
+
2015-01-16 Jorgen Schaefer <address@hidden>
* emacs-lisp/package.el: Provide repository priorities.
@@ -38,6 +184,13 @@
2015-01-15 Stefan Monnier <address@hidden>
+ * emacs-lisp/cl-macs.el (cl--labels-magic): New constant.
+ (cl--labels-convert): Use it to ask the macro what is its replacement
+ in the #'f case.
+
+ * emacs-lisp/cl-generic.el (cl--generic-build-combined-method):
+ Return the value of the primary rather than the after method.
+
* emacs-lisp/eieio-core.el: Provide support for cl-generic.
(eieio--generic-tagcode): New function.
(cl-generic-tagcode-function): Use it.
diff --git a/lisp/desktop.el b/lisp/desktop.el
index 3845f94..c355d7f 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -1191,7 +1191,6 @@ Using it may cause conflicts. Use it anyway? " owner)))))
(desktop-auto-save-enable)
t))
;; No desktop file found.
- (desktop-clear)
(let ((default-directory desktop-dirname))
(run-hooks 'desktop-no-desktop-file-hook))
(message "No desktop file.")
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 2f8a5a6..afc2adb 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -38,6 +38,7 @@
;;; Code:
(require 'cl-lib)
+(require 'seq)
;;; Type coercion.
@@ -521,28 +522,10 @@ If END is omitted, it defaults to the length of the
sequence.
If START or END is negative, it counts from the end."
(declare (gv-setter
(lambda (new)
- `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
- ,new))))
- (if (stringp seq) (substring seq start end)
- (let (len)
- (and end (< end 0) (setq end (+ end (setq len (length seq)))))
- (if (< start 0) (setq start (+ start (or len (setq len (length seq))))))
- (cond ((listp seq)
- (if (> start 0) (setq seq (nthcdr start seq)))
- (if end
- (let ((res nil))
- (while (>= (setq end (1- end)) start)
- (push (pop seq) res))
- (nreverse res))
- (copy-sequence seq)))
- (t
- (or end (setq end (or len (length seq))))
- (let ((res (make-vector (max (- end start) 0) nil))
- (i 0))
- (while (< start end)
- (aset res i (aref seq start))
- (setq i (1+ i) start (1+ start)))
- res))))))
+ (macroexp-let2 nil new new
+ `(progn (cl-replace ,seq ,new :start1 ,start :end1 ,end)
+ ,new)))))
+ (seq-subseq seq start end))
;;;###autoload
(defun cl-concatenate (type &rest seqs)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 41a419a..819e2e9 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -26,8 +26,7 @@
;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.
;; Missing elements:
-;; - We don't support next-method-p, make-method, call-method,
-;; define-method-combination.
+;; - We don't support make-method, call-method, define-method-combination.
;; - Method and generic function objects: CLOS defines methods as objects
;; (same for generic functions), whereas we don't offer such an abstraction.
;; - `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.")
(symbolp (symbol-function name)))
(setq name (symbol-function name)))
(unless (or (not (fboundp name))
+ (autoloadp (symbol-function name))
(and (functionp name) generic))
(error "%s is already defined as something else than a generic function"
origname))
@@ -132,7 +132,7 @@ They should be sorted from most specific to least
specific.")
"Create a generic function NAME.
DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body
-is appropriate to use. Specific methods are defined with `defmethod'.
+is appropriate to use. Specific methods are defined with `cl-defmethod'.
With this implementation the ARGS are currently ignored.
OPTIONS-AND-METHODS is currently only used to specify the docstring,
via (:documentation DOCSTRING)."
@@ -153,7 +153,7 @@ via (:documentation DOCSTRING)."
code))
(defalias ',name
(cl-generic-define ',name ',args ',options-and-methods)
- ,doc))))
+ ,(help-add-fundoc-usage doc args)))))
(defun cl--generic-mandatory-args (args)
(let ((res ()))
@@ -176,15 +176,10 @@ via (:documentation DOCSTRING)."
(setf (cl--generic-method-table generic) nil)
(cl--generic-make-function generic)))
-(defvar cl-generic-current-method-specializers nil
- ;; This is let-bound during macro-expansion of method bodies, so that those
- ;; bodies can be optimized knowing that the specializers have matched.
- ;; FIXME: This presumes the formal arguments aren't modified via `setq' and
- ;; aren't shadowed either ;-(
- ;; FIXME: This might leak outside the scope of the method if, during
- ;; macroexpansion of the method, something causes some other macroexpansion
- ;; (e.g. an autoload).
- "List of (VAR . TYPE) where TYPE is var's specializer.")
+(defmacro cl-generic-current-method-specializers ()
+ "List of (VAR . TYPE) where TYPE is var's specializer.
+This macro can only be used within the lexical scope of a cl-generic method."
+ (error "cl-generic-current-method-specializers used outside of a method"))
(eval-and-compile ;Needed while compiling the cl-defmethod calls below!
(defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
@@ -199,46 +194,54 @@ via (:documentation DOCSTRING)."
(defun cl--generic-lambda (args body with-cnm)
"Make the lambda expression for a method with ARGS and BODY."
(let ((plain-args ())
- (cl-generic-current-method-specializers nil)
+ (specializers nil)
(doc-string (if (stringp (car-safe body)) (pop body)))
(mandatory t))
(dolist (arg args)
(push (pcase arg
((or '&optional '&rest '&key) (setq mandatory nil) arg)
((and `(,name . ,type) (guard mandatory))
- (push (cons name (car type))
- cl-generic-current-method-specializers)
+ (push (cons name (car type)) specializers)
name)
(_ arg))
plain-args))
(setq plain-args (nreverse plain-args))
(let ((fun `(cl-function (lambda ,plain-args
,@(if doc-string (list doc-string))
- ,@body))))
+ ,@body)))
+ (macroenv (cons `(cl-generic-current-method-specializers
+ . ,(lambda () specializers))
+ macroexpand-all-environment)))
(if (not with-cnm)
- (cons nil fun)
+ (cons nil (macroexpand-all fun macroenv))
;; First macroexpand away the cl-function stuff (e.g. &key and
;; destructuring args, `declare' and whatnot).
- (pcase (macroexpand fun macroexpand-all-environment)
+ (pcase (macroexpand fun macroenv)
(`#'(lambda ,args . ,body)
(require 'cl-lib) ;Needed to expand `cl-flet'.
(let* ((doc-string (and doc-string (stringp (car body))
(pop body)))
(cnm (make-symbol "cl--cnm"))
+ (nmp (make-symbol "cl--nmp"))
(nbody (macroexpand-all
- `(cl-flet ((cl-call-next-method ,cnm))
+ `(cl-flet ((cl-call-next-method ,cnm)
+ (cl-next-method-p ,nmp))
,@body)
- macroexpand-all-environment))
+ macroenv))
;; FIXME: Rather than `grep' after the fact, the
;; macroexpansion should directly set some flag when cnm
;; is used.
;; FIXME: Also, optimize the case where call-next-method is
;; only called with explicit arguments.
- (uses-cnm (cl--generic-fgrep (list cnm) nbody)))
+ (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
(cons (not (not uses-cnm))
`#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
,@(if doc-string (list doc-string))
- ,nbody))))
+ ,(if (not (memq nmp uses-cnm))
+ nbody
+ `(let ((,nmp (lambda ()
+ (cl--generic-isnot-nnm-p ,cnm))))
+ ,nbody))))))
(f (error "Unexpected macroexpansion result: %S" f))))))))
@@ -263,7 +266,15 @@ Other than a type, TYPE can also be of the form `(eql
VAL)' in
which case this method will be invoked when the argument is `eql' to VAL.
\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
- (declare (doc-string 3) (indent 2))
+ (declare (doc-string 3) (indent 2)
+ (debug
+ (&define ; this means we are defining something
+ [&or name ("setf" :name setf name)]
+ ;; ^^ This is the methods symbol
+ [ &optional keywordp ] ; this is key :before etc
+ list ; arguments
+ [ &optional stringp ] ; documentation string
+ def-body))) ; part to be debugged
(let ((qualifiers nil))
(while (keywordp args)
(push args qualifiers)
@@ -309,8 +320,13 @@ which case this method will be invoked when the argument
is `eql' to VAL.
(setf (cl--generic-method-table generic)
(cons `(,key ,uses-cnm . ,function) mt)))
;; For aliases, cl--generic-name gives us the actual name.
- (defalias (cl--generic-name generic)
- (cl--generic-make-function generic))))
+ (let ((gfun (cl--generic-make-function generic))
+ ;; Prevent `defalias' from recording this as the definition site of
+ ;; the generic function.
+ current-load-list)
+ (defalias (cl--generic-name generic) gfun))
+ (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
+ current-load-list :test #'equal)))
(defmacro cl--generic-with-memoization (place &rest code)
(declare (indent 1) (debug t))
@@ -327,6 +343,14 @@ which case this method will be invoked when the argument
is `eql' to VAL.
(cl--generic-with-memoization
(gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers)
(let ((lexical-binding t)
+ (tag-exp `(or ,@(mapcar #'cdr
+ ;; Minor optimization: since this tag-exp is
+ ;; only used to lookup the method-cache, it
+ ;; doesn't matter if the default value is some
+ ;; constant or nil.
+ (if (macroexp-const-p (car (last tagcodes)))
+ (butlast tagcodes)
+ tagcodes))))
(extraargs ()))
(dotimes (_ dispatch-arg)
(push (make-symbol "arg") extraargs))
@@ -335,7 +359,7 @@ which case this method will be invoked when the argument is
`eql' to VAL.
(let ((method-cache (make-hash-table :test #'eql)))
(lambda (,@extraargs arg &rest args)
(apply (cl--generic-with-memoization
- (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache)
+ (gethash ,tag-exp method-cache)
(cl--generic-cache-miss
generic ',dispatch-arg dispatches-left
(list ,@(mapcar #'cdr tagcodes))))
@@ -391,7 +415,8 @@ for all those different tags in the method-cache.")
cl--generic-combined-method-memoization)
(cond
((null mets-by-qual) (lambda (&rest args)
- (cl-no-applicable-method generic-name args)))
+ (apply #'cl-no-applicable-method
+ generic-name args)))
(t
(let* ((fun (lambda (&rest args)
;; FIXME: CLOS passes as second arg the "calling method".
@@ -411,11 +436,44 @@ for all those different tags in the method-cache.")
(setq fun (lambda (&rest args)
(dolist (bf before)
(apply bf args))
- (apply next args)
- (dolist (af after)
- (apply af args))))))
+ (prog1
+ (apply next args)
+ (dolist (af after)
+ (apply af args)))))))
(cl--generic-nest fun (alist-get :around mets-by-qual))))))))
+(defconst cl--generic-nnm-sample
+ (cl--generic-build-combined-method nil '(((specializer . :qualifier)))))
+(defconst cl--generic-cnm-sample
+ (funcall (cl--generic-build-combined-method
+ nil `(((specializer . :primary) t . ,#'identity)))))
+
+(defun cl--generic-isnot-nnm-p (cnm)
+ "Return non-nil if CNM is the function that calls `cl-no-next-method'."
+ ;; ¡Big Gross Ugly Hack!
+ ;; `next-method-p' just sucks, we should let it die. But EIEIO did support
+ ;; it, and some packages use it, so we need to support it.
+ (catch 'found
+ (cl-assert (function-equal cnm cl--generic-cnm-sample))
+ (if (byte-code-function-p cnm)
+ (let ((cnm-constants (aref cnm 2))
+ (sample-constants (aref cl--generic-cnm-sample 2)))
+ (dotimes (i (length sample-constants))
+ (when (function-equal (aref sample-constants i)
+ cl--generic-nnm-sample)
+ (throw 'found
+ (not (function-equal (aref cnm-constants i)
+ cl--generic-nnm-sample))))))
+ (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample)))
+ (let ((cnm-env (cadr cnm)))
+ (dolist (vb (cadr cl--generic-cnm-sample))
+ (when (function-equal (cdr vb) cl--generic-nnm-sample)
+ (throw 'found
+ (not (function-equal (cdar cnm-env)
+ cl--generic-nnm-sample))))
+ (setq cnm-env (cdr cnm-env)))))
+ (error "Haven't found no-next-method-sample in cnm-sample")))
+
(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags)
(let ((types (apply #'append (mapcar cl-generic-tag-types-function tags)))
(methods '()))
@@ -440,12 +498,12 @@ for all those different tags in the method-cache.")
(cl-defgeneric cl-no-next-method (generic method &rest args)
"Function called when `cl-call-next-method' finds no next method.")
-(cl-defmethod cl-no-next-method ((generic t) method &rest args)
+(cl-defmethod cl-no-next-method (generic method &rest args)
(signal 'cl-no-next-method `(,generic ,method ,@args)))
(cl-defgeneric cl-no-applicable-method (generic &rest args)
"Function called when a method call finds no applicable method.")
-(cl-defmethod cl-no-applicable-method ((generic t) &rest args)
+(cl-defmethod cl-no-applicable-method (generic &rest args)
(signal 'cl-no-applicable-method `(,generic ,@args)))
(defun cl-call-next-method (&rest _args)
@@ -453,33 +511,71 @@ for all those different tags in the method-cache.")
Can only be used from within the lexical body of a primary or around method."
(error "cl-call-next-method only allowed inside primary and around methods"))
+(defun cl-next-method-p ()
+ "Return non-nil if there is a next method.
+Can only be used from within the lexical body of a primary or around method."
+ (declare (obsolete "make sure there's always a next method, or catch
`cl-no-next-method' instead" "25.1"))
+ (error "cl-next-method-p only allowed inside primary and around methods"))
+
;;; Add support for describe-function
-(add-hook 'help-fns-describe-function-functions 'cl--generic-describe)
+(defun cl--generic-search-method (met-name)
+ (let ((base-re (concat "(\\(?:cl-\\)?defmethod[ \t]+"
+ (regexp-quote (format "%s\\_>" (car met-name))))))
+ (or
+ (re-search-forward
+ (concat base-re "[^&\"\n]*"
+ (mapconcat (lambda (specializer)
+ (regexp-quote
+ (format "%S" (if (consp specializer)
+ (nth 1 specializer)
specializer))))
+ (remq t (cdr met-name))
+ "[ \t\n]*)[^&\"\n]*"))
+ nil t)
+ (re-search-forward base-re nil t))))
+
+
+(with-eval-after-load 'find-func
+ (defvar find-function-regexp-alist)
+ (add-to-list 'find-function-regexp-alist
+ `(cl-defmethod . ,#'cl--generic-search-method)))
+
+(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
(defun cl--generic-describe (function)
- ;; FIXME: Fix up the main "in `<file>'" hyperlink, and add such hyperlinks
- ;; for each method.
(let ((generic (if (symbolp function) (cl--generic function))))
(when generic
+ (require 'help-mode) ;Needed for `help-function-def' button!
(save-excursion
(insert "\n\nThis is a generic function.\n\n")
(insert (propertize "Implementations:\n\n" 'face 'bold))
;; Loop over fanciful generics
- (pcase-dolist (`((,type . ,qualifier) . ,method)
+ (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method)
(cl--generic-method-table generic))
- (insert "`")
- (if (symbolp type)
- ;; FIXME: Add support for cl-structs in help-variable.
- (help-insert-xref-button (symbol-name type)
- 'help-variable type)
- (insert (format "%S" type)))
- (insert (format "' %S %S\n"
- (car qualifier)
- (let ((args (help-function-arglist method)))
- ;; Drop cl--generic-next arg if present.
- (if (memq (car qualifier) '(:after :before))
- args (cdr args)))))
- (insert (or (documentation method) "Undocumented") "\n\n"))))))
+ (let* ((args (help-function-arglist method 'names))
+ (docstring (documentation method))
+ (doconly (if docstring
+ (let ((split (help-split-fundoc docstring nil)))
+ (if split (cdr split) docstring))))
+ (combined-args ()))
+ (if uses-cnm (setq args (cdr args)))
+ (dolist (specializer specializers)
+ (let ((arg (if (eq '&rest (car args))
+ (intern (format "arg%d" (length combined-args)))
+ (pop args))))
+ (push (if (eq specializer t) arg (list arg specializer))
+ combined-args)))
+ (setq combined-args (append (nreverse combined-args) args))
+ ;; FIXME: Add hyperlinks for the types as well.
+ (insert (format "%S %S" qualifier combined-args))
+ (let* ((met-name (cons function specializers))
+ (file (find-lisp-object-file-name met-name 'cl-defmethod)))
+ (when file
+ (insert " in `")
+ (help-insert-xref-button (help-fns-short-filename file)
+ 'help-function-def met-name file
+ 'cl-defmethod)
+ (insert "'.\n")))
+ (insert "\n" (or doconly "Undocumented") "\n\n")))))))
;;; Support for (eql <val>) specializers.
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 0070599..38f15b8 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."
(push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds))
(eval (list 'let ,binds (list 'funcall (list 'quote ,bodyfun))))))))
+(defconst cl--labels-magic (make-symbol "cl--labels-magic"))
+
(defvar cl--labels-convert-cache nil)
(defun cl--labels-convert (f)
@@ -1818,10 +1820,12 @@ a `let' form, except that the list of symbols can be
computed at run-time."
;; being expanded even though we don't receive it.
((eq f (car cl--labels-convert-cache)) (cdr cl--labels-convert-cache))
(t
- (let ((found (assq f macroexpand-all-environment)))
- (if (and found (ignore-errors
- (eq (cadr (cl-caddr found)) 'cl-labels-args)))
- (cadr (cl-caddr (cl-cadddr found)))
+ (let* ((found (assq f macroexpand-all-environment))
+ (replacement (and found
+ (ignore-errors
+ (funcall (cdr found) cl--labels-magic)))))
+ (if (and replacement (eq cl--labels-magic (car replacement)))
+ (nth 1 replacement)
(let ((res `(function ,f)))
(setq cl--labels-convert-cache (cons f res))
res))))))
@@ -1850,17 +1854,18 @@ for (FUNC (lambda ARGLIST BODY)).
`(cl-function (lambda . ,args-and-body))))
binds))
(push (cons (car binding)
- (lambda (&rest cl-labels-args)
- (cl-list* 'funcall var cl-labels-args)))
+ (lambda (&rest args)
+ (if (eq (car args) cl--labels-magic)
+ (list cl--labels-magic var)
+ `(funcall ,var ,@args))))
newenv)))
;; FIXME: Eliminate those functions which aren't referenced.
- `(let ,(nreverse binds)
- ,@(macroexp-unprogn
- (macroexpand-all
- `(progn ,@body)
- ;; Don't override lexical-let's macro-expander.
- (if (assq 'function newenv) newenv
- (cons (cons 'function #'cl--labels-convert) newenv)))))))
+ (macroexp-let* (nreverse binds)
+ (macroexpand-all
+ `(progn ,@body)
+ ;; Don't override lexical-let's macro-expander.
+ (if (assq 'function newenv) newenv
+ (cons (cons 'function #'cl--labels-convert) newenv))))))
;;;###autoload
(defmacro cl-flet* (bindings &rest body)
@@ -1887,8 +1892,10 @@ in closures will only work if `lexical-binding' is in
use.
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
(push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
(push (cons (car binding)
- (lambda (&rest cl-labels-args)
- (cl-list* 'funcall var cl-labels-args)))
+ (lambda (&rest args)
+ (if (eq (car args) cl--labels-magic)
+ (list cl--labels-magic var)
+ (cl-list* 'funcall var args))))
newenv)))
(macroexpand-all `(letrec ,(nreverse binds) ,@body)
;; 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 bfa922b..a82e887 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -34,19 +34,6 @@
(require 'cl-lib)
(require 'pcase)
-(put 'eieio--defalias 'byte-hunk-handler
- #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
-(defun eieio--defalias (name body)
- "Like `defalias', but with less side-effects.
-More specifically, it has no side-effects at all when the new function
-definition is the same (`eq') as the old one."
- (while (and (fboundp name) (symbolp (symbol-function name)))
- ;; Follow aliases, so methods applied to obsolete aliases still work.
- (setq name (symbol-function name)))
- (unless (and (fboundp name)
- (eq (symbol-function name) body))
- (defalias name body)))
-
;;;
;; A few functions that are better in the official EIEIO src, but
;; used from the core.
@@ -75,9 +62,6 @@ default setting for optimization purposes.")
(defvar eieio-optimize-primary-methods-flag t
"Non-nil means to optimize the method dispatch on primary methods.")
-(defvar eieio-initializing-object nil
- "Set to non-nil while initializing an object.")
-
(defvar eieio-backward-compatibility t
"If nil, drop support for some behaviors of older versions of EIEIO.
Currently under control of this var:
@@ -95,29 +79,6 @@ Currently under control of this var:
;; while it is being built itself.
(defvar eieio-default-superclass nil)
-;;;
-;; Class currently in scope.
-;;
-;; When invoking methods, the running method needs to know which class
-;; is currently in scope. Generally this is the class of the method
-;; being called, but 'call-next-method' needs to query this state,
-;; and change it to be then next super class up.
-;;
-;; Thus, the scoped class is a stack that needs to be managed.
-
-(defvar eieio--scoped-class-stack nil
- "A stack of the classes currently in scope during method invocation.")
-
-(defun eieio--scoped-class ()
- "Return the class object currently in scope, or nil."
- (car-safe eieio--scoped-class-stack))
-
-(defmacro eieio--with-scoped-class (class &rest forms)
- "Set CLASS as the currently scoped class while executing FORMS."
- (declare (indent 1))
- `(let ((eieio--scoped-class-stack (cons ,class eieio--scoped-class-stack)))
- ,@forms))
-
(progn
;; Arrange for field access not to bother checking if the access is indeed
;; made to an eieio--class object.
@@ -248,10 +209,8 @@ CLASS is a symbol." ;FIXME: Is it a
vector or a symbol?
(format "#<class %s>" (symbol-name class)))
(define-obsolete-function-alias 'class-name #'eieio-class-name "24.4")
-(defmacro class-constructor (class)
- "Return the symbol representing the constructor of CLASS."
- (declare (debug t))
- `(eieio--class-symbol (eieio--class-v ,class)))
+(defalias 'eieio--class-constructor #'identity
+ "Return the symbol representing the constructor of CLASS.")
(defmacro eieio--class-option-assoc (list option)
"Return from LIST the found OPTION, or nil if it doesn't exist."
@@ -292,7 +251,7 @@ Abstract classes cannot be instantiated."
;; We autoload this because it's used in `make-autoload'.
;;;###autoload
-(defun eieio-defclass-autoload (cname superclasses filename doc)
+(defun eieio-defclass-autoload (cname _superclasses filename doc)
"Create autoload symbols for the EIEIO class CNAME.
SUPERCLASSES are the superclasses that CNAME inherits from.
DOC is the docstring for CNAME.
@@ -301,58 +260,35 @@ SUPERCLASSES as children.
It creates an autoload function for CNAME's constructor."
;; Assume we've already debugged inputs.
+ ;; We used to store the list of superclasses in the `parent' slot (as a list
+ ;; of class names). But now this slot holds a list of class objects, and
+ ;; those parents may not exist yet, so the corresponding class objects may
+ ;; simply not exist yet. So instead we just don't store the list of parents
+ ;; here in eieio-defclass-autoload at all, since it seems that they're just
+ ;; not needed before the class is actually loaded.
(let* ((oldc (when (class-p cname) (eieio--class-v cname)))
(newc (eieio--class-make cname))
)
(if oldc
nil ;; Do nothing if we already have this class.
- (let ((clear-parent nil))
- ;; No parents?
- (when (not superclasses)
- (setq superclasses '(eieio-default-superclass)
- clear-parent t)
- )
-
- ;; Hook our new class into the existing structures so we can
- ;; autoload it later.
- (dolist (SC superclasses)
+ ;; turn this into a usable self-pointing symbol
+ (when eieio-backward-compatibility
+ (set cname cname)
+ (make-obsolete-variable cname (format "use '%s instead" cname) "25.1"))
+ ;; Store the new class vector definition into the symbol. We need to
+ ;; do this first so that we can call defmethod for the accessor.
+ ;; The vector will be updated by the following while loop and will not
+ ;; need to be stored a second time.
+ (setf (eieio--class-v cname) newc)
- ;; TODO - If we create an autoload that is in the map, that
- ;; map needs to be cleared!
-
-
- ;; Save the child in the parent.
- (cl-pushnew cname (if (class-p SC)
- (eieio--class-children (eieio--class-v SC))
- ;; Parent doesn't exist yet.
- (gethash SC eieio-defclass-autoload-map)))
-
- ;; Save parent in child.
- (push (eieio--class-v SC) (eieio--class-parent newc)))
-
- ;; turn this into a usable self-pointing symbol
- (when eieio-backward-compatibility
- (set cname cname)
- (make-obsolete-variable cname (format "use '%s instead" cname)
"25.1"))
-
- ;; Store the new class vector definition into the symbol. We need to
- ;; do this first so that we can call defmethod for the accessor.
- ;; The vector will be updated by the following while loop and will not
- ;; need to be stored a second time.
- (setf (eieio--class-v cname) newc)
-
- ;; Clear the parent
- (if clear-parent (setf (eieio--class-parent newc) nil))
-
- ;; Create an autoload on top of our constructor function.
- (autoload cname filename doc nil nil)
- (autoload (intern (concat (symbol-name cname) "-p")) filename "" nil
nil)
- (autoload (intern (concat (symbol-name cname) "-child-p")) filename ""
nil nil)
- (autoload (intern (concat (symbol-name cname) "-list-p")) filename ""
nil nil)
-
- ))))
+ ;; Create an autoload on top of our constructor function.
+ (autoload cname filename doc nil nil)
+ (autoload (intern (format "%s-p" cname)) filename "" nil nil)
+ (when eieio-backward-compatibility
+ (autoload (intern (format "%s-child-p" cname)) filename "" nil nil)
+ (autoload (intern (format "%s-list-p" cname)) filename "" nil nil)))))
(defsubst eieio-class-un-autoload (cname)
"If class CNAME is in an autoload state, load its file."
@@ -378,8 +314,13 @@ See `defclass' for more information."
(setq eieio-hook nil)
(let* ((pname superclasses)
- (newc (eieio--class-make cname))
(oldc (when (class-p cname) (eieio--class-v cname)))
+ (newc (if (and oldc (not (eieio--class-default-object-cache oldc)))
+ ;; The oldc class is a stub setup by
eieio-defclass-autoload.
+ ;; Reuse it instead of creating a new one, so that existing
+ ;; references are still valid.
+ oldc
+ (eieio--class-make cname)))
(groups nil) ;; list of groups id'd from slots
(clearparent nil))
@@ -1060,27 +1001,26 @@ Fills in the default value in CLASS' in SLOT with
VALUE."
(setq class (eieio--class-object class))
(eieio--check-type eieio--class-p class)
(eieio--check-type symbolp slot)
- (eieio--with-scoped-class class
- (let* ((c (eieio--slot-name-index class nil slot)))
- (if (not c)
- ;; It might be missing because it is a :class allocated slot.
- ;; Let's check that info out.
- (if (setq c (eieio--class-slot-name-index class slot))
- (progn
- ;; Oref that slot.
- (eieio--validate-class-slot-value class c value slot)
- (aset (eieio--class-class-allocation-values class) c
- value))
- (signal 'invalid-slot-name (list (eieio--class-symbol class) slot)))
- (eieio--validate-slot-value class c value slot)
- ;; Set this into the storage for defaults.
- (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots))
- (eieio--class-public-d class))
- value)
- ;; Take the value, and put it into our cache object.
- (eieio-oset (eieio--class-default-object-cache class)
- slot value)
- ))))
+ (let* ((c (eieio--slot-name-index class nil slot)))
+ (if (not c)
+ ;; It might be missing because it is a :class allocated slot.
+ ;; Let's check that info out.
+ (if (setq c (eieio--class-slot-name-index class slot))
+ (progn
+ ;; Oref that slot.
+ (eieio--validate-class-slot-value class c value slot)
+ (aset (eieio--class-class-allocation-values class) c
+ value))
+ (signal 'invalid-slot-name (list (eieio--class-symbol class) slot)))
+ (eieio--validate-slot-value class c value slot)
+ ;; Set this into the storage for defaults.
+ (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots))
+ (eieio--class-public-d class))
+ value)
+ ;; Take the value, and put it into our cache object.
+ (eieio-oset (eieio--class-default-object-cache class)
+ slot value)
+ )))
;;; EIEIO internal search functions
@@ -1111,27 +1051,7 @@ reverse-lookup that name, and recurse with the
associated slot value."
(let* ((fsym (gethash slot (eieio--class-symbol-hashtable class)))
(fsi (car fsym)))
(if (integerp fsi)
- (cond
- ((not (cdr fsym))
- (+ (eval-when-compile eieio--object-num-slots) fsi))
- ((and (eq (cdr fsym) 'protected)
- (eieio--scoped-class)
- (or (child-of-class-p class (eieio--scoped-class))
- (and (eieio-object-p obj)
- ;; AFAICT, for all callers, if `obj' is not a class,
- ;; then its class is `class'.
- ;;(child-of-class-p class (eieio--object-class-object
obj))
- (progn
- (cl-assert (eq class (eieio--object-class-object
obj)))
- t))))
- (+ (eval-when-compile eieio--object-num-slots) fsi))
- ((and (eq (cdr fsym) 'private)
- (or (and (eieio--scoped-class)
- (eieio--slot-originating-class-p
- (eieio--scoped-class) slot))
- eieio-initializing-object))
- (+ (eval-when-compile eieio--object-num-slots) fsi))
- (t nil))
+ (+ (eval-when-compile eieio--object-num-slots) fsi)
(let ((fn (eieio--initarg-to-attribute class slot)))
(if fn (eieio--slot-name-index class obj fn) nil)))))
@@ -1159,14 +1079,12 @@ reverse-lookup that name, and recurse with the
associated slot value."
If SET-ALL is non-nil, then when a default is nil, that value is
reset. If SET-ALL is nil, the slots are only reset if the default is
not nil."
- (eieio--with-scoped-class (eieio--object-class-object obj)
- (let ((eieio-initializing-object t)
- (pub (eieio--class-public-a (eieio--object-class-object obj))))
- (while pub
- (let ((df (eieio-oref-default obj (car pub))))
- (if (or df set-all)
- (eieio-oset obj (car pub) df)))
- (setq pub (cdr pub))))))
+ (let ((pub (eieio--class-public-a (eieio--object-class-object obj))))
+ (while pub
+ (let ((df (eieio-oref-default obj (car pub))))
+ (if (or df set-all)
+ (eieio-oset obj (car pub) df)))
+ (setq pub (cdr pub)))))
(defun eieio--initarg-to-attribute (class initarg)
"For CLASS, convert INITARG to the actual attribute name.
@@ -1284,6 +1202,8 @@ The order, in which the parents are returned depends on
the
method invocation orders of the involved classes."
(if (or (null class) (eq class eieio-default-superclass))
nil
+ (unless (eieio--class-default-object-cache class)
+ (eieio-class-un-autoload (eieio--class-symbol class)))
(cl-case (eieio--class-method-invocation-order class)
(:depth-first
(eieio--class-precedence-dfs class))
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el
index d0eaaf2..8ab74ae 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."
(if (not (widget-get widget :value))
(widget-put widget
:value (cond ((widget-get widget :objecttype)
- (funcall (class-constructor
+ (funcall (eieio--class-constructor
(widget-get widget :objecttype))
"Custom-new"))
((widget-get widget :objectcreatefcn)
diff --git a/lisp/emacs-lisp/eieio-datadebug.el
b/lisp/emacs-lisp/eieio-datadebug.el
index 43d9a03..ab8d41e 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."
"Name: ")
(let* ((cl (eieio-object-class obj))
(cv (eieio--class-v cl)))
- (data-debug-insert-thing (class-constructor cl)
+ (data-debug-insert-thing (eieio--class-constructor cl)
prefix
"Class: ")
;; Loop over all the public slots
diff --git a/lisp/emacs-lisp/eieio-generic.el b/lisp/emacs-lisp/eieio-generic.el
index 0e90074..27a5849 100644
--- a/lisp/emacs-lisp/eieio-generic.el
+++ b/lisp/emacs-lisp/eieio-generic.el
@@ -33,6 +33,19 @@
(require 'eieio-core)
(declare-function child-of-class-p "eieio")
+(put 'eieio--defalias 'byte-hunk-handler
+ #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
+(defun eieio--defalias (name body)
+ "Like `defalias', but with less side-effects.
+More specifically, it has no side-effects at all when the new function
+definition is the same (`eq') as the old one."
+ (while (and (fboundp name) (symbolp (symbol-function name)))
+ ;; Follow aliases, so methods applied to obsolete aliases still work.
+ (setq name (symbol-function name)))
+ (unless (and (fboundp name)
+ (eq (symbol-function name) body))
+ (defalias name body)))
+
(defconst eieio--method-static 0 "Index into :static tag on a method.")
(defconst eieio--method-before 1 "Index into :before tag on a method.")
(defconst eieio--method-primary 2 "Index into :primary tag on a method.")
@@ -101,7 +114,7 @@ Methods with only primary implementations are executed in
an optimized way."
;; Make sure the method tables are installed.
(eieio--mt-install method)
;; Construct the actual body of this function.
- (put method 'function-documentation doc-string)
+ (if doc-string (put method 'function-documentation doc-string))
(eieio--defgeneric-form method))
((generic-p method) (symbol-function method)) ;Leave it as-is.
(t (error "You cannot create a generic/method over an existing symbol: %s"
@@ -161,8 +174,7 @@ IMPL is the symbol holding the method implementation."
(eieio--generic-call-key eieio--method-primary)
(eieio--generic-call-arglst local-args)
)
- (eieio--with-scoped-class (eieio--class-v class)
- (apply impl local-args)))))))
+ (apply impl local-args))))))
(defun eieio-unbind-method-implementations (method)
"Make the generic method METHOD have no implementations.
@@ -177,20 +189,18 @@ but remove reference to all implementations of METHOD."
;;
;; If this method, after this setup, only has primary methods, then
;; we can setup the generic that way.
- (let ((doc-string (documentation method 'raw)))
- (put method 'function-documentation doc-string)
- ;; Use `defalias' so as to interact properly with nadvice.el.
- (defalias method
- (if (eieio--generic-primary-only-p method)
- ;; If there is only one primary method, then we can go one more
- ;; optimization step.
- (if (eieio--generic-primary-only-one-p method)
- (let* ((M (get method 'eieio-method-tree))
- (entry (car (aref M eieio--method-primary))))
- (eieio--defgeneric-form-primary-only-one
- method (car entry) (cdr entry)))
- (eieio--defgeneric-form-primary-only method))
- (eieio--defgeneric-form method))))))
+ ;; Use `defalias' so as to interact properly with nadvice.el.
+ (defalias method
+ (if (eieio--generic-primary-only-p method)
+ ;; If there is only one primary method, then we can go one more
+ ;; optimization step.
+ (if (eieio--generic-primary-only-one-p method)
+ (let* ((M (get method 'eieio-method-tree))
+ (entry (car (aref M eieio--method-primary))))
+ (eieio--defgeneric-form-primary-only-one
+ method (car entry) (cdr entry)))
+ (eieio--defgeneric-form-primary-only method))
+ (eieio--defgeneric-form method)))))
(defun eieio--defmethod (method kind argclass code)
"Work part of the `defmethod' macro defining METHOD with ARGS."
@@ -276,11 +286,9 @@ This should only be called from a generic function."
)
;; Now create a list in reverse order of all the calls we have
;; make in order to successfully do this right. Rules:
- ;; 1) Only call generics if scoped-class is not defined
- ;; This prevents multiple calls in the case of recursion
- ;; 2) Only call static if this is a static method.
- ;; 3) Only call specifics if the definition allows for them.
- ;; 4) Call in order based on :before, :primary, and :after
+ ;; 1) Only call static if this is a static method.
+ ;; 2) Only call specifics if the definition allows for them.
+ ;; 3) Call in order based on :before, :primary, and :after
(when (eieio-object-p firstarg)
;; Non-static calls do all this stuff.
@@ -346,22 +354,21 @@ This should only be called from a generic function."
(let ((rval nil) (lastval nil) (found nil))
(while lambdas
(if (car lambdas)
- (eieio--with-scoped-class (cdr (car lambdas))
- (let* ((eieio--generic-call-key (car keys))
- (has-return-val
- (or (= eieio--generic-call-key eieio--method-primary)
- (= eieio--generic-call-key eieio--method-static)))
- (eieio--generic-call-next-method-list
- ;; Use the cdr, as the first element is the fcn
- ;; we are calling right now.
- (when has-return-val (cdr primarymethodlist)))
- )
- (setq found t)
- ;;(setq rval (apply (car (car lambdas)) newargs))
- (setq lastval (apply (car (car lambdas)) newargs))
- (when has-return-val
- (setq rval lastval))
- )))
+ (let* ((eieio--generic-call-key (car keys))
+ (has-return-val
+ (or (= eieio--generic-call-key eieio--method-primary)
+ (= eieio--generic-call-key eieio--method-static)))
+ (eieio--generic-call-next-method-list
+ ;; Use the cdr, as the first element is the fcn
+ ;; we are calling right now.
+ (when has-return-val (cdr primarymethodlist)))
+ )
+ (setq found t)
+ ;;(setq rval (apply (car (car lambdas)) newargs))
+ (setq lastval (apply (car (car lambdas)) newargs))
+ (when has-return-val
+ (setq rval lastval))
+ ))
(setq lambdas (cdr lambdas)
keys (cdr keys)))
(if (not found)
@@ -414,33 +421,32 @@ for this common case to improve performance."
;; Now loop through all occurrences forms which we must execute
;; (which are happily sorted now) and execute them all!
- (eieio--with-scoped-class (cdr lambdas)
- (let* ((rval nil) (lastval nil)
- (eieio--generic-call-key eieio--method-primary)
- ;; Use the cdr, as the first element is the fcn
- ;; we are calling right now.
- (eieio--generic-call-next-method-list (cdr primarymethodlist))
- )
+ (let* ((rval nil) (lastval nil)
+ (eieio--generic-call-key eieio--method-primary)
+ ;; Use the cdr, as the first element is the fcn
+ ;; we are calling right now.
+ (eieio--generic-call-next-method-list (cdr primarymethodlist))
+ )
- (if (or (not lambdas) (not (car lambdas)))
+ (if (or (not lambdas) (not (car lambdas)))
- ;; No methods found for this impl...
- (if (eieio-object-p (car args))
- (setq rval (apply #'no-applicable-method
- (car args) method args))
- (signal
- 'no-method-definition
- (list method args)))
+ ;; No methods found for this impl...
+ (if (eieio-object-p (car args))
+ (setq rval (apply #'no-applicable-method
+ (car args) method args))
+ (signal
+ 'no-method-definition
+ (list method args)))
- ;; Do the regular implementation here.
+ ;; Do the regular implementation here.
- (run-hook-with-args 'eieio-pre-method-execution-functions
- lambdas)
+ (run-hook-with-args 'eieio-pre-method-execution-functions
+ lambdas)
- (setq lastval (apply (car lambdas) newargs))
- (setq rval lastval))
+ (setq lastval (apply (car lambdas) newargs))
+ (setq rval lastval))
- rval))))
+ rval)))
(defun eieio--mt-method-list (method key class)
"Return an alist list of methods lambdas.
@@ -627,7 +633,7 @@ is memorized for faster future use."
;;; CLOS methods and generics
;;
-(defmacro defgeneric (method _args &optional doc-string)
+(defmacro defgeneric (method args &optional doc-string)
"Create a generic function METHOD.
DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body
@@ -637,7 +643,9 @@ currently ignored. You can use `defgeneric' to apply
specialized
top level documentation to a method."
(declare (doc-string 3))
`(eieio--defalias ',method
- (eieio--defgeneric-init-form ',method ,doc-string)))
+ (eieio--defgeneric-init-form
+ ',method
+ ,(if doc-string (help-add-fundoc-usage doc-string
args)))))
(defmacro defmethod (method &rest args)
"Create a new METHOD through `defgeneric' with ARGS.
@@ -684,9 +692,7 @@ Summary:
(code `(lambda ,fargs ,@(cdr args))))
`(progn
;; Make sure there is a generic and the byte-compiler sees it.
- (defgeneric ,method ,args
- ,(or (documentation code)
- (format "Generically created method `%s'." method)))
+ (defgeneric ,method ,args)
(eieio--defmethod ',method ',key ',class #',code))))
@@ -710,8 +716,6 @@ If REPLACEMENT-ARGS is non-nil, then use them instead of
arguments passed in at the top level.
Use `next-method-p' to find out if there is a next method to call."
- (if (not (eieio--scoped-class))
- (error "`call-next-method' not called within a class specific method"))
(if (and (/= eieio--generic-call-key eieio--method-primary)
(/= eieio--generic-call-key eieio--method-static))
(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."
(eieio--generic-call-arglst newargs)
(fcn (car next))
)
- (eieio--with-scoped-class (cdr next)
- (apply fcn newargs)) ))))
+ (apply fcn newargs)) )))
(defgeneric no-applicable-method (object method &rest args)
"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 419a78b..c5597b8 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -36,12 +36,12 @@
;; Retrieved from:
;; http://192.220.96.201/dylan/linearization-oopsla96.html
-;; There is funny stuff going on with typep and deftype. This
-;; is the only way I seem to be able to make this stuff load properly.
-
;; @TODO - fix :initform to be a form, not a quoted value
;; @TODO - Prefix non-clos functions with `eieio-'.
+;; TODO: better integrate CL's defstructs and classes. E.g. make it possible
+;; to create a new class that inherits from a struct.
+
;;; Code:
(defvar eieio-version "1.4"
@@ -76,8 +76,6 @@ being the slots residing in that class definition. Supported
tags are:
- A string documenting use of this slot.
The following are extensions on CLOS:
- :protection - Specify protection for this slot.
- Defaults to `:public'. Also use `:protected', or `:private'.
:custom - When customizing an object, the custom :type. Public only.
:label - A text string label used for a slot when customizing.
:group - Name of a customization group this slot belongs in.
@@ -278,12 +276,6 @@ and reference them using the function `class-option'."
`(defun ,name (&rest slots)
,(format "Create a new object with name NAME of class type %S."
name)
- (if (and slots
- (let ((x (car slots)))
- (or (stringp x) (null x))))
- (funcall (if eieio-backward-compatibility #'ignore #'message)
- "Obsolete name %S passed to %S constructor"
- (pop slots) ',name))
(apply #'eieio-constructor ',name slots))))))
@@ -309,7 +301,7 @@ In EIEIO, the class' constructor requires a name for use
when printing.
`make-instance' in CLOS doesn't use names the way Emacs does, so the
class is used as the name slot instead when INITARGS doesn't start with
a string."
- (apply (class-constructor class) initargs))
+ (apply (eieio--class-constructor class) initargs))
;;; Get/Set slots in an object.
@@ -658,7 +650,14 @@ SLOTS are the initialization slots used by
`shared-initialize'.
This static method is called when an object is constructed.
It allocates the vector used to represent an EIEIO object, and then
calls `shared-initialize' on that object."
- (let* ((new-object (copy-sequence (eieio--class-default-object-cache
(eieio--class-v class)))))
+ (let* ((new-object (copy-sequence (eieio--class-default-object-cache
+ (eieio--class-v class)))))
+ (if (and slots
+ (let ((x (car slots)))
+ (or (stringp x) (null x))))
+ (funcall (if eieio-backward-compatibility #'ignore #'message)
+ "Obsolete name %S passed to %S constructor"
+ (pop slots) class))
;; Call the initialize method on the new object with the slots
;; that were passed down to us.
(initialize-instance new-object slots)
@@ -672,14 +671,13 @@ Called from the constructor routine.")
(defmethod shared-initialize ((obj eieio-default-superclass) slots)
"Set slots of OBJ with SLOTS which is a list of name/value pairs.
Called from the constructor routine."
- (eieio--with-scoped-class (eieio--object-class-object obj)
- (while slots
- (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj)
- (car slots))))
- (if (not rn)
- (slot-missing obj (car slots) 'oset (car (cdr slots)))
- (eieio-oset obj rn (car (cdr slots)))))
- (setq slots (cdr (cdr slots))))))
+ (while slots
+ (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj)
+ (car slots))))
+ (if (not rn)
+ (slot-missing obj (car slots) 'oset (car (cdr slots)))
+ (eieio-oset obj rn (car (cdr slots)))))
+ (setq slots (cdr (cdr slots)))))
(defgeneric initialize-instance (this &optional slots)
"Construct the new object THIS based on SLOTS.")
@@ -823,7 +821,7 @@ this object."
;; Each slot's slot is writen using its :writer.
(princ (make-string (* eieio-print-depth 2) ? ))
(princ "(")
- (princ (symbol-name (class-constructor (eieio-object-class this))))
+ (princ (symbol-name (eieio--class-constructor (eieio-object-class this))))
(princ " ")
(prin1 (eieio-object-name-string this))
(princ "\n")
@@ -926,7 +924,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is
passed to
;;; Start of automatically extracted autoloads.
-;;;### (autoloads nil "eieio-custom" "eieio-custom.el"
"9a908efef1720439feb6323c1dd01770")
+;;;### (autoloads nil "eieio-custom" "eieio-custom.el"
"6baa78cfc590cc0422e12b7eb55abf24")
;;; Generated autoloads from eieio-custom.el
(autoload 'customize-object "eieio-custom" "\
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index cc7b06c..6c9c798 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -1,4 +1,4 @@
-;;; find-func.el --- find the definition of the Emacs Lisp function near point
+;;; find-func.el --- find the definition of the Emacs Lisp function near point
-*- lexical-binding:t -*-
;; Copyright (C) 1997, 1999, 2001-2015 Free Software Foundation, Inc.
@@ -59,7 +59,7 @@
(concat
"^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\
ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\
-foo\\|[^icfgv]\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
+foo\\|\\(?:[^icfv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
menu-bar-make-toggle\\)"
find-function-space-re
"\\('\\|\(quote \\)?%s\\(\\s-\\|$\\|\(\\|\)\\)")
@@ -106,7 +106,10 @@ Please send improvements and fixes to the maintainer."
(defface . find-face-regexp))
"Alist mapping definition types into regexp variables.
Each regexp variable's value should actually be a format string
-to be used to substitute the desired symbol name into the regexp.")
+to be used to substitute the desired symbol name into the regexp.
+Instead of regexp variable, types can be mapped to functions as well,
+in which case the function is called with one argument (the object
+we're looking for) and it should search for it.")
(put 'find-function-regexp-alist 'risky-local-variable t)
(defcustom find-function-source-path nil
@@ -282,30 +285,33 @@ The search is done in the source for library LIBRARY."
(let* ((filename (find-library-name library))
(regexp-symbol (cdr (assq type find-function-regexp-alist))))
(with-current-buffer (find-file-noselect filename)
- (let ((regexp (format (symbol-value regexp-symbol)
- ;; Entry for ` (backquote) macro in loaddefs.el,
- ;; (defalias (quote \`)..., has a \ but
- ;; (symbol-name symbol) doesn't. Add an
- ;; optional \ to catch this.
- (concat "\\\\?"
- (regexp-quote (symbol-name symbol)))))
+ (let ((regexp (if (functionp regexp-symbol) regexp-symbol
+ (format (symbol-value regexp-symbol)
+ ;; Entry for ` (backquote) macro in
loaddefs.el,
+ ;; (defalias (quote \`)..., has a \ but
+ ;; (symbol-name symbol) doesn't. Add an
+ ;; optional \ to catch this.
+ (concat "\\\\?"
+ (regexp-quote (symbol-name symbol))))))
(case-fold-search))
(with-syntax-table emacs-lisp-mode-syntax-table
(goto-char (point-min))
- (if (or (re-search-forward regexp nil t)
- ;; `regexp' matches definitions using known forms like
- ;; `defun', or `defvar'. But some functions/variables
- ;; are defined using special macros (or functions), so
- ;; if `regexp' can't find the definition, we look for
- ;; something of the form "(SOMETHING <symbol> ...)".
- ;; This fails to distinguish function definitions from
- ;; variable declarations (or even uses thereof), but is
- ;; a good pragmatic fallback.
- (re-search-forward
- (concat "^([^ ]+" find-function-space-re "['(]?"
- (regexp-quote (symbol-name symbol))
- "\\_>")
- nil t))
+ (if (if (functionp regexp)
+ (funcall regexp symbol)
+ (or (re-search-forward regexp nil t)
+ ;; `regexp' matches definitions using known forms like
+ ;; `defun', or `defvar'. But some functions/variables
+ ;; are defined using special macros (or functions), so
+ ;; if `regexp' can't find the definition, we look for
+ ;; something of the form "(SOMETHING <symbol> ...)".
+ ;; This fails to distinguish function definitions from
+ ;; variable declarations (or even uses thereof), but is
+ ;; a good pragmatic fallback.
+ (re-search-forward
+ (concat "^([^ ]+" find-function-space-re "['(]?"
+ (regexp-quote (symbol-name symbol))
+ "\\_>")
+ nil t)))
(progn
(beginning-of-line)
(cons (current-buffer) (point)))
@@ -324,18 +330,19 @@ signal an error.
If VERBOSE is non-nil, and FUNCTION is an alias, display a
message about the whole chain of aliases."
- (let ((def (symbol-function (find-function-advised-original function)))
+ (let ((def (if (symbolp function)
+ (symbol-function (find-function-advised-original function))))
aliases)
;; FIXME for completeness, it might be nice to print something like:
;; foo (which is advised), which is an alias for bar (which is advised).
- (while (symbolp def)
+ (while (and def (symbolp def))
(or (eq def function)
(not verbose)
- (if aliases
- (setq aliases (concat aliases
+ (setq aliases (if aliases
+ (concat aliases
(format ", which is an alias for `%s'"
- (symbol-name def))))
- (setq aliases (format "`%s' is an alias for `%s'"
+ (symbol-name def)))
+ (format "`%s' is an alias for `%s'"
function (symbol-name def)))))
(setq function (symbol-function (find-function-advised-original
function))
def (symbol-function (find-function-advised-original function))))
@@ -408,7 +415,6 @@ See also `find-function-after-hook'.
Set mark before moving, if the buffer already existed."
(let* ((orig-point (point))
- (orig-buf (window-buffer))
(orig-buffers (buffer-list))
(buffer-point (save-excursion
(find-definition-noselect symbol type)))
diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el
index f2bcdad..e0945d4 100644
--- a/lisp/emacs-lisp/package-x.el
+++ b/lisp/emacs-lisp/package-x.el
@@ -207,6 +207,10 @@ if it exists."
(pkg-version (package-version-join split-version))
(pkg-buffer (current-buffer)))
+ ;; `package-upload-file' will error if given a directory,
+ ;; but we check it here as well just in case.
+ (when (eq 'dir file-type)
+ (user-error "Can't upload directory, tar it instead"))
;; Get archive-contents from ARCHIVE-URL if it's non-nil, or
;; from `package-archive-upload-base' otherwise.
(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 5336271..4be3b58 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
lower priorities, the user has to select those manually.
Archives not in this list have the priority 0."
- :type 'integer
+ :type '(alist :key-type (string :tag "Archive name")
+ :value-type (integer :tag "Priority (default is 0)"))
:risky t
:group 'package
:version "25.1")
@@ -413,6 +414,7 @@ Slots:
(pcase (package-desc-kind pkg-desc)
(`single ".el")
(`tar ".tar")
+ (`dir "")
(kind (error "Unknown package kind: %s" kind))))
(defun package-desc--keywords (pkg-desc)
@@ -800,6 +802,20 @@ untar into a directory named DIR; otherwise, signal an
error."
(dirname (package-desc-full-name pkg-desc))
(pkg-dir (expand-file-name dirname package-user-dir)))
(pcase (package-desc-kind pkg-desc)
+ (`dir
+ (make-directory pkg-dir t)
+ (let ((file-list
+ (directory-files
+ default-directory 'full "\\`[^.].*\\.el\\'" 'nosort)))
+ (dolist (source-file file-list)
+ (let ((target-el-file
+ (expand-file-name (file-name-nondirectory source-file)
pkg-dir)))
+ (copy-file source-file target-el-file t)))
+ ;; Now that the files have been installed, this package is
+ ;; indistinguishable from a `tar' or a `single'. Let's make
+ ;; things simple by ensuring we're one of them.
+ (setf (package-desc-kind pkg-desc)
+ (if (> (length file-list) 1) 'tar 'single))))
(`tar
(make-directory package-user-dir t)
;; FIXME: should we delete PKG-DIR if it exists?
@@ -925,6 +941,9 @@ GnuPG keyring is located under \"gnupg\" in
`package-user-dir'."
(defun package-install-from-archive (pkg-desc)
"Download and install a tar package."
+ ;; This won't happen, unless the archive is doing something wrong.
+ (when (eq (package-desc-kind pkg-desc) 'dir)
+ (error "Can't install directory package from archive"))
(let* ((location (package-archive-base pkg-desc))
(file (concat (package-desc-full-name pkg-desc)
(package-desc-suffix pkg-desc)))
@@ -1277,30 +1296,69 @@ The return result is a `package-desc'."
(unless tar-desc
(error "No package descriptor file found"))
(with-current-buffer (tar--extract tar-desc)
- (goto-char (point-min))
(unwind-protect
- (let* ((pkg-def-parsed (read (current-buffer)))
- (pkg-desc
- (if (not (eq (car pkg-def-parsed) 'define-package))
- (error "Can't find define-package in %s"
- (tar-header-name tar-desc))
- (apply #'package-desc-from-define
- (append (cdr pkg-def-parsed))))))
- (setf (package-desc-kind pkg-desc) 'tar)
- pkg-desc)
+ (package--read-pkg-desc 'tar)
(kill-buffer (current-buffer))))))
+(defun package-dir-info ()
+ "Find package information for a directory.
+The return result is a `package-desc'."
+ (cl-assert (derived-mode-p 'dired-mode))
+ (let* ((desc-file (package--description-file default-directory)))
+ (if (file-readable-p desc-file)
+ (with-temp-buffer
+ (insert-file-contents desc-file)
+ (package--read-pkg-desc 'dir))
+ (let ((files (directory-files default-directory t "\\.el\\'" t))
+ info)
+ (while files
+ (with-temp-buffer
+ (insert-file-contents (pop files))
+ (if (setq info (ignore-errors (package-buffer-info)))
+ (setq files nil)
+ (setf (package-desc-kind info) 'dir))))))))
+
+(defun package--read-pkg-desc (kind)
+ "Read a `define-package' form in current buffer.
+Return the pkg-desc, with desc-kind set to KIND."
+ (goto-char (point-min))
+ (unwind-protect
+ (let* ((pkg-def-parsed (read (current-buffer)))
+ (pkg-desc
+ (if (not (eq (car pkg-def-parsed) 'define-package))
+ (error "Can't find define-package in %s"
+ (tar-header-name tar-desc))
+ (apply #'package-desc-from-define
+ (append (cdr pkg-def-parsed))))))
+ (setf (package-desc-kind pkg-desc) kind)
+ pkg-desc)))
+
;;;###autoload
(defun package-install-from-buffer ()
"Install a package from the current buffer.
-The current buffer is assumed to be a single .el or .tar file that follows the
-packaging guidelines; see info node `(elisp)Packaging'.
+The current buffer is assumed to be a single .el or .tar file or
+a directory. These must follow the packaging guidelines (see
+info node `(elisp)Packaging').
+
+Specially, if current buffer is a directory, the -pkg.el
+description file is not mandatory, in which case the information
+is derived from the main .el file in the directory.
+
Downloads and installs required packages as needed."
(interactive)
- (let ((pkg-desc (if (derived-mode-p 'tar-mode)
- (package-tar-file-info)
- (package-buffer-info))))
+ (let ((pkg-desc
+ (cond
+ ((derived-mode-p 'dired-mode)
+ ;; This is the only way a package-desc object with a `dir'
+ ;; desc-kind can be created. Such packages can't be
+ ;; uploaded or installed from archives, they can only be
+ ;; installed from local buffers or directories.
+ (package-dir-info))
+ ((derived-mode-p 'tar-mode)
+ (package-tar-file-info))
+ (t
+ (package-buffer-info)))))
;; Download and install the dependencies.
(let* ((requires (package-desc-reqs pkg-desc))
(transaction (package-compute-transaction nil requires)))
@@ -1315,8 +1373,12 @@ Downloads and installs required packages as needed."
The file can either be a tar file or an Emacs Lisp file."
(interactive "fPackage file name: ")
(with-temp-buffer
- (insert-file-contents-literally file)
- (when (string-match "\\.tar\\'" file) (tar-mode))
+ (if (file-directory-p file)
+ (progn
+ (setq default-directory file)
+ (dired-mode))
+ (insert-file-contents-literally file)
+ (when (string-match "\\.tar\\'" file) (tar-mode)))
(package-install-from-buffer)))
(defun package-delete (pkg-desc)
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index f6740c7..b28153b 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.
If START or END is negative, it counts from the end."
(cond ((or (stringp seq) (vectorp seq)) (substring seq start end))
((listp seq)
- (let (len)
+ (let (len (errtext (format "Bad bounding indices: %s, %s" start end)))
(and end (< end 0) (setq end (+ end (setq len (seq-length seq)))))
(if (< start 0) (setq start (+ start (or len (setq len (seq-length
seq))))))
- (if (> start 0) (setq seq (nthcdr start seq)))
+ (when (> start 0)
+ (setq seq (nthcdr (1- start) seq))
+ (or seq (error "%s" errtext))
+ (setq seq (cdr seq)))
(if end
(let ((res nil))
- (while (>= (setq end (1- end)) start)
+ (while (and (>= (setq end (1- end)) start) seq)
(push (pop seq) res))
+ (or (= (1+ end) start) (error "%s" errtext))
(nreverse res))
(seq-copy seq))))
(t (error "Unsupported sequence: %s" seq))))
diff --git a/lisp/files.el b/lisp/files.el
index f8318d8..e9632ed 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -1489,8 +1489,9 @@ expand wildcards (if any) and visit multiple files."
(if (listp value)
(progn
(setq value (nreverse value))
- (cons (switch-to-buffer-other-window (car value))
- (mapcar 'switch-to-buffer (cdr value))))
+ (switch-to-buffer-other-window (car value))
+ (mapc 'switch-to-buffer (cdr value))
+ value)
(switch-to-buffer-other-window value))))
(defun find-file-other-frame (filename &optional wildcards)
@@ -1512,8 +1513,9 @@ expand wildcards (if any) and visit multiple files."
(if (listp value)
(progn
(setq value (nreverse value))
- (cons (switch-to-buffer-other-frame (car value))
- (mapcar 'switch-to-buffer (cdr value))))
+ (switch-to-buffer-other-frame (car value))
+ (mapc 'switch-to-buffer (cdr value))
+ value)
(switch-to-buffer-other-frame value))))
(defun find-file-existing (filename)
@@ -3600,7 +3602,9 @@ Returns the new list."
"Collect entries from CLASS-VARIABLES into VARIABLES.
ROOT is the root directory of the project.
Return the new variables list."
- (let* ((file-name (buffer-file-name))
+ (let* ((file-name (or (buffer-file-name)
+ ;; Handle non-file buffers, too.
+ (expand-file-name default-directory)))
(sub-file-name (if file-name
;; FIXME: Why not use file-relative-name?
(substring file-name (length root)))))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 10c040a..c0d6393 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -183,8 +183,7 @@ OBJECT should be a symbol associated with a function,
variable, or face;
alternatively, it can be a function definition.
If TYPE is `defvar', search for a variable definition.
If TYPE is `defface', search for a face definition.
-If TYPE is the value returned by `symbol-function' for a function symbol,
- search for a function definition.
+If TYPE is not a symbol, search for a function definition.
The return value is the absolute name of a readable file where OBJECT is
defined. If several such files exist, preference is given to a file
@@ -194,9 +193,10 @@ suitable file is found, return nil."
(let* ((autoloaded (autoloadp type))
(file-name (or (and autoloaded (nth 1 type))
(symbol-file
- object (if (memq type (list 'defvar 'defface))
- type
- 'defun)))))
+ ;; FIXME: Why do we have this weird "If TYPE is the
+ ;; value returned by `symbol-function' for a function
+ ;; symbol" exception?
+ object (or (if (symbolp type) type) 'defun)))))
(cond
(autoloaded
;; An autoloaded function: Locate the file since `symbol-function'
@@ -452,6 +452,18 @@ FILE is the file where FUNCTION was probably defined."
(t "."))
"\n")))))
+(defun help-fns-short-filename (filename)
+ (let* ((abbrev (abbreviate-file-name filename))
+ (short abbrev))
+ (dolist (dir load-path)
+ (let ((rel (file-relative-name filename dir)))
+ (if (< (length rel) (length short))
+ (setq short rel)))
+ (let ((rel (file-relative-name abbrev dir)))
+ (if (< (length rel) (length short))
+ (setq short rel))))
+ short))
+
;;;###autoload
(defun describe-function-1 (function)
(let* ((advised (and (symbolp function)
@@ -543,7 +555,7 @@ FILE is the file where FUNCTION was probably defined."
;; but that's completely wrong when the user used load-file.
(princ (if (eq file-name 'C-source)
"C source code"
- (file-name-nondirectory file-name)))
+ (help-fns-short-filename file-name)))
(princ "'")
;; Make a hyperlink to the library.
(with-current-buffer standard-output
@@ -564,7 +576,7 @@ FILE is the file where FUNCTION was probably defined."
help-enable-auto-load
(string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]"
doc-raw)
- (load (cadr real-def) t))
+ (autoload-do-load real-def))
(substitute-command-keys doc-raw))))
(help-fns--key-bindings function)
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index dd20307..c62ddc3 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -191,7 +191,7 @@ The format is (FUNCTION ARGS...).")
(define-button-type 'help-function-def
:supertype 'help-xref
- 'help-function (lambda (fun file)
+ 'help-function (lambda (fun file &optional type)
(require 'find-func)
(when (eq file 'C-source)
(setq file
@@ -199,7 +199,7 @@ The format is (FUNCTION ARGS...).")
;; Don't use find-function-noselect because it follows
;; aliases (which fails for built-in functions).
(let ((location
- (find-function-search-for-symbol fun nil file)))
+ (find-function-search-for-symbol fun type file)))
(pop-to-buffer (car location))
(if (cdr location)
(goto-char (cdr location))
diff --git a/lisp/misearch.el b/lisp/misearch.el
index 6daae24..dcc8195 100644
--- a/lisp/misearch.el
+++ b/lisp/misearch.el
@@ -377,6 +377,25 @@ whose file names match the specified wildcard."
(goto-char (if isearch-forward (point-min) (point-max)))
(isearch-forward-regexp nil t)))
+(defun multi-isearch-unload-function ()
+ "Remove autoloaded variables from `unload-function-defs-list'.
+Also prevent the feature from being reloaded via `isearch-mode-hook'."
+ (remove-hook 'isearch-mode-hook 'multi-isearch-setup)
+ (let ((defs (list (car unload-function-defs-list)))
+ (auto '(multi-isearch-next-buffer-function
+ multi-isearch-next-buffer-current-function
+ multi-isearch-current-buffer
+ multi-isearch-buffer-list multi-isearch-file-list)))
+ (dolist (def (cdr unload-function-defs-list))
+ (unless (and (symbolp def)
+ (memq def auto))
+ (push def defs)))
+ (setq unload-function-defs-list (nreverse defs))
+ ;; .
+ nil))
+
+(defalias 'misearch-unload-function 'multi-isearch-unload-function)
+
(provide 'multi-isearch)
(provide 'misearch)
diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el
index b9d45b3..040a50e 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."
;;;###autoload
(defun enriched-encode (from to orig-buf)
(if enriched-verbose (message "Enriched: encoding document..."))
- (let ((inhibit-read-only t))
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t))
(save-restriction
(narrow-to-region from to)
(delete-to-left-margin)
diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el
index ccb2606..a7b3d16 100644
--- a/lisp/url/url-cookie.el
+++ b/lisp/url/url-cookie.el
@@ -104,9 +104,10 @@ telling Microsoft that."
(insert ";; Emacs-W3 HTTP cookies file\n"
";; Automatically generated file!!! DO NOT EDIT!!!\n\n"
"(setq url-cookie-storage\n '")
- (pp url-cookie-storage (current-buffer))
- (insert ")\n(setq url-cookie-secure-storage\n '")
- (pp url-cookie-secure-storage (current-buffer))
+ (let ((print-length nil) (print-level nil))
+ (pp url-cookie-storage (current-buffer))
+ (insert ")\n(setq url-cookie-secure-storage\n '")
+ (pp url-cookie-secure-storage (current-buffer)))
(insert ")\n")
(insert " \n;; Local Variables:\n"
";; version-control: never\n"
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index 163df1f..96d6d1d 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)."
(add-hook 'after-save-hook 'vc-bzr-resolve-when-done nil t)
(message "There are unresolved conflicts in this file")))
+(defun vc-bzr-version-dirstate (dir)
+ "Try to return as a string the bzr revision ID of directory DIR.
+This uses the dirstate file's parent revision entry.
+Returns nil if unable to find this information."
+ (let ((file (expand-file-name ".bzr/checkout/dirstate" dir)))
+ (when (file-readable-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (and (looking-at "#bazaar dirstate flat format 3")
+ (forward-line 3)
+ (looking-at "[0-9]+\0\\([^\0\n]+\\)\0")
+ (match-string 1))))))
+
(defun vc-bzr-working-revision (file)
(let* ((rootdir (vc-bzr-root file))
(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)."
;; files exist.
(and (file-exists-p branch-format-file)
(file-exists-p lastrev-file)
- (equal (emacs-bzr-version-dirstate l-c-parent-dir)
- (emacs-bzr-version-dirstate rootdir))))))
+ (equal (vc-bzr-version-dirstate l-c-parent-dir)
+ (vc-bzr-version-dirstate rootdir))))))
t)))
(with-temp-buffer
(insert-file-contents branch-format-file)
diff --git a/lisp/version.el b/lisp/version.el
index 75763b3..1837cbf 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -93,41 +93,6 @@ or if we could not determine the revision.")
(define-obsolete-variable-alias 'emacs-bzr-version
'emacs-repository-version "24.4")
-(defun emacs-bzr-version-dirstate (dir)
- "Try to return as a string the bzr revision ID of directory DIR.
-This uses the dirstate file's parent revision entry.
-Returns nil if unable to find this information."
- (let ((file (expand-file-name ".bzr/checkout/dirstate" dir)))
- (when (file-readable-p file)
- (with-temp-buffer
- (insert-file-contents file)
- (and (looking-at "#bazaar dirstate flat format 3")
- (forward-line 3)
- (looking-at "[0-9]+\0\\([^\0\n]+\\)\0")
- (match-string 1))))))
-
-(defun emacs-bzr-version-bzr (dir)
- "Ask bzr itself for the version information for directory DIR."
- ;; Comments on `bzr version-info':
- ;; i) Unknown files also cause clean != 1.
- ;; ii) It can be slow, contacting the upstream repo to get the
- ;; branch nick if one is not set locally, even with a custom
- ;; template that is not asking for the nick (as used here). You'd
- ;; think the latter part would be trivial to fix:
- ;; https://bugs.launchpad.net/bzr/+bug/882541/comments/3
- ;; https://bugs.launchpad.net/bzr/+bug/629150
- ;; You can set the nick locally with `bzr nick ...', which speeds
- ;; things up enormously. `bzr revno' does not have this issue, but
- ;; has no way to print the revision_id AFAICS.
- (message "Waiting for bzr...")
- (with-temp-buffer
- (if (zerop
- (call-process "bzr" nil '(t nil) nil "version-info"
- "--custom"
- "--template={revno} {revision_id} (clean = {clean})"
- dir))
- (buffer-string))))
-
(define-obsolete-function-alias 'emacs-bzr-get-version
'emacs-repository-get-version "24.4")
@@ -140,48 +105,10 @@ this reports on the current state of the sources, which
may not
correspond to the running Emacs.
Optional argument DIR is a directory to use instead of
-`source-directory'. Optional argument EXTERNAL non-nil means to
-maybe ask the VCS itself, if the sources appear to be under
-version control. If `force', always ask. the VCS. Otherwise
-only ask the VCS if we cannot find any information ourselves."
+`source-directory'. Optional argument EXTERNAL is ignored and is
+retained for compatibility."
(or dir (setq dir source-directory))
- (cond ((file-directory-p (expand-file-name ".bzr/branch" dir))
- (if (eq external 'force)
- (emacs-bzr-version-bzr dir)
- (let (file loc rev)
- (cond ((file-readable-p
- (setq file (expand-file-name
- ".bzr/branch/last-revision" dir)))
- (with-temp-buffer
- (insert-file-contents file)
- (goto-char (point-max))
- (if (looking-back "\n")
- (delete-char -1))
- (buffer-string)))
- ;; OK, no last-revision. Is it a lightweight checkout?
- ((file-readable-p
- (setq file (expand-file-name ".bzr/branch/location" dir)))
- (setq rev (emacs-bzr-version-dirstate dir))
- ;; If parent branch is local, try looking there for the rev.
- ;; Note: there is no guarantee that the parent branch's rev
- ;; corresponds to this branch. This branch could have
- ;; been made with a specific -r revno argument, or the
- ;; parent could have been updated since this branch was
- ;; created.
- ;; To try and detect this, we check the dirstate revids
- ;; to see if they match.
- (if (and (setq loc (with-temp-buffer
- (insert-file-contents file)
- (if (looking-at "file://\\(.*\\)")
- (match-string 1))))
- (equal rev (emacs-bzr-version-dirstate loc)))
- (emacs-repository-get-version loc)
- ;; If parent does not match, the best we can do without
- ;; calling external commands is to use the dirstate rev.
- rev))
- (external
- (emacs-bzr-version-bzr dir))))))
- ((file-directory-p (expand-file-name ".git" dir))
+ (cond ((file-directory-p (expand-file-name ".git" dir))
(message "Waiting for git...")
(with-temp-buffer
(let ((default-directory (file-name-as-directory dir)))
diff --git a/test/ChangeLog b/test/ChangeLog
index 8ed02ee..15baf86 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,34 @@
+2015-01-18 Leo Liu <address@hidden>
+
+ * automated/seq-tests.el (test-seq-subseq): Add more tests.
+ (Bug#19434)
+
+2015-01-17 Stefan Monnier <address@hidden>
+
+ * automated/eieio-tests.el
+ (eieio-test-37-obsolete-name-in-constructor): New test.
+
+2015-01-17 Stefan Monnier <address@hidden>
+
+ * automated/eieio-tests.el (eieio-test-25-slot-tests)
+ (eieio-test-26-default-inheritance, eieio-test-28-slot-protection)
+ (eieio-test-30-slot-attribute-override)
+ (eieio-test-31-slot-attribute-override-class-allocation): Don't check
+ that we enforce :protection since we don't any more.
+
+ * automated/eieio-test-methodinvoke.el (eieio-test-method-store):
+ Use an explicit arg instead of eieio--scoped-class. Update all callers.
+
+2015-01-17 Stefan Monnier <address@hidden>
+
+ * automated/eieio-test-methodinvoke.el (eieio-test-cl-generic-1):
+ Reset eieio-test--1.
+
+ * automated/cl-generic-tests.el (cl-generic-test-8-after/before):
+ Rename from cl-generic-test-7-after/before.
+ (cl--generic-test-advice): New function.
+ (cl-generic-test-9-advice): New test.
+
2015-01-16 Jorgen Schaefer <address@hidden>
* automated/package-test.el (package-test-install-prioritized):
diff --git a/test/automated/cl-generic-tests.el
b/test/automated/cl-generic-tests.el
index 17bce6a..46397fb 100644
--- a/test/automated/cl-generic-tests.el
+++ b/test/automated/cl-generic-tests.el
@@ -129,5 +129,31 @@
(cons "x&y-int" (cl-call-next-method)))
(should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
+(ert-deftest cl-generic-test-8-after/before ()
+ (let ((log ()))
+ (cl-defgeneric cl--generic-1 (x y))
+ (cl-defmethod cl--generic-1 ((_x t) y) (cons y log))
+ (cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
+ (cons "quatre" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 :after (x _y)
+ (push (list :after x) log))
+ (cl-defmethod cl--generic-1 :before (x _y)
+ (push (list :before x) log))
+ (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4))))
+ (should (equal log '((:after 4) (:before 4))))))
+
+(defun cl--generic-test-advice (&rest args) (cons "advice" (apply args)))
+
+(ert-deftest cl-generic-test-9-advice ()
+ (cl-defgeneric cl--generic-1 (x y) "My doc.")
+ (cl-defmethod cl--generic-1 (x y) (list x y))
+ (advice-add 'cl--generic-1 :around #'cl--generic-test-advice)
+ (should (equal (cl--generic-1 4 5) '("advice" 4 5)))
+ (cl-defmethod cl--generic-1 ((_x integer) _y)
+ (cons "integer" (cl-call-next-method)))
+ (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5)))
+ (advice-remove 'cl--generic-1 #'cl--generic-test-advice)
+ (should (equal (cl--generic-1 4 5) '("integer" 4 5))))
+
(provide 'cl-generic-tests)
;;; cl-generic-tests.el ends here
diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el
index bbfb8d1..c83391b 100644
--- a/test/automated/cl-lib-tests.el
+++ b/test/automated/cl-lib-tests.el
@@ -245,4 +245,7 @@
(ert-deftest cl-loop-destructuring-with ()
(should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6)))
+(ert-deftest cl-flet-test ()
+ (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5)))
+
;;; cl-lib.el ends here
diff --git a/test/automated/eieio-test-methodinvoke.el
b/test/automated/eieio-test-methodinvoke.el
index 6362fc5..b6d60b8 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -58,11 +58,9 @@
(defvar eieio-test-method-order-list nil
"List of symbols stored during method invocation.")
-(defun eieio-test-method-store (keysym)
+(defun eieio-test-method-store (&rest args)
"Store current invocation class symbol in the invocation order list."
- ;; FIXME: Don't depend on `eieio--scoped-class'!
- (let* ((c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
- (push c eieio-test-method-order-list)))
+ (push args eieio-test-method-order-list))
(defun eieio-test-match (rightanswer)
"Do a test match."
@@ -86,36 +84,36 @@
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
(defmethod eitest-F :BEFORE ((p eitest-B-base1))
- (eieio-test-method-store :BEFORE))
+ (eieio-test-method-store :BEFORE 'eitest-B-base1))
(defmethod eitest-F :BEFORE ((p eitest-B-base2))
- (eieio-test-method-store :BEFORE))
+ (eieio-test-method-store :BEFORE 'eitest-B-base2))
(defmethod eitest-F :BEFORE ((p eitest-B))
- (eieio-test-method-store :BEFORE))
+ (eieio-test-method-store :BEFORE 'eitest-B))
(defmethod eitest-F ((p eitest-B))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'eitest-B)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base1))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'eitest-B-base1)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base2))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'eitest-B-base2)
(when (next-method-p)
(call-next-method))
)
(defmethod eitest-F :AFTER ((p eitest-B-base1))
- (eieio-test-method-store :AFTER))
+ (eieio-test-method-store :AFTER 'eitest-B-base1))
(defmethod eitest-F :AFTER ((p eitest-B-base2))
- (eieio-test-method-store :AFTER))
+ (eieio-test-method-store :AFTER 'eitest-B-base2))
(defmethod eitest-F :AFTER ((p eitest-B))
- (eieio-test-method-store :AFTER))
+ (eieio-test-method-store :AFTER 'eitest-B))
(ert-deftest eieio-test-method-order-list-3 ()
(let ((eieio-test-method-order-list nil)
@@ -150,15 +148,15 @@
;;; Return value from :PRIMARY
;;
(defmethod eitest-I :BEFORE ((a eitest-A))
- (eieio-test-method-store :BEFORE)
+ (eieio-test-method-store :BEFORE 'eitest-A)
":before")
(defmethod eitest-I :PRIMARY ((a eitest-A))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'eitest-A)
":primary")
(defmethod eitest-I :AFTER ((a eitest-A))
- (eieio-test-method-store :AFTER)
+ (eieio-test-method-store :AFTER 'eitest-A)
":after")
(ert-deftest eieio-test-method-order-list-5 ()
@@ -177,17 +175,17 @@
;; Just use the obsolete name once, to make sure it also works.
(defmethod constructor :STATIC ((p C-base1) &rest args)
- (eieio-test-method-store :STATIC)
+ (eieio-test-method-store :STATIC 'C-base1)
(if (next-method-p) (call-next-method))
)
(defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
- (eieio-test-method-store :STATIC)
+ (eieio-test-method-store :STATIC 'C-base2)
(if (next-method-p) (call-next-method))
)
(defmethod eieio-constructor :STATIC ((p C) &rest args)
- (eieio-test-method-store :STATIC)
+ (eieio-test-method-store :STATIC 'C)
(call-next-method)
)
@@ -214,24 +212,24 @@
(defmethod eitest-F ((p D))
"D"
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'D)
(call-next-method))
(defmethod eitest-F ((p D-base0))
"D-base0"
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'D-base0)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p D-base1))
"D-base1"
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'D-base1)
(call-next-method))
(defmethod eitest-F ((p D-base2))
"D-base2"
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'D-base2)
(when (next-method-p)
(call-next-method))
)
@@ -256,21 +254,21 @@
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
(defmethod eitest-F ((p E))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'E)
(call-next-method))
(defmethod eitest-F ((p E-base0))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'E-base0)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p E-base1))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'E-base1)
(call-next-method))
(defmethod eitest-F ((p E-base2))
- (eieio-test-method-store :PRIMARY)
+ (eieio-test-method-store :PRIMARY 'E-base2)
(when (next-method-p)
(call-next-method))
)
@@ -384,6 +382,7 @@
(cl-defgeneric eieio-test--1 (x y))
(ert-deftest eieio-test-cl-generic-1 ()
+ (cl-defgeneric eieio-test--1 (x y))
(cl-defmethod eieio-test--1 (x y) (list x y))
(cl-defmethod eieio-test--1 ((_x CNM-0) y)
(cons "CNM-0" (cl-call-next-method 7 y)))
diff --git a/test/automated/eieio-tests.el b/test/automated/eieio-tests.el
index 0b1ff1f..e0120b4 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."
(should (eq (oref eitest-t1 slot-1) 'moose))
(should (eq (oref eitest-t1 :moose) 'moose))
;; Don't pass reference of private slot
- (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
+ ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name)
;; Check private slot accessor
(should (string= (get-slot-2 eitest-t1) "penguin"))
;; Pass string instead of symbol
@@ -583,7 +583,7 @@ METHOD is the method that was attempting to be called."
(should (eq (oref eitest-t2 slot-1) 'moose))
(should (eq (oref eitest-t2 :moose) 'moose))
(should (string= (get-slot-2 eitest-t2) "linux"))
- (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
+ ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name)
(should (string= (get-slot-2 eitest-t2) "linux"))
(should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type))
@@ -654,20 +654,23 @@ Do not override for `prot-2'."
;; Access public slots
(oref eitest-p1 slot-1)
(oref eitest-p2 slot-1)
- ;; Accessing protected slot out of context must fail
- (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
+ ;; Accessing protected slot out of context used to fail, but we dropped this
+ ;; feature, since it was underused and noone noticed that the check was
+ ;; incorrect (much too loose).
+ ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name)
;; Access protected slot in method
(prot1-slot-2 eitest-p1)
;; Protected slot in subclass method
(prot1-slot-2 eitest-p2)
;; Protected slot from parent class method
(prot0-slot-2 eitest-p1)
- ;; Accessing private slot out of context must fail
- (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
+ ;; Accessing private slot out of context used to fail, but we dropped this
+ ;; feature, since it was not used.
+ ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name)
;; Access private slot in method
(prot1-slot-3 eitest-p1)
;; Access private slot in subclass method must fail
- (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
+ ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name)
;; Access private slot by same class
(prot1-slot-3-only eitest-p1)
;; Access private slot by subclass in sameclass method
@@ -729,12 +732,13 @@ Subclasses to override slot attributes.")
(ert-deftest eieio-test-30-slot-attribute-override ()
;; Subclass should not override :protection slot attribute
- (should-error
- (eval
- '(defclass slotattr-fail (slotattr-base)
- ((protection :protection :public)
- )
- "This class should throw an error.")))
+ ;;PROTECTION is gone.
+ ;;(should-error
+ ;; (eval
+ ;; '(defclass slotattr-fail (slotattr-base)
+ ;; ((protection :protection :public)
+ ;; )
+ ;; "This class should throw an error.")))
;; Subclass should not override :type slot attribute
(should-error
@@ -782,12 +786,13 @@ Subclasses to override slot attributes.")
(ert-deftest eieio-test-31-slot-attribute-override-class-allocation ()
;; Same as test-30, but with class allocation
- (should-error
- (eval
- '(defclass slotattr-fail (slotattr-class-base)
- ((protection :protection :public)
- )
- "This class should throw an error.")))
+ ;;PROTECTION is gone.
+ ;;(should-error
+ ;; (eval
+ ;; '(defclass slotattr-fail (slotattr-class-base)
+ ;; ((protection :protection :public)
+ ;; )
+ ;; "This class should throw an error.")))
(should-error
(eval
'(defclass slotattr-fail (slotattr-class-base)
@@ -887,6 +892,15 @@ Subclasses to override slot attributes.")
(should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2))
(should (= (length (eieio-build-class-alist 'opt-test1 t)) 1)))
+(defclass eieio--testing ()
+ ())
+
+(defmethod constructor :static ((_x eieio--testing) newname &rest _args)
+ (list newname 2))
+
+(ert-deftest eieio-test-37-obsolete-name-in-constructor ()
+ (should (equal (eieio--testing "toto") '("toto" 2))))
+
(provide 'eieio-tests)
;;; eieio-tests.el ends here
diff --git a/test/automated/seq-tests.el b/test/automated/seq-tests.el
index 9fcda7f..2398979 100644
--- a/test/automated/seq-tests.el
+++ b/test/automated/seq-tests.el
@@ -182,7 +182,12 @@ Evaluate BODY for each created sequence.
(should (same-contents-p (seq-subseq seq 1 -1) '(3 4))))
(should (vectorp (seq-subseq [2 3 4 5] 2)))
(should (stringp (seq-subseq "foo" 2 3)))
- (should (listp (seq-subseq '(2 3 4 4) 2 3))))
+ (should (listp (seq-subseq '(2 3 4 4) 2 3)))
+ (should-error (seq-subseq '(1 2 3) 4))
+ (should-not (seq-subseq '(1 2 3) 3))
+ (should (seq-subseq '(1 2 3) -3))
+ (should-error (seq-subseq '(1 2 3) 1 4))
+ (should (seq-subseq '(1 2 3) 1 3)))
(ert-deftest test-seq-concatenate ()
(with-test-sequences (seq '(2 4 6))