diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/autoload.el | 7 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 66 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 8 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-lib.el | 48 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 31 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl.el | 14 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cursor-sensor.el | 180 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 29 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 30 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/elint.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mnt.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 40 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package.el | 598 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 46 | ||||
| -rw-r--r-- | lisp/emacs-lisp/rx.el | 16 | ||||
| -rw-r--r-- | lisp/emacs-lisp/seq.el | 69 |
17 files changed, 827 insertions, 362 deletions
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 073d923a178..206d5bb4434 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -235,8 +235,9 @@ If a buffer is visiting the desired autoload file, return it." (enable-local-eval nil)) ;; We used to use `raw-text' to read this file, but this causes ;; problems when the file contains non-ASCII characters. - (find-file-noselect - (autoload-ensure-default-file (autoload-generated-file))))) + (let ((delay-mode-hooks t)) + (find-file-noselect + (autoload-ensure-default-file (autoload-generated-file)))))) (defun autoload-generated-file () (expand-file-name generated-autoload-file @@ -400,7 +401,7 @@ which lists the file name and which functions are in it, etc." (erase-buffer) (setq buffer-undo-list t buffer-read-only nil) - (emacs-lisp-mode) + (delay-mode-hooks (emacs-lisp-mode)) (setq default-directory (file-name-directory file)) (insert-file-contents file nil) (let ((enable-local-variables :safe) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e929c02eefb..51bbf8a2944 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -979,6 +979,17 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (lambda (x) (if (symbolp x) (list 'prin1-to-string x) x)) args)))))) +(defvar byte-compile--interactive nil + "Determine if `byte-compile--message' uses the minibuffer.") + +(defun byte-compile--message (format &rest args) + "Like `message', except sometimes don't print to minibuffer. +If the variable `byte-compile--interactive' is nil, the message +is not displayed on the minibuffer." + (apply #'message format args) + (unless byte-compile--interactive + (message nil))) + ;; Log something that isn't a warning. (defun byte-compile-log-1 (string) (with-current-buffer byte-compile-log-buffer @@ -986,7 +997,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (goto-char (point-max)) (byte-compile-warning-prefix nil nil) (cond (noninteractive - (message " %s" string)) + (byte-compile--message " %s" string)) (t (insert (format "%s\n" string))))))) @@ -1590,7 +1601,10 @@ extra args." "Recompile every `.el' file in DIRECTORY that already has a `.elc' file. Files in subdirectories of DIRECTORY are processed also." (interactive "DByte force recompile (directory): ") - (byte-recompile-directory directory nil t)) + (let ((byte-compile--interactive + (or byte-compile--interactive + (called-interactively-p 'any)))) + (byte-recompile-directory directory nil t))) ;;;###autoload (defun byte-recompile-directory (directory &optional arg force) @@ -1620,6 +1634,9 @@ that already has a `.elc' file." (compilation-mode)) (let ((directories (list default-directory)) (default-directory default-directory) + (byte-compile--interactive + (or byte-compile--interactive + (called-interactively-p 'any))) (skip-count 0) (fail-count 0) (file-count 0) @@ -1628,7 +1645,7 @@ that already has a `.elc' file." (displaying-byte-compile-warnings (while directories (setq directory (car directories)) - (message "Checking %s..." directory) + (byte-compile--message "Checking %s..." directory) (dolist (file (directory-files directory)) (let ((source (expand-file-name file directory))) (if (file-directory-p source) @@ -1653,13 +1670,13 @@ that already has a `.elc' file." (`t file-count) (_ fail-count))) (or noninteractive - (message "Checking %s..." directory)) + (byte-compile--message "Checking %s..." directory)) (if (not (eq last-dir directory)) (setq last-dir directory dir-count (1+ dir-count))) ))))) (setq directories (cdr directories)))) - (message "Done (Total of %d file%s compiled%s%s%s)" + (byte-compile--message "Done (Total of %d file%s compiled%s%s%s)" file-count (if (= file-count 1) "" "s") (if (> fail-count 0) (format ", %d failed" fail-count) "") (if (> skip-count 0) (format ", %d skipped" skip-count) "") @@ -1706,7 +1723,10 @@ If compilation is needed, this functions returns the result of current-prefix-arg))) (let ((dest (byte-compile-dest-file filename)) ;; Expand now so we get the current buffer's defaults - (filename (expand-file-name filename))) + (filename (expand-file-name filename)) + (byte-compile--interactive + (or byte-compile--interactive + (called-interactively-p 'any)))) (if (if (file-exists-p dest) ;; File was already compiled ;; Compile if forced to, or filename newer @@ -1718,7 +1738,7 @@ If compilation is needed, this functions returns the result of filename "? "))))) (progn (if (and noninteractive (not byte-compile-verbose)) - (message "Compiling %s..." filename)) + (byte-compile--message "Compiling %s..." filename)) (byte-compile-file filename load)) (when load (load (if (file-exists-p dest) dest filename))) @@ -1762,6 +1782,9 @@ The value is non-nil if there were no errors, nil if errors." (let ((byte-compile-current-file filename) (byte-compile-current-group nil) (set-auto-coding-for-load t) + (byte-compile--interactive + (or byte-compile--interactive + (called-interactively-p 'any))) target-file input-buffer output-buffer byte-compile-dest-file) (setq target-file (byte-compile-dest-file filename)) @@ -1799,7 +1822,7 @@ The value is non-nil if there were no errors, nil if errors." (progn (setq-default major-mode 'emacs-lisp-mode) ;; Arg of t means don't alter enable-local-variables. - (normal-mode t)) + (delay-mode-hooks (normal-mode t))) (setq-default major-mode dmm)) ;; There may be a file local variable setting (bug#10419). (setq buffer-read-only nil @@ -1817,14 +1840,14 @@ The value is non-nil if there were no errors, nil if errors." ;; (byte-compile-abbreviate-file filename) ;; (with-current-buffer input-buffer no-byte-compile)) (when (file-exists-p target-file) - (message "%s deleted because of `no-byte-compile: %s'" + (byte-compile--message "%s deleted because of `no-byte-compile: %s'" (byte-compile-abbreviate-file target-file) (buffer-local-value 'no-byte-compile input-buffer)) (condition-case nil (delete-file target-file) (error nil))) ;; We successfully didn't compile this file. 'no-byte-compile) (when byte-compile-verbose - (message "Compiling %s..." filename)) + (byte-compile--message "Compiling %s..." filename)) (setq byte-compiler-error-flag nil) ;; It is important that input-buffer not be current at this call, ;; so that the value of point set in input-buffer @@ -1836,7 +1859,7 @@ The value is non-nil if there were no errors, nil if errors." (if byte-compiler-error-flag nil (when byte-compile-verbose - (message "Compiling %s...done" filename)) + (byte-compile--message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer (goto-char (point-max)) @@ -1862,7 +1885,7 @@ The value is non-nil if there were no errors, nil if errors." ;; recompiled). Previously this was accomplished by ;; deleting target-file before writing it. (rename-file tempfile target-file t) - (or noninteractive (message "Wrote %s" target-file))) + (or noninteractive (byte-compile--message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (signal 'file-error (list "Opening output file" @@ -1896,6 +1919,9 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-read-position (point)) (byte-compile-last-position byte-compile-read-position) (byte-compile-last-warned-form 'nothing) + (byte-compile--interactive + (or byte-compile--interactive + (called-interactively-p 'any))) (value (eval (let ((read-with-symbol-positions (current-buffer)) (read-symbol-positions-list nil)) @@ -1903,10 +1929,10 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-sexp (read (current-buffer))))) lexical-binding))) (cond (arg - (message "Compiling from buffer... done.") + (byte-compile--message "Compiling from buffer... done.") (prin1 value (current-buffer)) (insert "\n")) - ((message "%s" (prin1-to-string value))))))) + ((byte-compile--message "%s" (prin1-to-string value))))))) (defun byte-compile-from-buffer (inbuffer) (let ((byte-compile-current-buffer inbuffer) @@ -2410,7 +2436,7 @@ not to take responsibility for the actual compilation of the code." (byte-compile-arglist-warn name arglist macro)) (if byte-compile-verbose - (message "Compiling %s... (%s)" + (byte-compile--message "Compiling %s... (%s)" (or byte-compile-current-file "") name)) (cond ((not (or macro (listp body))) ;; We do not know positively if the definition is a macro @@ -2580,7 +2606,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; error to a simple message for the known case where signaling an error ;; causes problems. ((byte-code-function-p fun) - (message "Function %s is already compiled" + (byte-compile--message "Function %s is already compiled" (if (symbolp form) form "provided")) fun) (t @@ -4398,8 +4424,8 @@ binding slots have been popped." name macro arglist body rest) (when macro (if (null fun) - (message "Macro %s unrecognized, won't work in file" name) - (message "Macro %s partly recognized, trying our luck" name) + (byte-compile--message "Macro %s unrecognized, won't work in file" name) + (byte-compile--message "Macro %s partly recognized, trying our luck" name) (push (cons name (eval fun)) byte-compile-macro-environment))) (byte-compile-keep-pending form)))) @@ -4525,11 +4551,11 @@ The call tree also lists those functions which are not known to be called \(that is, to which no calls have been compiled\), and which cannot be invoked interactively." (interactive) - (message "Generating call tree...") + (byte-compile--message "Generating call tree...") (with-output-to-temp-buffer "*Call-Tree*" (set-buffer "*Call-Tree*") (erase-buffer) - (message "Generating call tree... (sorting on %s)" + (byte-compile--message "Generating call tree... (sorting on %s)" byte-compile-call-tree-sort) (insert "Call tree for " (cond ((null byte-compile-current-file) (or filename "???")) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index afc2adbee6d..0a6bc3afda7 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -528,13 +528,9 @@ If START or END is negative, it counts from the end." (seq-subseq seq start end)) ;;;###autoload -(defun cl-concatenate (type &rest seqs) +(defalias 'cl-concatenate #'seq-concatenate "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -\n(fn TYPE SEQUENCE...)" - (cond ((eq type 'vector) (apply 'vconcat seqs)) - ((eq type 'string) (apply 'concat seqs)) - ((eq type 'list) (apply 'append (append seqs '(nil)))) - (t (error "Not a sequence type name: %s" type)))) +\n(fn TYPE SEQUENCE...)") ;;; List functions. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 10651cc29bd..6b43c126130 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -420,122 +420,122 @@ Signal an error if X is not a list." (defun cl-caaar (x) "Return the `car' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (car x)))) (defun cl-caadr (x) "Return the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (cdr x)))) (defun cl-cadar (x) "Return the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (car x)))) (defun cl-caddr (x) "Return the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (cdr x)))) (defun cl-cdaar (x) "Return the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (car x)))) (defun cl-cdadr (x) "Return the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (cdr x)))) (defun cl-cddar (x) "Return the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (car x)))) (defun cl-cdddr (x) "Return the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (cdr x)))) (defun cl-caaaar (x) "Return the `car' of the `car' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (car (car x))))) (defun cl-caaadr (x) "Return the `car' of the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (car (cdr x))))) (defun cl-caadar (x) "Return the `car' of the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (cdr (car x))))) (defun cl-caaddr (x) "Return the `car' of the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (car (cdr (cdr x))))) (defun cl-cadaar (x) "Return the `car' of the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (car (car x))))) (defun cl-cadadr (x) "Return the `car' of the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (car (cdr x))))) (defun cl-caddar (x) "Return the `car' of the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (cdr (car x))))) (defun cl-cadddr (x) "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (car (cdr (cdr (cdr x))))) (defun cl-cdaaar (x) "Return the `cdr' of the `car' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (car (car x))))) (defun cl-cdaadr (x) "Return the `cdr' of the `car' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (car (cdr x))))) (defun cl-cdadar (x) "Return the `cdr' of the `car' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (cdr (car x))))) (defun cl-cdaddr (x) "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (car (cdr (cdr x))))) (defun cl-cddaar (x) "Return the `cdr' of the `cdr' of the `car' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (car (car x))))) (defun cl-cddadr (x) "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (car (cdr x))))) (defun cl-cdddar (x) "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (cdr (car x))))) (defun cl-cddddr (x) "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." - (declare (compiler-macro cl--compiler-macro-cXXr)) + (declare (compiler-macro internal--compiler-macro-cXXr)) (cdr (cdr (cdr (cdr x))))) ;;(defun last* (x &optional n) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index f8ddc00c3bf..5bab84ed312 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -70,20 +70,12 @@ (setq form `(cons ,(car args) ,form))) form)) +;; Note: `cl--compiler-macro-cXXr' has been copied to +;; `internal--compiler-macro-cXXr' in subr.el. If you amend either +;; one, you may want to amend the other, too. ;;;###autoload -(defun cl--compiler-macro-cXXr (form x) - (let* ((head (car form)) - (n (symbol-name (car form))) - (i (- (length n) 2))) - (if (not (string-match "c[ad]+r\\'" n)) - (if (and (fboundp head) (symbolp (symbol-function head))) - (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form)) - x) - (error "Compiler macro for cXXr applied to non-cXXr form")) - (while (> i (match-beginning 0)) - (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x)) - (setq i (1- i))) - x))) +(define-obsolete-function-alias 'cl--compiler-macro-cXXr + 'internal--compiler-macro-cXXr "25.1") ;;; Some predicates for analyzing Lisp forms. ;; These are used by various @@ -1188,10 +1180,10 @@ For more details, see Info node `(cl)Loop Facility'. (if (memq (car cl--loop-args) '(downto above)) (error "Must specify `from' value for downward cl-loop")) (let* ((down (or (eq (car cl--loop-args) 'downfrom) - (memq (cl-caddr cl--loop-args) + (memq (nth 2 cl--loop-args) '(downto above)))) (excl (or (memq (car cl--loop-args) '(above below)) - (memq (cl-caddr cl--loop-args) + (memq (nth 2 cl--loop-args) '(above below)))) (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) @@ -1828,7 +1820,7 @@ from OBARRAY. (let (,(car spec)) (mapatoms #'(lambda (,(car spec)) ,@body) ,@(and (cadr spec) (list (cadr spec)))) - ,(cl-caddr spec)))) + ,(nth 2 spec)))) ;;;###autoload (defmacro cl-do-all-symbols (spec &rest body) @@ -2734,12 +2726,16 @@ non-nil value, that slot cannot be set via `setf'. constrs)) (while constrs (let* ((name (caar constrs)) - (args (cadr (pop constrs))) + (rest (cdr (pop constrs))) + (args (car rest)) + (doc (cadr rest)) (anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) (push `(cl-defsubst ,name (&cl-defs (nil ,@descs) ,@args) + ,@(if (stringp doc) (list doc) + (if (stringp docstring) (list docstring))) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) (,(or type #'vector) ,@make)) @@ -2788,6 +2784,7 @@ non-nil value, that slot cannot be set via `setf'. Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of field NAME is matched against UPAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." + (declare (debug (sexp &rest [&or (sexp pcase-UPAT) sexp]))) `(and (pred (pcase--flip cl-typep ',type)) ,@(mapcar (lambda (field) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 5da1cea6bb3..564a44457d8 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -397,7 +397,7 @@ lexical closures as in Common Lisp. (macroexpand-all `(cl-symbol-macrolet ,(mapcar (lambda (x) - `(,(car x) (symbol-value ,(cl-caddr x)))) + `(,(car x) (symbol-value ,(nth 2 x)))) vars) ,@body) (cons (cons 'function #'cl--function-convert) @@ -410,20 +410,20 @@ lexical closures as in Common Lisp. ;; dynamic scoping, since with lexical scoping we'd need ;; (let ((foo <val>)) ...foo...). `(progn - ,@(mapcar (lambda (x) `(defvar ,(cl-caddr x))) vars) - (let ,(mapcar (lambda (x) (list (cl-caddr x) (cadr x))) vars) + ,@(mapcar (lambda (x) `(defvar ,(nth 2 x))) vars) + (let ,(mapcar (lambda (x) (list (nth 2 x) (nth 1 x))) vars) ,(cl-sublis (mapcar (lambda (x) - (cons (cl-caddr x) - `',(cl-caddr x))) + (cons (nth 2 x) + `',(nth 2 x))) vars) ebody))) `(let ,(mapcar (lambda (x) - (list (cl-caddr x) + (list (nth 2 x) `(make-symbol ,(format "--%s--" (car x))))) vars) (setf ,@(apply #'append (mapcar (lambda (x) - (list `(symbol-value ,(cl-caddr x)) (cadr x))) + (list `(symbol-value ,(nth 2 x)) (nth 1 x))) vars))) ,ebody)))) diff --git a/lisp/emacs-lisp/cursor-sensor.el b/lisp/emacs-lisp/cursor-sensor.el new file mode 100644 index 00000000000..1d1780baed0 --- /dev/null +++ b/lisp/emacs-lisp/cursor-sensor.el @@ -0,0 +1,180 @@ +;;; cursor-sensor.el --- React to cursor movement -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package implements the `cursor-intangible' property, which is +;; meant to replace the old `intangible' property. To use it, just enable the +;; `cursor-intangible-mode', after which this package will move point away from +;; any position that has a non-nil `cursor-intangible' property. This is only +;; done just before redisplay happens, contrary to the old `intangible' +;; property which was done at a much lower level. + +;;; Code: + +(defvar cursor-sensor-inhibit nil) + +(defun cursor-sensor--intangible-p (pos) + (let ((p (get-pos-property pos 'cursor-intangible))) + (if p + (let (a b) + (if (and (setq a (get-char-property pos 'cursor-intangible)) + (setq b (if (> pos (point-min)) + (get-char-property (1- pos) 'cursor-intangible))) + (not (eq a b))) + ;; If we're right between two different intangible thingies, + ;; we can stop here. This is not quite consistent with the + ;; interpretation of "if it's sticky, then this boundary is + ;; itself intangible", but it's convenient (and it better matches + ;; the behavior of `intangible', making it easier to port code). + nil p)) + p))) + +(defun cursor-sensor-tangible-pos (curpos window &optional second-chance) + (let ((newpos curpos)) + (when (cursor-sensor--intangible-p newpos) + (let ((oldpos (window-parameter window 'cursor-intangible--last-point))) + (cond + ((or (and (integerp oldpos) (< oldpos newpos)) + (eq newpos (point-min))) + (while + (when (< newpos (point-max)) + (setq newpos + (if (get-char-property newpos 'cursor-intangible) + (next-single-char-property-change + newpos 'cursor-intangible nil (point-max)) + (1+ newpos))) + (cursor-sensor--intangible-p newpos)))) + (t ;; (>= oldpos newpos) + (while + (when (> newpos (point-min)) + (setq newpos + (if (get-char-property (1- newpos) 'cursor-intangible) + (previous-single-char-property-change + newpos 'cursor-intangible nil (point-min)) + (1- newpos))) + (cursor-sensor--intangible-p newpos))))) + (if (not (and (or (eq newpos (point-min)) (eq newpos (point-max))) + (cursor-sensor--intangible-p newpos))) + ;; All clear, we're good to go. + newpos + ;; We're still on an intangible position because we bumped + ;; into an intangible BOB/EOB: try to move in the other direction. + (if second-chance + ;; Actually, we tried already and that failed! + curpos + (cursor-sensor-tangible-pos newpos window 'second-chance))))))) + +(defun cursor-sensor-move-to-tangible (window) + (let* ((curpos (window-point window)) + (newpos (cursor-sensor-tangible-pos curpos window))) + (when newpos (set-window-point window newpos)) + (set-window-parameter window 'cursor-intangible--last-point + (or newpos curpos)))) + +(defun cursor-sensor--move-to-tangible (window) + (unless cursor-sensor-inhibit + (cursor-sensor-move-to-tangible window))) + +;;;###autoload +(define-minor-mode cursor-intangible-mode + "Keep cursor outside of any `cursor-intangible' text property." + nil nil nil + (if cursor-intangible-mode + (add-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible + nil t) + (remove-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible t))) + +;;; Detect cursor movement. + +(defun cursor-sensor--detect (window) + (unless cursor-sensor-inhibit + (let* ((point (window-point window)) + ;; It's often desirable to make the cursor-sensor-functions property + ;; non-sticky on both ends, but that means get-pos-property might + ;; never see it. + (new (or (get-char-property point 'cursor-sensor-functions) + (unless (bobp) + (get-char-property (1- point) 'cursor-sensor-functions)))) + (old (window-parameter window 'cursor-sensor--last-state)) + (oldposmark (car old)) + (oldpos (or (if oldposmark (marker-position oldposmark)) + (point-min))) + (start (min oldpos point)) + (end (max oldpos point))) + (unless (or (null old) (eq (marker-buffer oldposmark) (current-buffer))) + ;; `window' does not display the same buffer any more! + (setcdr old nil)) + (if (or (and (null new) (null (cdr old))) + (and (eq new (cdr old)) + (eq (next-single-property-change + start 'cursor-sensor-functions nil end) + end))) + ;; Clearly nothing to do. + nil + ;; Maybe something to do. Let's see exactly what needs to run. + (let* ((missing-p + (lambda (f) + "Non-nil if F is missing somewhere between START and END." + (let ((pos start) + (missing nil)) + (while (< pos end) + (setq pos (next-single-property-change + pos 'cursor-sensor-functions + nil end)) + (unless (memq f (get-char-property + pos 'cursor-sensor-functions)) + (setq missing t))) + missing)))) + (dolist (f (cdr old)) + (unless (and (memq f new) (not (funcall missing-p f))) + (funcall f window oldpos 'left))) + (dolist (f new) + (unless (and (memq f (cdr old)) (not (funcall missing-p f))) + (funcall f window oldpos 'entered))))) + + ;; Remember current state for next time. + ;; Re-read cursor-sensor-functions since the functions may have moved + ;; window-point! + (if old + (progn (move-marker (car old) point) + (setcdr old new)) + (set-window-parameter window 'cursor-sensor--last-state + (cons (copy-marker point) new)))))) + +;;;###autoload +(define-minor-mode cursor-sensor-mode + "Handle the `cursor-sensor-functions' text property. +This property should hold a list of functions which react to the motion +of the cursor. They're called with three arguments (WINDOW OLDPOS DIR) +where WINDOW is the affected window, OLDPOS is the last known position of +the cursor and DIR can be `left' or `entered' depending on whether the cursor is +entering the area covered by the text-property property or leaving it." + nil nil nil + (if cursor-sensor-mode + (add-hook 'pre-redisplay-functions #'cursor-sensor--detect + nil t) + (remove-hook 'pre-redisplay-functions #'cursor-sensor--detect + t))) + +(provide 'cursor-sensor) +;;; cursor-sensor.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index aa7cdf96337..98fb7e9888c 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1725,6 +1725,17 @@ expressions; a `progn' form will be returned enclosing these forms." (t (error "Bad spec: %s" specs))))) + ((eq 'vector spec) + (if (vectorp form) + ;; Special case: match a vector with the specs. + (let ((result (edebug-match-sublist + (edebug-new-cursor + form (cdr (edebug-top-offset cursor))) + (cdr specs)))) + (edebug-move-cursor cursor) + (list (apply 'vector result))) + (edebug-no-match cursor "Expected" specs))) + ((listp form) (prog1 (list (edebug-match-sublist @@ -1734,15 +1745,6 @@ expressions; a `progn' form will be returned enclosing these forms." specs)) (edebug-move-cursor cursor))) - ((and (eq 'vector spec) (vectorp form)) - ;; Special case: match a vector with the specs. - (let ((result (edebug-match-sublist - (edebug-new-cursor - form (cdr (edebug-top-offset cursor))) - (cdr specs)))) - (edebug-move-cursor cursor) - (list (apply 'vector result)))) - (t (edebug-no-match cursor "Expected" specs))) ))) @@ -1869,8 +1871,13 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Like body but body is wrapped in edebug-enter form. ;; The body is assumed to be executing inside of the function context. ;; Not to be used otherwise. - (let ((edebug-inside-func t)) - (list (edebug-wrap-def-body (edebug-forms cursor))))) + (let* ((edebug-inside-func t) + (forms (edebug-forms cursor))) + ;; If there's no form, there's nothing to wrap! + ;; This happens to handle bug#20281, tho maybe a better fix would be to + ;; improve the `defun' spec. + (when forms + (list (edebug-wrap-def-body forms))))) ;;;; Edebug Form Specs diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 6fd9c14088e..59d834837b0 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -89,21 +89,8 @@ Currently under control of this var: (cl-defstruct (eieio--class (:constructor nil) (:constructor eieio--class-make (name &aux (tag 'defclass))) - (:type vector) + (:include cl--class) (:copier nil)) - ;; We use an untagged cl-struct, with our own hand-made tag as first field - ;; (containing the symbol `defclass'). It would be better to use a normal - ;; cl-struct with its normal tag (e.g. so that cl-defstruct can define the - ;; predicate for us), but that breaks compatibility with .elc files compiled - ;; against older versions of EIEIO. - tag - ;; Fields we could inherit from cl--class (if we used a tagged cl-struct): - (name nil :type symbol) ;The type name. - (docstring nil :type string) - (parents nil :type (or eieio--class (list-of eieio--class))) - (slots nil :type (vector cl-slot-descriptor)) - (index-table nil :type hash-table) - ;; Fields specific to EIEIO classes: children initarg-tuples ;; initarg tuples list (class-slots nil :type eieio--slot) @@ -152,12 +139,6 @@ Currently under control of this var: (or (eieio--class-v class) class) class)) -(defsubst eieio--class-p (class) - "Return non-nil if CLASS is a valid class object." - (condition-case nil - (eq (aref class 0) 'defclass) - (error nil))) - (defun class-p (class) "Return non-nil if CLASS is a valid class vector. CLASS is a symbol." ;FIXME: Is it a vector or a symbol? @@ -198,7 +179,7 @@ Return nil if that option doesn't exist." (define-obsolete-function-alias 'object-p 'eieio-object-p "25.1") -(defsubst class-abstract-p (class) +(defun class-abstract-p (class) "Return non-nil if CLASS is abstract. Abstract classes cannot be instantiated." (eieio--class-option (eieio--class-v class) :abstract)) @@ -673,10 +654,9 @@ the new child class." (let ((pslots (eieio--class-slots pcv)) (pinit (eieio--class-initarg-tuples pcv))) (dotimes (i (length pslots)) - (eieio--add-new-slot newc (cl--copy-slot-descriptor (aref pslots i)) - (car-safe (car pinit)) nil nil sn) - ;; Increment each value. - (setq pinit (cdr pinit)) + (let* ((sd (cl--copy-slot-descriptor (aref pslots i))) + (init (car (rassq (cl--slot-descriptor-name sd) pinit)))) + (eieio--add-new-slot newc sd init nil nil sn)) )) ;; while/let ;; Now duplicate all the class alloc slots. (let ((pcslots (eieio--class-class-slots pcv))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index bca53c0c892..111459509bc 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -348,6 +348,7 @@ variable name of the same name as the slot." Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of field NAME is matched against UPAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." + (declare (debug (&rest [&or (sexp pcase-UPAT) sexp]))) (let ((is (make-symbol "table"))) ;; FIXME: This generates a horrendous mess of redundant let bindings. ;; `pcase' needs to be improved somehow to introduce let-bindings more diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 136467046b4..317e5a6fd3f 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -374,7 +374,7 @@ Returns the forms." (let ((elint-current-pos (point))) ;; non-list check could be here too. errors may be out of seq. ;; quoted check cannot be elsewhere, since quotes skipped. - (if (looking-back "'") + (if (looking-back "'" (1- (point))) ;; Eg cust-print.el uses ' as a comment syntax. (elint-warning "Skipping quoted form `'%.20s...'" (read (current-buffer))) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index fec172d05ca..104c23c2102 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -437,9 +437,9 @@ This can be found in an RCS or SCCS header." ((re-search-forward (concat "@(#)" - (if buffer-file-name + (if buffer-file-name (regexp-quote (file-name-nondirectory buffer-file-name)) - "[^\t\n]*") + "[^\t\n]+") "\t\\([012345679.]*\\)") header-max t) (match-string-no-properties 1))))))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 4c9a39fe174..108d5ccb0e3 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -181,22 +181,23 @@ nil))) res)) -(defun lisp--el-non-funcall-position-p (&optional pos) +(defun lisp--el-non-funcall-position-p (pos) "Heuristically determine whether POS is an evaluated position." - (setf pos (or pos (point))) (save-match-data (save-excursion (ignore-errors (goto-char pos) (or (eql (char-before) ?\') - (let ((parent - (progn - (up-list -1) - (cond + (let* ((ppss (syntax-ppss)) + (paren-posns (nth 9 ppss)) + (parent + (when paren-posns + (goto-char (car (last paren-posns))) ;(up-list -1) + (cond ((ignore-errors (and (eql (char-after) ?\() - (progn - (up-list -1) + (when (cdr paren-posns) + (goto-char (car (last paren-posns 2))) (looking-at "(\\_<let\\*?\\_>")))) (goto-char (match-end 0)) 'let) @@ -217,6 +218,7 @@ (< (point) pos)))))))))) (defun lisp--el-match-keyword (limit) + ;; FIXME: Move to elisp-mode.el. (catch 'found (while (re-search-forward "(\\(\\(?:\\sw\\|\\s_\\)+\\)\\_>" limit t) (let ((sym (intern-soft (match-string 1)))) @@ -227,17 +229,6 @@ (match-beginning 0))))) (throw 'found t)))))) -(defun lisp--el-font-lock-flush-elisp-buffers (&optional file) - ;; Don't flush during load unless called from after-load-functions. - ;; In that case, FILE is non-nil. It's somehow strange that - ;; load-in-progress is t when an after-load-function is called since - ;; that should run *after* the load... - (when (or (not load-in-progress) file) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (derived-mode-p 'emacs-lisp-mode) - (font-lock-flush)))))) - (pcase-let ((`(,vdefs ,tdefs ,el-defs-re ,cl-defs-re @@ -582,10 +573,6 @@ font-lock keywords will not be case sensitive." (font-lock-syntactic-face-function . lisp-font-lock-syntactic-face-function))) (setq-local prettify-symbols-alist lisp--prettify-symbols-alist) - (when elisp - (add-hook 'after-load-functions #'lisp--el-font-lock-flush-elisp-buffers) - (setq-local electric-pair-text-pairs - (cons '(?\` . ?\') electric-pair-text-pairs))) (setq-local electric-pair-skip-whitespace 'chomp) (setq-local electric-pair-open-newline-between-pairs nil)) @@ -868,9 +855,10 @@ is the buffer position of the start of the containing expression." ;; Handle prefix characters and whitespace ;; following an open paren. (Bug#1012) (backward-prefix-chars) - (while (and (not (looking-back "^[ \t]*\\|([ \t]+")) - (or (not containing-sexp) - (< (1+ containing-sexp) (point)))) + (while (not (or (looking-back "^[ \t]*\\|([ \t]+" + (line-beginning-position)) + (and containing-sexp + (>= (1+ containing-sexp) (point))))) (forward-sexp -1) (backward-prefix-chars)) (setq calculate-lisp-indent-last-sexp (point))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 583598ee10c..f770acd557e 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -225,6 +225,30 @@ a package can run arbitrary code." :group 'package :version "24.1") +(defcustom package-menu-hide-low-priority 'archive + "If non-nil, hide low priority packages from the packages menu. +A package is considered low priority if there's another version +of it available such that: + (a) the archive of the other package is higher priority than + this one, as per `package-archive-priorities'; + or + (b) they both have the same archive priority but the other + package has a higher version number. + +This variable has three possible values: + nil: no packages are hidden; + archive: only criteria (a) is used; + t: both criteria are used. + +This variable has no effect if `package-menu--hide-obsolete' is +nil, so it can be toggled with \\<package-menu-mode-map> \\[package-menu-hide-obsolete]." + :type '(choice (const :tag "Don't hide anything" nil) + (const :tag "Hide per package-archive-priorities" + archive) + (const :tag "Hide per archive and version number" t)) + :group 'package + :version "25.1") + (defcustom package-archive-priorities nil "An alist of priorities for packages. @@ -235,7 +259,9 @@ number from the archive with the highest priority is 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." +Archives not in this list have the priority 0. + +See also `package-menu-hide-low-priority'." :type '(alist :key-type (string :tag "Archive name") :value-type (integer :tag "Priority (default is 0)")) :risky t @@ -467,6 +493,10 @@ This is, approximately, the inverse of `version-to-list'. (nth 1 keywords) keywords))) +(defun package-desc-priority (p) + "Return the priority of the archive of package-desc object P." + (package-archive-priority (package-desc-archive p))) + ;; Package descriptor format used in finder-inf.el and package--builtins. (cl-defstruct (package--bi-desc (:constructor package-make-builtin (version summary)) @@ -866,6 +896,8 @@ untar into a directory named DIR; otherwise, signal an error." (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) + ;; Silence `autoload-generate-file-autoloads'. + (noninteractive package--silence) (backup-inhibited t) (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) @@ -1090,23 +1122,27 @@ function, call it with no arguments (instead of executing BODY), otherwise propagate the error. For description of the other arguments see `package--with-work-buffer'." (declare (indent 3) (debug t)) - `(if (or (not ,async) - (not (string-match-p "\\`https?:" ,location))) - (package--with-work-buffer ,location ,file ,@body) - (url-retrieve (concat ,location ,file) - (lambda (status) - (if (eq (car status) :error) - (if (functionp ,async) - (funcall ,async) - (signal (cdar status) (cddr status))) - (goto-char (point-min)) - (unless (search-forward "\n\n" nil 'noerror) - (error "Invalid url response")) - (delete-region (point-min) (point)) - ,@body) - (kill-buffer (current-buffer))) - nil - 'silent))) + (macroexp-let2* macroexp-copyable-p + ((async-1 async) + (file-1 file) + (location-1 location)) + `(if (or (not ,async-1) + (not (string-match-p "\\`https?:" ,location-1))) + (package--with-work-buffer ,location-1 ,file-1 ,@body) + (url-retrieve (concat ,location-1 ,file-1) + (lambda (status) + (if (eq (car status) :error) + (if (functionp ,async-1) + (funcall ,async-1) + (signal (cdar status) (cddr status))) + (goto-char (point-min)) + (unless (search-forward "\n\n" nil 'noerror) + (error "Invalid url response")) + (delete-region (point-min) (point)) + ,@body) + (kill-buffer (current-buffer))) + nil + 'silent)))) (defun package--check-signature-content (content string &optional sig-file) "Check signature CONTENT against STRING. @@ -1195,6 +1231,8 @@ version higher than the one being used. To check for package (defun package--build-compatibility-table () "Build `package--compatibility-table' with `package--mapc'." + ;; Initialize the list of built-ins. + (require 'finder-inf nil t) ;; Build compat table. (setq package--compatibility-table (make-hash-table :test 'eq)) (package--mapc #'package--add-to-compatibility-table)) @@ -1275,7 +1313,8 @@ Will throw an error if the archive version is too new." (let ((filename (expand-file-name file package-user-dir))) (when (file-exists-p filename) (with-temp-buffer - (insert-file-contents-literally filename) + (let ((coding-system-for-read 'utf-8)) + (insert-file-contents filename)) (let ((contents (read (current-buffer)))) (if (> (car contents) package-archive-version) (error "Package archive version %d is higher than %d" @@ -1311,9 +1350,12 @@ If successful, set `package-archive-contents'." (defun package-initialize (&optional no-activate) "Load Emacs Lisp packages, and activate them. The variable `package-load-list' controls which packages to load. -If optional arg NO-ACTIVATE is non-nil, don't activate packages." +If optional arg NO-ACTIVATE is non-nil, don't activate packages. +If `user-init-file' does not mention `(package-initialize)', add +it to the file." (interactive) (setq package-alist nil) + (package--ensure-init-file) (package-load-all-descriptors) (package-read-all-archive-contents) (unless no-activate @@ -1336,6 +1378,16 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (declare-function epg-configuration "epg-config" ()) (declare-function epg-import-keys-from-file "epg" (context keys)) +(defvar package--silence nil) + +(defun package--message (format &rest args) + "Like `message', except sometimes don't print to minibuffer. +If the variable `package--silence' is non-nil, the message is not +displayed on the minibuffer." + (apply #'message format args) + (when package--silence + (message nil))) + ;;;###autoload (defun package-import-keyring (&optional file) "Import keys from FILE." @@ -1346,9 +1398,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (with-file-modes 448 (make-directory homedir t)) (setf (epg-context-home-directory context) homedir) - (message "Importing %s..." (file-name-nondirectory file)) + (package--message "Importing %s..." (file-name-nondirectory file)) (epg-import-keys-from-file context file) - (message "Importing %s...done" (file-name-nondirectory file)))) + (package--message "Importing %s...done" (file-name-nondirectory file)))) (defvar package--post-download-archives-hook nil "Hook run after the archive contents are downloaded. @@ -1364,8 +1416,8 @@ Once it's empty, run `package--post-download-archives-hook'." (remove entry package--downloads-in-progress)) ;; If this was the last download, run the hook. (unless package--downloads-in-progress - (package--build-compatibility-table) (package-read-all-archive-contents) + (package--build-compatibility-table) ;; We message before running the hook, so the hook can give ;; messages as well. (message "Package refresh done") @@ -1393,8 +1445,12 @@ similar to an entry in `package-alist'. Save the cached copy to ;; If we care, check it (perhaps async) and *then* write the file. (package--check-signature location file content async + ;; This function will be called after signature checking. (lambda (&optional good-sigs) (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + ;; Even if the sig fails, this download is done, so + ;; remove it from the in-progress list. + (package--update-downloads-in-progress archive) (error "Unsigned archive `%s'" name)) ;; Write out the archives file. (write-region content nil local-file nil 'silent) @@ -1410,10 +1466,16 @@ This populates `package-archive-contents'. If ASYNC is non-nil, perform the downloads asynchronously." ;; The downloaded archive contents will be read as part of ;; `package--update-downloads-in-progress'. - (setq package--downloads-in-progress package-archives) + (setq package--downloads-in-progress + (append package-archives + package--downloads-in-progress)) (dolist (archive package-archives) (condition-case-unless-debug nil - (package--download-one-archive archive "archive-contents" async) + (package--download-one-archive + archive "archive-contents" + ;; Called if the async download fails + (when async + (lambda () (package--update-downloads-in-progress archive)))) (error (message "Failed to download `%s' archive." (car archive)))))) @@ -1426,18 +1488,18 @@ and make them available for download. Optional argument ASYNC specifies whether to perform the downloads in the background." (interactive) - ;; FIXME: Do it asynchronously. (unless (file-exists-p package-user-dir) (make-directory package-user-dir t)) (let ((default-keyring (expand-file-name "package-keyring.gpg" - data-directory))) + data-directory)) + (package--silence async)) (when (and package-check-signature (file-exists-p default-keyring)) (condition-case-unless-debug error (progn (epg-check-configuration (epg-configuration)) (package-import-keyring default-keyring)) - (error (message "Cannot import default keyring: %S" (cdr error)))))) - (package--download-and-read-archives async)) + (error (message "Cannot import default keyring: %S" (cdr error))))) + (package--download-and-read-archives async))) ;;; Dependency Management @@ -1479,7 +1541,7 @@ SEEN is used internally to detect infinite recursion." ;; we re-add it (along with its dependencies) at an earlier place ;; below (bug#16994). (if (memq already seen) ;Avoid inf-loop on dependency cycles. - (message "Dependency cycle going through %S" + (package--message "Dependency cycle going through %S" (package-desc-full-name already)) (setq packages (delq already packages)) (setq already nil)) @@ -1543,15 +1605,20 @@ Used to populate `package-selected-packages'." unless (memq name dep-list) collect name))) +(defun package--save-selected-packages (value) + "Set and save `package-selected-packages' to VALUE." + (let ((save-silently package--silence)) + (customize-save-variable + 'package-selected-packages + (setq package-selected-packages value)))) + (defun package--user-selected-p (pkg) "Return non-nil if PKG is a package was installed by the user. PKG is a package name. This looks into `package-selected-packages', populating it first if it is still empty." (unless (consp package-selected-packages) - (customize-save-variable - 'package-selected-packages - (setq package-selected-packages (package--find-non-dependencies)))) + (package--save-selected-packages (package--find-non-dependencies))) (memq pkg package-selected-packages)) (defun package--get-deps (pkg &optional only) @@ -1644,43 +1711,58 @@ if all the in-between dependencies are also in PACKAGE-LIST." "Return the archive containing the package NAME." (cdr (assoc (package-desc-archive desc) package-archives))) -(defun package-install-from-archive (pkg-desc) - "Download and install a tar package." +(defun package-install-from-archive (pkg-desc &optional async callback) + "Download and install a tar package. +If ASYNC is non-nil, perform the download asynchronously. +If CALLBACK is non-nil, call it with no arguments once the +operation is done." ;; 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))) - (sig-file (concat file ".sig")) - good-signatures pkg-descs) - (package--with-work-buffer location file - (if (and package-check-signature - (not (member (package-desc-archive pkg-desc) - package-unsigned-archives))) - (if (package--archive-file-exists-p location sig-file) - (setq good-signatures (package--check-signature location file)) - (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned package: `%s'" - (package-desc-name pkg-desc))))) - (package-unpack pkg-desc)) - ;; Here the package has been installed successfully, mark it as - ;; signed if appropriate. - (when good-signatures - ;; Write out good signatures into NAME-VERSION.signed file. - (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") - nil - (expand-file-name - (concat (package-desc-full-name pkg-desc) - ".signed") - package-user-dir) - nil 'silent) - ;; Update the old pkg-desc which will be shown on the description buffer. - (setf (package-desc-signed pkg-desc) t) - ;; Update the new (activated) pkg-desc as well. - (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist))) - (if pkg-descs - (setf (package-desc-signed (car pkg-descs)) t))))) + (package-desc-suffix pkg-desc)))) + (package--with-work-buffer-async location file async + (if (or (not package-check-signature) + (member (package-desc-archive pkg-desc) + package-unsigned-archives)) + ;; If we don't care about the signature, unpack and we're + ;; done. + (progn (let ((save-silently async)) + (package-unpack pkg-desc)) + (funcall callback)) + ;; If we care, check it and *then* write the file. + (let ((content (buffer-string))) + (package--check-signature + location file content async + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + ;; Even if the sig fails, this download is done, so + ;; remove it from the in-progress list. + (error "Unsigned package: `%s'" + (package-desc-name pkg-desc))) + ;; Signature checked, unpack now. + (with-temp-buffer (insert content) + (let ((save-silently async)) + (package-unpack pkg-desc))) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-sigs + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (when-let ((pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))) + (setf (package-desc-signed (car pkg-descs)) t))) + (when (functionp callback) + (funcall callback))))))))) (defun package-installed-p (package &optional min-version) "Return true if PACKAGE, of MIN-VERSION or newer, is installed. @@ -1701,22 +1783,75 @@ If PACKAGE is a package-desc object, MIN-VERSION is ignored." ;; Also check built-in packages. (package-built-in-p package min-version)))) -(defun package-download-transaction (packages) +(defun package-download-transaction (packages &optional async callback) "Download and install all the packages in PACKAGES. PACKAGES should be a list of package-desc. +If ASYNC is non-nil, perform the downloads asynchronously. +If CALLBACK is non-nil, call it with no arguments once the +entire operation is done. + This function assumes that all package requirements in PACKAGES are satisfied, i.e. that PACKAGES is computed using `package-compute-transaction'." - (mapc #'package-install-from-archive packages)) + (cond + (packages (package-install-from-archive + (car packages) + async + (lambda () + (package-download-transaction (cdr packages)) + (when (functionp callback) + (funcall callback))))) + (callback (funcall callback)))) + +(defun package--ensure-init-file () + "Ensure that the user's init file calls `package-initialize'." + ;; Don't mess with the init-file from "emacs -Q". + (when user-init-file + (let* ((buffer (find-buffer-visiting user-init-file)) + (contains-init + (if buffer + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (search-forward "(package-initialize)" nil 'noerror)))) + (with-temp-buffer + (insert-file-contents user-init-file) + (goto-char (point-min)) + (search-forward "(package-initialize)" nil 'noerror))))) + (unless contains-init + (with-current-buffer (or buffer + (let ((delay-mode-hooks t)) + (find-file-noselect user-init-file))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (insert + ";; Added by Package.el. This must come before configurations of\n" + ";; installed packages. Don't delete this line. If you don't want it,\n" + ";; just comment it out by adding a semicolon to the start of the line.\n" + ";; You may delete these explanatory comments.\n" + "(package-initialize)\n") + (unless (looking-at-p "$") + (insert "\n")) + (let ((file-precious-flag t)) + (save-buffer)) + (unless buffer + (kill-buffer (current-buffer)))))))))) ;;;###autoload -(defun package-install (pkg &optional dont-select) +(defun package-install (pkg &optional dont-select async callback) "Install the package PKG. PKG can be a package-desc or the package name of one the available packages in an archive in `package-archives'. Interactively, prompt for its name. If called interactively or if DONT-SELECT nil, add PKG to `package-selected-packages'. +If ASYNC is non-nil, perform the downloads asynchronously. +If CALLBACK is non-nil, call it with no arguments once the +entire operation is done. If PKG is a package-desc and it is already installed, don't try to install it but still mark it as selected." @@ -1741,17 +1876,16 @@ to install it but still mark it as selected." (package-desc-name pkg) pkg))) (unless (or dont-select (package--user-selected-p name)) - (customize-save-variable 'package-selected-packages - (cons name package-selected-packages)))) - (if (package-desc-p pkg) - (if (package-installed-p pkg) - (message "`%s' is already installed" (package-desc-full-name pkg)) - (package-download-transaction - (package-compute-transaction (list pkg) - (package-desc-reqs pkg)))) - (package-download-transaction - (package-compute-transaction () - (list (list pkg)))))) + (package--save-selected-packages + (cons name package-selected-packages)))) + (if-let ((transaction + (if (package-desc-p pkg) + (unless (package-installed-p pkg) + (package-compute-transaction (list pkg) + (package-desc-reqs pkg))) + (package-compute-transaction () (list (list pkg)))))) + (package-download-transaction transaction async callback) + (package--message "`%s' is already installed" (package-desc-full-name pkg)))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -1800,8 +1934,8 @@ Downloads and installs required packages as needed." ;; Install the package itself. (package-unpack pkg-desc) (unless (package--user-selected-p name) - (customize-save-variable 'package-selected-packages - (cons name package-selected-packages))) + (package--save-selected-packages + (cons name package-selected-packages))) pkg-desc)) ;;;###autoload @@ -1868,8 +2002,7 @@ If NOSAVE is non-nil, the package is not removed from ;; Don't deselect if this is an older version of an ;; upgraded package. (package--newest-p pkg-desc)) - (customize-save-variable - 'package-selected-packages (remove name package-selected-packages))) + (package--save-selected-packages (remove name package-selected-packages))) (cond ((not (string-prefix-p (file-name-as-directory (expand-file-name package-user-dir)) (expand-file-name dir))) @@ -1894,7 +2027,7 @@ If NOSAVE is non-nil, the package is not removed from (delete pkg-desc pkgs) (unless (cdr pkgs) (setq package-alist (delq pkgs package-alist)))) - (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) + (package--message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) ;;;###autoload (defun package-reinstall (pkg) @@ -2187,6 +2320,7 @@ will be deleted." (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) (define-key map "?" 'package-menu-describe-package) + (define-key map "(" #'package-menu-hide-obsolete) (define-key map [menu-bar package-menu] (cons "Package" menu-map)) (define-key menu-map [mq] '(menu-item "Quit" quit-window @@ -2241,7 +2375,7 @@ will be deleted." map) "Local keymap for `package-menu-mode' buffers.") -(defvar-local package-menu--new-package-list nil +(defvar package-menu--new-package-list nil "List of newly-available packages since `list-packages' was last called.") (define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" @@ -2249,6 +2383,7 @@ will be deleted." Letters do not insert themselves; instead, they are commands. \\<package-menu-mode-map> \\{package-menu-mode-map}" + (setq mode-line-process '(package--downloads-in-progress ":Loading")) (setq tabulated-list-format `[("Package" 18 package-menu--name-predicate) ("Version" 13 nil) @@ -2336,14 +2471,55 @@ of these dependencies, similar to the list returned by (let* ((ins (cadr (assq name package-alist))) (ins-v (if ins (package-desc-version ins)))) (cond - ((or (null ins) (version-list-< ins-v version)) + ;; Installed obsolete packages are handled in the `dir' + ;; clause above. Here we handle available obsolete, which + ;; are displayed depending on `package-menu--hide-obsolete'. + ((and ins (version-list-<= version ins-v)) "avail-obso") + (t (if (memq name package-menu--new-package-list) - "new" "available")) - ((version-list-< version ins-v) "obsolete") - ((version-list-= version ins-v) - (if (not signed) "unsigned" - (if (package--user-selected-p name) - "installed" "dependency"))))))))) + "new" "available")))))))) + +(defvar package-menu--hide-obsolete t + "Whether available obsolete packages should be hidden. +Can be toggled with \\<package-menu-mode-map> \\[package-menu-hide-obsolete]. +Installed obsolete packages are always displayed.") + +(defun package-menu-hide-obsolete () + "Toggle visibility of obsolete available packages." + (interactive) + (unless (derived-mode-p 'package-menu-mode) + (user-error "The current buffer is not a Package Menu")) + (setq package-menu--hide-obsolete + (not package-menu--hide-obsolete)) + (message "%s available-obsolete packages" (if package-menu--hide-obsolete + "Hiding" "Displaying")) + (revert-buffer nil 'no-confirm)) + +(defun package--remove-hidden (pkg-list) + "Filter PKG-LIST according to `package-archive-priorities'. +PKG-LIST must be a list of package-desc objects sorted by +decreasing version number. +Return a list of packages tied for the highest priority according +to their archives." + (when pkg-list + ;; The first is a variable toggled with + ;; `package-menu-hide-obsolete', the second is a static user + ;; option that defines *what* we hide. + (if (and package-menu--hide-obsolete + package-menu-hide-low-priority) + (let ((max-priority (package-desc-priority (car pkg-list))) + (out (list (pop pkg-list)))) + (dolist (p pkg-list (nreverse out)) + (let ((priority (package-desc-priority p))) + (cond + ((> priority max-priority) + (setq max-priority priority) + (setq out (list p))) + ;; This assumes pkg-list is sorted by version number. + ((and (= priority max-priority) + (eq package-menu-hide-low-priority 'archive)) + (push p out)))))) + pkg-list))) (defun package-menu--refresh (&optional packages keywords) "Re-populate the `tabulated-list-entries'. @@ -2374,10 +2550,11 @@ KEYWORDS should be nil or a list of keywords." (dolist (elt package-archive-contents) (setq name (car elt)) (when (or (eq packages t) (memq name packages)) - (dolist (pkg (cdr elt)) - ;; Hide obsolete packages. - (when (and (not (package-installed-p (package-desc-name pkg) - (package-desc-version pkg))) + (dolist (pkg (package--remove-hidden (cdr elt))) + ;; Hide available obsolete packages. + (when (and (not (and package-menu--hide-obsolete + (package-installed-p (package-desc-name pkg) + (package-desc-version pkg)))) (package--has-keyword-p pkg keywords)) (package--push pkg (package-desc-status pkg) info-list))))) @@ -2387,11 +2564,11 @@ KEYWORDS should be nil or a list of keywords." (defun package-all-keywords () "Collect all package keywords" - (let (keywords) + (let ((key-list)) (package--mapc (lambda (desc) - (let* ((desc-keywords (and desc (package-desc--keywords desc)))) - (setq keywords (append keywords desc-keywords))))) - keywords)) + (setq key-list (append (package-desc--keywords desc) + key-list)))) + key-list)) (defun package--mapc (function &optional packages) "Call FUNCTION for all known PACKAGES. @@ -2430,12 +2607,14 @@ Built-in packages are converted with `package--from-builtin'." "Test if package DESC has any of the given KEYWORDS. When none are given, the package matches." (if keywords - (let* ((desc-keywords (and desc (package-desc--keywords desc))) - found) - (dolist (k keywords) - (when (and (not found) - (member k desc-keywords)) - (setq found t))) + (let ((desc-keywords (and desc (package-desc--keywords desc))) + found) + (while (and (not found) keywords) + (let ((k (pop keywords))) + (setq found + (or (string= k (concat "arc:" (package-desc-archive desc))) + (string= k (concat "status:" (package-desc-status desc))) + (member k desc-keywords))))) found) t)) @@ -2468,6 +2647,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (face (pcase status (`"built-in" 'font-lock-builtin-face) (`"available" 'default) + (`"avail-obso" 'font-lock-comment-face) (`"new" 'bold) (`"held" 'font-lock-constant-face) (`"disabled" 'font-lock-warning-face) @@ -2499,8 +2679,9 @@ This fetches the contents of each archive specified in (interactive) (unless (derived-mode-p 'package-menu-mode) (user-error "The current buffer is not a Package Menu")) - (package-refresh-contents) - (package-menu--generate t t)) + (setq package-menu--old-archive-contents package-archive-contents) + (setq package-menu--new-package-list nil) + (package-refresh-contents package-menu-async)) (defun package-menu-describe-package (&optional button) "Describe the current package. @@ -2524,7 +2705,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-mark-install (&optional _num) "Mark a package for installation and move to the next line." (interactive "p") - (if (member (package-menu-get-status) '("available" "new" "dependency")) + (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency")) (tabulated-list-put-tag "I" t) (forward-line))) @@ -2549,10 +2730,31 @@ If optional arg BUTTON is non-nil, describe its associated package." (tabulated-list-put-tag "D" t) (forward-line 1))))) +(defvar package--quick-help-keys + '(("install," "delete," "unmark," ("execute" . 1)) + ("next," "previous") + ("refresh-contents," "g-redisplay," "filter," "(-toggle-obsolete" "help"))) + +(defun package--prettify-quick-help-key (desc) + "Prettify DESC to be displayed as a help menu." + (if (listp desc) + (if (listp (cdr desc)) + (mapconcat #'package--prettify-quick-help-key desc " ") + (let ((place (cdr desc)) + (out (car desc))) + ;; (setq out (propertize out 'face 'paradox-comment-face)) + (add-text-properties place (1+ place) + '(face (bold font-lock-function-name-face)) + out) + out)) + (package--prettify-quick-help-key (cons desc 0)))) + (defun package-menu-quick-help () - "Show short key binding help for package-menu-mode." + "Show short key binding help for `package-menu-mode'. +The full list of keys can be viewed with \\[describe-mode]." (interactive) - (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp")) + (message (mapconcat #'package--prettify-quick-help-key + package--quick-help-keys "\n"))) (define-obsolete-function-alias 'package-menu-view-commentary 'package-menu-describe-package "24.1") @@ -2579,8 +2781,7 @@ defaults to 0." This allows for easy comparison of package versions from different archives if archive priorities are meant to be taken in consideration." - (cons (package-archive-priority - (package-desc-archive pkg-desc)) + (cons (package-desc-priority pkg-desc) (package-desc-version pkg-desc))) (defun package-menu--find-upgrades () @@ -2632,6 +2833,75 @@ call will upgrade the package." (length upgrades) (if (= (length upgrades) 1) "" "s"))))) +(defun package-menu--list-to-prompt (packages) + "Return a string listing PACKAGES that's usable in a prompt. +PACKAGES is a list of `package-desc' objects. +Formats the returned string to be usable in a minibuffer +prompt (see `package-menu--prompt-transaction-p')." + (cond + ;; None + ((not packages) "") + ;; More than 1 + ((cdr packages) + (format "these %d packages (%s)" + (length packages) + (mapconcat #'package-desc-full-name packages ", "))) + ;; Exactly 1 + (t (format "package `%s'" + (package-desc-full-name (car packages)))))) + +(defun package-menu--prompt-transaction-p (install delete) + "Prompt the user about installing INSTALL and deleting DELETE. +INSTALL and DELETE are lists of `package-desc'. Either may be +nil, but not both." + (let* ((upg (cl-intersection install delete :key #'package-desc-name)) + (ins (cl-set-difference install upg :key #'package-desc-name)) + (del (cl-set-difference delete upg :key #'package-desc-name))) + (y-or-n-p + (concat + (when del "Delete ") + (package-menu--list-to-prompt del) + (when (and del ins) + (if upg "; " "; and ")) + (when ins "Install ") + (package-menu--list-to-prompt ins) + (when (and upg (or ins del)) "; and ") + (when upg "Upgrade ") + (package-menu--list-to-prompt upg) + "? ")))) + +(defun package-menu--perform-transaction (install-list delete-list &optional async) + "Install packages in INSTALL-LIST and delete DELETE-LIST. +If ASYNC is non-nil, perform the installation downloads +asynchronously." + ;; While there are packages to install, call `package-install' on + ;; the next one and defer deletion to the callback function. + (if install-list + (let* ((pkg (car install-list)) + (rest (cdr install-list)) + ;; Don't mark as selected if it's a new version of an + ;; installed package. + (dont-mark (and (not (package-installed-p pkg)) + (package-installed-p + (package-desc-name pkg))))) + (package-install + pkg dont-mark async + (lambda () (package-menu--perform-transaction rest delete-list async)))) + ;; Once there are no more packages to install, proceed to + ;; deletion. + (let ((package--silence async)) + (dolist (elt (package--sort-by-dependence delete-list)) + (condition-case-unless-debug err + (package-delete elt) + (error (message (cadr err))))) + (when package-selected-packages + (when-let ((removable (package--removable-packages))) + (package--message "These %d packages are no longer needed, type `M-x package-autoremove' to remove them (%s)" + (length removable) + (mapconcat #'symbol-name removable ", "))))) + (message "Transaction done") + (package-menu--post-refresh))) + (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. Packages marked for installation are downloaded and installed; @@ -2653,54 +2923,14 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((eq cmd ?I) (push pkg-desc install-list)))) (forward-line))) - (when install-list - (if (or - noquery - (yes-or-no-p - (if (= (length install-list) 1) - (format "Install package `%s'? " - (package-desc-full-name (car install-list))) - (format "Install these %d packages (%s)? " - (length install-list) - (mapconcat #'package-desc-full-name - install-list ", "))))) - (mapc (lambda (p) - ;; Don't mark as selected if it's a new version of - ;; an installed package. - (package-install p (and (not (package-installed-p p)) - (package-installed-p - (package-desc-name p))))) - install-list))) - ;; Delete packages, prompting if necessary. - (when delete-list - (if (or - noquery - (yes-or-no-p - (if (= (length delete-list) 1) - (format "Delete package `%s'? " - (package-desc-full-name (car delete-list))) - (format "Delete these %d packages (%s)? " - (length delete-list) - (mapconcat #'package-desc-full-name - delete-list ", "))))) - (dolist (elt (package--sort-by-dependence delete-list)) - (condition-case-unless-debug err - (package-delete elt) - (error (message (cadr err))))) - (error "Aborted"))) - (if (not (or delete-list install-list)) - (message "No operations specified.") - (when package-selected-packages - (let ((removable (package--removable-packages))) - (when (and removable - (y-or-n-p - (format "These %d packages are no longer needed, delete them (%s)? " - (length removable) - (mapconcat #'symbol-name removable ", ")))) - ;; We know these are removable, so we can use force instead of sorting them. - (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) 'force 'nosave)) - removable)))) - (package-menu--generate t t)))) + (unless (or delete-list install-list) + (user-error "No operations specified")) + (when (or noquery + (package-menu--prompt-transaction-p install-list delete-list)) + (message "Transaction started") + ;; This calls `package-menu--generate' after everything's done. + (package-menu--perform-transaction + install-list delete-list package-menu-async)))) (defun package-menu--version-predicate (A B) (let ((vA (or (aref (cadr A) 1) '(0))) @@ -2716,8 +2946,11 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (package-menu--name-predicate A B)) ((string= sA "new") t) ((string= sB "new") nil) - ((string= sA "available") t) - ((string= sB "available") nil) + ((string-prefix-p "avail" sA) + (if (string-prefix-p "avail" sB) + (package-menu--name-predicate A B) + t)) + ((string-prefix-p "avail" sB) nil) ((string= sA "installed") t) ((string= sB "installed") nil) ((string= sA "dependency") t) @@ -2749,7 +2982,7 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (string< (or (package-desc-archive (car A)) "") (or (package-desc-archive (car B)) ""))) -(defvar-local package-menu--old-archive-contents nil +(defvar package-menu--old-archive-contents nil "`package-archive-contents' before the latest refresh.") (defun package-menu--populate-new-package-list () @@ -2773,9 +3006,8 @@ Store this list in `package-menu--new-package-list'." (defun package-menu--post-refresh () "Check for new packages, revert the *Packages* buffer, and check for upgrades. -This function is called after `package-refresh-contents' is done. -It goes in `package--post-download-archives-hook', so that it -works with async refresh as well." +This function is called after `package-refresh-contents' and +after `package-menu--perform-transaction'." (package-menu--populate-new-package-list) (let ((buf (get-buffer "*Packages*"))) (when (buffer-live-p buf) @@ -2785,10 +3017,10 @@ works with async refresh as well." (defcustom package-menu-async t "If non-nil, package-menu will use async operations when possible. -Currently, only the refreshing of archive contents supports -asynchronous operations. Package transactions are still done -synchronously." +This includes refreshing archive contents as well as installing +packages." :type 'boolean + :version "25.1" :group 'package) ;;;###autoload @@ -2806,17 +3038,17 @@ The list is displayed in a buffer named `*Packages*'." (add-hook 'package--post-download-archives-hook #'package-menu--post-refresh) - (unless no-fetch - (setq package-menu--old-archive-contents package-archive-contents) - (setq package-menu--new-package-list nil) - ;; Fetch the remote list of packages. - (package-refresh-contents package-menu-async)) - ;; Generate the Package Menu. (let ((buf (get-buffer-create "*Packages*"))) (with-current-buffer buf (package-menu-mode) - (package-menu--generate nil t)) + + ;; Fetch the remote list of packages. + (unless no-fetch (package-menu-refresh)) + + ;; If we're not async, this would be redundant. + (when package-menu-async + (package-menu--generate nil t))) ;; The package menu buffer has keybindings. If the user types ;; `M-x list-packages', that suggests it should become current. (switch-to-buffer buf))) @@ -2849,9 +3081,17 @@ shown." (defun package-menu-filter (keyword) "Filter the *Packages* buffer. Show only those items that relate to the specified KEYWORD. +KEYWORD can be a string or a list of strings. If it is a list, a +package will be displayed if it matches any of the keywords. +Interactively, it is a list of strings separated by commas. + To restore the full package list, type `q'." - (interactive (list (completing-read "Keyword: " (package-all-keywords)))) - (package-show-package-list t (list keyword))) + (interactive + (list (completing-read-multiple + "Keywords (comma separated): " (package-all-keywords)))) + (package-show-package-list t (if (stringp keyword) + (list keyword) + keyword))) (defun package-list-packages-no-fetch () "Display a list of packages. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 3a2fa4fdc81..978c3f0dd30 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -75,22 +75,32 @@ (&or symbolp ("or" &rest pcase-UPAT) ("and" &rest pcase-UPAT) - ("`" pcase-QPAT) ("guard" form) ("let" pcase-UPAT form) - ("pred" - &or lambda-expr - ;; Punt on macros/special forms. - (functionp &rest form) - sexp) + ("pred" pcase-FUN) + ("app" pcase-FUN pcase-UPAT) + pcase-MACRO sexp)) (def-edebug-spec - pcase-QPAT - (&or ("," pcase-UPAT) - (pcase-QPAT . pcase-QPAT) + pcase-FUN + (&or lambda-expr + ;; Punt on macros/special forms. + (functionp &rest form) sexp)) +(def-edebug-spec pcase-MACRO pcase--edebug-match-macro) + +(defun pcase--edebug-match-macro (cursor) + (let (specs) + (mapatoms + (lambda (s) + (let ((m (get s 'pcase-macroexpander))) + (when (and m (get-edebug-spec m)) + (push (cons (symbol-name s) (get-edebug-spec m)) + specs))))) + (edebug-match cursor (cons '&or specs)))) + ;;;###autoload (defmacro pcase (exp &rest cases) "Perform ML-style pattern matching on EXP. @@ -253,6 +263,7 @@ of the form (UPAT EXP)." (push (list (car binding) tmpvar) matches))))) `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) +;;;###autoload (defmacro pcase-dolist (spec &rest body) (declare (indent 1) (debug ((pcase-UPAT form) body))) (if (pcase--trivial-upat-p (car spec)) @@ -362,11 +373,14 @@ of the form (UPAT EXP)." (defmacro pcase-defmacro (name args &rest body) "Define a pcase UPattern macro." (declare (indent 2) (debug defun) (doc-string 3)) - (let ((fsym (intern (format "%s--pcase-macroexpander" name)))) - ;; Add the function via `fsym', so that an autoload cookie placed - ;; on a pcase-defmacro will cause the macro to be loaded on demand. + ;; Add the function via `fsym', so that an autoload cookie placed + ;; on a pcase-defmacro will cause the macro to be loaded on demand. + (let ((fsym (intern (format "%s--pcase-macroexpander" name))) + (decl (assq 'declare body))) + (when decl (setq body (remove decl body))) `(progn (defun ,fsym ,args ,@body) + (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl))) (put ',name 'pcase-macroexpander #',fsym)))) (defun pcase--match (val upat) @@ -828,6 +842,13 @@ Otherwise, it defers to REST which is a list of branches of the form (t (error "Unknown internal pattern `%S'" upat))))) (t (error "Incorrect MATCH %S" (car matches))))) +(def-edebug-spec + pcase-QPAT + (&or ("," pcase-UPAT) + (pcase-QPAT . pcase-QPAT) + (vector &rest pcase-QPAT) + sexp)) + (pcase-defmacro \` (qpat) "Backquote-style pcase patterns. QPAT can take the following forms: @@ -837,6 +858,7 @@ QPAT can take the following forms: ,UPAT matches if the UPattern UPAT matches. STRING matches if the object is `equal' to STRING. ATOM matches if the object is `eq' to ATOM." + (declare (debug (pcase-QPAT))) (cond ((eq (car-safe qpat) '\,) (cadr qpat)) ((vectorp qpat) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 20af59f2abf..520210614f5 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -965,20 +965,20 @@ CHAR matches space and tab only. `graphic', `graph' - matches graphic characters--everything except ASCII control chars, - space, and DEL. + matches graphic characters--everything except whitespace, ASCII + and non-ASCII control characters, surrogates, and codepoints + unassigned by Unicode. `printing', `print' - matches printing characters--everything except ASCII control chars - and DEL. + matches whitespace and graphic characters. `alphanumeric', `alnum' - matches letters and digits. (But at present, for multibyte characters, - it matches anything that has word syntax.) + matches alphabetic characters and digits. (For multibyte characters, + it matches according to Unicode character properties.) `letter', `alphabetic', `alpha' - matches letters. (But at present, for multibyte characters, - it matches anything that has word syntax.) + matches alphabetic characters. (For multibyte characters, + it matches according to Unicode character properties.) `ascii' matches ASCII (unibyte) characters. diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index c5f5906e7e5..0050ff0a303 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: sequences -;; Version: 1.3 +;; Version: 1.4 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -44,31 +44,28 @@ (defmacro seq-doseq (spec &rest body) "Loop over a sequence. -Similar to `dolist' but can be applied lists, strings and vectors. +Similar to `dolist' but can be applied to lists, strings, and vectors. Evaluate BODY with VAR bound to each element of SEQ, in turn. -Then evaluate RESULT to get return value, default nil. -\(fn (VAR SEQ [RESULT]) BODY...)" +\(fn (VAR SEQ) BODY...)" (declare (indent 1) (debug ((symbolp form &optional form) body))) - (let ((is-list (make-symbol "is-list")) + (let ((length (make-symbol "length")) (seq (make-symbol "seq")) (index (make-symbol "index"))) `(let* ((,seq ,(cadr spec)) - (,is-list (listp ,seq)) - (,index (if ,is-list ,seq 0))) - (while (if ,is-list - (consp ,index) - (< ,index (seq-length ,seq))) - (let ((,(car spec) (if ,is-list - (car ,index) - (seq-elt ,seq ,index)))) - ,@body - (setq ,index (if ,is-list - (cdr ,index) - (+ ,index 1))))) - ,@(if (cddr spec) - `((setq ,(car spec) nil) ,@(cddr spec)))))) + (,length (if (listp ,seq) nil (seq-length ,seq))) + (,index (if ,length 0 ,seq))) + (while (if ,length + (< ,index ,length) + (consp ,index)) + (let ((,(car spec) (if ,length + (prog1 (seq-elt ,seq ,index) + (setq ,index (+ ,index 1))) + (pop ,index)))) + ,@body)) + ;; FIXME: Do we really want to support this? + ,@(cddr spec)))) (defun seq-drop (seq n) "Return a subsequence of SEQ without its first N elements. @@ -221,7 +218,7 @@ TYPE must be one of following symbols: vector, string or list. (`vector (apply #'vconcat seqs)) (`string (apply #'concat seqs)) (`list (apply #'append (append seqs '(nil)))) - (t (error "Not a sequence type name: %s" type)))) + (t (error "Not a sequence type name: %S" type)))) (defun seq-mapcat (function seq &optional type) "Concatenate the result of applying FUNCTION to each element of SEQ. @@ -240,6 +237,26 @@ negative integer or 0, nil is returned." (setq seq (seq-drop seq n))) (nreverse result)))) +(defun seq-intersection (seq1 seq2 &optional testfn) + "Return a list of the elements that appear in both SEQ1 and SEQ2. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (seq-reduce (lambda (acc elt) + (if (seq-contains-p seq2 elt testfn) + (cons elt acc) + acc)) + (seq-reverse seq1) + '())) + +(defun seq-difference (seq1 seq2 &optional testfn) + "Return a list of th elements that appear in SEQ1 but not in SEQ2. +Equality is defined by TESTFN if non-nil or by `equal' if nil." + (seq-reduce (lambda (acc elt) + (if (not (seq-contains-p seq2 elt testfn)) + (cons elt acc) + acc)) + (seq-reverse seq1) + '())) + (defun seq-group-by (function seq) "Apply FUNCTION to each element of SEQ. Separate the elements of SEQ into an alist using the results as @@ -275,7 +292,7 @@ TYPE can be one of the following symbols: vector, string or list." (`vector (vconcat seq)) (`string (concat seq)) (`list (append seq nil)) - (t (error "Not a sequence type name: %s" type)))) + (t (error "Not a sequence type name: %S" type)))) (defun seq--drop-list (list n) "Return a list from LIST without its first N elements. @@ -318,6 +335,11 @@ This is an optimization for lists in `seq-take-while'." (setq n (+ 1 n))) n)) +(defun seq--activate-font-lock-keywords () + "Activate font-lock keywords for some symbols defined in seq." + (font-lock-add-keywords 'emacs-lisp-mode + '("\\<seq-doseq\\>"))) + (defalias 'seq-copy #'copy-sequence) (defalias 'seq-elt #'elt) (defalias 'seq-length #'length) @@ -325,5 +347,10 @@ This is an optimization for lists in `seq-take-while'." (defalias 'seq-each #'seq-do) (defalias 'seq-map #'mapcar) +(unless (fboundp 'elisp--font-lock-flush-elisp-buffers) + ;; In Emacsā„25, (via elisp--font-lock-flush-elisp-buffers and a few others) + ;; we automatically highlight macros. + (add-to-list 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) + (provide 'seq) ;;; seq.el ends here |