From 083940a93df17c6e50d6523e30d56ca3d179f688 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sun, 9 Jul 2017 16:04:02 -0700 Subject: Fix core dump in substitute-object-in-subtree MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Without this fix, (substitute-object-in-subtree #0=(#0# 'a) 'a) would dump core, since the C code would recurse indefinitely through the infinite structure. This patch adds an argument to the function, and renames it to lread--substitute-object-in-subtree as the function is not general-purpose and should not be relied on by outside code. See Bug#23660. * src/intervals.c (traverse_intervals_noorder): ARG is now void *, not Lisp_Object, so that callers need not cons unnecessarily. All callers changed. Also, remove related #if-0 code that was “temporary” in the early 1990s and has not been compilable for some time. * src/lread.c (struct subst): New type, for substitution closure data. (seen_list): Remove this static var, as this info is now part of struct subst. All uses removed. (Flread__substitute_object_in_subtree): Rename from Fsubstitute_object_in_subtree, and give it a 3rd arg so that it doesn’t dump core when called from the top level with an already-cyclic structure. All callers changed. (SUBSTITUTE): Remove. All callers expanded and then simplified. (substitute_object_recurse): Take a single argument SUBST rather than a pair OBJECT and PLACEHOLDER, so that its address can be passed around as part of a closure; this avoids the need for an AUTO_CONS call. All callers changed. If the COMPLETED component is t, treat every subobject as potentially circular. (substitute_in_interval): Take a struct subst * rather than a Lisp_Object, for the closure data. All callers changed. * test/src/lread-tests.el (lread-lread--substitute-object-in-subtree): New test, to check that the core dump does not reoccur. --- lisp/emacs-lisp/edebug.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 65e30f86778..1494ed1d9c3 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -906,7 +906,7 @@ circular objects. Let `read' read everything else." ;; with the object itself, wherever it occurs. (forward-char 1) (let ((obj (edebug-read-storing-offsets stream))) - (substitute-object-in-subtree obj placeholder) + (lread--substitute-object-in-subtree obj placeholder t) (throw 'return (setf (cdr elem) obj))))) ((eq ?# (following-char)) ;; #n# returns a previously read object. -- cgit v1.2.3 From 6443a95ad74d54b8be5ba85af9b893f3f1d5fa02 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Fri, 14 Jul 2017 02:47:30 -0700 Subject: Remove duplicate cl--random-state definition * lisp/emacs-lisp/cl-lib.el (cl--random-state): Remove. This variable is now defined in cl-extra.el (Bug#27617). --- lisp/emacs-lisp/cl-lib.el | 3 --- 1 file changed, 3 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 936c852526c..3c9c6223018 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -293,9 +293,6 @@ If true return the decimal value of digit CHAR in RADIX." (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) v)) -(defvar cl--random-state - (vector 'cl--random-state-tag -1 30 (cl--random-time))) - (defconst cl-most-positive-float nil "The largest value that a Lisp float can hold. If your system supports infinities, this is the largest finite value. -- cgit v1.2.3 From 0f3cc0b8245dfd7a9f6fcc95ec148be03fde8931 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 14 Jul 2017 10:29:10 -0400 Subject: * lisp/emacs-lisp/cl-lib.el (cl--random-time): Remove as well It's also defined in cl-extra.el. --- lisp/emacs-lisp/cl-lib.el | 5 ----- 1 file changed, 5 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 3c9c6223018..c183852fd3b 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -288,11 +288,6 @@ If true return the decimal value of digit CHAR in RADIX." (let ((n (aref cl-digit-char-table char))) (and n (< n (or radix 10)) n))) -(defun cl--random-time () - (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) - (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) - v)) - (defconst cl-most-positive-float nil "The largest value that a Lisp float can hold. If your system supports infinities, this is the largest finite value. -- cgit v1.2.3 From 6e2d6d54e1236216462c13655ea1fe573d9672e7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 14 Jul 2017 11:27:21 -0400 Subject: * lisp/emacs-lisp/bytecomp.el: Fix bug#14860. * lisp/emacs-lisp/bytecomp.el (byte-compile--function-signature): New fun. Dig into advice wrappers to find the "real" signature. (byte-compile-callargs-warn, byte-compile-arglist-warn): Use it. (byte-compile-arglist-signature): Don't bother with "new-style" arglists, since bytecode functions are now handled in byte-compile--function-signature. * lisp/files.el (create-file-buffer, insert-directory): Remove workaround introduced for (bug#14860). * lisp/help-fns.el (help-fns--analyse-function): `nadvice` is preloaded. * lisp/help.el (help-function-arglist): Dig into advice wrappers to find the "real" signature. --- lisp/emacs-lisp/bytecomp.el | 43 +++++++++++++++---------------------------- lisp/files.el | 9 --------- lisp/help-fns.el | 1 - lisp/help.el | 3 +++ 4 files changed, 18 insertions(+), 38 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e5b9b47b1d0..fdd4276e4e7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1263,12 +1263,6 @@ when printing the error message." (defun byte-compile-arglist-signature (arglist) (cond - ;; New style byte-code arglist. - ((integerp arglist) - (cons (logand arglist 127) ;Mandatory. - (if (zerop (logand arglist 128)) ;No &rest. - (lsh arglist -8)))) ;Nonrest. - ;; Old style byte-code, or interpreted function. ((listp arglist) (let ((args 0) opts @@ -1289,6 +1283,19 @@ when printing the error message." ;; Unknown arglist. (t '(0)))) +(defun byte-compile--function-signature (f) + ;; Similar to help-function-arglist, except that it returns the info + ;; in a different format. + (and (eq 'macro (car-safe f)) (setq f (cdr f))) + ;; Advice wrappers have "catch all" args, so fetch the actual underlying + ;; function to find the real arguments. + (while (advice--p f) (setq f (advice--cdr f))) + (if (eq (car-safe f) 'declared) + (byte-compile-arglist-signature (nth 1 f)) + (condition-case nil + (let ((sig (func-arity f))) + (if (numberp (cdr sig)) sig (list (car sig)))) + (error '(0))))) (defun byte-compile-arglist-signatures-congruent-p (old new) (not (or @@ -1330,19 +1337,7 @@ when printing the error message." (defun byte-compile-callargs-warn (form) (let* ((def (or (byte-compile-fdefinition (car form) nil) (byte-compile-fdefinition (car form) t))) - (sig (if (and def (not (eq def t))) - (progn - (and (eq (car-safe def) 'macro) - (eq (car-safe (cdr-safe def)) 'lambda) - (setq def (cdr def))) - (byte-compile-arglist-signature - (if (memq (car-safe def) '(declared lambda)) - (nth 1 def) - (if (byte-code-function-p def) - (aref def 0) - '(&rest def))))) - (if (subrp (symbol-function (car form))) - (subr-arity (symbol-function (car form)))))) + (sig (byte-compile--function-signature def)) (ncall (length (cdr form)))) ;; Check many or unevalled from subr-arity. (if (and (cdr-safe sig) @@ -1461,15 +1456,7 @@ extra args." (and initial (symbolp initial) (setq old (byte-compile-fdefinition initial nil))) (when (and old (not (eq old t))) - (and (eq 'macro (car-safe old)) - (eq 'lambda (car-safe (cdr-safe old))) - (setq old (cdr old))) - (let ((sig1 (byte-compile-arglist-signature - (pcase old - (`(lambda ,args . ,_) args) - (`(closure ,_ ,args . ,_) args) - ((pred byte-code-function-p) (aref old 0)) - (_ '(&rest def))))) + (let ((sig1 (byte-compile--function-signature old)) (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position name) diff --git a/lisp/files.el b/lisp/files.el index 646387f8c86..2f3efa33c28 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1821,10 +1821,6 @@ otherwise a string <2> or <3> or ... is appended to get an unused name. Emacs treats buffers whose names begin with a space as internal buffers. To avoid confusion when visiting a file whose name begins with a space, this function prepends a \"|\" to the final result if necessary." - ;; We need the following 'declare' form to shut up the byte - ;; compiler, which displays a bogus warning for advised functions, - ;; see bug#14860. - (declare (advertised-calling-convention (filename) "18.59")) (let ((lastname (file-name-nondirectory filename))) (if (string= lastname "") (setq lastname filename)) @@ -6594,11 +6590,6 @@ When SWITCHES contains the long `--dired' option, this function treats it specially, for the sake of dired. However, the normally equivalent short `-D' option is just passed on to `insert-directory-program', as any other option." - ;; We need the following 'declare' form to shut up the byte - ;; compiler, which displays a bogus warning for advised functions, - ;; see bug#14860. - (declare (advertised-calling-convention - (file switches &optional wildcard full-directory-p) "19.34")) ;; We need the directory in order to find the right handler. (let ((handler (find-file-name-handler (expand-file-name file) 'insert-directory))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index f5d94d8419f..cb0b2d71d33 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -564,7 +564,6 @@ FILE is the file where FUNCTION was probably defined." "Return information about FUNCTION. Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (let* ((advised (and (symbolp function) - (featurep 'nadvice) (advice--p (advice--symbol-function function)))) ;; If the function is advised, use the symbol that has the ;; real definition, if that symbol is already set up. diff --git a/lisp/help.el b/lisp/help.el index 0fb1c2dab77..bc7ee2c9b1b 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1384,6 +1384,9 @@ If PRESERVE-NAMES is non-nil, return a formal arglist that uses the same names as used in the original source code, when possible." ;; Handle symbols aliased to other symbols. (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) + ;; Advice wrappers have "catch all" args, so fetch the actual underlying + ;; function to find the real arguments. + (while (advice--p def) (setq def (advice--cdr def))) ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) (cond -- cgit v1.2.3 From 76e1f7d00fbff7bf8183ba85db2f67a11aa2d5ce Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Mon, 17 Jul 2017 21:30:50 +0900 Subject: alist-get: Add optional arg TESTFN If TESTFN is non-nil, then it is the predicate to lookup the alist. Otherwise, use 'eq' (Bug#27584). * lisp/subr.el (alist-get): Add optional arg FULL. * lisp/emacs-lisp/map.el (map-elt, map-put): Add optional arg TESTFN. * lisp/emacs-lisp/gv.el (alist-get): Update expander. * doc/lispref/lists.texi (Association Lists): Update manual. * etc/NEWS: Announce the changes. * test/lisp/emacs-lisp/map-tests.el (test-map-put-testfn-alist) (test-map-elt-testfn): New tests. --- doc/lispref/lists.texi | 24 ++++++++++++++---------- etc/NEWS | 3 +++ lisp/emacs-lisp/gv.el | 6 ++++-- lisp/emacs-lisp/map.el | 21 +++++++++++++-------- lisp/subr.el | 9 ++++++--- test/lisp/emacs-lisp/map-tests.el | 12 ++++++++++++ 6 files changed, 52 insertions(+), 23 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 966d8f18b17..0c993806824 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -1589,16 +1589,20 @@ keys may not be symbols: @end smallexample @end defun -@defun alist-get key alist &optional default remove -This function is like @code{assq}, but instead of returning the entire -association for @var{key} in @var{alist}, -@w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}. -If @var{key} is not found in @var{alist}, it returns @var{default}. - -This is a generalized variable (@pxref{Generalized Variables}) that -can be used to change a value with @code{setf}. When using it to set -a value, optional argument @var{remove} non-@code{nil} means to remove -@var{key} from @var{alist} if the new value is @code{eql} to @var{default}. +@defun alist-get key alist &optional default remove testfn +This function is similar to @code{assq}. It finds the first +association @w{@code{(@var{key} . @var{value})}} by comparing +@var{key} with @var{alist} elements, and, if found, returns the +@var{value} of that association. If no association is found, the +function returns @var{default}. Comparison of @var{key} against +@var{alist} elements uses the function specified by @var{testfn}, +defaulting to @code{eq}. + +This is a generalized variable (@pxref{Generalized Variables}) +that can be used to change a value with @code{setf}. When +using it to set a value, optional argument @var{remove} non-@code{nil} +means to remove @var{key}'s association from @var{alist} if the new +value is @code{eql} to @var{default}. @end defun @defun rassq value alist diff --git a/etc/NEWS b/etc/NEWS index edb71118efd..dca562cb3b9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1119,6 +1119,9 @@ break. * Lisp Changes in Emacs 26.1 ++++ +** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'. + ** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2 contain the same elements, regardless of the order. diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index c5c12a6414c..27376fc7f95 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -377,10 +377,12 @@ The return value is the last VAL in the list. `(with-current-buffer ,buf (set (make-local-variable ,var) ,v)))) (gv-define-expander alist-get - (lambda (do key alist &optional default remove) + (lambda (do key alist &optional default remove testfn) (macroexp-let2 macroexp-copyable-p k key (gv-letplace (getter setter) alist - (macroexp-let2 nil p `(assq ,k ,getter) + (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq))) + (assoc ,k ,getter ,testfn) + (assq ,k ,getter)) (funcall do (if (null default) `(cdr ,p) `(if ,p (cdr ,p) ,default)) (lambda (v) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index a89457e877d..31ba075c40f 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 1.1 +;; Version: 1.2 ;; Package: map ;; Maintainer: emacs-devel@gnu.org @@ -93,11 +93,13 @@ Returns the result of evaluating the form associated with MAP-VAR's type." ((arrayp ,map-var) ,(plist-get args :array)) (t (error "Unsupported map: %s" ,map-var))))) -(defun map-elt (map key &optional default) +(defun map-elt (map key &optional default testfn) "Lookup KEY in MAP and return its associated value. If KEY is not found, return DEFAULT which defaults to nil. -If MAP is a list, `eql' is used to lookup KEY. +If MAP is a list, `eql' is used to lookup KEY. Optional argument +TESTFN, if non-nil, means use its function definition instead of +`eql'. MAP can be a list, hash-table or array." (declare @@ -106,30 +108,33 @@ MAP can be a list, hash-table or array." (gv-letplace (mgetter msetter) `(gv-delay-error ,map) (macroexp-let2* nil ;; Eval them once and for all in the right order. - ((key key) (default default)) + ((key key) (default default) (testfn testfn)) `(if (listp ,mgetter) ;; Special case the alist case, since it can't be handled by the ;; map--put function. ,(gv-get `(alist-get ,key (gv-synthetic-place ,mgetter ,msetter) - ,default) + ,default nil ,testfn) do) ,(funcall do `(map-elt ,mgetter ,key ,default) (lambda (v) `(map--put ,mgetter ,key ,v))))))))) (map--dispatch map - :list (alist-get key map default) + :list (alist-get key map default nil testfn) :hash-table (gethash key map default) :array (if (and (>= key 0) (< key (seq-length map))) (seq-elt map key) default))) -(defmacro map-put (map key value) +(defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. If KEY is already present in MAP, replace the associated value with VALUE. +When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'. +TESTFN, if non-nil, means use its function definition instead of +`eql'. MAP can be a list, hash-table or array." - `(setf (map-elt ,map ,key) ,value)) + `(setf (map-elt ,map ,key nil ,testfn) ,value)) (defun map-delete (map key) "Delete KEY from MAP and return MAP. diff --git a/lisp/subr.el b/lisp/subr.el index a9edff6166f..d9d918ed12d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -725,15 +725,18 @@ Elements of ALIST that are not conses are ignored." (setq tail tail-cdr)))) alist) -(defun alist-get (key alist &optional default remove) - "Return the value associated with KEY in ALIST, using `assq'. +(defun alist-get (key alist &optional default remove testfn) + "Return the value associated with KEY in ALIST. If KEY is not found in ALIST, return DEFAULT. +Use TESTFN to lookup in the alist if non-nil. Otherwise, use `assq'. This is a generalized variable suitable for use with `setf'. When using it to set a value, optional argument REMOVE non-nil means to remove KEY from ALIST if the new value is `eql' to DEFAULT." (ignore remove) ;;Silence byte-compiler. - (let ((x (assq key alist))) + (let ((x (if (not testfn) + (assq key alist) + (assoc key alist testfn)))) (if x (cdr x) default))) (defun remove (elt seq) diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 07e85cc5391..15b0655040c 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -63,6 +63,11 @@ Evaluate BODY for each created map. (with-maps-do map (should (= 5 (map-elt map 7 5))))) +(ert-deftest test-map-elt-testfn () + (let ((map (list (cons "a" 1) (cons "b" 2)))) + (should-not (map-elt map "a")) + (should (map-elt map "a" nil 'equal)))) + (ert-deftest test-map-elt-with-nil-value () (should (null (map-elt '((a . 1) (b)) @@ -94,6 +99,13 @@ Evaluate BODY for each created map. (should (eq (map-elt alist 2) 'b)))) +(ert-deftest test-map-put-testfn-alist () + (let ((alist (list (cons "a" 1) (cons "b" 2)))) + (map-put alist "a" 3 'equal) + (should-not (cddr alist)) + (map-put alist "a" 9) + (should (cddr alist)))) + (ert-deftest test-map-put-return-value () (let ((ht (make-hash-table))) (should (eq (map-put ht 'a 'hello) 'hello)))) -- cgit v1.2.3 From 5e2ae74df54d4090c591c79ab13e7713c6654b9c Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Mon, 17 Jul 2017 22:01:17 +0900 Subject: * lisp/emacs-lisp/map.el (map-put): Fix redundancy in docstring. --- lisp/emacs-lisp/map.el | 2 -- 1 file changed, 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 31ba075c40f..e098eef8294 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -130,8 +130,6 @@ MAP can be a list, hash-table or array." If KEY is already present in MAP, replace the associated value with VALUE. When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'. -TESTFN, if non-nil, means use its function definition instead of -`eql'. MAP can be a list, hash-table or array." `(setf (map-elt ,map ,key nil ,testfn) ,value)) -- cgit v1.2.3 From fa72de6cf74735c1983720c818b6d67af832e646 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 18 Jul 2017 12:01:27 -0400 Subject: * emacs-lisp/cl-lib.el (cl--old-struct-type-of): Accept `[]' --- lisp/emacs-lisp/cl-lib.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index c183852fd3b..6ac08d839b1 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -631,7 +631,7 @@ If ALIST is non-nil, the new pairs are prepended to it." (require 'cl-seq)) (defun cl--old-struct-type-of (orig-fun object) - (or (and (vectorp object) + (or (and (vectorp object) (> (length object) 0) (let ((tag (aref object 0))) (when (and (symbolp tag) (string-prefix-p "cl-struct-" (symbol-name tag))) -- cgit v1.2.3 From 5ab91020fbc2f3bf75aa732a7456d9119ccbc347 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Tue, 18 Jul 2017 12:53:46 -0400 Subject: Use a more specific test for running on hydra.nixos.org * lisp/emacs-lisp/ert.el (ert-summarize-tests-batch-and-exit): * test/Makefile.in (WRITE_LOG): * test/lisp/filenotify-tests.el: * test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el (eieio-test-method-order-list-6): * test/lisp/emacs-lisp/eieio-tests/eieio-tests.el (eieio-test-37-obsolete-name-in-constructor): * test/lisp/net/tramp-tests.el: Replace NIX_STORE with EMACS_HYDRA_CI. --- lisp/emacs-lisp/ert.el | 2 +- test/Makefile.in | 2 +- test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el | 2 +- test/lisp/emacs-lisp/eieio-tests/eieio-tests.el | 2 +- test/lisp/filenotify-tests.el | 4 ++-- test/lisp/net/tramp-tests.el | 6 +++--- 6 files changed, 9 insertions(+), 9 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index eb2b2e3e11b..cee225cc8e0 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1512,7 +1512,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (message "%d files contained unexpected results:" (length unexpected)) (mapc (lambda (l) (message " %s" l)) unexpected)) ;; More details on hydra, where the logs are harder to get to. - (when (and (getenv "NIX_STORE") + (when (and (getenv "EMACS_HYDRA_CI") (not (zerop (+ nunexpected nskipped)))) (message "\nDETAILS") (message "-------") diff --git a/test/Makefile.in b/test/Makefile.in index 4e1a120d5c2..ba823ec7e32 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -136,7 +136,7 @@ endif $(AM_V_ELC)$(emacs) -f batch-byte-compile $< ## Save logs, and show logs for failed tests. -WRITE_LOG = $(if $(and ${NIX_STORE}, $(findstring tramp, $@)), |& tee $@, > $@ 2>&1) \ +WRITE_LOG = $(if $(and ${EMACS_HYDRA_CI}, $(findstring tramp, $@)), |& tee $@, > $@ 2>&1) \ || { STAT=$$?; cat $@; exit $$STAT; } ifeq ($(TEST_LOAD_EL), yes) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index 241ca65122d..3df2157cc83 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -192,7 +192,7 @@ (ert-deftest eieio-test-method-order-list-6 () ;; FIXME repeated intermittent failures on hydra (bug#24503) ;; ((:STATIC C) (:STATIC C-base1) (:STATIC C-base2)) != ((:STATIC C))") - (skip-unless (not (getenv "NIX_STORE"))) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (let ((eieio-test-method-order-list nil) (ans '( (:STATIC C) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index c34560ab585..1a6ab9da085 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -894,7 +894,7 @@ Subclasses to override slot attributes.") (ert-deftest eieio-test-37-obsolete-name-in-constructor () ;; FIXME repeated intermittent failures on hydra (bug#24503) - (skip-unless (not (getenv "NIX_STORE"))) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (should (equal (eieio--testing "toto") '("toto" 2)))) (ert-deftest eieio-autoload () diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 8d05ceacee2..3456d31fda9 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -173,8 +173,8 @@ Return nil when any other file notification watch is still active." tramp-verbose 0 tramp-message-show-message nil) -;; This shall happen on hydra only. -(when (getenv "NIX_STORE") +;; This should happen on hydra only. +(when (getenv "EMACS_HYDRA_CI") (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) ;; We do not want to try and fail `file-notify-add-watch'. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index de4fc8e0513..94e91b79300 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -86,8 +86,8 @@ tramp-message-show-message nil tramp-persistency-file-name nil) -;; This shall happen on hydra only. -(when (getenv "NIX_STORE") +;; This should happen on hydra only. +(when (getenv "EMACS_HYDRA_CI") (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) (defvar tramp--test-expensive-test @@ -3706,7 +3706,7 @@ process sentinels. They shall not disturb each other." ;; On hydra, timings are bad. (timer-repeat (cond - ((getenv "NIX_STORE") 10) + ((getenv "EMACS_HYDRA_CI") 10) (t 1))) ;; We must distinguish due to performance reasons. (timer-operation -- cgit v1.2.3 From 24bd52565a7652817e6bf9b7a5cb9ad99c955a13 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 18 Jul 2017 14:07:16 -0400 Subject: * lisp/emacs-lisp/nadvice.el (advice--defalias-fset): Strip advices This tries to make sure that (defalias F (symbol-function F)) stays a no-op. --- lisp/emacs-lisp/nadvice.el | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index fd1cd2c7aaf..c68ecbc59ee 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -385,6 +385,18 @@ of the piece of advice." (defun advice--defalias-fset (fsetfun symbol newdef) (unless fsetfun (setq fsetfun #'fset)) + ;; `newdef' shouldn't include advice wrappers, since that's what *we* manage! + ;; So if `newdef' includes advice wrappers, it's usually because someone + ;; naively took (symbol-function F) and then passed that back to `defalias': + ;; let's strip them away. + (cond + ((advice--p newdef) (setq newdef (advice--cd*r newdef))) + ((and (eq 'macro (car-safe newdef)) + (advice--p (cdr newdef))) + (setq newdef `(macro . ,(advice--cd*r (cdr newdef)))))) + ;; The saved-rewrite is specific to the current value, so since we are about + ;; to overwrite that current value with new value, the old saved-rewrite is + ;; not relevant any more. (when (get symbol 'advice--saved-rewrite) (put symbol 'advice--saved-rewrite nil)) (setq newdef (advice--normalize symbol newdef)) -- cgit v1.2.3 From d37a82b4a35bdffa0462ba9954bd432cf7d54659 Mon Sep 17 00:00:00 2001 From: "Charles A. Roelli" Date: Sat, 22 Jul 2017 11:09:36 +0300 Subject: ElDoc: add docstrings and minor refactoring * lisp/emacs-lisp/eldoc.el (eldoc-edit-message-commands): Add docstring. (turn-on-eldoc-mode): Fix capitalization. (eldoc--supported-p): Add docstring. (eldoc-schedule-timer): Add docstring and use 'eldoc--supported-p'. (eldoc-message): Add docstring and make calling convention clearer. (eldoc--message-command-p): (eldoc-pre-command-refresh-echo-area): (eldoc-display-message-p): (eldoc-display-message-no-interference-p): (eldoc-print-current-symbol-info): (eldoc-docstring-format-sym-doc): (eldoc-add-command, eldoc-add-command-completions): (eldoc-remove-command, eldoc-remove-command-completions): Add docstring. (Bug#27230) --- lisp/emacs-lisp/eldoc.el | 49 +++++++++++++++++++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 11 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index a05bd7cc4d4..bca40ab87da 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -160,6 +160,10 @@ This is used to determine if `eldoc-idle-delay' is changed by the user.") It should receive the same arguments as `message'.") (defun eldoc-edit-message-commands () + "Return an obarray containing common editing commands. + +When `eldoc-print-after-edit' is non-nil, ElDoc messages are only +printed after commands contained in this obarray." (let ((cmds (make-vector 31 0)) (re (regexp-opt '("delete" "insert" "edit" "electric" "newline")))) (mapatoms (lambda (s) @@ -211,16 +215,21 @@ expression point is on." ;;;###autoload (defun turn-on-eldoc-mode () - "Turn on `eldoc-mode' if the buffer has eldoc support enabled. + "Turn on `eldoc-mode' if the buffer has ElDoc support enabled. See `eldoc-documentation-function' for more detail." (when (eldoc--supported-p) (eldoc-mode 1))) (defun eldoc--supported-p () + "Non-nil if an ElDoc function is set for this buffer." (not (memq eldoc-documentation-function '(nil ignore)))) (defun eldoc-schedule-timer () + "Ensure `eldoc-timer' is running. + +If the user has changed `eldoc-idle-delay', update the timer to +reflect the change." (or (and eldoc-timer (memq eldoc-timer timer-idle-list)) ;FIXME: Why? (setq eldoc-timer @@ -229,8 +238,7 @@ See `eldoc-documentation-function' for more detail." (lambda () (when (or eldoc-mode (and global-eldoc-mode - (not (memq eldoc-documentation-function - '(nil ignore))))) + (eldoc--supported-p))) (eldoc-print-current-symbol-info)))))) ;; If user has changed the idle delay, update the timer. @@ -268,16 +276,19 @@ Otherwise work like `message'." (force-mode-line-update))) (apply 'message format-string args))) -(defun eldoc-message (&rest args) +(defun eldoc-message (&optional format-string &rest args) + "Display FORMAT-STRING formatted with ARGS as an ElDoc message. + +Store the message (if any) in `eldoc-last-message', and return it." (let ((omessage eldoc-last-message)) (setq eldoc-last-message - (cond ((eq (car args) eldoc-last-message) eldoc-last-message) - ((null (car args)) nil) + (cond ((eq format-string eldoc-last-message) eldoc-last-message) + ((null format-string) nil) ;; If only one arg, no formatting to do, so put it in ;; eldoc-last-message so eq test above might succeed on ;; subsequent calls. - ((null (cdr args)) (car args)) - (t (apply #'format-message args)))) + ((null args) format-string) + (t (apply #'format-message format-string args)))) ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages ;; are recorded in a log. Do not put eldoc messages in that log since ;; they are Legion. @@ -289,6 +300,7 @@ Otherwise work like `message'." eldoc-last-message) (defun eldoc--message-command-p (command) + "Return non-nil if COMMAND is in `eldoc-message-commands'." (and (symbolp command) (intern-soft (symbol-name command) eldoc-message-commands))) @@ -299,6 +311,7 @@ Otherwise work like `message'." ;; before the next command executes, which does away with the flicker. ;; This doesn't seem to be required for Emacs 19.28 and earlier. (defun eldoc-pre-command-refresh-echo-area () + "Reprint `eldoc-last-message' in the echo area." (and eldoc-last-message (not (minibufferp)) ;We don't use the echo area when in minibuffer. (if (and (eldoc-display-message-no-interference-p) @@ -310,6 +323,7 @@ Otherwise work like `message'." ;; Decide whether now is a good time to display a message. (defun eldoc-display-message-p () + "Return non-nil when it is appropriate to display an ElDoc message." (and (eldoc-display-message-no-interference-p) ;; If this-command is non-nil while running via an idle ;; timer, we're still in the middle of executing a command, @@ -322,6 +336,7 @@ Otherwise work like `message'." ;; Check various conditions about the current environment that might make ;; it undesirable to print eldoc messages right this instant. (defun eldoc-display-message-no-interference-p () + "Return nil if displaying a message would cause interference." (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) @@ -347,6 +362,7 @@ variable) is taken into account if the major mode specific function does not return any documentation.") (defun eldoc-print-current-symbol-info () + "Print the text produced by `eldoc-documentation-function'." ;; This is run from post-command-hook or some idle timer thing, ;; so we need to be careful that errors aren't ignored. (with-demoted-errors "eldoc error: %s" @@ -361,6 +377,13 @@ return any documentation.") ;; truncated or eliminated entirely from the output to make room for the ;; description. (defun eldoc-docstring-format-sym-doc (prefix doc &optional face) + "Combine PREFIX and DOC, and shorten the result to fit in the echo area. + +When PREFIX is a symbol, propertize its symbol name with FACE +before combining it with DOC. If FACE is not provided, just +apply the nil face. + +See also: `eldoc-echo-area-use-multiline-p'." (when (symbolp prefix) (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) (let* ((ea-multi eldoc-echo-area-use-multiline-p) @@ -390,22 +413,26 @@ return any documentation.") ;; These functions do display-command table management. (defun eldoc-add-command (&rest cmds) + "Add each of CMDS to the obarray `eldoc-message-commands'." (dolist (name cmds) (and (symbolp name) (setq name (symbol-name name))) (set (intern name eldoc-message-commands) t))) (defun eldoc-add-command-completions (&rest names) + "Pass every prefix completion of NAMES to `eldoc-add-command'." (dolist (name names) (apply #'eldoc-add-command (all-completions name obarray 'commandp)))) (defun eldoc-remove-command (&rest cmds) + "Remove each of CMDS from the obarray `eldoc-message-commands'." (dolist (name cmds) (and (symbolp name) (setq name (symbol-name name))) (unintern name eldoc-message-commands))) (defun eldoc-remove-command-completions (&rest names) + "Pass every prefix completion of NAMES to `eldoc-remove-command'." (dolist (name names) (apply #'eldoc-remove-command (all-completions name eldoc-message-commands)))) @@ -418,9 +445,9 @@ return any documentation.") "down-list" "end-of-" "exchange-point-and-mark" "forward-" "goto-" "handle-select-window" "indent-for-tab-command" "left-" "mark-page" "mark-paragraph" "mouse-set-point" "move-" "move-beginning-of-" - "move-end-of-" "newline" "next-" "other-window" "pop-global-mark" "previous-" - "recenter" "right-" "scroll-" "self-insert-command" "split-window-" - "up-list") + "move-end-of-" "newline" "next-" "other-window" "pop-global-mark" + "previous-" "recenter" "right-" "scroll-" "self-insert-command" + "split-window-" "up-list") (provide 'eldoc) -- cgit v1.2.3 From ad4eff3b905dbc32e2d38bfec1e4f93eceec288d Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Thu, 20 Jul 2017 21:36:18 +0200 Subject: Add 'rx' pattern for pcase. * lisp/emacs-lisp/rx.el (rx): New pcase macro. * test/lisp/emacs-lisp/rx-tests.el (rx-pcase): Add unit test. --- etc/NEWS | 3 +++ lisp/emacs-lisp/pcase.el | 1 - lisp/emacs-lisp/rx.el | 56 ++++++++++++++++++++++++++++++++++++++++ test/lisp/emacs-lisp/rx-tests.el | 10 +++++++ 4 files changed, 69 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 4cb02bf518a..f43491b6306 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1555,6 +1555,9 @@ manual. ** 'tcl-auto-fill-mode' is now declared obsolete. Its functionality can be replicated simply by setting 'comment-auto-fill-only-comments'. +** New pcase pattern 'rx' to match against a rx-style regular +expression. + * Changes in Emacs 26.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 4a06ab25d3e..b40161104d2 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -930,6 +930,5 @@ QPAT can take the following forms: ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat) (t (error "Unknown QPAT: %S" qpat)))) - (provide 'pcase) ;;; pcase.el ends here diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 386232c6eef..b66f2c6d512 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1169,6 +1169,62 @@ enclosed in `(and ...)'. (rx-to-string `(and ,@regexps) t)) (t (rx-to-string (car regexps) t)))) + + +(pcase-defmacro rx (&rest regexps) + "Build a `pcase' pattern matching `rx' regexps. +The REGEXPS are interpreted as by `rx'. The pattern matches if +the regular expression so constructed matches the object, as if +by `string-match'. + +In addition to the usual `rx' constructs, REGEXPS can contain the +following constructs: + + (let VAR FORM...) creates a new explicitly numbered submatch + that matches FORM and binds the match to + VAR. + (backref VAR) creates a backreference to the submatch + introduced by a previous (let VAR ...) + construct. + +The VARs are associated with explicitly numbered submatches +starting from 1. Multiple occurrences of the same VAR refer to +the same submatch. + +If a case matches, the match data is modified as usual so you can +use it in the case body, but you still have to pass the correct +string as argument to `match-string'." + (let* ((vars ()) + (rx-constituents + `((let + ,(lambda (form) + (rx-check form) + (let ((var (cadr form))) + (cl-check-type var symbol) + (let ((i (or (cl-position var vars :test #'eq) + (prog1 (length vars) + (setq vars `(,@vars ,var)))))) + (rx-form `(submatch-n ,(1+ i) ,@(cddr form)))))) + 1 nil) + (backref + ,(lambda (form) + (rx-check form) + (rx-backref + `(backref ,(let ((var (cadr form))) + (if (integerp var) var + (1+ (cl-position var vars :test #'eq))))))) + 1 1 + ,(lambda (var) + (cond ((integerp var) (rx-check-backref var)) + ((memq var vars) t) + (t (error "rx `backref' variable must be one of %s: %s" + vars var))))) + ,@rx-constituents)) + (regexp (rx-to-string `(seq ,@regexps) :no-group))) + `(and (pred (string-match ,regexp)) + ,@(cl-loop for i from 1 + for var in vars + collect `(app (match-string ,i) ,var))))) ;; ;; sregex.el replacement diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 8b7945c9d27..8f353b7e863 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -33,5 +33,15 @@ (number-sequence ?< ?\]) (number-sequence ?- ?:)))))) +(ert-deftest rx-pcase () + (should (equal (pcase "a 1 2 3 1 1 b" + ((rx (let u (+ digit)) space + (let v (+ digit)) space + (let v (+ digit)) space + (backref u) space + (backref 1)) + (list u v))) + '("1" "3")))) + (provide 'rx-tests) ;; rx-tests.el ends here. -- cgit v1.2.3 From 69fb12a66b3d6b9bfb55d8bcd58bec2a8e7ca55b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 24 Jul 2017 15:58:30 -0400 Subject: (loadhist-unload-element): Move ERT and cl-generic methods * lisp/loadhist.el (loadhist-unload-element): Don't define cl-generic and ert methods here. (loadhist-unload-element) <(head define-type)>: Remove unused var `slots'. * lisp/emacs-lisp/cl-generic.el (loadhist-unload-element): Define unload method for cl-defmethod. (cl-generic-ensure-function): Remove redundant `defalias'. * lisp/emacs-lisp/ert.el (ert-set-test): Move the current-load-list setting here... (ert-deftest): ...from here. (loadhist-unload-element): Define unload method for ert-deftest. --- lisp/emacs-lisp/cl-generic.el | 16 ++++++++++++++-- lisp/emacs-lisp/ert.el | 13 +++++++------ lisp/loadhist.el | 10 +++------- 3 files changed, 24 insertions(+), 15 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c64376b940f..6a4ee47ac24 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -182,8 +182,7 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG origname)) (if generic (cl-assert (eq name (cl--generic-name generic))) - (setf (cl--generic name) (setq generic (cl--generic-make name))) - (defalias name (cl--generic-make-function generic))) + (setf (cl--generic name) (setq generic (cl--generic-make name)))) generic)) ;;;###autoload @@ -1210,5 +1209,18 @@ Used internally for the (major-mode MODE) context specializers." (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) +;;; Support for unloading. + +(cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) + (pcase-let* + ((`(,name ,qualifiers . ,specializers) (cdr x)) + (generic (cl-generic-ensure-function name 'noerror))) + (when generic + (let* ((mt (cl--generic-method-table generic)) + (me (cl--generic-member-method specializers qualifiers mt))) + (when me + (setf (cl--generic-method-table generic) (delq (car me) mt))))))) + + (provide 'cl-generic) ;;; cl-generic.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index cee225cc8e0..5c88b070f65 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -136,8 +136,15 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) (put symbol 'ert--test definition) + ;; Register in load-history, so `symbol-file' can find us, and so + ;; unload-feature can unload our tests. + (cl-pushnew `(ert-deftest . ,symbol) current-load-list :test #'equal) definition) +(cl-defmethod loadhist-unload-element ((x (head ert-deftest))) + (let ((name (cdr x))) + (put name 'ert--test nil))) + (defun ert-make-test-unbound (symbol) "Make SYMBOL name no test. Return SYMBOL." (cl-remprop symbol 'ert--test) @@ -214,12 +221,6 @@ description of valid values for RESULT-TYPE. ,@(when tags-supplied-p `(:tags ,tags)) :body (lambda () ,@body))) - ;; This hack allows `symbol-file' to associate `ert-deftest' - ;; forms with files, and therefore enables `find-function' to - ;; work with tests. However, it leads to warnings in - ;; `unload-feature', which doesn't know how to undefine tests - ;; and has no mechanism for extension. - (push '(ert-deftest . ,name) current-load-list) ',name)))) ;; We use these `put' forms in addition to the (declare (indent)) in diff --git a/lisp/loadhist.el b/lisp/loadhist.el index 693050d7044..24c3acd1b99 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -196,11 +196,8 @@ restore a previous autoload if possible.") (cl-defmethod loadhist-unload-element ((x (head autoload))) (loadhist--unload-function x)) -(cl-defmethod loadhist-unload-element ((x (head require))) nil) -(cl-defmethod loadhist-unload-element ((x (head defface))) nil) -;; The following two might require more actions. -(cl-defmethod loadhist-unload-element ((x (head ert-deftest))) nil) -(cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) nil) +(cl-defmethod loadhist-unload-element ((_ (head require))) nil) +(cl-defmethod loadhist-unload-element ((_ (head defface))) nil) (cl-defmethod loadhist-unload-element ((x (head provide))) ;; Remove any feature names that this file provided. @@ -220,8 +217,7 @@ restore a previous autoload if possible.") (makunbound x))) (cl-defmethod loadhist-unload-element ((x (head define-type))) - (let* ((name (cdr x)) - (slots (mapcar 'car (cdr (cl-struct-slot-info name))))) + (let* ((name (cdr x))) ;; Remove the struct. (setf (cl--find-class name) nil))) -- cgit v1.2.3