diff options
Diffstat (limited to 'lisp/emacs-lisp')
36 files changed, 1300 insertions, 860 deletions
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 212ae909866..907f03bde45 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -2149,7 +2149,6 @@ the cache-id will clear the cache." (defun ad-arglist (definition) "Return the argument list of DEFINITION." - (require 'help-fns) (help-function-arglist (if (or (macrop definition) (ad-advice-p definition)) (cdr definition) @@ -2474,8 +2473,6 @@ Example: `(ad-map-arglists '(a &rest args) '(w x y z))' will return (capitalize (symbol-name class)) (ad-advice-name advice))))))) -(require 'help-fns) ;For help-split-fundoc and help-add-fundoc-usage. - (defun ad--make-advised-docstring (function &optional style) "Construct a documentation string for the advised FUNCTION. Concatenate the original documentation with the documentation diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 206d5bb4434..a6fefebf3f5 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -32,7 +32,6 @@ (require 'lisp-mode) ;for `doc-string-elt' properties. (require 'lisp-mnt) -(require 'help-fns) ;for help-add-fundoc-usage. (eval-when-compile (require 'cl-lib)) (defvar generated-autoload-file nil diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index d5cdca2b1b5..dc61e156130 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -99,9 +99,9 @@ places where expressions are evaluated and inserted or spliced in. For example: b => (ba bb bc) ; assume b has this value -`(a b c) => (a b c) ; backquote acts like quote -`(a ,b c) => (a (ba bb bc) c) ; insert the value of b -`(a ,@b c) => (a ba bb bc c) ; splice in the value of b +\\=`(a b c) => (a b c) ; backquote acts like quote +\\=`(a ,b c) => (a (ba bb bc) c) ; insert the value of b +\\=`(a ,@b c) => (a ba bb bc c) ; splice in the value of b Vectors work just like lists. Nested backquotes are permitted." (cdr (backquote-process structure))) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 06a11063025..30147931adc 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -566,7 +566,7 @@ (cons fn args))))))) (defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `macroexp-const-p" + "Non-nil if all elements of LIST satisfy `macroexp-const-p'." (let ((constant t)) (while (and list constant) (unless (macroexp-const-p (car list)) @@ -1225,7 +1225,7 @@ window-left-child window-left-column window-margins window-minibuffer-p window-next-buffers window-next-sibling window-new-normal window-new-total window-normal-size window-parameter window-parameters - window-parent window-pixel-edges window-point window-prev-buffers + window-parent window-pixel-edges window-point window-prev-buffers window-prev-sibling window-redisplay-end-trigger window-scroll-bars window-start window-text-height window-top-child window-top-line window-total-height window-total-width window-use-time window-vscroll diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 51bbf8a2944..efd43898b60 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -348,7 +348,7 @@ else the global value will be modified." ;;;###autoload (defun byte-compile-enable-warning (warning) "Change `byte-compile-warnings' to enable WARNING. -If `byte-compile-warnings' is `t', do nothing. Otherwise, if the +If `byte-compile-warnings' is t, do nothing. Otherwise, if the first element is `not', remove WARNING, else add it. Normally you should let-bind `byte-compile-warnings' before calling this, else the global value will be modified." @@ -979,17 +979,6 @@ 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 @@ -997,7 +986,7 @@ is not displayed on the minibuffer." (goto-char (point-max)) (byte-compile-warning-prefix nil nil) (cond (noninteractive - (byte-compile--message " %s" string)) + (message " %s" string)) (t (insert (format "%s\n" string))))))) @@ -1601,10 +1590,7 @@ 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): ") - (let ((byte-compile--interactive - (or byte-compile--interactive - (called-interactively-p 'any)))) - (byte-recompile-directory directory nil t))) + (byte-recompile-directory directory nil t)) ;;;###autoload (defun byte-recompile-directory (directory &optional arg force) @@ -1634,9 +1620,6 @@ 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) @@ -1645,7 +1628,7 @@ that already has a `.elc' file." (displaying-byte-compile-warnings (while directories (setq directory (car directories)) - (byte-compile--message "Checking %s..." directory) + (message "Checking %s..." directory) (dolist (file (directory-files directory)) (let ((source (expand-file-name file directory))) (if (file-directory-p source) @@ -1670,13 +1653,13 @@ that already has a `.elc' file." (`t file-count) (_ fail-count))) (or noninteractive - (byte-compile--message "Checking %s..." directory)) + (message "Checking %s..." directory)) (if (not (eq last-dir directory)) (setq last-dir directory dir-count (1+ dir-count))) ))))) (setq directories (cdr directories)))) - (byte-compile--message "Done (Total of %d file%s compiled%s%s%s)" + (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) "") @@ -1723,10 +1706,7 @@ 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)) - (byte-compile--interactive - (or byte-compile--interactive - (called-interactively-p 'any)))) + (filename (expand-file-name filename))) (if (if (file-exists-p dest) ;; File was already compiled ;; Compile if forced to, or filename newer @@ -1738,7 +1718,7 @@ If compilation is needed, this functions returns the result of filename "? "))))) (progn (if (and noninteractive (not byte-compile-verbose)) - (byte-compile--message "Compiling %s..." filename)) + (message "Compiling %s..." filename)) (byte-compile-file filename load)) (when load (load (if (file-exists-p dest) dest filename))) @@ -1782,9 +1762,6 @@ 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)) @@ -1840,14 +1817,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) - (byte-compile--message "%s deleted because of `no-byte-compile: %s'" + (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 - (byte-compile--message "Compiling %s..." filename)) + (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 @@ -1859,7 +1836,7 @@ The value is non-nil if there were no errors, nil if errors." (if byte-compiler-error-flag nil (when byte-compile-verbose - (byte-compile--message "Compiling %s...done" filename)) + (message "Compiling %s...done" filename)) (kill-buffer input-buffer) (with-current-buffer output-buffer (goto-char (point-max)) @@ -1885,7 +1862,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 (byte-compile--message "Wrote %s" target-file))) + (or noninteractive (message "Wrote %s" target-file))) ;; This is just to give a better error message than write-region (signal 'file-error (list "Opening output file" @@ -1919,9 +1896,6 @@ 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)) @@ -1929,10 +1903,10 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-sexp (read (current-buffer))))) lexical-binding))) (cond (arg - (byte-compile--message "Compiling from buffer... done.") + (message "Compiling from buffer... done.") (prin1 value (current-buffer)) (insert "\n")) - ((byte-compile--message "%s" (prin1-to-string value))))))) + ((message "%s" (prin1-to-string value))))))) (defun byte-compile-from-buffer (inbuffer) (let ((byte-compile-current-buffer inbuffer) @@ -2436,7 +2410,7 @@ not to take responsibility for the actual compilation of the code." (byte-compile-arglist-warn name arglist macro)) (if byte-compile-verbose - (byte-compile--message "Compiling %s... (%s)" + (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 @@ -2606,7 +2580,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) - (byte-compile--message "Function %s is already compiled" + (message "Function %s is already compiled" (if (symbolp form) form "provided")) fun) (t @@ -2946,11 +2920,17 @@ for symbols generated by the byte compiler itself." ;; Special macro-expander used during byte-compilation. (defun byte-compile-macroexpand-declare-function (fn file &rest args) - (push (cons fn - (if (and (consp args) (listp (car args))) - (list 'declared (car args)) - t)) ; Arglist not specified. - byte-compile-function-environment) + (let ((gotargs (and (consp args) (listp (car args)))) + (unresolved (assq fn byte-compile-unresolved-functions))) + (when unresolved ; function was called before declaration + (if (and gotargs (byte-compile-warning-enabled-p 'callargs)) + (byte-compile-arglist-warn fn (car args) nil) + (setq byte-compile-unresolved-functions + (delq unresolved byte-compile-unresolved-functions)))) + (push (cons fn (if gotargs + (list 'declared (car args)) + t)) ; Arglist not specified. + byte-compile-function-environment)) ;; We are stating that it _will_ be defined at runtime. (setq byte-compile-noruntime-functions (delq fn byte-compile-noruntime-functions)) @@ -4424,8 +4404,8 @@ binding slots have been popped." name macro arglist body rest) (when macro (if (null fun) - (byte-compile--message "Macro %s unrecognized, won't work in file" name) - (byte-compile--message "Macro %s partly recognized, trying our luck" name) + (message "Macro %s unrecognized, won't work in file" name) + (message "Macro %s partly recognized, trying our luck" name) (push (cons name (eval fun)) byte-compile-macro-environment))) (byte-compile-keep-pending form)))) @@ -4551,11 +4531,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) - (byte-compile--message "Generating call tree...") + (message "Generating call tree...") (with-output-to-temp-buffer "*Call-Tree*" (set-buffer "*Call-Tree*") (erase-buffer) - (byte-compile--message "Generating call tree... (sorting on %s)" + (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/chart.el b/lisp/emacs-lisp/chart.el index 851b3bfc6fd..06601252a4c 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -280,7 +280,7 @@ START and END represent the boundary." "Draw axis information based upon a range to be spread along the edge. A is the chart to draw. DIR is the direction. MARGIN, ZONE, START, and END specify restrictions in chart space." - (call-next-method) + (cl-call-next-method) ;; We prefer about 5 spaces between each value (let* ((i (car (oref a bounds))) (e (cdr (oref a bounds))) @@ -333,7 +333,7 @@ Automatically compensates for direction." "Draw axis information based upon A range to be spread along the edge. Optional argument DIR is the direction of the chart. Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing." - (call-next-method) + (cl-call-next-method) ;; We prefer about 5 spaces between each value (let* ((i 0) (s (oref a items)) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 8fc299d7e93..ecdb6d8983c 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -98,7 +98,7 @@ don't know how to recognize (e.g. some macros)." (stringp (setq fnfile (nth 2 form))) (setq fnfile (check-declare-locate fnfile (expand-file-name file))) - ;; Use `t' to distinguish unspecified arglist from empty one. + ;; Use t to distinguish unspecified arglist from empty one. (or (eq t (setq arglist (if (> len 3) (nth 3 form) t))) @@ -157,6 +157,7 @@ is a string giving details of the error." (setq re (format (if cflag "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" "^[ \t]*(\\(fset[ \t]+'\\|\ +cl-def\\(?:generic\\|method\\)\\|\ def\\(?:un\\|subst\\|foo\\|method\\|class\\|\ ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\ \\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\ @@ -200,8 +201,8 @@ ine-overloadable-function\\)\\)\ type) 'obsolete) ;; Can't easily check arguments in these cases. - ((string-match "\\`\\(def\\(alias\\|\ -method\\|class\\)\\|fset\\)\\>" type) + ((string-match "\\`\\(def\\(alias\\|class\\)\\|\ +fset\\|\\(?:cl-\\)?defmethod\\)\\>" type) t) ((looking-at "\\((\\|nil\\)") (byte-compile-arglist-signature @@ -284,6 +285,8 @@ TYPE is a string giving the nature of the error. Warning is displayed in type) nil check-declare-warning-buffer))) +(declare-function compilation-forget-errors "compile" ()) + (defun check-declare-files (&rest files) "Check veracity of all `declare-function' statements in FILES. Return a list of any errors found." diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 777fed082d9..4761ac5e6fc 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1524,7 +1524,7 @@ may require more formatting") ;; Instead, use the `\\[...]' construct to stand for them. (save-excursion (let ((f nil) (m nil) (start (point)) - (re "[^`A-Za-z0-9_]\\([CMA]-[a-zA-Z]\\|\\(\\([CMA]-\\)?\ + (re "[^`‘A-Za-z0-9_]\\([CMA]-[a-zA-Z]\\|\\(\\([CMA]-\\)?\ mouse-[0-3]\\)\\)\\>")) ;; Find the first key sequence not in a sample (while (and (not f) (setq m (re-search-forward re e t))) @@ -1554,7 +1554,8 @@ mouse-[0-3]\\)\\)\\>")) (save-excursion (let ((case-fold-search t) (ret nil) mb me) - (while (and (re-search-forward "`\\(\\sw\\(\\sw\\|\\s_\\)+\\)'" e t) + (while (and (re-search-forward + "[`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\)['’]" e t) (not ret)) (let* ((ms1 (match-string 1)) (sym (intern-soft ms1))) @@ -1615,8 +1616,8 @@ function,command,variable,option or symbol." ms1)))))) (or ;; * The documentation string for a variable that is a ;; yes-or-no flag should start with words such as Non-nil - ;; means..., to make it clear that all non-`nil' values are - ;; equivalent and indicate explicitly what `nil' and non-`nil' + ;; means..., to make it clear that all non-nil values are + ;; equivalent and indicate explicitly what nil and non-nil ;; mean. ;; * If a user option variable records a true-or-false ;; condition, give it a name that ends in `-flag'. @@ -1785,16 +1786,17 @@ Replace with \"%s\"? " original replace) ))) ;;* When a documentation string refers to a Lisp symbol, write it as ;; it would be printed (which usually means in lower case), with - ;; single-quotes around it. For example: `lambda'. There are two - ;; exceptions: write t and nil without single-quotes. (In this - ;; manual, we normally do use single-quotes for those symbols.) + ;; single-quotes around it. For example: ‘lambda’. There are two + ;; exceptions: write t and nil without single-quotes. (For + ;; compatibility with an older Emacs style, quoting with ` and ' + ;; also works, e.g., `lambda' is treated like ‘lambda’.) (save-excursion (let ((found nil) (start (point)) (msg nil) (ms nil)) (while (and (not msg) (re-search-forward ;; Ignore manual page references like ;; git-config(1). - "[^-([`':a-zA-Z]\\(\\w+[:-]\\(\\w\\|\\s_\\)+\\)[^](']" + "[^-([`'‘’:a-zA-Z]\\(\\w+[:-]\\(\\w\\|\\s_\\)+\\)[^]('’]" e t)) (setq ms (match-string 1)) ;; A . is a \s_ char, so we must remove periods from @@ -1812,7 +1814,7 @@ Replace with \"%s\"? " original replace) (if (checkdoc-autofix-ask-replace (match-beginning 1) (+ (match-beginning 1) (length ms)) - msg (concat "`" ms "'") t) + msg (concat "‘" ms "’") t) (setq msg nil) (setq msg (format "Lisp symbol `%s' should appear in quotes" @@ -1824,7 +1826,7 @@ Replace with \"%s\"? " original replace) nil))) ;; t and nil case (save-excursion - (if (re-search-forward "\\(`\\(t\\|nil\\)'\\)" e t) + (if (re-search-forward "\\([`‘]\\(t\\|nil\\)['’]\\)" e t) (if (checkdoc-autofix-ask-replace (match-beginning 1) (match-end 1) (format "%s should not appear in quotes. Remove? " @@ -1989,7 +1991,7 @@ If the offending word is in a piece of quoted text, then it is skipped." (if (and (not (save-excursion (goto-char b) (forward-char -1) - (looking-at "`\\|\"\\|\\.\\|\\\\"))) + (looking-at "[`\".‘]\\|\\\\"))) ;; surrounded by /, as in a URL or filename: /emacs/ (not (and (= ?/ (char-after e)) (= ?/ (char-before b)))) @@ -2405,7 +2407,7 @@ Argument END is the maximum bounds to search in." According to the documentation for the function `error', the error list should not end with a period, and should start with a capital letter. The function `y-or-n-p' has similar constraints. -Argument TYPE specifies the type of question, such as `error or `y-or-n-p." +Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." ;; If type is nil, then attempt to derive it. (if (not type) (save-excursion @@ -2613,9 +2615,12 @@ function called to create the messages." (count-lines (point-min) (or point (point-min)))) ": " msg))) (with-current-buffer (get-buffer checkdoc-diagnostic-buffer) - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (apply #'insert text))))) + (let ((inhibit-read-only t) + (pt (point-max))) + (goto-char pt) + (apply #'insert text) + (when noninteractive + (warn (buffer-substring pt (point-max)))))))) (defun checkdoc-show-diagnostics () "Display the checkdoc diagnostic buffer in a temporary window." diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index fb11a3e25a1..96b86aa21cc 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -54,6 +54,15 @@ ;; - The standard method combination supports ":extra STRING" qualifiers ;; which simply allows adding more methods for the same ;; specializers&qualifiers. +;; - Methods can dispatch on the context. For that, a method needs to specify +;; context arguments, introduced by `&context' (which need to come right +;; after the mandatory arguments and before anything like +;; &optional/&rest/&key). Each context argument is given as (EXP SPECIALIZER) +;; which means that EXP is taken as an expression which computes some context +;; and this value is then used to dispatch. +;; E.g. (foo &context (major-mode (eql c-mode))) is an arglist specifying +;; that this method will only be applicable when `major-mode' has value +;; `c-mode'. ;; Efficiency considerations: overall, I've made an effort to make this fairly ;; efficient for the expected case (e.g. no constant redefinition of methods). @@ -222,25 +231,25 @@ BODY, if present, is used as the body of a default method. ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) (nreverse methods))))) -(defun cl--generic-mandatory-args (args) - (let ((res ())) - (while (not (memq (car args) '(nil &rest &optional &key))) - (push (pop args) res)) - (nreverse res))) - ;;;###autoload (defun cl-generic-define (name args options) - (let ((generic (cl-generic-ensure-function name)) - (mandatory (cl--generic-mandatory-args args)) - (apo (assq :argument-precedence-order options))) - (setf (cl--generic-dispatches generic) nil) + (pcase-let* ((generic (cl-generic-ensure-function name)) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (mandatory (mapcar #'car spec-args)) + (apo (assq :argument-precedence-order options))) + (unless (fboundp name) + ;; If the generic function was fmakunbound, throw away previous methods. + (setf (cl--generic-dispatches generic) nil) + (setf (cl--generic-method-table generic) nil)) (when apo (dolist (arg (cdr apo)) (let ((pos (memq arg mandatory))) (unless pos (error "%S is not a mandatory argument" arg)) - (push (list (- (length mandatory) (length pos))) - (cl--generic-dispatches generic))))) - (setf (cl--generic-method-table generic) nil) + (let* ((argno (- (length mandatory) (length pos))) + (dispatches (cl--generic-dispatches generic)) + (dispatch (or (assq argno dispatches) (list argno)))) + (setf (cl--generic-dispatches generic) + (cons dispatch (delq dispatch dispatches))))))) (setf (cl--generic-options generic) options) (cl--generic-make-function generic))) @@ -259,52 +268,70 @@ This macro can only be used within the lexical scope of a cl-generic method." (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) res)) - (defun cl--generic-lambda (args body) - "Make the lambda expression for a method with ARGS and BODY." + (defun cl--generic-split-args (args) + "Return (SPEC-ARGS . PLAIN-ARGS)." (let ((plain-args ()) (specializers nil) (mandatory t)) (dolist (arg args) (push (pcase arg ((or '&optional '&rest '&key) (setq mandatory nil) arg) - ((and `(,name . ,type) (guard mandatory)) + ('&context + (unless mandatory + (error "&context not immediately after mandatory args")) + (setq mandatory 'context) nil) + ((let 'nil mandatory) arg) + ((let 'context mandatory) + (unless (consp arg) + (error "Invalid &context arg: %S" arg)) + (push `((&context . ,(car arg)) . ,(cadr arg)) specializers) + nil) + (`(,name . ,type) (push (cons name (car type)) specializers) name) - (_ arg)) + (_ + (push (cons arg t) specializers) + arg)) plain-args)) - (setq plain-args (nreverse plain-args)) - (let ((fun `(cl-function (lambda ,plain-args ,@body))) - (macroenv (cons `(cl-generic-current-method-specializers - . ,(lambda () specializers)) - macroexpand-all-environment))) - (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. - ;; First macroexpand away the cl-function stuff (e.g. &key and - ;; destructuring args, `declare' and whatnot). - (pcase (macroexpand fun macroenv) - (`#'(lambda ,args . ,body) - (let* ((parsed-body (macroexp-parse-body body)) - (cnm (make-symbol "cl--cnm")) - (nmp (make-symbol "cl--nmp")) - (nbody (macroexpand-all - `(cl-flet ((cl-call-next-method ,cnm) - (cl-next-method-p ,nmp)) - ,@(cdr parsed-body)) - macroenv)) - ;; FIXME: Rather than `grep' after the fact, the - ;; macroexpansion should directly set some flag when cnm - ;; is used. - ;; FIXME: Also, optimize the case where call-next-method is - ;; only called with explicit arguments. - (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) - (cons (not (not uses-cnm)) - `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(car parsed-body) - ,(if (not (memq nmp uses-cnm)) - nbody - `(let ((,nmp (lambda () - (cl--generic-isnot-nnm-p ,cnm)))) - ,nbody)))))) - (f (error "Unexpected macroexpansion result: %S" f))))))) + (cons (nreverse specializers) + (nreverse (delq nil plain-args))))) + + (defun cl--generic-lambda (args body) + "Make the lambda expression for a method with ARGS and BODY." + (pcase-let* ((`(,spec-args . ,plain-args) + (cl--generic-split-args args)) + (fun `(cl-function (lambda ,plain-args ,@body))) + (macroenv (cons `(cl-generic-current-method-specializers + . ,(lambda () spec-args)) + macroexpand-all-environment))) + (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. + ;; First macroexpand away the cl-function stuff (e.g. &key and + ;; destructuring args, `declare' and whatnot). + (pcase (macroexpand fun macroenv) + (`#'(lambda ,args . ,body) + (let* ((parsed-body (macroexp-parse-body body)) + (cnm (make-symbol "cl--cnm")) + (nmp (make-symbol "cl--nmp")) + (nbody (macroexpand-all + `(cl-flet ((cl-call-next-method ,cnm) + (cl-next-method-p ,nmp)) + ,@(cdr parsed-body)) + macroenv)) + ;; FIXME: Rather than `grep' after the fact, the + ;; macroexpansion should directly set some flag when cnm + ;; is used. + ;; FIXME: Also, optimize the case where call-next-method is + ;; only called with explicit arguments. + (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) + (cons (not (not uses-cnm)) + `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) + ,@(car parsed-body) + ,(if (not (memq nmp uses-cnm)) + nbody + `(let ((,nmp (lambda () + (cl--generic-isnot-nnm-p ,cnm)))) + ,nbody)))))) + (f (error "Unexpected macroexpansion result: %S" f)))))) ;;;###autoload @@ -375,21 +402,26 @@ which case this method will be invoked when the argument is `eql' to VAL. ;;;###autoload (defun cl-generic-define-method (name qualifiers args uses-cnm function) - (let* ((generic (cl-generic-ensure-function name)) - (mandatory (cl--generic-mandatory-args args)) - (specializers - (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) - (method (cl--generic-make-method - specializers qualifiers uses-cnm function)) - (mt (cl--generic-method-table generic)) - (me (cl--generic-member-method specializers qualifiers mt)) - (dispatches (cl--generic-dispatches generic)) - (i 0)) - (dolist (specializer specializers) - (let* ((generalizers (cl-generic-generalizers specializer)) - (x (assq i dispatches))) + (pcase-let* + ((generic (cl-generic-ensure-function name)) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (specializers (mapcar (lambda (spec-arg) + (if (eq '&context (car-safe (car spec-arg))) + spec-arg (cdr spec-arg))) + spec-args)) + (method (cl--generic-make-method + specializers qualifiers uses-cnm function)) + (mt (cl--generic-method-table generic)) + (me (cl--generic-member-method specializers qualifiers mt)) + (dispatches (cl--generic-dispatches generic)) + (i 0)) + (dolist (spec-arg spec-args) + (let* ((key (if (eq '&context (car-safe (car spec-arg))) + (car spec-arg) i)) + (generalizers (cl-generic-generalizers (cdr spec-arg))) + (x (assoc key dispatches))) (unless x - (setq x (cons i (cl-generic-generalizers t))) + (setq x (cons key (cl-generic-generalizers t))) (setf (cl--generic-dispatches generic) (setq dispatches (cons x dispatches)))) (dolist (generalizer generalizers) @@ -400,8 +432,10 @@ which case this method will be invoked when the argument is `eql' to VAL. (> (cl--generic-generalizer-priority x) (cl--generic-generalizer-priority y))))))) (setq i (1+ i)))) - (if me (setcar me method) - (setf (cl--generic-method-table generic) (cons method mt))) + ;; We used to (setcar me method), but that can cause false positives in + ;; the hash-consing table of the method-builder (bug#20644). + ;; See the related FIXME in cl--generic-build-combined-method. + (setf (cl--generic-method-table generic) (cons method (delq (car me) mt))) (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) current-load-list :test #'equal) ;; FIXME: Try to avoid re-constructing a new function if the old one @@ -411,7 +445,14 @@ which case this method will be invoked when the argument is `eql' to VAL. ;; the generic function. current-load-list) ;; For aliases, cl--generic-name gives us the actual name. - (defalias (cl--generic-name generic) gfun)))) + (let ((purify-flag + ;; BEWARE! Don't purify this function definition, since that leads + ;; to memory corruption if the hash-tables it holds are modified + ;; (the GC doesn't trace those pointers). + nil)) + ;; But do use `defalias', so that it interacts properly with nadvice, + ;; e.g. for tracing/debug-on-entry. + (defalias (cl--generic-name generic) gfun))))) (defmacro cl--generic-with-memoization (place &rest code) (declare (indent 1) (debug t)) @@ -427,6 +468,7 @@ which case this method will be invoked when the argument is `eql' to VAL. (defun cl--generic-get-dispatcher (dispatch) (cl--generic-with-memoization (gethash dispatch cl--generic-dispatchers) + ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) (generalizers (cdr dispatch)) (lexical-binding t) @@ -437,13 +479,14 @@ which case this method will be invoked when the argument is `eql' to VAL. 'arg)) generalizers)) (typescodes - (mapcar (lambda (generalizer) - `(funcall ',(cl--generic-generalizer-specializers-function - generalizer) - ,(funcall (cl--generic-generalizer-tagcode-function - generalizer) - 'arg))) - generalizers)) + (mapcar + (lambda (generalizer) + `(funcall ',(cl--generic-generalizer-specializers-function + generalizer) + ,(funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg))) + generalizers)) (tag-exp ;; Minor optimization: since this tag-exp is ;; only used to lookup the method-cache, it @@ -452,23 +495,30 @@ which case this method will be invoked when the argument is `eql' to VAL. `(or ,@(if (macroexp-const-p (car (last tagcodes))) (butlast tagcodes) tagcodes))) - (extraargs ())) - (dotimes (_ dispatch-arg) - (push (make-symbol "arg") extraargs)) + (fixedargs '(arg)) + (dispatch-idx dispatch-arg) + (bindings nil)) + (when (eq '&context (car-safe dispatch-arg)) + (setq bindings `((arg ,(cdr dispatch-arg)))) + (setq fixedargs nil) + (setq dispatch-idx 0)) + (dotimes (i dispatch-idx) + (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs)) ;; FIXME: For generic functions with a single method (or with 2 methods, ;; one of which always matches), using a tagcode + hash-table is ;; overkill: better just use a `cl-typep' test. (byte-compile `(lambda (generic dispatches-left methods) (let ((method-cache (make-hash-table :test #'eql))) - (lambda (,@extraargs arg &rest args) - (apply (cl--generic-with-memoization - (gethash ,tag-exp method-cache) - (cl--generic-cache-miss - generic ',dispatch-arg dispatches-left methods - ,(if (cdr typescodes) - `(append ,@typescodes) (car typescodes)))) - ,@extraargs arg args)))))))) + (lambda (,@fixedargs &rest args) + (let ,bindings + (apply (cl--generic-with-memoization + (gethash ,tag-exp method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) + ,@fixedargs args))))))))) (defun cl--generic-make-function (generic) (cl--generic-make-next-function generic @@ -480,7 +530,7 @@ which case this method will be invoked when the argument is `eql' to VAL. (progn (while (and dispatches (let ((x (nth 1 (car dispatches)))) - ;; No need to dispatch for `t' specializers. + ;; No need to dispatch for t specializers. (or (null x) (equal x cl--generic-t-generalizer)))) (setq dispatches (cdr dispatches))) (pop dispatches)))) @@ -593,8 +643,11 @@ FUN is the function that should be called when METHOD calls dispatch-arg dispatches-left methods-left types) (let ((methods '())) (dolist (method methods-left) - (let* ((specializer (or (nth dispatch-arg - (cl--generic-method-specializers method)) + (let* ((specializer (or (if (integerp dispatch-arg) + (nth dispatch-arg + (cl--generic-method-specializers method)) + (cdr (assoc dispatch-arg + (cl--generic-method-specializers method)))) t)) (m (member specializer types))) (when m @@ -653,10 +706,34 @@ methods.") #'cl--generic-standard-method-combination) (cl-defmethod cl-generic-generalizers (specializer) - "Support for the catch-all `t' specializer." + "Support for the catch-all t specializer." (if (eq specializer t) (list cl--generic-t-generalizer) (error "Unknown specializer %S" specializer))) +(eval-when-compile + ;; This macro is brittle and only really important in order to be + ;; able to preload cl-generic without also preloading the byte-compiler, + ;; So we use `eval-when-compile' so as not keep it available longer than + ;; strictly needed. +(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer) + (unless (integerp arg-or-context) + (setq arg-or-context `(&context . ,arg-or-context))) + (unless (fboundp 'cl--generic-get-dispatcher) + (require 'cl-generic)) + (let ((fun (cl--generic-get-dispatcher + `(,arg-or-context ,@(cl-generic-generalizers specializer) + ,cl--generic-t-generalizer)))) + ;; Recompute dispatch at run-time, since the generalizers may be slightly + ;; different (e.g. byte-compiled rather than interpreted). + ;; FIXME: There is a risk that the run-time generalizer is not equivalent + ;; to the compile-time one, in which case `fun' may not be correct + ;; any more! + `(let ((dispatch `(,',arg-or-context + ,@(cl-generic-generalizers ',specializer) + ,cl--generic-t-generalizer))) + ;; (message "Prefilling for %S with \n%S" dispatch ',fun) + (puthash dispatch ',fun cl--generic-dispatchers))))) + (cl-defmethod cl-generic-combine-methods (generic methods) "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." (cl--generic-standard-method-combination generic methods)) @@ -729,8 +806,6 @@ Can only be used from within the lexical body of a primary or around method." specializers qualifiers (cl--generic-method-table (cl--generic generic))))) -(defalias 'cl-method-qualifiers 'cl--generic-method-qualifiers) - ;;; Add support for describe-function (defun cl--generic-search-method (met-name) @@ -783,6 +858,9 @@ Can only be used from within the lexical body of a primary or around method." (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) + ;; Supposedly this is called from help-fns, so help-fns should be loaded at + ;; this point. + (declare-function help-fns-short-filename "help-fns" (filename)) (let ((generic (if (symbolp function) (cl--generic function)))) (when generic (require 'help-mode) ;Needed for `help-function-def' button! @@ -798,11 +876,11 @@ Can only be used from within the lexical body of a primary or around method." (cl--generic-method-specializers method))) (file (find-lisp-object-file-name met-name 'cl-defmethod))) (when file - (insert " in `") + (insert " in ‘") (help-insert-xref-button (help-fns-short-filename file) 'help-function-def met-name file 'cl-defmethod) - (insert "'.\n"))) + (insert "’.\n"))) (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) ;;; Support for (head <val>) specializers. @@ -840,6 +918,8 @@ Can only be used from within the lexical body of a primary or around method." (gethash (cadr specializer) cl--generic-head-used) specializer) (list cl--generic-head-generalizer))) +(cl--generic-prefill-dispatchers 0 (head eql)) + ;;; Support for (eql <val>) specializers. (defvar cl--generic-eql-used (make-hash-table :test #'eql)) @@ -854,6 +934,9 @@ Can only be used from within the lexical body of a primary or around method." (puthash (cadr specializer) specializer cl--generic-eql-used) (list cl--generic-eql-generalizer)) +(cl--generic-prefill-dispatchers 0 (eql nil)) +(cl--generic-prefill-dispatchers window-system (eql nil)) + ;;; Support for cl-defstructs specializers. (defun cl--generic-struct-tag (name) @@ -910,6 +993,8 @@ Can only be used from within the lexical body of a primary or around method." (list cl--generic-struct-generalizer)))) (cl-call-next-method))) +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer) + ;;; Dispatch on "system types". (defconst cl--generic-typeof-types @@ -948,39 +1033,7 @@ Can only be used from within the lexical body of a primary or around method." (list cl--generic-typeof-generalizer))) (cl-call-next-method))) -;;; Just for kicks: dispatch on major-mode -;; -;; Here's how you'd use it: -;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...) -;; And then -;; (foo 'major-mode toto titi) -;; -;; FIXME: Better would be to do that via dispatch on an "implicit argument". -;; E.g. (cl-defmethod foo (y z &context (major-mode text-mode)) ...) - -;; (defvar cl--generic-major-modes (make-hash-table :test #'eq)) -;; -;; (add-function :before-until cl-generic-generalizer-function -;; #'cl--generic-major-mode-tagcode) -;; (defun cl--generic-major-mode-tagcode (type name) -;; (if (eq 'major-mode (car-safe type)) -;; `(50 . (if (eq ,name 'major-mode) -;; (cl--generic-with-memoization -;; (gethash major-mode cl--generic-major-modes) -;; `(cl--generic-major-mode . ,major-mode)))))) -;; -;; (add-function :before-until cl-generic-tag-types-function -;; #'cl--generic-major-mode-types) -;; (defun cl--generic-major-mode-types (tag) -;; (when (eq (car-safe tag) 'cl--generic-major-mode) -;; (if (eq tag 'fundamental-mode) '(fundamental-mode t) -;; (let ((types `((major-mode ,(cdr tag))))) -;; (while (get (car types) 'derived-mode-parent) -;; (push (list 'major-mode (get (car types) 'derived-mode-parent)) -;; types)) -;; (unless (eq 'fundamental-mode (car types)) -;; (push '(major-mode fundamental-mode) types)) -;; (nreverse types))))) +(cl--generic-prefill-dispatchers 0 integer) ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index 5e75406cf22..57da7159d5c 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -140,13 +140,13 @@ If non-nil, alignment is done with the first parameter (defcustom lisp-indent-backquote-substitution-mode t "How to indent substitutions in backquotes. -If `t', the default, indent substituted forms normally. -If `nil', do not apply special indentation rule to substituted +If t, the default, indent substituted forms normally. +If nil, do not apply special indentation rule to substituted forms. If `corrected', subtract the `,' or `,@' from the form column, indenting as if this character sequence were not present. In any case, do not backtrack beyond a backquote substitution. -Until Emacs 25.1, the `nil' behavior was hard-wired." +Until Emacs 25.1, the nil behavior was hard-wired." :version "25.1" :type '(choice (const corrected) (const nil) (const t)) :group 'lisp-indent) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 6b43c126130..b6f3a793be6 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -731,9 +731,10 @@ If ALIST is non-nil, the new pairs are prepended to it." ;;; Miscellaneous. (provide 'cl-lib) -(or (load "cl-loaddefs" 'noerror 'quiet) - ;; When bootstrapping, cl-loaddefs hasn't been built yet! - (require 'cl-macs)) +(unless (load "cl-loaddefs" 'noerror 'quiet) + ;; When bootstrapping, cl-loaddefs hasn't been built yet! + (require 'cl-macs) + (require 'cl-seq)) ;; Local variables: ;; byte-compile-dynamic: t diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5bab84ed312..636c5433a97 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -294,7 +294,6 @@ FORM is of the form (ARGS . BODY)." ;; apparently harmless computation, so it should not ;; touch the match-data. (save-match-data - (require 'help-fns) (cons (help-add-fundoc-usage (if (stringp (car header)) (pop header)) ;; Be careful with make-symbol and (back)quote, @@ -1787,7 +1786,8 @@ Labels have lexical scope and dynamic extent." (unless (eq 'go (car-safe (car-safe block))) (push `(go cl--exit) block)) (push (nreverse block) blocks)) - (let ((catch-tag (make-symbol "cl--tagbody-tag"))) + (let ((catch-tag (make-symbol "cl--tagbody-tag")) + (cl--tagbody-alist cl--tagbody-alist)) (push (cons 'cl--exit catch-tag) cl--tagbody-alist) (dolist (block blocks) (push (cons (car block) catch-tag) cl--tagbody-alist)) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 5624accf66a..3aea67ad11b 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -1018,4 +1018,6 @@ Atoms are compared by `eql'; cons cells are compared recursively. ;; generated-autoload-file: "cl-loaddefs.el" ;; End: +(provide 'cl-seq) + ;;; cl-seq.el ends here diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 564a44457d8..c966ace3852 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -626,6 +626,8 @@ You can replace this form with `gv-define-setter'. ;; ...the rest, and build the 5-tuple)) (make-obsolete 'get-setf-method 'gv-letplace "24.3") +(declare-function cl--arglist-args "cl-macs" (args)) + (defmacro define-modify-macro (name arglist func &optional doc) "Define a `setf'-like modify macro. If NAME is called, it combines its PLACE argument with the other @@ -639,6 +641,7 @@ You can replace this macro with `gv-letplace'." symbolp &optional stringp))) (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) + (require 'cl-macs) ;For cl--arglist-args. (let ((place (make-symbol "--cl-place--"))) `(cl-defmacro ,name (,place ,@arglist) ,doc diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index ce5c7863c3c..77d6332feee 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -54,7 +54,7 @@ the middle is discarded, and just the beginning and end are displayed." The value affects the behavior of operations on any window previously showing the debugger buffer. -`nil' means that if its window is not deleted when exiting the +nil means that if its window is not deleted when exiting the debugger, invoking `switch-to-prev-buffer' will usually show the debugger buffer again. @@ -731,7 +731,8 @@ Complete list of commands: (buffer-substring (line-beginning-position 0) (line-end-position 0))))) -(declare-function help-xref-interned "help-mode" (symbol)) +(declare-function help-xref-interned "help-mode" + (symbol &optional buffer frame)) (defun debug-help-follow (&optional pos) "Follow cross-reference at POS, defaulting to point. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 98fb7e9888c..b5b68d268f6 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -561,7 +561,7 @@ already is one.)" (defun edebug-install-read-eval-functions () (interactive) (add-function :around load-read-function #'edebug--read) - (advice-add 'eval-defun :override 'edebug-eval-defun)) + (advice-add 'eval-defun :override #'edebug-eval-defun)) (defun edebug-uninstall-read-eval-functions () (interactive) @@ -600,7 +600,7 @@ list of a symbol.") (defun edebug-get-form-data-entry (pnt &optional end-point) ;; Find the edebug form data entry which is closest to PNT. ;; If END-POINT is supplied, match must be exact. - ;; Return `nil' if none found. + ;; Return nil if none found. (let ((rest edebug-form-data) closest-entry (closest-dist 999999)) ;; Need maxint here. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 59d834837b0..bf3f44206c4 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -88,7 +88,7 @@ Currently under control of this var: (cl-defstruct (eieio--class (:constructor nil) - (:constructor eieio--class-make (name &aux (tag 'defclass))) + (:constructor eieio--class-make (name)) (:include cl--class) (:copier nil)) children @@ -277,12 +277,12 @@ See `defclass' for more information." (setq eieio-hook nil) (let* ((oldc (let ((c (eieio--class-v cname))) (if (eieio--class-p c) c))) - (newc (if (and oldc (not (eieio--class-default-object-cache oldc))) - ;; The oldc class is a stub setup by eieio-defclass-autoload. - ;; Reuse it instead of creating a new one, so that existing - ;; references stay valid. - oldc - (eieio--class-make cname))) + (newc (or oldc + ;; Reuse `oldc' instead of creating a new one, so that + ;; existing references stay valid. E.g. when + ;; reloading the file that does the `defclass', we don't + ;; want to create a new class object. + (eieio--class-make cname))) (groups nil) ;; list of groups id'd from slots (clearparent nil)) @@ -292,7 +292,13 @@ See `defclass' for more information." ;; method table breakage, particularly when the users is only ;; byte compiling an EIEIO file. (if oldc - (setf (eieio--class-children newc) (eieio--class-children oldc)) + (progn + (cl-assert (eq newc oldc)) + ;; Reset the fields. + (setf (eieio--class-parents newc) nil) + (setf (eieio--class-slots newc) nil) + (setf (eieio--class-initarg-tuples newc) nil) + (setf (eieio--class-class-slots newc) nil)) ;; If the old class did not exist, but did exist in the autoload map, ;; then adopt those children. This is like the above, but deals with ;; autoloads nicely. @@ -724,7 +730,7 @@ Argument FN is the function calling this verifier." (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) - (error "eieio-oref called on a class!") + (error "eieio-oref called on a class: %s" obj) (let ((c (eieio--class-v obj))) (if (eieio--class-p c) (eieio-class-un-autoload obj)) c)) diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 26fc452f7b1..31d0b85c55a 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el @@ -223,6 +223,7 @@ Optional argument IGNORE is an extraneous parameter." ;; Loop over all the slots, creating child widgets. (dotimes (i (length slots)) (let* ((slot (aref slots i)) + (sname (eieio-slot-descriptor-name slot)) (props (cl--slot-descriptor-props slot))) ;; Output this slot if it has a customize flag associated with it. (when (and (alist-get :custom props) @@ -261,13 +262,13 @@ Optional argument IGNORE is an extraneous parameter." (or (eieio--class-slot-initarg (eieio--object-class obj) - (car slots)) - (car slots))))) + sname) + sname)))) (capitalize (if (string-match "^:" s) (substring s (match-end 0)) s))))) - :value (slot-value obj (car slots)) + :value (slot-value obj sname) :doc (or (alist-get :documentation props) "Slot not Documented.") :eieio-custom-visibility 'visible @@ -297,6 +298,13 @@ Optional argument IGNORE is an extraneous parameter." (let* ((slot (aref slots i)) (props (cl--slot-descriptor-props slot)) (cust (alist-get :custom props))) + ;; + ;; Shouldn't I be incremented unconditionally? Or + ;; better shouldn't we simply mapc on the slots vector + ;; avoiding use of this integer variable? PLN Sat May + ;; 2 07:35:45 2015 + ;; + (setq i (+ i 1)) (if (and cust (or eieio-custom-ignore-eieio-co (not master-group) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 7f98730340d..11d99849a97 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -74,6 +74,9 @@ Argument CH-PREFIX is another character prefix to display." ;;; CLASS COMPLETION / DOCUMENTATION +;; Called via help-fns-describe-function-functions. +(declare-function help-fns-short-filename "help-fns" (filename)) + ;;;###autoload (defun eieio-help-class (class) "Print help description for CLASS. @@ -87,11 +90,11 @@ If CLASS is actually an object, then also display current values of that object. " class") (let ((location (find-lisp-object-file-name class 'eieio-defclass))) (when location - (insert " in `") + (insert " in ‘") (help-insert-xref-button (help-fns-short-filename location) 'eieio-class-def class location 'eieio-defclass) - (insert "'"))) + (insert "’"))) (insert ".\n") ;; Parents (let ((pl (eieio-class-parents class)) @@ -100,10 +103,10 @@ If CLASS is actually an object, then also display current values of that object. (insert " Inherits from ") (while (setq cur (pop pl)) (setq cur (eieio--class-name cur)) - (insert "`") + (insert "‘") (help-insert-xref-button (symbol-name cur) 'help-function cur) - (insert (if pl "', " "'"))) + (insert (if pl "’, " "’"))) (insert ".\n"))) ;; Children (let ((ch (eieio-class-children class)) @@ -111,10 +114,10 @@ If CLASS is actually an object, then also display current values of that object. (when ch (insert " Children ") (while (setq cur (pop ch)) - (insert "`") + (insert "‘") (help-insert-xref-button (symbol-name cur) 'help-function cur) - (insert (if ch "', " "'"))) + (insert (if ch "’, " "’"))) (insert ".\n"))) ;; System documentation (let ((doc (documentation-property class 'variable-documentation))) @@ -127,9 +130,9 @@ If CLASS is actually an object, then also display current values of that object. (when generics (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) (dolist (generic generics) - (insert "`") + (insert "‘") (help-insert-xref-button (symbol-name generic) 'help-function generic) - (insert "'") + (insert "’") (pcase-dolist (`(,qualifiers ,args ,doc) (eieio-method-documentation generic class)) (insert (format " %s%S\n" qualifiers args) @@ -242,11 +245,11 @@ are not abstract." (setq location (find-lisp-object-file-name ctr def))) (when location - (insert " in `") + (insert " in ‘") (help-insert-xref-button (help-fns-short-filename location) 'eieio-class-def ctr location 'eieio-defclass) - (insert "'")) + (insert "’")) (insert ".\nCreates an object of class " (symbol-name ctr) ".") (goto-char (point-max)) (if (autoloadp def) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 111459509bc..8387d81c0c0 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -967,7 +967,7 @@ variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to ;;; Start of automatically extracted autoloads. -;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "813d32fbf76d4248fc6b4dc97ebcd720") +;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "916f54b818479a77a02f3ecccda84a11") ;;; Generated autoloads from eieio-custom.el (autoload 'customize-object "eieio-custom" "\ @@ -978,7 +978,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "3005b815c6b30eccbf0642170b3f82a5") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "4b96541a14ecb2ac82ce5da7da79fd88") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index d527d676d51..0091cdb8484 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -354,7 +354,32 @@ return any documentation.") nil)) (eldoc-message (funcall eldoc-documentation-function))))) - +;; If the entire line cannot fit in the echo area, the symbol name may be +;; truncated or eliminated entirely from the output to make room for the +;; description. +(defun eldoc-docstring-format-sym-doc (prefix doc &optional face) + (when (symbolp prefix) + (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) + (let* ((ea-multi eldoc-echo-area-use-multiline-p) + ;; Subtract 1 from window width since emacs will not write + ;; any chars to the last column, or in later versions, will + ;; cause a wraparound and resize of the echo area. + (ea-width (1- (window-width (minibuffer-window)))) + (strip (- (+ (length prefix) (length doc)) ea-width))) + (cond ((or (<= strip 0) + (eq ea-multi t) + (and ea-multi (> (length doc) ea-width))) + (concat prefix doc)) + ((> (length doc) ea-width) + (substring (format "%s" doc) 0 ea-width)) + ((>= strip (string-match-p ":? *\\'" prefix)) + doc) + (t + ;; Show the end of the partial symbol name, rather + ;; than the beginning, since the former is more likely + ;; to be unique given package namespace conventions. + (concat (substring prefix strip) doc))))) + ;; When point is in a sexp, the function args are not reprinted in the echo ;; area after every possible interactive command because some of them print ;; their own messages in the echo area; the eldoc functions would instantly diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 136467046b4..fc66c82c81d 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -46,8 +46,6 @@ ;;; Code: -(require 'help-fns) - (defgroup elint nil "Linting for Emacs Lisp." :prefix "elint-" @@ -374,7 +372,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/ert.el b/lisp/emacs-lisp/ert.el index 4ffd8cd8558..99c5ede33a0 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -269,7 +269,7 @@ DATA is displayed to the user and should state the reason for skipping." (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) - (let ((definition (indirect-function thing t))) + (let ((definition (indirect-function thing))) (and (subrp definition) (eql (cdr (subr-arity definition)) 'unevalled))))) @@ -1849,7 +1849,9 @@ non-nil, returns the face for expected results.." (when (ert-test-documentation test) (insert " " (propertize - (ert--string-first-line (ert-test-documentation test)) + (ert--string-first-line + (substitute-command-keys + (ert-test-documentation test))) 'font-lock-face 'font-lock-doc-face) "\n")) (cl-etypecase result @@ -2063,7 +2065,7 @@ and how to display message." "--" ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] ["Show messages" ert-results-pop-to-messages-for-test-at-point] - ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Show ‘should’ forms" ert-results-pop-to-should-forms-for-test-at-point] ["Describe test" ert-results-describe-test-at-point] "--" ["Delete test" ert-delete-test] @@ -2375,9 +2377,9 @@ To be used in the ERT results buffer." (ert--print-backtrace backtrace) (debugger-make-xrefs) (goto-char (point-min)) - (insert "Backtrace for test `") + (insert "Backtrace for test ‘") (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n"))))))) + (insert "’:\n"))))))) (defun ert-results-pop-to-messages-for-test-at-point () "Display the part of the *Messages* buffer generated during the test at point. @@ -2396,9 +2398,9 @@ To be used in the ERT results buffer." (ert-simple-view-mode) (insert (ert-test-result-messages result)) (goto-char (point-min)) - (insert "Messages for test `") + (insert "Messages for test ‘") (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n"))))) + (insert "’:\n"))))) (defun ert-results-pop-to-should-forms-for-test-at-point () "Display the list of `should' forms executed during the test at point. @@ -2426,9 +2428,9 @@ To be used in the ERT results buffer." (ert--pp-with-indentation-and-newline form-description) (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) - (insert "`should' forms executed during test `") + (insert "‘should’ forms executed during test ‘") (ert-insert-test-name-button (ert-test-name test)) - (insert "':\n") + (insert "’:\n") (insert "\n") (insert (concat "(Values are shallow copies and may have " "looked different during the test if they\n" @@ -2505,9 +2507,9 @@ To be used in the ERT results buffer." (let ((file-name (and test-name (symbol-file test-name 'ert-deftest)))) (when file-name - (insert " defined in `" (file-name-nondirectory file-name) "'") + (insert " defined in ‘" (file-name-nondirectory file-name) "’") (save-excursion - (re-search-backward "`\\([^`']+\\)'" nil t) + (re-search-backward "‘\\([^‘’]+\\)’" nil t) (help-xref-button 1 'help-function-def test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) @@ -2519,8 +2521,9 @@ To be used in the ERT results buffer." "this documentation refers to an old definition.") (fill-region-as-paragraph begin (point))) (insert "\n\n")) - (insert (or (ert-test-documentation test-definition) - "It is not documented.") + (insert (substitute-command-keys + (or (ert-test-documentation test-definition) + "It is not documented.")) "\n"))))))) (defun ert-results-describe-test-at-point () @@ -2537,7 +2540,7 @@ To be used in the ERT results buffer." (add-to-list 'minor-mode-alist '(ert--current-run-stats (:eval (ert--tests-running-mode-line-indicator)))) -(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) +(add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords) (defun ert--unload-function () "Unload function to undo the side-effects of loading ert.el." @@ -2548,7 +2551,7 @@ To be used in the ERT results buffer." nil) (defvar ert-unload-hook '()) -(add-hook 'ert-unload-hook 'ert--unload-function) +(add-hook 'ert-unload-hook #'ert--unload-function) (provide 'ert) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 8251682590e..08e1b7c27a9 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -90,7 +90,7 @@ ;; Change this function to use `cl-gensym' if you want the generated ;; code to be easier to read and debug. ;; (cl-gensym (apply #'format fmt args)) - `(make-symbol ,fmt)) + `(progn (ignore ,@args) (make-symbol ,fmt))) (defvar cps--dynamic-wrappers '(identity) "List of transformer functions to apply to atomic forms we @@ -308,14 +308,14 @@ don't yield.") collect (if (symbolp binding) (list binding nil) binding))) - (temps (cl-loop for (var value-form) in bindings + (temps (cl-loop for (var _value-form) in bindings collect (cps--add-binding var)))) (cps--transform-1 `(let* ,(append - (cl-loop for (var value-form) in bindings + (cl-loop for (_var value-form) in bindings for temp in temps collect (list temp value-form)) - (cl-loop for (var binding) in bindings + (cl-loop for (var _binding) in bindings for temp in temps collect (list var temp))) ,@body) @@ -704,7 +704,7 @@ of values. Callers can retrieve each value using `iter-next'." (defun iter-next (iterator &optional yield-result) "Extract a value from an iterator. -YIELD-RESULT becomes the return value of `iter-yield` in the +YIELD-RESULT becomes the return value of `iter-yield' in the context of the generator. This routine raises the `iter-end-of-sequence' condition if the 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 26a21d52370..ab01a109b7a 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -229,248 +229,246 @@ (match-beginning 0))))) (throw 'found t)))))) -(pcase-let - ((`(,vdefs ,tdefs - ,el-defs-re ,cl-defs-re - ,el-kws-re ,cl-kws-re - ,el-errs-re ,cl-errs-re) - (eval-when-compile - (let ((lisp-fdefs '("defmacro" "defsubst" "defun")) - (lisp-vdefs '("defvar")) - (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" - "prog2" "lambda" "unwind-protect" "condition-case" - "when" "unless" "with-output-to-string" - "ignore-errors" "dotimes" "dolist" "declare")) - (lisp-errs '("warn" "error" "signal")) - ;; Elisp constructs. Now they are update dynamically - ;; from obarray but they are also used for setting up - ;; the keywords for Common Lisp. - (el-fdefs '("define-advice" "defadvice" "defalias" - "define-derived-mode" "define-minor-mode" - "define-generic-mode" "define-global-minor-mode" - "define-globalized-minor-mode" "define-skeleton" - "define-widget")) - (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" - "defface")) - (el-tdefs '("defgroup" "deftheme")) - (el-kw '("while-no-input" "letrec" "pcase" "pcase-exhaustive" - "pcase-lambda" "pcase-let" "pcase-let*" "save-restriction" - "save-excursion" "save-selected-window" - ;; "eval-after-load" "eval-next-after-load" - "save-window-excursion" "save-current-buffer" - "save-match-data" "combine-after-change-calls" - "condition-case-unless-debug" "track-mouse" - "eval-and-compile" "eval-when-compile" "with-case-table" - "with-category-table" "with-coding-priority" - "with-current-buffer" "with-demoted-errors" - "with-electric-help" "with-eval-after-load" - "with-file-modes" - "with-local-quit" "with-no-warnings" - "with-output-to-temp-buffer" "with-selected-window" - "with-selected-frame" "with-silent-modifications" - "with-syntax-table" "with-temp-buffer" "with-temp-file" - "with-temp-message" "with-timeout" - "with-timeout-handler")) - (el-errs '("user-error")) - ;; Common-Lisp constructs supported by EIEIO. FIXME: namespace. - (eieio-fdefs '("defgeneric" "defmethod")) - (eieio-tdefs '("defclass")) - (eieio-kw '("with-slots")) - ;; Common-Lisp constructs supported by cl-lib. - (cl-lib-fdefs '("defmacro" "defsubst" "defun" "defmethod")) - (cl-lib-tdefs '("defstruct" "deftype")) - (cl-lib-kw '("progv" "eval-when" "case" "ecase" "typecase" - "etypecase" "ccase" "ctypecase" "loop" "do" "do*" - "the" "locally" "proclaim" "declaim" "letf" "go" - ;; "lexical-let" "lexical-let*" - "symbol-macrolet" "flet" "flet*" "destructuring-bind" - "labels" "macrolet" "tagbody" "multiple-value-bind" - "block" "return" "return-from")) - (cl-lib-errs '("assert" "check-type")) - ;; Common-Lisp constructs not supported by cl-lib. - (cl-fdefs '("defsetf" "define-method-combination" - "define-condition" "define-setf-expander" - ;; "define-function"?? - "define-compiler-macro" "define-modify-macro")) - (cl-vdefs '("define-symbol-macro" "defconstant" "defparameter")) - (cl-tdefs '("defpackage" "defstruct" "deftype")) - (cl-kw '("prog" "prog*" "handler-case" "handler-bind" - "in-package" "restart-case" ;; "inline" - "restart-bind" "break" "multiple-value-prog1" - "compiler-let" "with-accessors" "with-compilation-unit" - "with-condition-restarts" "with-hash-table-iterator" - "with-input-from-string" "with-open-file" - "with-open-stream" "with-package-iterator" - "with-simple-restart" "with-standard-io-syntax")) - (cl-errs '("abort" "cerror"))) - - (list (append lisp-vdefs el-vdefs cl-vdefs) - (append el-tdefs eieio-tdefs cl-tdefs cl-lib-tdefs - (mapcar (lambda (s) (concat "cl-" s)) cl-lib-tdefs)) - - ;; Elisp and Common Lisp definers. - (regexp-opt (append lisp-fdefs lisp-vdefs - el-fdefs el-vdefs el-tdefs - (mapcar (lambda (s) (concat "cl-" s)) - (append cl-lib-fdefs cl-lib-tdefs)) - eieio-fdefs eieio-tdefs) - t) - (regexp-opt (append lisp-fdefs lisp-vdefs - cl-lib-fdefs cl-lib-tdefs - eieio-fdefs eieio-tdefs - cl-fdefs cl-vdefs cl-tdefs) - t) - - ;; Elisp and Common Lisp keywords. - (regexp-opt (append - lisp-kw el-kw eieio-kw - (cons "go" (mapcar (lambda (s) (concat "cl-" s)) - (remove "go" cl-lib-kw)))) - t) - (regexp-opt (append lisp-kw cl-kw eieio-kw cl-lib-kw) - t) - - ;; Elisp and Common Lisp "errors". - (regexp-opt (append (mapcar (lambda (s) (concat "cl-" s)) - cl-lib-errs) - lisp-errs el-errs) - t) - (regexp-opt (append lisp-errs cl-lib-errs cl-errs) t)))))) - - (dolist (v vdefs) - (put (intern v) 'lisp-define-type 'var)) - (dolist (v tdefs) - (put (intern v) 'lisp-define-type 'type)) - - (define-obsolete-variable-alias 'lisp-font-lock-keywords-1 - 'lisp-el-font-lock-keywords-1 "24.4") - (defconst lisp-el-font-lock-keywords-1 - `( ;; Definitions. - (,(concat "(" el-defs-re "\\_>" - ;; Any whitespace and defined object. - "[ \t']*" - "\\(([ \t']*\\)?" ;; An opening paren. - "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") - (1 font-lock-keyword-face) - (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) - (cond ((eq type 'var) font-lock-variable-name-face) - ((eq type 'type) font-lock-type-face) - ;; If match-string 2 is non-nil, we encountered a - ;; form like (defalias (intern (concat s "-p"))), - ;; unless match-string 4 is also there. Then its a - ;; defmethod with (setf foo) as name. - ((or (not (match-string 2)) ;; Normal defun. - (and (match-string 2) ;; Setf method. - (match-string 4))) font-lock-function-name-face))) - nil t)) - ;; Emacs Lisp autoload cookies. Supports the slightly different - ;; forms used by mh-e, calendar, etc. - ("^;;;###\\([-a-z]*autoload\\)" 1 font-lock-warning-face prepend)) - "Subdued level highlighting for Emacs Lisp mode.") - - (defconst lisp-cl-font-lock-keywords-1 - `( ;; Definitions. - (,(concat "(" cl-defs-re "\\_>" - ;; Any whitespace and defined object. - "[ \t']*" - "\\(([ \t']*\\)?" ;; An opening paren. - "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") - (1 font-lock-keyword-face) - (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) - (cond ((eq type 'var) font-lock-variable-name-face) - ((eq type 'type) font-lock-type-face) - ((or (not (match-string 2)) ;; Normal defun. - (and (match-string 2) ;; Setf function. - (match-string 4))) font-lock-function-name-face))) - nil t))) - "Subdued level highlighting for Lisp modes.") - - (define-obsolete-variable-alias 'lisp-font-lock-keywords-2 - 'lisp-el-font-lock-keywords-2 "24.4") - (defconst lisp-el-font-lock-keywords-2 - (append - lisp-el-font-lock-keywords-1 - `( ;; Regexp negated char group. - ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) - ;; Control structures. Common Lisp forms. - (lisp--el-match-keyword . 1) - ;; Exit/Feature symbols as constants. - (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" - "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") - (1 font-lock-keyword-face) - (2 font-lock-constant-face nil t)) - ;; Erroneous structures. - (,(concat "(" el-errs-re "\\_>") - (1 font-lock-warning-face)) - ;; Words inside \\[] tend to be for `substitute-command-keys'. - ("\\\\\\\\\\[\\(\\(?:\\sw\\|\\s_\\)+\\)\\]" - (1 font-lock-constant-face prepend)) - ;; Words inside `' tend to be symbol names. - ("`\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)'" - (1 font-lock-constant-face prepend)) - ;; Constant values. - ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) - ;; ELisp and CLisp `&' keywords as types. - ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) - ;; ELisp regexp grouping constructs - (,(lambda (bound) - (catch 'found - ;; The following loop is needed to continue searching after matches - ;; that do not occur in strings. The associated regexp matches one - ;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to - ;; avoid highlighting, for example, `\\(' in `\\\\('. - (while (re-search-forward "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" bound t) - (unless (match-beginning 2) - (let ((face (get-text-property (1- (point)) 'face))) - (when (or (and (listp face) - (memq 'font-lock-string-face face)) - (eq 'font-lock-string-face face)) - (throw 'found t))))))) - (1 'font-lock-regexp-grouping-backslash prepend) - (3 'font-lock-regexp-grouping-construct prepend)) - ;; This is too general -- rms. - ;; A user complained that he has functions whose names start with `do' - ;; and that they get the wrong color. - ;; ;; CL `with-' and `do-' constructs - ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) - (lisp--match-hidden-arg - (0 '(face font-lock-warning-face - help-echo "Hidden behind deeper element; move to another line?"))) - )) - "Gaudy level highlighting for Emacs Lisp mode.") - - (defconst lisp-cl-font-lock-keywords-2 - (append - lisp-cl-font-lock-keywords-1 - `( ;; Regexp negated char group. - ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) - ;; Control structures. Common Lisp forms. - (,(concat "(" cl-kws-re "\\_>") . 1) - ;; Exit/Feature symbols as constants. - (,(concat "(\\(catch\\|throw\\|provide\\|require\\)\\_>" - "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") - (1 font-lock-keyword-face) - (2 font-lock-constant-face nil t)) - ;; Erroneous structures. - (,(concat "(" cl-errs-re "\\_>") - (1 font-lock-warning-face)) - ;; Words inside `' tend to be symbol names. - ("`\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)'" - (1 font-lock-constant-face prepend)) - ;; Constant values. - ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) - ;; ELisp and CLisp `&' keywords as types. - ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) - ;; This is too general -- rms. - ;; A user complained that he has functions whose names start with `do' - ;; and that they get the wrong color. - ;; ;; CL `with-' and `do-' constructs - ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) - (lisp--match-hidden-arg - (0 '(face font-lock-warning-face - help-echo "Hidden behind deeper element; move to another line?"))) - )) - "Gaudy level highlighting for Lisp modes.")) +(let-when-compile + ((lisp-fdefs '("defmacro" "defsubst" "defun")) + (lisp-vdefs '("defvar")) + (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" + "prog2" "lambda" "unwind-protect" "condition-case" + "when" "unless" "with-output-to-string" + "ignore-errors" "dotimes" "dolist" "declare")) + (lisp-errs '("warn" "error" "signal")) + ;; Elisp constructs. Now they are update dynamically + ;; from obarray but they are also used for setting up + ;; the keywords for Common Lisp. + (el-fdefs '("define-advice" "defadvice" "defalias" + "define-derived-mode" "define-minor-mode" + "define-generic-mode" "define-global-minor-mode" + "define-globalized-minor-mode" "define-skeleton" + "define-widget")) + (el-vdefs '("defconst" "defcustom" "defvaralias" "defvar-local" + "defface")) + (el-tdefs '("defgroup" "deftheme")) + (el-kw '("while-no-input" "letrec" "pcase" "pcase-exhaustive" + "pcase-lambda" "pcase-let" "pcase-let*" "save-restriction" + "save-excursion" "save-selected-window" + ;; "eval-after-load" "eval-next-after-load" + "save-window-excursion" "save-current-buffer" + "save-match-data" "combine-after-change-calls" + "condition-case-unless-debug" "track-mouse" + "eval-and-compile" "eval-when-compile" "with-case-table" + "with-category-table" "with-coding-priority" + "with-current-buffer" "with-demoted-errors" + "with-electric-help" "with-eval-after-load" + "with-file-modes" + "with-local-quit" "with-no-warnings" + "with-output-to-temp-buffer" "with-selected-window" + "with-selected-frame" "with-silent-modifications" + "with-syntax-table" "with-temp-buffer" "with-temp-file" + "with-temp-message" "with-timeout" + "with-timeout-handler")) + (el-errs '("user-error")) + ;; Common-Lisp constructs supported by EIEIO. FIXME: namespace. + (eieio-fdefs '("defgeneric" "defmethod")) + (eieio-tdefs '("defclass")) + (eieio-kw '("with-slots")) + ;; Common-Lisp constructs supported by cl-lib. + (cl-lib-fdefs '("defmacro" "defsubst" "defun" "defmethod")) + (cl-lib-tdefs '("defstruct" "deftype")) + (cl-lib-kw '("progv" "eval-when" "case" "ecase" "typecase" + "etypecase" "ccase" "ctypecase" "loop" "do" "do*" + "the" "locally" "proclaim" "declaim" "letf" "go" + ;; "lexical-let" "lexical-let*" + "symbol-macrolet" "flet" "flet*" "destructuring-bind" + "labels" "macrolet" "tagbody" "multiple-value-bind" + "block" "return" "return-from")) + (cl-lib-errs '("assert" "check-type")) + ;; Common-Lisp constructs not supported by cl-lib. + (cl-fdefs '("defsetf" "define-method-combination" + "define-condition" "define-setf-expander" + ;; "define-function"?? + "define-compiler-macro" "define-modify-macro")) + (cl-vdefs '("define-symbol-macro" "defconstant" "defparameter")) + (cl-tdefs '("defpackage" "defstruct" "deftype")) + (cl-kw '("prog" "prog*" "handler-case" "handler-bind" + "in-package" "restart-case" ;; "inline" + "restart-bind" "break" "multiple-value-prog1" + "compiler-let" "with-accessors" "with-compilation-unit" + "with-condition-restarts" "with-hash-table-iterator" + "with-input-from-string" "with-open-file" + "with-open-stream" "with-package-iterator" + "with-simple-restart" "with-standard-io-syntax")) + (cl-errs '("abort" "cerror"))) + (let ((vdefs (eval-when-compile + (append lisp-vdefs el-vdefs cl-vdefs))) + (tdefs (eval-when-compile + (append el-tdefs eieio-tdefs cl-tdefs cl-lib-tdefs + (mapcar (lambda (s) (concat "cl-" s)) cl-lib-tdefs)))) + ;; Elisp and Common Lisp definers. + (el-defs-re (eval-when-compile + (regexp-opt (append lisp-fdefs lisp-vdefs + el-fdefs el-vdefs el-tdefs + (mapcar (lambda (s) (concat "cl-" s)) + (append cl-lib-fdefs cl-lib-tdefs)) + eieio-fdefs eieio-tdefs) + t))) + (cl-defs-re (eval-when-compile + (regexp-opt (append lisp-fdefs lisp-vdefs + cl-lib-fdefs cl-lib-tdefs + eieio-fdefs eieio-tdefs + cl-fdefs cl-vdefs cl-tdefs) + t))) + ;; Elisp and Common Lisp keywords. + ;; (el-kws-re (eval-when-compile + ;; (regexp-opt (append + ;; lisp-kw el-kw eieio-kw + ;; (cons "go" (mapcar (lambda (s) (concat "cl-" s)) + ;; (remove "go" cl-lib-kw)))) + ;; t))) + (cl-kws-re (eval-when-compile + (regexp-opt (append lisp-kw cl-kw eieio-kw cl-lib-kw) + t))) + ;; Elisp and Common Lisp "errors". + (el-errs-re (eval-when-compile + (regexp-opt (append (mapcar (lambda (s) (concat "cl-" s)) + cl-lib-errs) + lisp-errs el-errs) + t))) + (cl-errs-re (eval-when-compile + (regexp-opt (append lisp-errs cl-lib-errs cl-errs) t)))) + (dolist (v vdefs) + (put (intern v) 'lisp-define-type 'var)) + (dolist (v tdefs) + (put (intern v) 'lisp-define-type 'type)) + + (define-obsolete-variable-alias 'lisp-font-lock-keywords-1 + 'lisp-el-font-lock-keywords-1 "24.4") + (defconst lisp-el-font-lock-keywords-1 + `( ;; Definitions. + (,(concat "(" el-defs-re "\\_>" + ;; Any whitespace and defined object. + "[ \t']*" + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (cond ((eq type 'var) font-lock-variable-name-face) + ((eq type 'type) font-lock-type-face) + ;; If match-string 2 is non-nil, we encountered a + ;; form like (defalias (intern (concat s "-p"))), + ;; unless match-string 4 is also there. Then its a + ;; defmethod with (setf foo) as name. + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf method. + (match-string 4))) font-lock-function-name-face))) + nil t)) + ;; Emacs Lisp autoload cookies. Supports the slightly different + ;; forms used by mh-e, calendar, etc. + ("^;;;###\\([-a-z]*autoload\\)" 1 font-lock-warning-face prepend)) + "Subdued level highlighting for Emacs Lisp mode.") + + (defconst lisp-cl-font-lock-keywords-1 + `( ;; Definitions. + (,(concat "(" cl-defs-re "\\_>" + ;; Any whitespace and defined object. + "[ \t']*" + "\\(([ \t']*\\)?" ;; An opening paren. + "\\(\\(setf\\)[ \t]+\\(?:\\sw\\|\\s_\\)+\\|\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (3 (let ((type (get (intern-soft (match-string 1)) 'lisp-define-type))) + (cond ((eq type 'var) font-lock-variable-name-face) + ((eq type 'type) font-lock-type-face) + ((or (not (match-string 2)) ;; Normal defun. + (and (match-string 2) ;; Setf function. + (match-string 4))) font-lock-function-name-face))) + nil t))) + "Subdued level highlighting for Lisp modes.") + + (define-obsolete-variable-alias 'lisp-font-lock-keywords-2 + 'lisp-el-font-lock-keywords-2 "24.4") + (defconst lisp-el-font-lock-keywords-2 + (append + lisp-el-font-lock-keywords-1 + `( ;; Regexp negated char group. + ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) + ;; Control structures. Common Lisp forms. + (lisp--el-match-keyword . 1) + ;; Exit/Feature symbols as constants. + (,(concat "(\\(catch\\|throw\\|featurep\\|provide\\|require\\)\\_>" + "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (2 font-lock-constant-face nil t)) + ;; Erroneous structures. + (,(concat "(" el-errs-re "\\_>") + (1 font-lock-warning-face)) + ;; Words inside \\[] tend to be for `substitute-command-keys'. + ("\\\\\\\\\\[\\(\\(?:\\sw\\|\\s_\\)+\\)\\]" + (1 font-lock-constant-face prepend)) + ;; Words inside ‘’ and `' tend to be symbol names. + ("[`‘]\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)['’]" + (1 font-lock-constant-face prepend)) + ;; Constant values. + ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) + ;; ELisp and CLisp `&' keywords as types. + ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) + ;; ELisp regexp grouping constructs + (,(lambda (bound) + (catch 'found + ;; The following loop is needed to continue searching after matches + ;; that do not occur in strings. The associated regexp matches one + ;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to + ;; avoid highlighting, for example, `\\(' in `\\\\('. + (while (re-search-forward "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" bound t) + (unless (match-beginning 2) + (let ((face (get-text-property (1- (point)) 'face))) + (when (or (and (listp face) + (memq 'font-lock-string-face face)) + (eq 'font-lock-string-face face)) + (throw 'found t))))))) + (1 'font-lock-regexp-grouping-backslash prepend) + (3 'font-lock-regexp-grouping-construct prepend)) + ;; This is too general -- rms. + ;; A user complained that he has functions whose names start with `do' + ;; and that they get the wrong color. + ;; ;; CL `with-' and `do-' constructs + ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + (lisp--match-hidden-arg + (0 '(face font-lock-warning-face + help-echo "Hidden behind deeper element; move to another line?"))) + )) + "Gaudy level highlighting for Emacs Lisp mode.") + + (defconst lisp-cl-font-lock-keywords-2 + (append + lisp-cl-font-lock-keywords-1 + `( ;; Regexp negated char group. + ("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend) + ;; Control structures. Common Lisp forms. + (,(concat "(" cl-kws-re "\\_>") . 1) + ;; Exit/Feature symbols as constants. + (,(concat "(\\(catch\\|throw\\|provide\\|require\\)\\_>" + "[ \t']*\\(\\(?:\\sw\\|\\s_\\)+\\)?") + (1 font-lock-keyword-face) + (2 font-lock-constant-face nil t)) + ;; Erroneous structures. + (,(concat "(" cl-errs-re "\\_>") + (1 font-lock-warning-face)) + ;; Words inside ‘’ and `' tend to be symbol names. + ("[`‘]\\(\\(?:\\sw\\|\\s_\\)\\(?:\\sw\\|\\s_\\)+\\)['’]" + (1 font-lock-constant-face prepend)) + ;; Constant values. + ("\\_<:\\(?:\\sw\\|\\s_\\)+\\_>" 0 font-lock-builtin-face) + ;; ELisp and CLisp `&' keywords as types. + ("\\_<\\&\\(?:\\sw\\|\\s_\\)+\\_>" . font-lock-type-face) + ;; This is too general -- rms. + ;; A user complained that he has functions whose names start with `do' + ;; and that they get the wrong color. + ;; ;; CL `with-' and `do-' constructs + ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + (lisp--match-hidden-arg + (0 '(face font-lock-warning-face + help-echo "Hidden behind deeper element; move to another line?"))) + )) + "Gaudy level highlighting for Lisp modes."))) (define-obsolete-variable-alias 'lisp-font-lock-keywords 'lisp-el-font-lock-keywords "24.4") @@ -855,9 +853,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/lisp.el b/lisp/emacs-lisp/lisp.el index 67d14872b3a..7b7b48c66de 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -736,22 +736,20 @@ character." ) (call-interactively 'minibuffer-complete))) -(defun lisp-complete-symbol (&optional predicate) +(defun lisp-complete-symbol (&optional _predicate) "Perform completion on Lisp symbol preceding point. Compare that symbol against the known Lisp symbols. If no characters can be completed, display a list of possible completions. Repeating the command at that point scrolls the list. -When called from a program, optional arg PREDICATE is a predicate -determining which symbols are considered, e.g. `commandp'. -If PREDICATE is nil, the context determines which symbols are -considered. If the symbol starts just after an open-parenthesis, only -symbols with function definitions are considered. Otherwise, all -symbols with function definitions, values or properties are -considered." - (declare (obsolete completion-at-point "24.4")) +The context determines which symbols are considered. If the +symbol starts just after an open-parenthesis, only symbols with +function definitions are considered. Otherwise, all symbols with +function definitions, values or properties are considered." + (declare (obsolete completion-at-point "24.4") + (advertised-calling-convention () "25.1")) (interactive) - (let* ((data (lisp-completion-at-point predicate)) + (let* ((data (elisp-completion-at-point)) (plist (nthcdr 3 data))) (if (null data) (minibuffer-message "Nothing to complete") diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index f0410f87447..05ffa8d52cc 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -343,7 +343,7 @@ definitions to shadow the loaded ones for use in file byte-compilation." (defmacro macroexp-let2 (test var exp &rest exps) "Bind VAR to a copyable expression that returns the value of EXP. -This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated +This is like \\=`(let ((v ,EXP)) ,EXPS) except that `v' is a new generated symbol which EXPS can find in VAR. TEST should be the name of a predicate on EXP checking whether the `let' can be skipped; if nil, as is usual, `macroexp-const-p' is used." diff --git a/lisp/emacs-lisp/package-x.el b/lisp/emacs-lisp/package-x.el index 6955ce8f5a6..81d0b834722 100644 --- a/lisp/emacs-lisp/package-x.el +++ b/lisp/emacs-lisp/package-x.el @@ -156,6 +156,7 @@ DESCRIPTION is the text of the news item." archive-url)) (declare-function lm-commentary "lisp-mnt" (&optional file)) +(defvar tar-data-buffer) (defun package-upload-buffer-internal (pkg-desc extension &optional archive-url) "Upload a package whose contents are in the current buffer. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2fb54f0d944..6fecd9a837d 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -185,7 +185,6 @@ and before `after-init-hook'. Activation is not done if Even if the value is nil, you can type \\[package-initialize] to activate the package system at any time." :type 'boolean - :group 'package :version "24.1") (defcustom package-load-list '(all) @@ -203,7 +202,6 @@ If VERSION is a string, only that version is ever loaded. If VERSION is nil, the package is not loaded (it is \"disabled\")." :type '(repeat symbol) :risky t - :group 'package :version "24.1") (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) @@ -222,9 +220,31 @@ a package can run arbitrary code." :type '(alist :key-type (string :tag "Archive name") :value-type (string :tag "URL or directory name")) :risky t - :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)) + :version "25.1") + (defcustom package-archive-priorities nil "An alist of priorities for packages. @@ -235,11 +255,12 @@ 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 - :group 'package :version "25.1") (defcustom package-pinned-packages nil @@ -263,7 +284,6 @@ the package will be unavailable." ;; via an entry (PACKAGE . NON-EXISTING). Which could be an issue ;; if PACKAGE has a known vulnerability that is fixed in newer versions. :risky t - :group 'package :version "24.4") (defcustom package-user-dir (locate-user-emacs-file "elpa") @@ -273,7 +293,6 @@ Apart from this directory, Emacs also looks for system-wide packages in `package-directory-list'." :type 'directory :risky t - :group 'package :version "24.1") (defcustom package-directory-list @@ -291,7 +310,6 @@ These directories contain packages intended for system-wide; in contrast, `package-user-dir' contains packages for personal use." :type '(repeat directory) :risky t - :group 'package :version "24.1") (defvar epg-gpg-program) @@ -309,14 +327,12 @@ contents of the archive." (const allow-unsigned :tag "Allow unsigned") (const t :tag "Check always")) :risky t - :group 'package :version "24.4") (defcustom package-unsigned-archives nil "List of archives where we do not check for package signatures." :type '(repeat (string :tag "Archive name")) :risky t - :group 'package :version "24.4") (defcustom package-selected-packages nil @@ -325,14 +341,21 @@ This variable is fed automatically by Emacs when installing a new package. This variable is used by `package-autoremove' to decide which packages are no longer needed. You can use it to (re)install packages on other machines -by running `package-user-selected-packages-install'. +by running `package-install-selected-packages'. To check if a package is contained in this list here, use `package--user-selected-p', as it may populate the variable with a sane initial value." - :group 'package :type '(repeat symbol)) +(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." + :type 'boolean + :version "25.1") + ;;; `package-desc' object definition ;; This is the struct used internally to represent packages. @@ -467,6 +490,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)) @@ -560,9 +587,10 @@ updates `package-alist'." (dolist (dir (cons package-user-dir package-directory-list)) (when (file-directory-p dir) (dolist (subdir (directory-files dir)) - (let ((pkg-dir (expand-file-name subdir dir))) - (when (file-directory-p pkg-dir) - (package-load-descriptor pkg-dir))))))) + (unless (equal subdir "..") + (let ((pkg-dir (expand-file-name subdir dir))) + (when (file-directory-p pkg-dir) + (package-load-descriptor pkg-dir)))))))) (defun define-package (_name-string _version-string &optional _docstring _requirements @@ -867,7 +895,7 @@ untar into a directory named DIR; otherwise, signal an error." ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) ;; Silence `autoload-generate-file-autoloads'. - (noninteractive package--silence) + (noninteractive inhibit-message) (backup-inhibited t) (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) @@ -887,10 +915,13 @@ untar into a directory named DIR; otherwise, signal an error." ) ;;;; Compilation +(defvar warning-minimum-level) (defun package--compile (pkg-desc) "Byte-compile installed package PKG-DESC." - (package-activate-1 pkg-desc) - (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)) + (let ((warning-minimum-level :error) + (save-silently inhibit-message)) + (package-activate-1 pkg-desc) + (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) ;;;; Inferring package from current buffer (defun package-read-from-string (str) @@ -928,7 +959,7 @@ is wrapped around any parts requiring it." deps)))) (declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-homepage "lisp-mnt" ()) +(declare-function lm-homepage "lisp-mnt" (&optional file)) (defun package-buffer-info () "Return a `package-desc' describing the package in the current buffer. @@ -1050,7 +1081,7 @@ The return result is a `package-desc'." (declare-function epg-verify-string "epg" (context signature &optional signed-text)) (declare-function epg-context-result-for "epg" (context name)) -(declare-function epg-signature-status "epg" (signature)) +(declare-function epg-signature-status "epg" (signature) t) (declare-function epg-signature-to-string "epg" (signature)) (defun package--display-verify-error (context sig-file) @@ -1107,7 +1138,8 @@ arguments see `package--with-work-buffer'." (signal (cdar status) (cddr status))) (goto-char (point-min)) (unless (search-forward "\n\n" nil 'noerror) - (error "Invalid url response")) + (error "Invalid url response in buffer %s" + (current-buffer))) (delete-region (point-min) (point)) ,@body) (kill-buffer (current-buffer))) @@ -1283,7 +1315,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" @@ -1315,6 +1348,9 @@ If successful, set `package-archive-contents'." ;; available on disk. (defvar package--initialized nil) +(defvar package--init-file-ensured nil + "Whether we know the init file has package-initialize.") + ;;;###autoload (defun package-initialize (&optional no-activate) "Load Emacs Lisp packages, and activate them. @@ -1324,7 +1360,11 @@ If `user-init-file' does not mention `(package-initialize)', add it to the file." (interactive) (setq package-alist nil) - (package--ensure-init-file) + (if (equal user-init-file load-file-name) + ;; If `package-initialize' is being called as part of loading + ;; the init file, it's obvious we don't need to ensure-init. + (setq package--init-file-ensured t) + (package--ensure-init-file)) (package-load-all-descriptors) (package-read-all-archive-contents) (unless no-activate @@ -1347,16 +1387,6 @@ it to the file." (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." @@ -1367,9 +1397,9 @@ displayed on the minibuffer." (with-file-modes 448 (make-directory homedir t)) (setf (epg-context-home-directory context) homedir) - (package--message "Importing %s..." (file-name-nondirectory file)) + (message "Importing %s..." (file-name-nondirectory file)) (epg-import-keys-from-file context file) - (package--message "Importing %s...done" (file-name-nondirectory file)))) + (message "Importing %s...done" (file-name-nondirectory file)))) (defvar package--post-download-archives-hook nil "Hook run after the archive contents are downloaded. @@ -1435,9 +1465,9 @@ 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 - (append package-archives - package--downloads-in-progress)) + (dolist (archive package-archives) + (cl-pushnew archive package--downloads-in-progress + :test #'equal)) (dolist (archive package-archives) (condition-case-unless-debug nil (package--download-one-archive @@ -1457,19 +1487,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)) - (package--silence async)) + (inhibit-message 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 @@ -1511,7 +1540,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. - (package--message "Dependency cycle going through %S" + (message "Dependency cycle going through %S" (package-desc-full-name already)) (setq packages (delq already packages)) (setq already nil)) @@ -1577,7 +1606,7 @@ Used to populate `package-selected-packages'." (defun package--save-selected-packages (value) "Set and save `package-selected-packages' to VALUE." - (let ((save-silently package--silence)) + (let ((save-silently inhibit-message)) (customize-save-variable 'package-selected-packages (setq package-selected-packages value)))) @@ -1619,21 +1648,25 @@ These are packages which are neither contained in unless (memq p needed) collect p))) -(defun package--used-elsewhere-p (pkg-desc &optional pkg-list) +(defun package--used-elsewhere-p (pkg-desc &optional pkg-list all) "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. Return the first package found in PKG-LIST of which PKG is a -dependency. +dependency. If ALL is non-nil, return all such packages instead. When not specified, PKG-LIST defaults to `package-alist' with PKG-DESC entry removed." (unless (string= (package-desc-status pkg-desc) "obsolete") - (let ((pkg (package-desc-name pkg-desc))) - (cl-loop with alist = (or pkg-list - (remove (assq pkg package-alist) - package-alist)) - for p in alist thereis - (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p)))) - (car p)))))) + (let* ((pkg (package-desc-name pkg-desc)) + (alist (or pkg-list + (remove (assq pkg package-alist) + package-alist)))) + (if all + (cl-loop for p in alist + if (assq pkg (package-desc-reqs (cadr p))) + collect (cadr p)) + (cl-loop for p in alist thereis + (and (assq pkg (package-desc-reqs (cadr p))) + (cadr p))))))) (defun package--sort-deps-in-alist (package only) "Return a list of dependencies for PACKAGE sorted by dependency. @@ -1681,30 +1714,26 @@ 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 &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." +(defun package-install-from-archive (pkg-desc) + "Download and install a tar package." ;; This won't happen, unless the archive is doing something wrong. (when (eq (package-desc-kind pkg-desc) 'dir) (error "Can't install directory package from archive")) (let* ((location (package-archive-base pkg-desc)) (file (concat (package-desc-full-name pkg-desc) (package-desc-suffix pkg-desc)))) - (package--with-work-buffer-async location file async + (package--with-work-buffer location file (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)) + (let ((save-silently t)) + (package-unpack pkg-desc)) ;; If we care, check it and *then* write the file. (let ((content (buffer-string))) (package--check-signature - location file content async + location file content nil ;; This function will be called after signature checking. (lambda (&optional good-sigs) (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) @@ -1714,7 +1743,7 @@ operation is done." (package-desc-name pkg-desc))) ;; Signature checked, unpack now. (with-temp-buffer (insert content) - (let ((save-silently async)) + (let ((save-silently t)) (package-unpack pkg-desc))) ;; Here the package has been installed successfully, mark it as ;; signed if appropriate. @@ -1730,9 +1759,7 @@ operation is done." (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))))))))) + (setf (package-desc-signed (car pkg-descs)) t)))))))))) (defun package-installed-p (package &optional min-version) "Return true if PACKAGE, of MIN-VERSION or newer, is installed. @@ -1753,30 +1780,24 @@ 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 &optional async callback) +(defun package-download-transaction (packages) "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'." - (cond - (packages (package-install-from-archive - (car packages) - async - (lambda () - (package-download-transaction (cdr packages)) - (when (functionp callback) - (funcall callback))))) - (callback (funcall callback)))) + (mapc #'package-install-from-archive packages)) (defun package--ensure-init-file () - "Ensure that the user's init file calls `package-initialize'." + "Ensure that the user's init file has `package-initialize'. +`package-initialize' doesn't have to be called, as long as it is +present somewhere in the file, even as a comment. If it is not, +add a call to it along with some explanatory comments." ;; Don't mess with the init-file from "emacs -Q". - (when user-init-file + (when (and (stringp user-init-file) + (not package--init-file-ensured) + (file-readable-p user-init-file) + (file-writable-p user-init-file)) (let* ((buffer (find-buffer-visiting user-init-file)) (contains-init (if buffer @@ -1786,6 +1807,7 @@ using `package-compute-transaction'." (widen) (goto-char (point-min)) (search-forward "(package-initialize)" nil 'noerror)))) + ;; Don't visit the file if we don't have to. (with-temp-buffer (insert-file-contents user-init-file) (goto-char (point-min)) @@ -1798,7 +1820,11 @@ using `package-compute-transaction'." (save-restriction (widen) (goto-char (point-min)) + (while (and (looking-at-p "[[:blank:]]*\\(;\\|$\\)") + (not (eobp))) + (forward-line 1)) (insert + "\n" ";; 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" @@ -1809,19 +1835,17 @@ using `package-compute-transaction'." (let ((file-precious-flag t)) (save-buffer)) (unless buffer - (kill-buffer (current-buffer)))))))))) + (kill-buffer (current-buffer))))))))) + (setq package--init-file-ensured t)) ;;;###autoload -(defun package-install (pkg &optional dont-select async callback) +(defun package-install (pkg &optional dont-select) "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." @@ -1854,8 +1878,8 @@ to install it but still mark it as selected." (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)))) + (package-download-transaction transaction) + (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. @@ -1923,7 +1947,7 @@ The file can either be a tar file or an Emacs Lisp file." (package-install-from-buffer))) ;;;###autoload -(defun package-install-user-selected-packages () +(defun package-install-selected-packages () "Ensure packages in `package-selected-packages' are installed. If some packages are not installed propose to install them." (interactive) @@ -1985,7 +2009,7 @@ If NOSAVE is non-nil, the package is not removed from ;; Don't delete packages used as dependency elsewhere. (error "Package `%s' is used by `%s' as dependency, not deleting" (package-desc-full-name pkg-desc) - pkg-used-elsewhere-by)) + (package-desc-name pkg-used-elsewhere-by))) (t (delete-directory dir t t) ;; Remove NAME-VERSION.signed file. @@ -1997,7 +2021,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)))) - (package--message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) + (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) ;;;###autoload (defun package-reinstall (pkg) @@ -2085,6 +2109,7 @@ will be deleted." (name (if desc (package-desc-name desc) pkg)) (pkg-dir (if desc (package-desc-dir desc))) (reqs (if desc (package-desc-reqs desc))) + (required-by (if desc (package--used-elsewhere-p desc nil 'all))) (version (if desc (package-desc-version desc))) (archive (if desc (package-desc-archive desc))) (extras (and desc (package-desc-extras desc))) @@ -2113,20 +2138,27 @@ will be deleted." "Installed" (capitalize status)) ;FIXME: Why comment-face? 'font-lock-face 'font-lock-comment-face)) - (insert " in `") + (insert " in ‘") ;; Todo: Add button for uninstalling. (help-insert-xref-button (abbreviate-file-name (file-name-as-directory pkg-dir)) 'help-package-def pkg-dir) (if (and (package-built-in-p name) (not (package-built-in-p name version))) - (insert "',\n shadowing a " + (insert "’,\n shadowing a " (propertize "built-in package" 'font-lock-face 'font-lock-builtin-face)) - (insert "'")) + (insert "’")) (if signed (insert ".") - (insert " (unsigned)."))) + (insert " (unsigned).")) + (when (and (package-desc-p desc) + (not required-by) + (package-installed-p desc)) + (insert " ") + (package-make-button "Delete" + 'action #'package-delete-button-action + 'package-desc desc))) (incompatible-reason (insert (propertize "Incompatible" 'face font-lock-warning-face) " because it depends on ") @@ -2170,6 +2202,19 @@ will be deleted." (help-insert-xref-button text 'help-package name) (insert reason))) (insert "\n"))) + (when required-by + (insert (propertize "Required by" 'font-lock-face 'bold) ": ") + (let ((first t)) + (dolist (pkg required-by) + (let ((text (package-desc-full-name pkg))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package + (package-desc-name pkg)))) + (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) ": " (if desc (package-desc-summary desc)) "\n") (when homepage @@ -2257,6 +2302,14 @@ will be deleted." (revert-buffer nil t) (goto-char (point-min))))) +(defun package-delete-button-action (button) + (let ((pkg-desc (button-get button 'package-desc))) + (when (y-or-n-p (format "Delete package `%s'? " + (package-desc-full-name pkg-desc))) + (package-delete pkg-desc) + (revert-buffer nil t) + (goto-char (point-min))))) + (defun package-keyword-button-action (button) (let ((pkg-keyword (button-get button 'package-keyword))) (package-show-package-list t (list pkg-keyword)))) @@ -2290,6 +2343,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 @@ -2347,12 +2401,17 @@ will be deleted." (defvar package-menu--new-package-list nil "List of newly-available packages since `list-packages' was last called.") +(defvar package-menu--transaction-status nil + "Mode-line status of ongoing package transaction.") + (define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" "Major mode for browsing a list of packages. 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 mode-line-process '((package--downloads-in-progress ":Loading") + (package-menu--transaction-status + package-menu--transaction-status))) (setq tabulated-list-format `[("Package" 18 package-menu--name-predicate) ("Version" 13 nil) @@ -2426,28 +2485,84 @@ of these dependencies, similar to the list returned by ((version-list-= version hv) "held") ((version-list-< version hv) "obsolete") (t "disabled")))) - ((package-built-in-p name version) "obsolete") - ((package--incompatible-p pkg-desc) "incompat") (dir ;One of the installed packages. (cond - ((not (file-exists-p (package-desc-dir pkg-desc))) "deleted") + ((not (file-exists-p dir)) "deleted") + ;; Not inside `package-user-dir'. + ((not (file-in-directory-p dir package-user-dir)) "external") ((eq pkg-desc (cadr (assq name package-alist))) (if (not signed) "unsigned" (if (package--user-selected-p name) "installed" "dependency"))) (t "obsolete"))) + ((package--incompatible-p pkg-desc) "incompat") (t (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, all with the +same name, sorted by decreasing `package-desc-priority-version'. +Return a list of packages tied for the highest priority according +to their archives." + (when pkg-list + ;; Variable toggled with `package-menu-hide-obsolete'. + (if (not package-menu--hide-obsolete) + pkg-list + (let ((installed (cadr (assq (package-desc-name (car pkg-list)) + package-alist)))) + (when installed + (setq pkg-list + (let ((ins-version (package-desc-version installed))) + (cl-remove-if (lambda (p) (version-list-< (package-desc-version p) + ins-version)) + pkg-list)))) + (let ((filtered-by-priority + (cond + ((not package-menu-hide-low-priority) + pkg-list) + ((eq package-menu-hide-low-priority 'archive) + (let* ((max-priority most-negative-fixnum) + (out)) + (while pkg-list + (let ((p (pop pkg-list))) + (if (>= (package-desc-priority p) max-priority) + (push p out) + (setq pkg-list nil)))) + (nreverse out))) + (pkg-list + (list (car pkg-list)))))) + (if (not installed) + filtered-by-priority + (let ((ins-version (package-desc-version installed))) + (cl-remove-if (lambda (p) (version-list-= (package-desc-version p) + ins-version)) + filtered-by-priority)))))))) (defun package-menu--refresh (&optional packages keywords) "Re-populate the `tabulated-list-entries'. @@ -2455,47 +2570,46 @@ PACKAGES should be nil or t, which means to display all known packages. KEYWORDS should be nil or a list of keywords." ;; Construct list of (PKG-DESC . STATUS). (unless packages (setq packages t)) - (let (info-list name) + (let (info-list) ;; Installed packages: (dolist (elt package-alist) - (setq name (car elt)) - (when (or (eq packages t) (memq name packages)) - (dolist (pkg (cdr elt)) - (when (package--has-keyword-p pkg keywords) - (package--push pkg (package-desc-status pkg) info-list))))) + (let ((name (car elt))) + (when (or (eq packages t) (memq name packages)) + (dolist (pkg (cdr elt)) + (when (package--has-keyword-p pkg keywords) + (push pkg info-list)))))) ;; Built-in packages: (dolist (elt package--builtins) - (setq name (car elt)) - (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. - (package--has-keyword-p (package--from-builtin elt) keywords) - (or package-list-unversioned - (package--bi-desc-version (cdr elt))) - (or (eq packages t) (memq name packages))) - (package--push (package--from-builtin elt) "built-in" info-list))) + (let ((pkg (package--from-builtin elt)) + (name (car elt))) + (when (not (eq name 'emacs)) ; Hide the `emacs' package. + (when (and (package--has-keyword-p pkg keywords) + (or package-list-unversioned + (package--bi-desc-version (cdr elt))) + (or (eq packages t) (memq name packages))) + (push pkg info-list))))) ;; Available and disabled packages: (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))) - (package--has-keyword-p pkg keywords)) - (package--push pkg (package-desc-status pkg) info-list))))) + (let ((name (car elt))) + (when (or (eq packages t) (memq name packages)) + ;; Hide available-obsolete or low-priority packages. + (dolist (pkg (package--remove-hidden (cdr elt))) + (when (package--has-keyword-p pkg keywords) + (push pkg info-list)))))) ;; Print the result. (setq tabulated-list-entries - (mapcar #'package-menu--print-info info-list)))) + (mapcar #'package-menu--print-info-simple info-list)))) (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. @@ -2534,12 +2648,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)) @@ -2567,11 +2683,20 @@ shown." "Return a package entry suitable for `tabulated-list-entries'. PKG has the form (PKG-DESC . STATUS). Return (PKG-DESC [NAME VERSION STATUS DOC])." - (let* ((pkg-desc (car pkg)) - (status (cdr pkg)) + (package-menu--print-info-simple (car pkg))) +(make-obsolete 'package-menu--print-info + 'package-menu--print-info-simple "25.1") + +(defun package-menu--print-info-simple (pkg) + "Return a package entry suitable for `tabulated-list-entries'. +PKG is a package-desc object. +Return (PKG-DESC [NAME VERSION STATUS DOC])." + (let* ((status (package-desc-status pkg)) (face (pcase status (`"built-in" 'font-lock-builtin-face) + (`"external" 'font-lock-builtin-face) (`"available" 'default) + (`"avail-obso" 'font-lock-comment-face) (`"new" 'bold) (`"held" 'font-lock-constant-face) (`"disabled" 'font-lock-warning-face) @@ -2580,21 +2705,23 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (`"unsigned" 'font-lock-warning-face) (`"incompat" 'font-lock-comment-face) (_ 'font-lock-warning-face)))) ; obsolete. - (list pkg-desc - `[,(list (symbol-name (package-desc-name pkg-desc)) - 'face 'link - 'follow-link t - 'package-desc pkg-desc - 'action 'package-menu-describe-package) + (list pkg + `[(,(symbol-name (package-desc-name pkg)) + face link + follow-link t + package-desc ,pkg + action package-menu-describe-package) ,(propertize (package-version-join - (package-desc-version pkg-desc)) + (package-desc-version pkg)) 'font-lock-face face) ,(propertize status 'font-lock-face face) ,@(if (cdr package-archives) - (list (propertize (or (package-desc-archive pkg-desc) "") + (list (propertize (or (package-desc-archive pkg) "") 'font-lock-face face))) - ,(propertize (package-desc-summary pkg-desc) - 'font-lock-face face)]))) + ,(package-desc-summary pkg)]))) + +(defvar package-menu--old-archive-contents nil + "`package-archive-contents' before the latest refresh.") (defun package-menu-refresh () "Download the Emacs Lisp package archive. @@ -2629,7 +2756,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))) @@ -2657,7 +2784,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defvar package--quick-help-keys '(("install," "delete," "unmark," ("execute" . 1)) ("next," "previous") - ("refresh-contents," "g-redisplay," "filter," "help"))) + ("refresh-contents," "g-redisplay," "filter," "(-toggle-obsolete" "help"))) (defun package--prettify-quick-help-key (desc) "Prettify DESC to be displayed as a help menu." @@ -2685,7 +2812,7 @@ The full list of keys can be viewed with \\[describe-mode]." (defun package-menu-get-status () (let* ((id (tabulated-list-get-id)) - (entry (and id (assq id tabulated-list-entries)))) + (entry (and id (assoc id tabulated-list-entries)))) (if entry (aref (cadr entry) 2) ""))) @@ -2705,8 +2832,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 () @@ -2730,15 +2856,15 @@ consideration." (push (cons name avail-pkg) upgrades)))) upgrades)) -(defun package-menu-mark-upgrades () +(defvar package-menu--mark-upgrades-pending nil + "Whether mark-upgrades is waiting for a refresh to finish.") + +(defun package-menu--mark-upgrades-1 () "Mark all upgradable packages in the Package Menu. -For each installed package with a newer version available, place -an (I)nstall flag on the available version and a (D)elete flag on -the installed version. A subsequent \\[package-menu-execute] -call will upgrade the package." - (interactive) +Implementation of `package-menu-mark-upgrades'." (unless (derived-mode-p 'package-menu-mode) (error "The current buffer is not a Package Menu")) + (setq package-menu--mark-upgrades-pending nil) (let ((upgrades (package-menu--find-upgrades))) (if (null upgrades) (message "No packages to upgrade.") @@ -2755,8 +2881,24 @@ call will upgrade the package." (t (package-menu-mark-delete)))))) (message "%d package%s marked for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s"))))) + (length upgrades) + (if (= (length upgrades) 1) "" "s"))))) + +(defun package-menu-mark-upgrades () + "Mark all upgradable packages in the Package Menu. +For each installed package with a newer version available, place +an (I)nstall flag on the available version and a (D)elete flag on +the installed version. A subsequent \\[package-menu-execute] +call will upgrade the package. + +If there's an async refresh operation in progress, the flags will +be placed as part of `package-menu--post-refresh' instead of +immediately." + (interactive) + (if (not package--downloads-in-progress) + (package-menu--mark-upgrades-1) + (setq package-menu--mark-upgrades-pending t) + (message "Waiting for refresh to finish..."))) (defun package-menu--list-to-prompt (packages) "Return a string listing PACKAGES that's usable in a prompt. @@ -2775,57 +2917,77 @@ prompt (see `package-menu--prompt-transaction-p')." (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." +(defun package-menu--prompt-transaction-p (delete install upgrade) + "Prompt the user about DELETE, INSTALL, and UPGRADE. +DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects. +Either may be nil, but not all." + (y-or-n-p + (concat + (when delete "Delete ") + (package-menu--list-to-prompt delete) + (when (and delete install) + (if upgrade "; " "; and ")) + (when install "Install ") + (package-menu--list-to-prompt install) + (when (and upgrade (or install delete)) "; and ") + (when upgrade "Upgrade ") + (package-menu--list-to-prompt upgrade) + "? "))) + +(defun package-menu--partition-transaction (install delete) + "Return an alist describing an INSTALL DELETE transaction. +Alist contains three entries, upgrade, delete, and install, each +with a list of package names. + +The upgrade entry contains any `package-desc' objects in INSTALL +whose name coincides with an object in DELETE. The delete and +the install entries are the same as DELETE and INSTALL with such +objects removed." (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. + `((delete . ,del) (install . ,ins) (upgrade . ,upg)))) + +(defun package-menu--perform-transaction (install-list delete-list) + "Install packages in INSTALL-LIST and delete DELETE-LIST." (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)))) + (let ((status-format (format ":Installing %%d/%d" + (length install-list))) + (i 0) + (package-menu--transaction-status)) + (dolist (pkg install-list) + (setq package-menu--transaction-status + (format status-format (cl-incf i))) + (force-mode-line-update) + (redisplay 'force) + ;; Don't mark as selected, `package-menu-execute' already + ;; does that. + (package-install pkg 'dont-select))) ;; Once there are no more packages to install, proceed to ;; deletion. - (let ((package--silence async)) + (let ((package-menu--transaction-status ":Deleting")) + (force-mode-line-update) + (redisplay 'force) (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))) + (let ((inhibit-message t)) + (package-delete elt nil 'nosave)) + (error (message (cadr err)))))))) + +(defun package--update-selected-packages (add remove) + "Update the `package-selected-packages' list according to ADD and REMOVE. +ADD and REMOVE must be disjoint lists of package names (or +`package-desc' objects) to be added and removed to the selected +packages list, respectively." + (dolist (p add) + (cl-pushnew (if (package-desc-p p) (package-desc-name p) p) + package-selected-packages)) + (dolist (p remove) + (setq package-selected-packages + (remove (if (package-desc-p p) (package-desc-name p) p) + package-selected-packages))) + (when (or add remove) + (package--save-selected-packages package-selected-packages))) (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. @@ -2850,12 +3012,30 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (forward-line))) (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)))) + (let-alist (package-menu--partition-transaction install-list delete-list) + (when (or noquery + (package-menu--prompt-transaction-p .delete .install .upgrade)) + (let ((message-template + (concat "Package menu: Operation %s [" + (when .delete (format "Delet__ %s" (length .delete))) + (when (and .delete .install) "; ") + (when .install (format "Install__ %s" (length .install))) + (when (and .upgrade (or .install .delete)) "; ") + (when .upgrade (format "Upgrad__ %s" (length .upgrade))) + "]"))) + (message (replace-regexp-in-string "__" "ing" message-template) "started") + ;; Packages being upgraded are not marked as selected. + (package--update-selected-packages .install .delete) + (package-menu--perform-transaction install-list delete-list) + (when package-selected-packages + (if-let ((removable (package--removable-packages))) + (message "Package menu: Operation finished. %d packages %s" + (length removable) + "are no longer needed, type `M-x package-autoremove' to remove them") + (message (replace-regexp-in-string "__" "ed" message-template) + "finished")))) + ;; This calls `package-menu--generate'. + (package-menu--post-refresh))))) (defun package-menu--version-predicate (A B) (let ((vA (or (aref (cadr A) 1) '(0))) @@ -2871,8 +3051,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) @@ -2881,6 +3064,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((string= sB "unsigned") nil) ((string= sA "held") t) ((string= sB "held") nil) + ((string= sA "external") t) + ((string= sB "external") nil) ((string= sA "built-in") t) ((string= sB "built-in") nil) ((string= sA "obsolete") t) @@ -2904,9 +3089,6 @@ 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 package-menu--old-archive-contents nil - "`package-archive-contents' before the latest refresh.") - (defun package-menu--populate-new-package-list () "Decide which packages are new in `package-archives-contents'. Store this list in `package-menu--new-package-list'." @@ -2934,15 +3116,11 @@ after `package-menu--perform-transaction'." (let ((buf (get-buffer "*Packages*"))) (when (buffer-live-p buf) (with-current-buffer buf - (revert-buffer nil 'noconfirm)))) - (package-menu--find-and-notify-upgrades)) - -(defcustom package-menu-async t - "If non-nil, package-menu will use async operations when possible. -This includes refreshing archive contents as well as installing -packages." - :type 'boolean - :group 'package) + (run-hooks 'tabulated-list-revert-hook) + (tabulated-list-print 'remember 'update) + (if package-menu--mark-upgrades-pending + (package-menu--mark-upgrades-1) + (package-menu--find-and-notify-upgrades)))))) ;;;###autoload (defun list-packages (&optional no-fetch) @@ -3002,9 +3180,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 978c3f0dd30..ab82b7eaef3 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -47,7 +47,7 @@ ;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). ;; - provide Agda's `with' (along with its `...' companion). -;; - implement (not UPAT). This might require a significant redesign. +;; - implement (not PAT). This might require a significant redesign. ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to ;; generate a lex-style DFA to decide whether to run E1 or E2. @@ -71,14 +71,14 @@ (defvar pcase--dontwarn-upats '(pcase--dontcare)) (def-edebug-spec - pcase-UPAT + pcase-PAT (&or symbolp - ("or" &rest pcase-UPAT) - ("and" &rest pcase-UPAT) + ("or" &rest pcase-PAT) + ("and" &rest pcase-PAT) ("guard" form) - ("let" pcase-UPAT form) + ("let" pcase-PAT form) ("pred" pcase-FUN) - ("app" pcase-FUN pcase-UPAT) + ("app" pcase-FUN pcase-PAT) pcase-MACRO sexp)) @@ -91,6 +91,10 @@ (def-edebug-spec pcase-MACRO pcase--edebug-match-macro) +;; Only called from edebug. +(declare-function get-edebug-spec "edebug" (symbol)) +(declare-function edebug-match "edebug" (cursor specs)) + (defun pcase--edebug-match-macro (cursor) (let (specs) (mapatoms @@ -104,19 +108,19 @@ ;;;###autoload (defmacro pcase (exp &rest cases) "Perform ML-style pattern matching on EXP. -CASES is a list of elements of the form (UPATTERN CODE...). +CASES is a list of elements of the form (PATTERN CODE...). -UPatterns can take the following forms: +Patterns can take the following forms: _ matches anything. SELFQUOTING matches itself. This includes keywords, numbers, and strings. SYMBOL matches anything and binds it to SYMBOL. - (or UPAT...) matches if any of the patterns matches. - (and UPAT...) matches if all the patterns match. + (or PAT...) matches if any of the patterns matches. + (and PAT...) matches if all the patterns match. 'VAL matches if the object is `equal' to VAL (pred FUN) matches if FUN applied to the object returns non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. - (let UPAT EXP) matches if EXP matches UPAT. - (app FUN UPAT) matches if FUN applied to the object matches UPAT. + (let PAT EXP) matches if EXP matches PAT. + (app FUN PAT) matches if FUN applied to the object matches PAT. If a SYMBOL is used twice in the same pattern (i.e. the pattern is \"non-linear\"), then the second occurrence is turned into an `eq'uality test. @@ -129,12 +133,12 @@ FUN can refer to variables bound earlier in the pattern. FUN is assumed to be pure, i.e. it can be dropped if its result is not used, and two identical calls can be merged into one. E.g. you can match pairs where the cdr is larger than the car with a pattern -like `(,a . ,(pred (< a))) or, with more checks: -`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) +like \\=`(,a . ,(pred (< a))) or, with more checks: +\\=`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a)))) Additional patterns can be defined via `pcase-defmacro'. Currently, the following patterns are provided this way:" - (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) + (declare (indent 1) (debug (form &rest (pcase-PAT body)))) ;; We want to use a weak hash table as a cache, but the key will unavoidably ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time ;; we're called so it'll be immediately GC'd. So we use (car cases) as key @@ -158,12 +162,18 @@ Currently, the following patterns are provided this way:" ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) expansion)))) +(declare-function help-fns--signature "help-fns" + (function doc real-def real-function)) + ;; FIXME: Obviously, this will collide with nadvice's use of ;; function-documentation if we happen to advise `pcase'. (put 'pcase 'function-documentation '(pcase--make-docstring)) (defun pcase--make-docstring () (let* ((main (documentation (symbol-function 'pcase) 'raw)) (ud (help-split-fundoc main 'pcase))) + ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works, + ;; where cl-lib is anything using pcase-defmacro. + (require 'help-fns) (with-temp-buffer (insert (or (cdr ud) main)) (mapatoms @@ -190,12 +200,12 @@ Currently, the following patterns are provided this way:" ;;;###autoload (defmacro pcase-lambda (lambda-list &rest body) - "Like `lambda' but allow each argument to be a UPattern. + "Like `lambda' but allow each argument to be a pattern. I.e. accepts the usual &optional and &rest keywords, but every formal argument can be any pattern accepted by `pcase' (a mere variable name being but a special case of it)." (declare (doc-string 2) (indent defun) - (debug ((&rest pcase-UPAT) body))) + (debug ((&rest pcase-PAT) body))) (let* ((bindings ()) (parsed-body (macroexp-parse-body body)) (args (mapcar (lambda (pat) @@ -232,9 +242,9 @@ variable name being but a special case of it)." (defmacro pcase-let* (bindings &rest body) "Like `let*' but where you can use `pcase' patterns for bindings. BODY should be an expression, and BINDINGS should be a list of bindings -of the form (UPAT EXP)." +of the form (PAT EXP)." (declare (indent 1) - (debug ((&rest (pcase-UPAT &optional form)) body))) + (debug ((&rest (pcase-PAT &optional form)) body))) (let ((cached (gethash bindings pcase--memoize))) ;; cached = (BODY . EXPANSION) (if (equal (car cached) body) @@ -247,7 +257,10 @@ of the form (UPAT EXP)." (defmacro pcase-let (bindings &rest body) "Like `let' but where you can use `pcase' patterns for bindings. BODY should be a list of expressions, and BINDINGS should be a list of bindings -of the form (UPAT EXP)." +of the form (PAT EXP). +The macro is expanded and optimized under the assumption that those +patterns *will* match, so a mismatch may go undetected or may cause +any kind of error." (declare (indent 1) (debug pcase-let*)) (if (null (cdr bindings)) `(pcase-let* ,bindings ,@body) @@ -265,7 +278,7 @@ of the form (UPAT EXP)." ;;;###autoload (defmacro pcase-dolist (spec &rest body) - (declare (indent 1) (debug ((pcase-UPAT form) body))) + (declare (indent 1) (debug ((pcase-PAT form) body))) (if (pcase--trivial-upat-p (car spec)) `(dolist ,spec ,@body) (let ((tmpvar (make-symbol "x"))) @@ -371,7 +384,9 @@ of the form (UPAT EXP)." ;;;###autoload (defmacro pcase-defmacro (name args &rest body) - "Define a pcase UPattern macro." + "Define a new kind of pcase PATTERN, by macro expansion. +Patterns of the form (NAME ...) will be expanded according +to this macro." (declare (indent 2) (debug defun) (doc-string 3)) ;; Add the function via `fsym', so that an autoload cookie placed ;; on a pcase-defmacro will cause the macro to be loaded on demand. @@ -442,7 +457,7 @@ Each BRANCH has the form (MATCH CODE . VARS) where CODE is the code generator for that branch. VARS is the set of vars already bound by earlier matches. MATCH is the pattern that needs to be matched, of the form: - (match VAR . UPAT) + (match VAR . PAT) (and MATCH ...) (or MATCH ...)" (when (setq branches (delq nil branches)) @@ -787,7 +802,7 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches) code vars rest))) ((eq (car-safe upat) 'app) - ;; A upat of the form (app FUN UPAT) + ;; A upat of the form (app FUN PAT) (pcase--mark-used sym) (let* ((fun (nth 1 upat)) (nsym (make-symbol "x")) @@ -844,7 +859,7 @@ Otherwise, it defers to REST which is a list of branches of the form (def-edebug-spec pcase-QPAT - (&or ("," pcase-UPAT) + (&or ("," pcase-PAT) (pcase-QPAT . pcase-QPAT) (vector &rest pcase-QPAT) sexp)) @@ -855,7 +870,7 @@ QPAT can take the following forms: (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match its 0..(n-1)th elements, respectively. - ,UPAT matches if the UPattern UPAT matches. + ,PAT matches if the pattern PAT matches. STRING matches if the object is `equal' to STRING. ATOM matches if the object is `eq' to ATOM." (declare (debug (pcase-QPAT))) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 6f7f3c46e2a..0aa0f095969 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.4 +;; Version: 1.7 ;; Package: seq ;; Maintainer: emacs-devel@gnu.org @@ -44,31 +44,59 @@ (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))))) + +(if (fboundp 'pcase-defmacro) + ;; Implementation of `seq-let' based on a `pcase' + ;; pattern. Requires Emacs>=25.1. + (progn + (pcase-defmacro seq (&rest args) + "pcase pattern matching sequence elements. +Matches if the object is a sequence (list, string or vector), and +binds each element of ARGS to the corresponding element of the +sequence." + `(and (pred seq-p) + ,@(seq--make-pcase-bindings args))) + + (defmacro seq-let (args seq &rest body) + "Bind the variables in ARGS to the elements of SEQ then evaluate BODY. + +ARGS can also include the `&rest' marker followed by a variable +name to be bound to the rest of SEQ." + (declare (indent 2) (debug t)) + `(pcase-let ((,(seq--make-pcase-patterns args) ,seq)) + ,@body))) + + ;; Implementation of `seq-let' compatible with Emacs<25.1. + (defmacro seq-let (args seq &rest body) + "Bind the variables in ARGS to the elements of SEQ then evaluate BODY. + +ARGS can also include the `&rest' marker followed by a variable +name to be bound to the rest of SEQ." + (declare (indent 2) (debug t)) + (let ((seq-var (make-symbol "seq"))) + `(let* ((,seq-var ,seq) + ,@(seq--make-bindings args seq-var)) + ,@body)))) (defun seq-drop (seq n) "Return a subsequence of SEQ without its first N elements. @@ -221,7 +249,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. @@ -295,7 +323,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. @@ -338,10 +366,70 @@ This is an optimization for lists in `seq-take-while'." (setq n (+ 1 n))) n)) +(defun seq--make-pcase-bindings (args) + "Return a list of bindings of the variables in ARGS to the elements of a sequence." + (let ((bindings '()) + (index 0) + (rest-marker nil)) + (seq-doseq (name args) + (unless rest-marker + (pcase name + (`&rest + (progn (push `(app (pcase--flip seq-drop ,index) + ,(seq--elt-safe args (1+ index))) + bindings) + (setq rest-marker t))) + (t + (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings)))) + (setq index (1+ index))) + bindings)) + +(defun seq--make-pcase-patterns (args) + "Return a list of `(seq ...)' pcase patterns from the argument list ARGS." + (cons 'seq + (seq-map (lambda (elt) + (if (seq-p elt) + (seq--make-pcase-patterns elt) + elt)) + args))) + +;; Helper function for the Backward-compatible version of `seq-let' +;; for Emacs<25.1. +(defun seq--make-bindings (args seq &optional bindings) + "Return a list of bindings of the variables in ARGS to the elements of a sequence. +if BINDINGS is non-nil, append new bindings to it, and return +BINDINGS." + (let ((index 0) + (rest-marker nil)) + (seq-doseq (name args) + (unless rest-marker + (pcase name + ((pred seq-p) + (setq bindings (seq--make-bindings (seq--elt-safe args index) + `(seq--elt-safe ,seq ,index) + bindings))) + (`&rest + (progn (push `(,(seq--elt-safe args (1+ index)) + (seq-drop ,seq ,index)) + bindings) + (setq rest-marker t))) + (t + (push `(,name (seq--elt-safe ,seq ,index)) bindings)))) + (setq index (1+ index))) + bindings)) + +(defun seq--elt-safe (seq n) + "Return element of SEQ at the index N. +If no element is found, return nil." + (when (or (listp seq) + (and (sequencep seq) + (> (seq-length seq) n))) + (seq-elt seq 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\\>"))) + '("\\<seq-doseq\\>" "\\<seq-let\\>"))) (defalias 'seq-copy #'copy-sequence) (defalias 'seq-elt #'elt) @@ -349,8 +437,12 @@ This is an optimization for lists in `seq-take-while'." (defalias 'seq-do #'mapc) (defalias 'seq-each #'seq-do) (defalias 'seq-map #'mapcar) +(defalias 'seq-p #'sequencep) -(add-to-list 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords) +(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-hook 'emacs-lisp-mode-hook #'seq--activate-font-lock-keywords)) (provide 'seq) ;;; seq.el ends here diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 78a6dc98456..e6d451ac62e 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -120,7 +120,8 @@ Argument BINDINGS is a list of tuples whose car is a symbol to be bound and (optionally) used in THEN, and its cadr is a sexp to be evalled to set symbol's value. In the special case you only want to bind a single value, BINDINGS can just be a plain tuple." - (declare (indent 2) (debug ((&rest (symbolp form)) form body))) + (declare (indent 2) + (debug ([&or (&rest (symbolp form)) (symbolp form)] form body))) (when (and (<= (length bindings) 2) (not (listp (car bindings)))) ;; Adjust the single binding case @@ -139,6 +140,10 @@ to bind a single value, BINDINGS can just be a plain tuple." (declare (indent 1) (debug if-let)) (list 'if-let bindings (macroexp-progn body))) +(defsubst hash-table-empty-p (hash-table) + "Check whether HASH-TABLE is empty (has 0 elements)." + (zerop (hash-table-count hash-table))) + (defsubst hash-table-keys (hash-table) "Return a list of keys in HASH-TABLE." (let ((keys '())) diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 81ef7a6fbf3..05dd7d57503 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -574,7 +574,7 @@ running the hook." ;; (defun buffer-syntactic-context (&optional buffer) ;; "Syntactic context at point in BUFFER. -;; Either of `string', `comment' or `nil'. +;; Either of `string', `comment' or nil. ;; This is an XEmacs compatibility function." ;; (with-current-buffer (or buffer (current-buffer)) ;; (syntax-ppss-context (syntax-ppss)))) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 15a0914cb17..fb3045d2b4c 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -179,7 +179,9 @@ If ADVANCE is non-nil, move forward by one line afterwards." table) "The `glyphless-char-display' table in Tabulated List buffers.") -(defvar tabulated-list--header-string nil) +(defvar tabulated-list--header-string nil + "Holds the header if `tabulated-list-use-header-line' is nil. +Populated by `tabulated-list-init-header'.") (defvar tabulated-list--header-overlay nil) (defun tabulated-list-init-header () @@ -243,15 +245,17 @@ If ADVANCE is non-nil, move forward by one line afterwards." (setq-local tabulated-list--header-string cols)))) (defun tabulated-list-print-fake-header () - "Insert a fake Tabulated List \"header line\" at the start of the buffer." - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (insert tabulated-list--header-string "\n") - (if tabulated-list--header-overlay - (move-overlay tabulated-list--header-overlay (point-min) (point)) - (setq-local tabulated-list--header-overlay - (make-overlay (point-min) (point)))) - (overlay-put tabulated-list--header-overlay 'face 'underline))) + "Insert a fake Tabulated List \"header line\" at the start of the buffer. +Do nothing if `tabulated-list--header-string' is nil." + (when tabulated-list--header-string + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (insert tabulated-list--header-string "\n") + (if tabulated-list--header-overlay + (move-overlay tabulated-list--header-overlay (point-min) (point)) + (setq-local tabulated-list--header-overlay + (make-overlay (point-min) (point)))) + (overlay-put tabulated-list--header-overlay 'face 'underline)))) (defun tabulated-list-revert (&rest ignored) "The `revert-buffer-function' for `tabulated-list-mode'. @@ -273,58 +277,104 @@ It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." (or found (error "No column named %s" name)))) -(defun tabulated-list-print (&optional remember-pos) +(defun tabulated-list--get-sorter () + "Return a sorting predicate for the current tabulated-list. +Return nil if `tabulated-list-sort-key' specifies an unsortable +column. Negate the predicate that would be returned if +`tabulated-list-sort-key' has a non-nil cdr." + (when (and tabulated-list-sort-key + (car tabulated-list-sort-key)) + (let* ((sort-column (car tabulated-list-sort-key)) + (n (tabulated-list--column-number sort-column)) + (sorter (nth 2 (aref tabulated-list-format n)))) + (when (eq sorter t); Default sorter checks column N: + (setq sorter (lambda (A B) + (let ((a (aref (cadr A) n)) + (b (aref (cadr B) n))) + (string< (if (stringp a) a (car a)) + (if (stringp b) b (car b))))))) + ;; Reversed order. + (if (cdr tabulated-list-sort-key) + (lambda (a b) (not (funcall sorter a b))) + sorter)))) + +(defun tabulated-list-print (&optional remember-pos update) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is specified by `tabulated-list-sort-key'. It then erases the buffer and inserts the entries with `tabulated-list-printer'. Optional argument REMEMBER-POS, if non-nil, means to move point -to the entry with the same ID element as the current line." +to the entry with the same ID element as the current line and +recenter window line accordingly. + +Non-nil UPDATE argument means to use an alternative printing +method which is faster if most entries haven't changed since the +last print. The only difference in outcome is that tags will not +be removed from entries that haven't changed (see +`tabulated-list-put-tag'). Don't use this immediately after +changing `tabulated-list-sort-key'." (let ((inhibit-read-only t) (entries (if (functionp tabulated-list-entries) (funcall tabulated-list-entries) tabulated-list-entries)) - entry-id saved-pt saved-col) + (sorter (tabulated-list--get-sorter)) + entry-id saved-pt saved-col window-line) (and remember-pos + (when (eq (window-buffer) (current-buffer)) + (setq window-line + (count-screen-lines (window-start) (point)))) (setq entry-id (tabulated-list-get-id)) (setq saved-col (current-column))) - (erase-buffer) - (unless tabulated-list-use-header-line - (tabulated-list-print-fake-header)) ;; Sort the entries, if necessary. - (when (and tabulated-list-sort-key - (car tabulated-list-sort-key)) - (let* ((sort-column (car tabulated-list-sort-key)) - (n (tabulated-list--column-number sort-column)) - (sorter (nth 2 (aref tabulated-list-format n)))) - ;; Is the specified column sortable? - (when sorter - (when (eq sorter t) - (setq sorter ; Default sorter checks column N: - (lambda (A B) - (setq A (aref (cadr A) n)) - (setq B (aref (cadr B) n)) - (string< (if (stringp A) A (car A)) - (if (stringp B) B (car B)))))) - (setq entries (sort entries sorter)) - (if (cdr tabulated-list-sort-key) - (setq entries (nreverse entries))) - (unless (functionp tabulated-list-entries) - (setq tabulated-list-entries entries))))) - ;; Print the resulting list. + (when sorter + (setq entries (sort entries sorter))) + (unless (functionp tabulated-list-entries) + (setq tabulated-list-entries entries)) + ;; Without a sorter, we have no way to just update. + (when (and update (not sorter)) + (setq update nil)) + (if update (goto-char (point-min)) + ;; Redo the buffer, unless we're just updating. + (erase-buffer) + (unless tabulated-list-use-header-line + (tabulated-list-print-fake-header))) + ;; Finally, print the resulting list. (dolist (elt entries) - (and entry-id - (equal entry-id (car elt)) - (setq saved-pt (point))) - (apply tabulated-list-printer elt)) + (let ((id (car elt))) + (and entry-id + (equal entry-id id) + (setq entry-id nil + saved-pt (point))) + ;; If the buffer this empty, simply print each elt. + (if (eobp) + (apply tabulated-list-printer elt) + (while (let ((local-id (tabulated-list-get-id))) + ;; If we find id, then nothing to update. + (cond ((equal id local-id) + (forward-line 1) + nil) + ;; If this entry sorts after id (or it's the + ;; end), then just insert id and move on. + ((funcall sorter elt + ;; FIXME: Might be faster if + ;; don't construct this list. + (list local-id (tabulated-list-get-entry))) + (apply tabulated-list-printer elt) + nil) + ;; We find an entry that sorts before id, + ;; it needs to be deleted. + (t t))) + (let ((old (point))) + (forward-line 1) + (delete-region old (point))))))) (set-buffer-modified-p nil) ;; If REMEMBER-POS was specified, move to the "old" location. (if saved-pt (progn (goto-char saved-pt) (move-to-column saved-col) - (when (eq (window-buffer) (current-buffer)) - (recenter))) + (when window-line + (recenter window-line))) (goto-char (point-min))))) (defun tabulated-list-print-entry (id cols) @@ -341,8 +391,10 @@ of column descriptors." (dotimes (n ncols) (setq x (tabulated-list-print-col n (aref cols n) x))) (insert ?\n) - (put-text-property beg (point) 'tabulated-list-id id) - (put-text-property beg (point) 'tabulated-list-entry cols))) + ;; Ever so slightly faster than calling `put-text-property' twice. + (add-text-properties + beg (point) + `(tabulated-list-id ,id tabulated-list-entry ,cols)))) (defun tabulated-list-print-col (n col-desc x) "Insert a specified Tabulated List entry at point. diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index a91704a11bf..110c63f777a 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -1,4 +1,4 @@ -;;;; testcover.el -- Visual code-coverage tool +;;;; testcover.el -- Visual code-coverage tool -*- lexical-binding:t -*- ;; Copyright (C) 2002-2015 Free Software Foundation, Inc. @@ -191,8 +191,9 @@ problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is non-nil, byte-compiles each function after instrumenting." (interactive "fStart covering file: ") (let ((buf (find-file filename)) - (load-read-function 'testcover-read) - (edebug-all-defs t)) + (load-read-function load-read-function)) + (add-function :around load-read-function + #'testcover--read) (setq edebug-form-data nil testcover-module-constants nil testcover-module-1value-functions nil) @@ -207,22 +208,26 @@ non-nil, byte-compiles each function after instrumenting." (defun testcover-this-defun () "Start coverage on function under point." (interactive) - (let* ((edebug-all-defs t) - (x (symbol-function (eval-defun nil)))) + (let ((x (let ((edebug-all-defs t)) + (symbol-function (eval-defun nil))))) (testcover-reinstrument x) x)) -(defun testcover-read (&optional stream) +(defun testcover--read (orig &optional stream) "Read a form using edebug, changing edebug callbacks to testcover callbacks." - (let ((x (edebug-read stream))) - (testcover-reinstrument x) - x)) + (or stream (setq stream standard-input)) + (if (eq stream (current-buffer)) + (let ((x (let ((edebug-all-defs t)) + (edebug-read-and-maybe-wrap-form)))) + (testcover-reinstrument x) + x) + (funcall (or orig #'read) stream))) (defun testcover-reinstrument (form) "Reinstruments FORM to use testcover instead of edebug. This function modifies the list that FORM points to. Result is nil if FORM should return multiple values, t if should always return same -value, 'maybe if either is acceptable." +value, `maybe' if either is acceptable." (let ((fun (car-safe form)) id val) (cond @@ -495,7 +500,7 @@ eliminated by adding more test cases." (len (length points)) (changed (buffer-modified-p)) (coverage (get def 'edebug-coverage)) - ov j item) + ov j) (or (and def-mark points coverage) (error "Missing edebug data for function %s" def)) (when (> len 0) |